Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitignore =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitignore (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitignore (revision 6016) @@ -0,0 +1,6 @@ +*.o +*.a +*~ +*_out.nc +config_*.nam +*_sza.nc Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/HEAD =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/HEAD (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/HEAD (revision 6016) @@ -0,0 +1,1 @@ +ref: refs/heads/master Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/config =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/config (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/config (revision 6016) @@ -0,0 +1,11 @@ +[core] + repositoryformatversion = 0 + filemode = true + bare = false + logallrefupdates = true +[remote "origin"] + url = https://github.com/lguez/ecrad.git + fetch = +refs/heads/*:refs/remotes/origin/* +[branch "master"] + remote = origin + merge = refs/heads/master Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/description =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/description (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/description (revision 6016) @@ -0,0 +1,1 @@ +Unnamed repository; edit this file 'description' to name the repository. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/applypatch-msg.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/applypatch-msg.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/applypatch-msg.sample (revision 6016) @@ -0,0 +1,15 @@ +#!/bin/sh +# +# An example hook script to check the commit log message taken by +# applypatch from an e-mail message. +# +# The hook should exit with non-zero status after issuing an +# appropriate message if it wants to stop the commit. The hook is +# allowed to edit the commit message file. +# +# To enable this hook, rename this file to "applypatch-msg". + +. git-sh-setup +commitmsg="$(git rev-parse --git-path hooks/commit-msg)" +test -x "$commitmsg" && exec "$commitmsg" ${1+"$@"} +: Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/commit-msg.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/commit-msg.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/commit-msg.sample (revision 6016) @@ -0,0 +1,24 @@ +#!/bin/sh +# +# An example hook script to check the commit log message. +# Called by "git commit" with one argument, the name of the file +# that has the commit message. The hook should exit with non-zero +# status after issuing an appropriate message if it wants to stop the +# commit. The hook is allowed to edit the commit message file. +# +# To enable this hook, rename this file to "commit-msg". + +# Uncomment the below to add a Signed-off-by line to the message. +# Doing this in a hook is a bad idea in general, but the prepare-commit-msg +# hook is more suited to it. +# +# SOB=$(git var GIT_AUTHOR_IDENT | sed -n 's/^\(.*>\).*$/Signed-off-by: \1/p') +# grep -qs "^$SOB" "$1" || echo "$SOB" >> "$1" + +# This example catches duplicate Signed-off-by lines. + +test "" = "$(grep '^Signed-off-by: ' "$1" | + sort | uniq -c | sed -e '/^[ ]*1[ ]/d')" || { + echo >&2 Duplicate Signed-off-by lines. + exit 1 +} Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/fsmonitor-watchman.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/fsmonitor-watchman.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/fsmonitor-watchman.sample (revision 6016) @@ -0,0 +1,109 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use IPC::Open2; + +# An example hook script to integrate Watchman +# (https://facebook.github.io/watchman/) with git to speed up detecting +# new and modified files. +# +# The hook is passed a version (currently 1) and a time in nanoseconds +# formatted as a string and outputs to stdout all files that have been +# modified since the given time. Paths must be relative to the root of +# the working tree and separated by a single NUL. +# +# To enable this hook, rename this file to "query-watchman" and set +# 'git config core.fsmonitor .git/hooks/query-watchman' +# +my ($version, $time) = @ARGV; + +# Check the hook interface version + +if ($version == 1) { + # convert nanoseconds to seconds + # subtract one second to make sure watchman will return all changes + $time = int ($time / 1000000000) - 1; +} else { + die "Unsupported query-fsmonitor hook version '$version'.\n" . + "Falling back to scanning...\n"; +} + +my $git_work_tree; +if ($^O =~ 'msys' || $^O =~ 'cygwin') { + $git_work_tree = Win32::GetCwd(); + $git_work_tree =~ tr/\\/\//; +} else { + require Cwd; + $git_work_tree = Cwd::cwd(); +} + +my $retry = 1; + +launch_watchman(); + +sub launch_watchman { + + my $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'watchman -j --no-pretty') + or die "open2() failed: $!\n" . + "Falling back to scanning...\n"; + + # In the query expression below we're asking for names of files that + # changed since $time but were not transient (ie created after + # $time but no longer exist). + # + # To accomplish this, we're using the "since" generator to use the + # recency index to select candidate nodes and "fields" to limit the + # output to file names only. + + my $query = <<" END"; + ["query", "$git_work_tree", { + "since": $time, + "fields": ["name"] + }] + END + + print CHLD_IN $query; + close CHLD_IN; + my $response = do {local $/; }; + + die "Watchman: command returned no output.\n" . + "Falling back to scanning...\n" if $response eq ""; + die "Watchman: command returned invalid output: $response\n" . + "Falling back to scanning...\n" unless $response =~ /^\{/; + + my $json_pkg; + eval { + require JSON::XS; + $json_pkg = "JSON::XS"; + 1; + } or do { + require JSON::PP; + $json_pkg = "JSON::PP"; + }; + + my $o = $json_pkg->new->utf8->decode($response); + + if ($retry > 0 and $o->{error} and $o->{error} =~ m/unable to resolve root .* directory (.*) is not watched/) { + print STDERR "Adding '$git_work_tree' to watchman's watch list.\n"; + $retry--; + qx/watchman watch "$git_work_tree"/; + die "Failed to make watchman watch '$git_work_tree'.\n" . + "Falling back to scanning...\n" if $? != 0; + + # Watchman will always return all files on the first query so + # return the fast "everything is dirty" flag to git and do the + # Watchman query just to get it over with now so we won't pay + # the cost in git to look up each individual file. + print "/\0"; + eval { launch_watchman() }; + exit 0; + } + + die "Watchman: $o->{error}.\n" . + "Falling back to scanning...\n" if $o->{error}; + + binmode STDOUT, ":utf8"; + local $, = "\0"; + print @{$o->{files}}; +} Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/post-update.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/post-update.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/post-update.sample (revision 6016) @@ -0,0 +1,8 @@ +#!/bin/sh +# +# An example hook script to prepare a packed repository for use over +# dumb transports. +# +# To enable this hook, rename this file to "post-update". + +exec git update-server-info Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-applypatch.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-applypatch.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-applypatch.sample (revision 6016) @@ -0,0 +1,14 @@ +#!/bin/sh +# +# An example hook script to verify what is about to be committed +# by applypatch from an e-mail message. +# +# The hook should exit with non-zero status after issuing an +# appropriate message if it wants to stop the commit. +# +# To enable this hook, rename this file to "pre-applypatch". + +. git-sh-setup +precommit="$(git rev-parse --git-path hooks/pre-commit)" +test -x "$precommit" && exec "$precommit" ${1+"$@"} +: Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-commit.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-commit.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-commit.sample (revision 6016) @@ -0,0 +1,49 @@ +#!/bin/sh +# +# An example hook script to verify what is about to be committed. +# Called by "git commit" with no arguments. The hook should +# exit with non-zero status after issuing an appropriate message if +# it wants to stop the commit. +# +# To enable this hook, rename this file to "pre-commit". + +if git rev-parse --verify HEAD >/dev/null 2>&1 +then + against=HEAD +else + # Initial commit: diff against an empty tree object + against=$(git hash-object -t tree /dev/null) +fi + +# If you want to allow non-ASCII filenames set this variable to true. +allownonascii=$(git config --bool hooks.allownonascii) + +# Redirect output to stderr. +exec 1>&2 + +# Cross platform projects tend to avoid non-ASCII filenames; prevent +# them from being added to the repository. We exploit the fact that the +# printable range starts at the space character and ends with tilde. +if [ "$allownonascii" != "true" ] && + # Note that the use of brackets around a tr range is ok here, (it's + # even required, for portability to Solaris 10's /usr/bin/tr), since + # the square bracket bytes happen to fall in the designated range. + test $(git diff --cached --name-only --diff-filter=A -z $against | + LC_ALL=C tr -d '[ -~]\0' | wc -c) != 0 +then + cat <<\EOF +Error: Attempt to add a non-ASCII file name. + +This can cause problems if you want to work with people on other platforms. + +To be portable it is advisable to rename the file. + +If you know what you are doing you can disable this check using: + + git config hooks.allownonascii true +EOF + exit 1 +fi + +# If there are whitespace errors, print the offending file names and fail. +exec git diff-index --check --cached $against -- Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-merge-commit.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-merge-commit.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-merge-commit.sample (revision 6016) @@ -0,0 +1,13 @@ +#!/bin/sh +# +# An example hook script to verify what is about to be committed. +# Called by "git merge" with no arguments. The hook should +# exit with non-zero status after issuing an appropriate message to +# stderr if it wants to stop the merge commit. +# +# To enable this hook, rename this file to "pre-merge-commit". + +. git-sh-setup +test -x "$GIT_DIR/hooks/pre-commit" && + exec "$GIT_DIR/hooks/pre-commit" +: Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-push.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-push.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-push.sample (revision 6016) @@ -0,0 +1,53 @@ +#!/bin/sh + +# An example hook script to verify what is about to be pushed. Called by "git +# push" after it has checked the remote status, but before anything has been +# pushed. If this script exits with a non-zero status nothing will be pushed. +# +# This hook is called with the following parameters: +# +# $1 -- Name of the remote to which the push is being done +# $2 -- URL to which the push is being done +# +# If pushing without using a named remote those arguments will be equal. +# +# Information about the commits which are being pushed is supplied as lines to +# the standard input in the form: +# +# +# +# This sample shows how to prevent push of commits where the log message starts +# with "WIP" (work in progress). + +remote="$1" +url="$2" + +z40=0000000000000000000000000000000000000000 + +while read local_ref local_sha remote_ref remote_sha +do + if [ "$local_sha" = $z40 ] + then + # Handle delete + : + else + if [ "$remote_sha" = $z40 ] + then + # New branch, examine all commits + range="$local_sha" + else + # Update to existing branch, examine new commits + range="$remote_sha..$local_sha" + fi + + # Check for WIP commit + commit=`git rev-list -n 1 --grep '^WIP' "$range"` + if [ -n "$commit" ] + then + echo >&2 "Found WIP commit in $local_ref, not pushing" + exit 1 + fi + fi +done + +exit 0 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-rebase.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-rebase.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-rebase.sample (revision 6016) @@ -0,0 +1,169 @@ +#!/bin/sh +# +# Copyright (c) 2006, 2008 Junio C Hamano +# +# The "pre-rebase" hook is run just before "git rebase" starts doing +# its job, and can prevent the command from running by exiting with +# non-zero status. +# +# The hook is called with the following parameters: +# +# $1 -- the upstream the series was forked from. +# $2 -- the branch being rebased (or empty when rebasing the current branch). +# +# This sample shows how to prevent topic branches that are already +# merged to 'next' branch from getting rebased, because allowing it +# would result in rebasing already published history. + +publish=next +basebranch="$1" +if test "$#" = 2 +then + topic="refs/heads/$2" +else + topic=`git symbolic-ref HEAD` || + exit 0 ;# we do not interrupt rebasing detached HEAD +fi + +case "$topic" in +refs/heads/??/*) + ;; +*) + exit 0 ;# we do not interrupt others. + ;; +esac + +# Now we are dealing with a topic branch being rebased +# on top of master. Is it OK to rebase it? + +# Does the topic really exist? +git show-ref -q "$topic" || { + echo >&2 "No such branch $topic" + exit 1 +} + +# Is topic fully merged to master? +not_in_master=`git rev-list --pretty=oneline ^master "$topic"` +if test -z "$not_in_master" +then + echo >&2 "$topic is fully merged to master; better remove it." + exit 1 ;# we could allow it, but there is no point. +fi + +# Is topic ever merged to next? If so you should not be rebasing it. +only_next_1=`git rev-list ^master "^$topic" ${publish} | sort` +only_next_2=`git rev-list ^master ${publish} | sort` +if test "$only_next_1" = "$only_next_2" +then + not_in_topic=`git rev-list "^$topic" master` + if test -z "$not_in_topic" + then + echo >&2 "$topic is already up to date with master" + exit 1 ;# we could allow it, but there is no point. + else + exit 0 + fi +else + not_in_next=`git rev-list --pretty=oneline ^${publish} "$topic"` + /usr/bin/perl -e ' + my $topic = $ARGV[0]; + my $msg = "* $topic has commits already merged to public branch:\n"; + my (%not_in_next) = map { + /^([0-9a-f]+) /; + ($1 => 1); + } split(/\n/, $ARGV[1]); + for my $elem (map { + /^([0-9a-f]+) (.*)$/; + [$1 => $2]; + } split(/\n/, $ARGV[2])) { + if (!exists $not_in_next{$elem->[0]}) { + if ($msg) { + print STDERR $msg; + undef $msg; + } + print STDERR " $elem->[1]\n"; + } + } + ' "$topic" "$not_in_next" "$not_in_master" + exit 1 +fi + +<<\DOC_END + +This sample hook safeguards topic branches that have been +published from being rewound. + +The workflow assumed here is: + + * Once a topic branch forks from "master", "master" is never + merged into it again (either directly or indirectly). + + * Once a topic branch is fully cooked and merged into "master", + it is deleted. If you need to build on top of it to correct + earlier mistakes, a new topic branch is created by forking at + the tip of the "master". This is not strictly necessary, but + it makes it easier to keep your history simple. + + * Whenever you need to test or publish your changes to topic + branches, merge them into "next" branch. + +The script, being an example, hardcodes the publish branch name +to be "next", but it is trivial to make it configurable via +$GIT_DIR/config mechanism. + +With this workflow, you would want to know: + +(1) ... if a topic branch has ever been merged to "next". Young + topic branches can have stupid mistakes you would rather + clean up before publishing, and things that have not been + merged into other branches can be easily rebased without + affecting other people. But once it is published, you would + not want to rewind it. + +(2) ... if a topic branch has been fully merged to "master". + Then you can delete it. More importantly, you should not + build on top of it -- other people may already want to + change things related to the topic as patches against your + "master", so if you need further changes, it is better to + fork the topic (perhaps with the same name) afresh from the + tip of "master". + +Let's look at this example: + + o---o---o---o---o---o---o---o---o---o "next" + / / / / + / a---a---b A / / + / / / / + / / c---c---c---c B / + / / / \ / + / / / b---b C \ / + / / / / \ / + ---o---o---o---o---o---o---o---o---o---o---o "master" + + +A, B and C are topic branches. + + * A has one fix since it was merged up to "next". + + * B has finished. It has been fully merged up to "master" and "next", + and is ready to be deleted. + + * C has not merged to "next" at all. + +We would want to allow C to be rebased, refuse A, and encourage +B to be deleted. + +To compute (1): + + git rev-list ^master ^topic next + git rev-list ^master next + + if these match, topic has not merged in next at all. + +To compute (2): + + git rev-list master..topic + + if this is empty, it is fully merged to "master". + +DOC_END Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-receive.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-receive.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/pre-receive.sample (revision 6016) @@ -0,0 +1,24 @@ +#!/bin/sh +# +# An example hook script to make use of push options. +# The example simply echoes all push options that start with 'echoback=' +# and rejects all pushes when the "reject" push option is used. +# +# To enable this hook, rename this file to "pre-receive". + +if test -n "$GIT_PUSH_OPTION_COUNT" +then + i=0 + while test "$i" -lt "$GIT_PUSH_OPTION_COUNT" + do + eval "value=\$GIT_PUSH_OPTION_$i" + case "$value" in + echoback=*) + echo "echo from the pre-receive-hook: ${value#*=}" >&2 + ;; + reject) + exit 1 + esac + i=$((i + 1)) + done +fi Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/prepare-commit-msg.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/prepare-commit-msg.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/prepare-commit-msg.sample (revision 6016) @@ -0,0 +1,42 @@ +#!/bin/sh +# +# An example hook script to prepare the commit log message. +# Called by "git commit" with the name of the file that has the +# commit message, followed by the description of the commit +# message's source. The hook's purpose is to edit the commit +# message file. If the hook fails with a non-zero status, +# the commit is aborted. +# +# To enable this hook, rename this file to "prepare-commit-msg". + +# This hook includes three examples. The first one removes the +# "# Please enter the commit message..." help message. +# +# The second includes the output of "git diff --name-status -r" +# into the message, just before the "git status" output. It is +# commented because it doesn't cope with --amend or with squashed +# commits. +# +# The third example adds a Signed-off-by line to the message, that can +# still be edited. This is rarely a good idea. + +COMMIT_MSG_FILE=$1 +COMMIT_SOURCE=$2 +SHA1=$3 + +/usr/bin/perl -i.bak -ne 'print unless(m/^. Please enter the commit message/..m/^#$/)' "$COMMIT_MSG_FILE" + +# case "$COMMIT_SOURCE,$SHA1" in +# ,|template,) +# /usr/bin/perl -i.bak -pe ' +# print "\n" . `git diff --cached --name-status -r` +# if /^#/ && $first++ == 0' "$COMMIT_MSG_FILE" ;; +# *) ;; +# esac + +# SOB=$(git var GIT_COMMITTER_IDENT | sed -n 's/^\(.*>\).*$/Signed-off-by: \1/p') +# git interpret-trailers --in-place --trailer "$SOB" "$COMMIT_MSG_FILE" +# if test -z "$COMMIT_SOURCE" +# then +# /usr/bin/perl -i.bak -pe 'print "\n" if !$first_line++' "$COMMIT_MSG_FILE" +# fi Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/update.sample =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/update.sample (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/hooks/update.sample (revision 6016) @@ -0,0 +1,128 @@ +#!/bin/sh +# +# An example hook script to block unannotated tags from entering. +# Called by "git receive-pack" with arguments: refname sha1-old sha1-new +# +# To enable this hook, rename this file to "update". +# +# Config +# ------ +# hooks.allowunannotated +# This boolean sets whether unannotated tags will be allowed into the +# repository. By default they won't be. +# hooks.allowdeletetag +# This boolean sets whether deleting tags will be allowed in the +# repository. By default they won't be. +# hooks.allowmodifytag +# This boolean sets whether a tag may be modified after creation. By default +# it won't be. +# hooks.allowdeletebranch +# This boolean sets whether deleting branches will be allowed in the +# repository. By default they won't be. +# hooks.denycreatebranch +# This boolean sets whether remotely creating branches will be denied +# in the repository. By default this is allowed. +# + +# --- Command line +refname="$1" +oldrev="$2" +newrev="$3" + +# --- Safety check +if [ -z "$GIT_DIR" ]; then + echo "Don't run this script from the command line." >&2 + echo " (if you want, you could supply GIT_DIR then run" >&2 + echo " $0 )" >&2 + exit 1 +fi + +if [ -z "$refname" -o -z "$oldrev" -o -z "$newrev" ]; then + echo "usage: $0 " >&2 + exit 1 +fi + +# --- Config +allowunannotated=$(git config --bool hooks.allowunannotated) +allowdeletebranch=$(git config --bool hooks.allowdeletebranch) +denycreatebranch=$(git config --bool hooks.denycreatebranch) +allowdeletetag=$(git config --bool hooks.allowdeletetag) +allowmodifytag=$(git config --bool hooks.allowmodifytag) + +# check for no description +projectdesc=$(sed -e '1q' "$GIT_DIR/description") +case "$projectdesc" in +"Unnamed repository"* | "") + echo "*** Project description file hasn't been set" >&2 + exit 1 + ;; +esac + +# --- Check types +# if $newrev is 0000...0000, it's a commit to delete a ref. +zero="0000000000000000000000000000000000000000" +if [ "$newrev" = "$zero" ]; then + newrev_type=delete +else + newrev_type=$(git cat-file -t $newrev) +fi + +case "$refname","$newrev_type" in + refs/tags/*,commit) + # un-annotated tag + short_refname=${refname##refs/tags/} + if [ "$allowunannotated" != "true" ]; then + echo "*** The un-annotated tag, $short_refname, is not allowed in this repository" >&2 + echo "*** Use 'git tag [ -a | -s ]' for tags you want to propagate." >&2 + exit 1 + fi + ;; + refs/tags/*,delete) + # delete tag + if [ "$allowdeletetag" != "true" ]; then + echo "*** Deleting a tag is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/tags/*,tag) + # annotated tag + if [ "$allowmodifytag" != "true" ] && git rev-parse $refname > /dev/null 2>&1 + then + echo "*** Tag '$refname' already exists." >&2 + echo "*** Modifying a tag is not allowed in this repository." >&2 + exit 1 + fi + ;; + refs/heads/*,commit) + # branch + if [ "$oldrev" = "$zero" -a "$denycreatebranch" = "true" ]; then + echo "*** Creating a branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/heads/*,delete) + # delete branch + if [ "$allowdeletebranch" != "true" ]; then + echo "*** Deleting a branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/remotes/*,commit) + # tracking branch + ;; + refs/remotes/*,delete) + # delete tracking branch + if [ "$allowdeletebranch" != "true" ]; then + echo "*** Deleting a tracking branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + *) + # Anything else (is there anything else?) + echo "*** Update hook: unknown type of update to ref $refname of type $newrev_type" >&2 + exit 1 + ;; +esac + +# --- Finished +exit 0 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/info/exclude =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/info/exclude (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/info/exclude (revision 6016) @@ -0,0 +1,6 @@ +# git ls-files --others --exclude-from=.git/info/exclude +# Lines that start with '#' are comments. +# For a project mostly in C, the following would be a good set of +# exclude patterns (uncomment them if you want to use them): +# *.[oa] +# *~ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/HEAD =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/HEAD (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/HEAD (revision 6016) @@ -0,0 +1,1 @@ +0000000000000000000000000000000000000000 060d1121e4ea1d85add64001ba4b8546f5b18009 Lmdz Compte generique 1697450331 +0200 clone: from https://github.com/lguez/ecrad.git Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/refs/heads/master =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/refs/heads/master (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/refs/heads/master (revision 6016) @@ -0,0 +1,1 @@ +0000000000000000000000000000000000000000 060d1121e4ea1d85add64001ba4b8546f5b18009 Lmdz Compte generique 1697450331 +0200 clone: from https://github.com/lguez/ecrad.git Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/refs/remotes/origin/HEAD =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/refs/remotes/origin/HEAD (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/logs/refs/remotes/origin/HEAD (revision 6016) @@ -0,0 +1,1 @@ +0000000000000000000000000000000000000000 060d1121e4ea1d85add64001ba4b8546f5b18009 Lmdz Compte generique 1697450331 +0200 clone: from https://github.com/lguez/ecrad.git Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/packed-refs =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/packed-refs (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/packed-refs (revision 6016) @@ -0,0 +1,7 @@ +# pack-refs with: peeled fully-peeled sorted +4353f754f2bc3f0ee7b42e7e1f4db44811338844 refs/remotes/origin/develop +493036ad04a9584031209330ed537314adc600d2 refs/remotes/origin/ecckd +379350130da02aef94c9bf2148730e907bb5f884 refs/remotes/origin/flotsam +060d1121e4ea1d85add64001ba4b8546f5b18009 refs/remotes/origin/master +665379bce4d820c54f65b8349205e6c4badf01ca refs/remotes/origin/nabr-ifsdriver +f517c5ed2b5e378a4823fb8f0b0bc537338d2516 refs/remotes/origin/tripleclouds_radiance Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/refs/heads/master =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/refs/heads/master (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/refs/heads/master (revision 6016) @@ -0,0 +1,1 @@ +060d1121e4ea1d85add64001ba4b8546f5b18009 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/refs/remotes/origin/HEAD =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/refs/remotes/origin/HEAD (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/.gitx/refs/remotes/origin/HEAD (revision 6016) @@ -0,0 +1,1 @@ +ref: refs/remotes/origin/master Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/CHANGELOG =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/CHANGELOG (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/CHANGELOG (revision 6016) @@ -0,0 +1,750 @@ +version 1.6.1 + - radiation_cloud:set_overlap_param now has alternative form in + which input decorrelation_length may vary with column, useful for + models with a latitudinal or other dependence + - radiation_ecckd:calc_optical_depth has vector version for NEC + - test/ckdmip can now run CKDMIP scenarios of concentrations + downloaded (see Makefile) + - ecCKD gas optics can now be used with older cloud/aerosol optics + files provided they have the same number of bands + - Added dependence to Makefile ensuring libradiation built after + libifsrrtm, ensuring that multi-threaded make works + - Added radiation_driver:do_save_cloud_optics namelist entry which + saves look-up table averaged to the bands of the radiation scheme + (general cloud optics only) + - Increased security value in single-precision SW + reflectance-transmittance calculation from 1e-12 to 1e-6 + - Added radiation/ecrad_config.h file to provide site-specific + optimization options as preprocessor parameters + - Replaced slow "sum" intrinsic function in McICA and Tripleclouds + solvers with optimized versions for x86-64 and DWD's NEC + - Enable different gas optics models for shortwave and longwave: + namelist gas_model_name can still be used, or use + sw_gas_model_name and lw_gas_model_name to specify separate models + - Fix the general aerosol optics + RRTMG combination, so that + optical properties correctly weighted by solar or terrestrial + Planck function, rather than unweighted. This changes fluxes by up + to 0.3 W m-2 in SW and 0.03 in LW, heating rates by up to 0.015 + K/d in SW and 0.0015 in LW. Reverts bug introduced between git + commits a405cca (5 Dec 2022) and 7182230 (8 Dec 2022). + - Added ifs/satur.F90, used in the IFS to compute relative + humidity for aerosol hydration, and the ability to call it from + ecrad_driver.F90, but note that this routine computes saturation + with respect to ice at colder temperatures. If used, the impact on + fluxes is up to around 1 W m-2 in the SW and 0.05 in the LW, and + for heating rates 0.002 K/d in the SW and 0.003 in the LW. + +version 1.6.0 (27 April 2023) + - Removed compiler flag specifying to load unformated Fortran + files as big endian: now the OPEN commands for the files RADRRTM + and RADSRTM specify CONVERT='BIG_ENDIAN' in rrtm_kgb1.F90 and + srtm_kgb16.F90 + - make test_programs to make test programs in driver directory + - Unpublished "Baran" and "Baran2017" ice optics models are + deprecated, only accessible with namelist entries + "Baran-EXPERIMENTAL" and "Baran2017-EXPERIMENTAL" + - Wavelength tolerance for requesting monochromatic aerosol info + increased from 1% to 2% + - test/ifs directory contains configCY*.nam files corresponding to + more previous operational IFS cycles, and added + ecrad_meridian_default_out_REFERENCE.log indicating how the + reference file (now updated) was produced + - Default generalized aerosol optics file changed to + aerosol_ifs_49R1_20230119.nc + +version 1.5.1 (8 December 2022) + - Added Makefile_include.intel_atos to match compiler options on + ECMWF supercomputer, plus "-heap-arrays" which is necessary for + - Fix occasional crash in single-precision fast_expm_exchange_3 + for shortwave SPARTACUS entrapment + - Fixed radiation_random_numbers.F90 in single precision + - Removed Dr Hook implementation for profiling; instead optionally + call make with FIATDIR to specify the location of ECMWF's fiat + library which contains Dr Hook + - Added "make ifsdriver" which compiles ifs/libifs.a and + bin/ecrad_ifs to demonstrate use of IFS's radiation_scheme and + setup_radiation_scheme; test with make test_ifsdriver in + test/ifs. Note that the input file must have variables with the + dimensions expected in the IFS, as in test/ifs/ecrad_meridian.nc. + - Added "make ifsdriver_blocked" from Balthasar Reuter which + compiles bin/ecrad_ifs_blocked, gathering the input data into + blocks of length driver_config%nblocksize as in the IFS, which can + benefit memory locality + - Added capability for ecCKD to represent the solar cycle in solar + spectral irradiance, via "radiation" namelist parameter + use_spectral_solar_cycle and new file ssi_nrl2.nc (which can be + overridden with ssi_override_file_name). Caller provides + single_level%spectral_solar_cycle_multiplier from -1 (solar + minimum) to +1 (solar maximum), or "radiation_driver" namelist + parameter solar_cycle_multiplier_override + - If use_spectral_solar_cycle then if also + use_updated_solar_spectrum, the mean solar irradiance per g-point + will be updated from the solar cycle file. This only works for + gas-optics models from ecCKD >= 1.4, since these store the solar + spectrum on a wavenumber grid. + - Added get_sw_mapping, which returns a matrix to map from fluxes + in solar bands to fluxes in user-specified wavelength intervals, + useful for (for example) computing spectral fluxes for ocean + biology or UV index + - Added demonstration of get_sw_mapping: radiation_driver namelist + now accepts sw_diag_wavelength_bound, which takes a list of + wavenumber bounds for shortwave diagnostics. These are written to + radiation_driver: sw_diag_file_name, or sw_diagnostics.nc by + default. Test with "make test_ecckd_diag" in test/ifs. + - do_toa_spectral_flux namelist option stores top-of-atmosphere + spectral flux diagnostics per band + +version 1.5.0 (22 May 2022) + - Added ecCKD gas optics scheme and generalized cloud description + - Optimized the LW Tripleclouds solver for cloud but not aerosol + scattering + - Added general spectral description of aerosol, compatible with + ecCKD gas optics model + - Added 50 CKDMIP test profiles in test/ckdmip directory + - General cloud and aerosol optics controlled with + use_general_cloud_optics and use_general_aerosol_optics + - Added use_thick_cloud_spectral_averaging config vector + corresponding to cloud_type_name + - Generalized clouds and aerosols can compute optical properties + per g-point or band, controlled with + do_cloud_aerosol_per_[lw|sw]_g_point + - Default is to average albedo/emissivity source data to ecRad + bands/g-points, rather than just to find the nearest value + (i.e. do_nearest_spectral_sw_albedo and + do_nearest_spectral_lw_emiss are now false by default) + - Replaced dry_sw_aerosol_mass_extinction and + aerosol_sw_extinction routines with dry_aerosol_mass_extinction + and aerosol_extinction, which take wavelength rather than band + number + - "make GPROF=1" compiles with -pg option for the GNU profiler + - For consistency with IFS, "PARKIND1_SINGLE" is now the + preprocessor variable to detect single precision + - "make OMPFLAG=-DNO_OPENMP" compiles without OpenMP + - Generalized aerosol has ability to read old-style aerosol + property files in predefined (e.g. RRTM) bands into the spectral + intervals of the ecCKD gas optics scheme + - Added radiation_driver:do_save_aerosol_optics namelist option to + save aerosol optical properties in aerosol_optics.nc, and "make + test_aerosol_averaging" in test/ifs to test the various + combinations of gas optics scheme and aerosol optics file + - Added do_weighted_surface_mapping, which if false does not + weight the surface albedo/emissivity by the solar/terrestrial + reference Planck function, thereby reproducing ecRad-1.4.x + behaviour + - Added Fu-Muskatel ice optics model, which can be used by the + generalized cloud optics and extends the Fu model to larger + effective radius + +version 1.4.2 (15 October 2021) + - radiation_driver:do_write_double_precision writes fluxes as + doubles in NetCDF file, which reduces noise in heating rate + differences between two experiments + - Added use_vectorizable_generator for vectorizable random number + generator that speeds-up McICA solver on NEC hardware + - Numerous modifications to improve performance on DWD's NEC but + which don't affect performance on Intel + - Removed unused radsurf code - use SPARTACUS-Surface instead + +version 1.4.1 (17 March 2021) + - Added Jupyter notebook to the practical directory + +version 1.4.0 (5 November 2020) + - Replaced OpenIFS license with Apache License (version 2.0) and + added copyright statements to each file + - Bug fix in cum_cloud_cover_exp_exp that was triggered if exactly + zero overlap parameter between cloud objects + - Corrected the metadata in fu_ice_scattering_rrtm.nc for the + meaning of the coefficients representing the single-scattering + albedo (or mass absorption coefficient) of ice in the longwave + - Fixed bug in McICA solvers in single-precision where ssa*od can + underflow to zero even when the terms individually are larger than + zero + +version 1.3.1 (10 August 2020) + - Functional Dr Hook added by Ioan Hadade, enabled with "make + DR_HOOK=1" + - Fix from Daniel Rieger in ifsrrtm/srtm_taumol[16-29].F90, + correcting a bug that violated bit-reproducibility when changing + the number of MPI tasks + - Makefile_include.cray added by Ioan Hadade so that "make + PROFILE=cray" uses the Cray compiler, if available + - Added securities to Fu ice optics: re <= 100um and g < 1 + - Added securities to SOCRATES liquid optics: 1.2um <= re <= 50um + +version 1.3.0 (20 March 2020) + - Corrected shortwave band fluxes in Cloudless and Homogeneous + solvers, which scaled the direct downwelling spectral flux by the + cosine of the solar zenith angle twice + - Write "experiment" global attribute to output if + radiation_driver variable "experiment_name" is present + - Previously overlap_decorr_length_scaling=0.0 was ignored; now it + implements random overlap + - Added the ecRad practical exercises to the "practical" directory + - Removed non-functioning hooks to PSRAD code + +version 1.2.0 (30 October 2019) + - Increased default minimum cloud effective size to 100 m + (although 500 m is used in the IFS for better SPARTACUS + stability) + - Reduced max_cloud_od to 16 for SPARTACUS stability + - Allow water vapour to be specified by "h2o_mmr" or "h2o_vmr" if + "q" not present in input file + - Fixed effective_size_scaling namelist variable, broken in v1.1.8 + - cos_solar_zenith_angle not needed if do_sw=false + - skin_temperature set to lowest air temperature if not provided + - Warning issued if default solar_irradiance of 1366 is used + - Added radiation_driver namelist variable "vmr_suffix_str" + (default "_vmr") to enable the expected variable names containing + gas volume mixing ratios to be overridden + - Use the nf-config utility to set NETCDF_INCLUDE and NETCDF_LIB + +version 1.1.10 (8 April 2019) + - Renamed occurrences of "encroachment" with "entrapment" to match + terminology of Hogan et al. entrapment paper, but namelist + interface still accepts sw_encroachment_name (sw_entrapment_name + preferred) and encroachment_scaling (overhang_factor preferred). + - Added gas%scale routine to scale gas concentrations and namelist + parameters driver_config%co2_scaling (and all gases) so that users + can easily test the effect of, for example, doubling CO2 or + setting it to zero. + - Fixed parameterization of cloud scales in radiation_cloud to + optionally take as input the range of columns to process. + - Redefined use of scale_factor in radiation_gas.F90 + +version 1.1.9 (9 Feb 2019) + - Mapping from albedo/emissivity intevals to bands may be done as + before by selecting the nearest interval to the centre of each + band, or now by computing the fractional overlap of each interval + with each band. This is controlled by the + do_nearest_spectral_[sw_albedo|lw_emiss] configuration parameter + - The user can specify the spectral range of the albedo/emissivity + intervals using namelist parameters + [sw_albedo|lw_emiss]_wavelength_bound and + i_[sw_albedo|lw_emiss]_index, or calling the + config%define_[sw_albedo|lw_albedo]_intervals routines before + calling setup_radiation, which does the actual mapping once the + ecRad bands are known + - Parameterize cloud separation scale via radiation_driver + namelist options "cloud_separation_scale_[toa|surface|power]" + - radiation_driver:do_correct_unphysical_inputs namelist option + does not simply warn about unphysical inputs (e.g. negative gas + concentrations) but fixes them + - Replaced LwDiffusivity by 2.0 in + radiation_two_stream:calc_frac_scattered_diffuse_sw, which is + more consistent with the Zdunkowski scheme, but has a very small + effect + +version 1.1.8 (17 January 2019) + - easy_netcdf.F90 allows for reading and writing slices of larger + arrays and writing HDF5 files, overcoming the maximum array size + limitation of classic NetCDF files + - cloud%inv_inhom_effective_size allows different effective sizes + for cloud inhomogeneities and cloud boundaries in SPARTACUS, + important for realistic behaviour when cloud fraction is near one, + and can be specified directly in the NetCDF input file + - The namelist variable "do_ignore_inhom_effective_size" in + "driver_config" means that "inv_inhom_effective_size" will be + ignored if it is present in the file, reverting to the old + behaviour + - Alternative input variables "inv_cloud_effective_separation" and + "inv_inhom_effective_separation" allow cloud structure for + SPARTACUS to be specified in a way less dependent on cloud + fraction + - If "inv_cloud_effective_separation" provided but not + "inv_inhom_effective_separation" then the effective size of + inhomogeneities is computed as that for the clouds themselves + multiplied by the "cloud_inhom_separation_factor" namelist + variable from "driver_config" (or 1 if not provided). + - Check physical bounds of inputs to radiation interface + - [aerosol|ice|liq]_optics_override_file_name now read from namelist + - radiation_homogeneous_[sl]w.F90 now stores spectral flux + profiles, if required + +version 1.1.7 (8 January 2019) + - Added "Cloudless" solvers in shortwave and longwave + - Writing radiative_properties*.nc files now thread-safe + - Fixed segmentation fault in solver_tripleclouds_sw when + do_save_spectral_flux .and. .not. do_sw_direct + - Initialize shortwave properties in radiation_ifs_rrtm in case + sun is below horizon, needed for some compiler options + - Modified test/ifs/ecrad_meridian.nc to allow sun to go below + horizon, rather than including the online correction for Earth + curvature. + - Modified driver/ecrad_driver_read_input.F90 so that if sw_albedo + and lw_emissivity override namelist parameters are provided, they + don't also need to be provided in the input files + +version 1.1.6 (17 December 2018) + - Generalized "alpha" overlap matrix calculation to allow for + possibility that the two cloudy regions in the Tripleclouds + assumption are not of equal size + - Introduced radiation_regions.F90 to compute region fractions and + optical depth scalings at the same time + - New gamma distribution behaviour in Tripleclouds and SPARTACUS: + if fractional standard deviation FSD > 1.5 then use non-equal + fractions for the two cloudy regions, which better predicts + fluxes. Also set a minimum optical depth scaling of 1/40, which + means that Tripleclouds and SPARTACUS will give slightly different + fluxes from before (< 0.1 W m-2) even for FSD < 1.5 + - SPARTACUS shortwave encroachment uses new fast_expm_exchange + routine given that matrix to be exponentiated has a regular structure + - Execution halts if gases not provided with 0 (well-mixed) or 2 + dimensions; before execution silently continued with these gases + not present + +version 1.1.5 (15 September 2018) + - Added "Zero" option for sw_encroachment_name, which turns off + not only encroachment due to horizontal transport within regions, + but also encroachment due to horizontal transport between regions + +version 1.1.4 (13 September 2018) + - Added "Fractal" option for sw_encroachment_name, which makes a + better assumption about the cloud size distribution than + "Computed" in the part that uses the horizontal radiation + migration distance to work out how much exchange has occurred + under regions + +version 1.1.3 (4 September 2018) + - Added (shortwave) encroachment_scaling to namelist, configuring + how one assumes cloud boundaries line up in adjacent layers: 0.0 + (the boundaries line up to the greatest extent possible given the + overlap parameter) and 1.0 (the boundaries line up to the minimum + extent possible, which was the old behaviour) + - Fixed related minor bug where encroachment transfer rate was + computed from the edge lengths in the wrong layer + +version 1.1.2 (3 September 2018) + - Added Python script test/ifs/plot_ifs.py (thanks to Alessio + Bozzo) + - Bug fix in calculation of direct horizontal migration distance + in radiation_spartacus_sw.F90 + - Added namelist parameter min_cloud_effective_size to help with + stability of SPARTACUS + +version 1.1.1 (29 August 2018) + - Complete reformulation of the calculation of horizontal + migration distances in radiation_spartacus_sw.F90 + - Option to set particulate single-scattering albedo and asymmetry + factor via namelist in LW and SW monochromatic case + +version 1.1.0 (21 August 2018) + - Clean-up for release + - Updated test/i3rc/duplicate_profiles.sh to work with latest nco + tools + +version 1.0.16 (7 May 2018) + - "make PRINT_ENCROACHMENT_DATA=1" prints encroachment data from + SPARTACUS shortwave solver to units 101 and 102, which can be + tested with test/i3rc/plot_encroachment.m + - Enabled radsurf canopies to include longwave gas + absorption/emission at full spectral resolution + - Monochromatic shortwave properties now more consistent with 0.55 + micron wavelength (g=0.86, ssa=0.999999, delta-Eddington applied) + - Now pass in KLEV rather than a structure to ifsrrtm routines + +version 1.0.15 (18 April 2018) + - Added capability to provide aerosol optical properties rather + than mixing ratios, implemented via the add_aerosol_optics_direct + routine + - Removed dummy "method" argument to calc_two_stream_gammas_?w + - Removed a large number of unused dummy arguments + - Updated README and test/ifs/ecrad_meridian_default_out_REFERENCE.nc + +version 1.0.14 (23 March 2018) + - Large number of improvements and fixes to the treatment of urban + areas + +version 1.0.13 (14 March 2018) + - Extra securities on transmittance, reflectance etc. in shortwave + SPARTACUS solver + - Reduced default max_cloud_od for SPARTACUS solver to 18 for + stability + - Finally fixed permute option when writing 3D array using + easy_netcdf.F90 + +version 1.0.12 (22 February 2018) + - Optimized radiation_ifs_rrtm.F90 and radiation_cloud_generator.F90 + +version 1.0.11 (20 February 2018) + - Corrected "computed encroachment" in SPARTACUS shortwave solver + to propagate migration distances according to overlap rules + - Default configuration file in test/ifs directory is for Cycle + 46R1 of IFS, which includes longwave scattering, fixes LW ice + optics bug and computes shortwave delta-Eddington scaling for + particulates only + +version 1.0.10 (23 October 2017) + - Added single precision option: compile with "make + SINGLE_PRECISION=1" + - easy_netcdf can read 4D arrays (thanks to Alessio Bozzo) + - Renamed single-character variables + - New data/yi_ice_scattering_rrtm.nc with longwave extinction + rather than absorption coefficient (thanks to Mark Fielding) + - Added security on n_scat_diffuse + +version 1.0.9 (26 July 2017) + - Refined shortwave SPARTACUS such that computed encroachment + estimates the number of diffuse scattering events and reduces the + migration distance accordingly + - Optimized calculation of longwave reflection/transmission coeffs + +version 1.0.8 (22 July 2017) + - Added lognormal/gamma cloud PDF options that affect McICA, + Tripleclouds and SPARTACUS solvers: namelist entry + "cloud_pdf_shape_name" can be "Lognormal" or "Gamma" (default + "Gamma") + - radiation_driver can read "iseed" variable for seeding the McICA + cloud generator + - Added Yi et al. (2013) ice optics model (thanks to Mark + Fielding): namelist entry ice_model_name="Yi" + +version 1.0.7 (7 July 2017) + - Bug fix in reformulated SPARTACUS solver + +version 1.0.6 (4 July 2017) + - Reformulated shortwave SPARTACUS solver to have the option of + explicitly computing "encroachment" (what Shonk & Hogan called + "anomalous transport") accounting for expected horizontal + migration distance during a reflection event + +version 1.0.5 (29 June 2017) + - Added "urban" tile type + +version 1.0.4 (24 April 2017) + - Added "flat" and "vegetation" tile types + - Added "make DEBUG=1" option for turning on debug flags + +version 1.0.3 (11 April 2017) + - Converted code to use "surface" type for multi-tile surfaces in + future + +(version 1.0.2surface - unstable intermediate version) + +version 1.0.1 (15 February 2017) + - Fixed Makefile options for PGI Fortran + - Removed erroneous commas from test/i3rc/Makefile + - Renamed variables shadowing intrinsics "scale" and "index" + +version 1.0 (13 February 2017) + - Read RADRRTM and RADSRTM from data directory + - Renamed "PROFILE" in test/i3rc/Makefile to avoid clash with use + of the same name in top-level Makefile + +version 0.9.48 (13 January 2017) + - test/ifs now includes a test where aerosol is turned off, and a + reference output NetCDF file so that the compilation can be checked + +version 0.9.47 (9 January 2017) + - Can specify output precision via "is_double" argument in easy_netcdf + - save_inputs stores iseed in double precision + - test/i3rc contains I3RC test case + - test/ifs contains IFS test case + - Preliminary "Baran-2017" ice optics scheme: a new + parameterization derived from the Baran et al. (2016) ice optical + properties + +version 0.9.46 (3 January 2017) + - Added mcica_bidisperse.nc to enable McICA to reproduce the + two-mode PDF used by the Tripleclouds and SPARTACUS schemes + +version 0.9.45 (25 November 2016) + - Added OpenIFS license + - Changed build system to use Makefile_include. files + - Renamed package from "spartacus" to "ecrad" + - Fixed writing of 3D arrays in easy_netcdf to permute + withorder=i_permute_3d(i_permute_3d) + - Offline code can be run on input data written by + radiation_save:save_inputs + - New file socrates_droplet_scattering_rrtm.nc with manually + changed coefficients for shortwave band 11 to prevent singularity + in SSA calculation at re=25.733um. Note that there is still a + singularity at re=1.63um in shortwave optical depth in band 10, + so effective radius should be capped to the range 2-50 microns. + +version 0.9.44 (22 October 2016) + - Revised aerosol scattering file aerosol_ifs_rrtm_43R1.nc + - Fixed radiation_cloud_cover: it could access arrays out of + bounds - provided that the memory address was accessible this + would have had no impact since the data were not used + +version 0.9.43 (23 September 2016) + - RADRRTM and RADSRTM can now be read from directory in + environment variable "DATA" + - do_fu_lw_ice_optics_bug is now a namelist option + - Added Baran 2016 ice optics option + - Optimized calculation of Planck function + - Better ordered the printing of configuration information + - Added configCY43R3.nam to match expected configuration in ECMWF + IFS cycle 43R3 + +version 0.9.42 (31 August 2016) + - Optimized radiation_ifs_rrtm.F90 and added + rrtm_gas_optical_depth.F90 to replace rrtm_gasabs1a_140gp.F90 + - Optimized calc_two_stream_gammas_sw + - Added Tripleclouds solvers in longwave and shortwave + +version 0.9.41 (16 August 2016) + - Added possibility to reproduce IFS bug in longwave ice where + single scattering albedo is one minus what it should be + - Ensure initialization to zero of [od/ssa/g]_[sw/lw]_[liq/ice] + variables in radiation_cloud_optics.F90 + - Removed Dr Hook calls for small routines called many times: + everything in radiation_two_stream, plus + radiation_aerosol_optics_data:calc_rh_index, calc_liq_optics_*, + calc_ice_optics_* + +version 0.9.40 (14 July 2016) + - Updated files in ifs directory + +version 0.9.39 (22 June 2016) + - Renamed cloud_cover_* routines to cum_cloud_cover_* since they + compute the cumulative cloud cover, and added a "cloud_cover" + function that does actually compute the total cloud cover (only) + - Use gamma rather than lognormal distribution for McICA to better + match the current IFS + - radiation_cloud::set_overlap_param now uses the correct layer + separation from temperature and pressure, rather than an + approximate one using a constant atmospheric scale height + - radiation_cloud_generator now correlates cloud inhomogeneities + between non-adjacent layers if the Exp-Exp overlap scheme is used + - radiation_cloud_cover::cum_cloud_cover_exp_exp now checks for + pair_cloud_cover not consistent with the cumulative cloud cover + profile + +version 0.9.38 (2 June 2016) + - Added Tegen climatology data file and modified + radiation_aerosol_optics_data to read data files that don't + contain hydrophilic aerosols + - Added Slingo (1989) and Lindner and Li (2000) liquid droplet + optics parameterizations for backwards compatibility with the IFS, + although note that Slingo (1989) has been found to have errors + +version 0.9.37 (17 May 2016) + - Added do_3d_lw_multilayer_effects to mirror the same for + shortwave. This controls whether off-diagonal elements are + permitted in the total_albedo matrix - these represent the + probability that downwelling radiaton exiting a region is + reflected up in another region. This may be due to transport + through cloud sides, or due to "anomalous" horizontal transport + where fluxes are homogenized in regions. Unlike in the shortwave, + this option is not forced on if 3D effects are enabled; in fact, + it is probably better to turn it off in both 1D and 3D cases + because this homogenization is not likely to occur to any + significant degree in the longwave. + - Added capability to select single/double precision in + easy_netcdf.F90, and radiative properties are now stored in double + precision. + - Changed verbosity settings of driver: 2 = print *all* setup + info, 3 = also print numbers of current profiles being processed. + - radiation_ifs_rrtm now checks solar zenith angle for positivity + to decide whether to set incident solar radiation to zero + + +version 0.9.36 (10 May 2016) + - Bug fix in radiation_monochromatic.F90: Planck profile calculation + - Maximum 3D transfer rate is now configurable (max_3d_transfer_rate) + - Inverse effective cloud size can be specified separately for eta + in the bands 0-0.45, 0.45-0.8 and 0.8-1 via high_inv_eff_size, + middle_inv_eff_size, low_inv_eff_size in the radiation_driver + namelist. + - License and copyright now in LICENSE and NOTICE; COPYING has + been removed + - "ifs" directory added illustrating how the radiation scheme is + called from the IFS, including the routines for computing cloud + particle effective radius. + +version 0.9.35 (29 April 2016) + - Added Exponential-Exponential overlap capability to match + original IFS Raisanen cloud generator + - Overlap in McICA can be selected with overlap_scheme_name in + namelist = Exp-Exp, Exp-Ran or Max-Ran + - Removed test on od_over_mu0 in + calc_reflectance_transmittance_sw, which speeds up IFS + implementation + - In same routine, increased minimum "k^2" to 1.0e-12_jprb which + removes noise in clear-sky upwelling versus solar zenith angle + +version 0.9.34 (20 April 2016) + - Added option to do delta-Eddington scaling after merging with + gases, which seems less "correct", but is how the original IFS + scheme works + - Delta-Eddington now a header file included by several modules + - Clarified that RRTMG license is now BSD 3-clause + +version 0.9.33 (March 2016) + - Removed PS-Rad implementation of RRTMG + - Added delta-Eddington scaling of aerosol scattering properties + +version 0.9.32 (17 March 2016) + - Slight change to the way that cloud overlap is specified + - Added aerosol optics data files matching IFS cycles + - Default aerosol file is aerosol_ifs_rrtm_42R1.nc + +version 0.9.31 (26 January 2016) + - Print out description of aerosol types being used + - Added iverbosesetup in order to specify separately the verbosity + of the setup and normal execution parts + - Removed "is_verbose" from namelist + - Removed "ncol" as an argument from the solvers + - PS-Rad RRTMG option now prefixed by PSRAD in the code and the + directory structure; radiation_ifsrrtm renamed to + radiation_ifs_rrtm + +version 0.9.30 (16 January 2016) + - Bug fix: if layer overcast and only 2 regions then 3D + calculations not performed + - Split cloud optics into separate source files + +version 0.9.29 (7 January 2016) + - Support for separate direct and diffuse shortwave albedos + - Explicit loop indices in radiation_adding_ica_*w and + radiation_ifsrrtm speeds these routines up somewhat + - Added capability to calculate longwave derivatives for Hogan & + Bozzo (2015) method + - Faster longwave McICA solver if cloud scattering not represented + - Added homogeneous solvers + +version 0.9.28 (17 November 2015) + - Added some comments to McICA parts and cleaned up + +version 0.9.27 (13 November 2015) + - Capped the transfer rate between regions in 3D SPARTACUS to "10" + per layer, equivalent to an optical depth of 10 + - Fixed cloud cover calculation in cloud generator + - Fixed bug in McICA LW where surface Planck function taken from + wrong column + - Optimized SW reflectance transmittance: use simple expression + for optically thin points + +version 0.9.26 (6 November 2015) + - Added no-scattering solver for McICA longwave, typically used in + clear skies when aerosol scattering is turned off + +version 0.9.25 (4 November 2015) + - Reordered gas and cloud optical properties to have g-point + varying fastest, leading to a significant speed-up + +version 0.9.24 (4 November 2015) + - Added possibility for radiation to be transported directly + between regions a and c, via clear_to_thick_fraction + - Added capability for direct beam from overhead sun to pass + through cloud sides, to improve 3D effect for overhead sun + - Read McICA PDF look-up table from mcica_lognormal.nc to + radiation_pdf_sampler.F90 + - Verified McICA cloud generator + - Added capability to interpret overlap parameter as Hogan & + Illingworth's "alpha" rather than Shonk et al.'s "beta", made this + the default and verified that McICA and SPARTACUS give the same + total cloud cover. + - Added capability to repeat calculation multiple times for better + profiling + - Gas optics unit scaling now done all at once to avoid bugs + associated with part of mixing_ratio array being in one unit and + another part being in another unit (for the same gas) + - Some optimization of gamma calculations + +version 0.9.23 (19 October 2015) + - Thresholds on gas optical depth now performed in + radiation_ifsrrtm.F90 to avoid problems with unphysical ssa after + aerosol optics + +version 0.9.22 (13 October 2015) + - Protection for zero Kelvin in monochromatic Planck function + - Check on dimensions read from aerosol optics file + - Better diagnostic of aerosol settings in print_config + - Included longwave internal radiation distribution + parameterization for 3D (config%do_lw_side_emissivity) + - Added requirement for non-zero water content in + radiation_spartacus_?w.F90 + +version 0.9.21 + - Fixed the monochromatic option + +version 0.9.20 + - Bug fixes in radiation_matrix.F90 and radiation_ifsrrtm.F90 + - Better printing of the configuration in radiation_config.F90 + +version 0.9.19 (not a stable version) + - Moved solar irradiance from config to single_level + +version 0.9.18 + - Module radiation_io for abort and output units + - Started shortwave McICA implementation + - Better IFS compatibility + - Revised config_type structure + +version 0.9.17 + - Optical depth thresholds now in the radiation namelist as + max_gas_od_3d and max_cloud_od + - Can process limited number of columns via istartcol and iendcol + in the radiation_driver namelist + - Fixed bug where upwelling longwave surface clear-sky flux was + underestimated if a cloud was present in lowest model level + - Incoming solar flux scaled in radiation_ifsrrtm to match + requested TSI + +version 0.9.16 + - Rather than turning off 3D radiation if OD in a region is too + high, we cap the OD of the cloud and still do 3D calculations. + Note that to enable 3D effect to be calculated, this is done even + if 3D effects are turned OFF. + +version 0.9.15 + - Added capability to output fluxes per g-point with + do_save_gpoint_flux + - Check for "ghost" clouds (zero water content, non-zero cloud + fraction) + - 3D radiation only called if optical depth of gas < 8 and total + optical depth of thickest region < 30 + +version 0.9.14 + - Cleaned up the text output via separate "iverbose" config + variables for the driver and the main radiation code + +version 0.9.13 + - driver/radiation_driver_config.F90 now handles the aspects of + the configuration that are limited to the driver rather than the + radiation code itself + +version 0.9.12 + - Now use IFS version of RRTM-G gas optics + - g_lw zeroed in radiation_interface + +version 0.9.11 + - Monochromatic is now a run-time rather than compile-time option + - Option to output spectral fluxes + +version 0.9.10 + - Added overlap_decorr_length_scaling option for namelists + +version 0.9.9 + - Added IFS RRTM code in ifsrrtm/ + - Added "make resort" in work/ to provide re-sorted g points for + radiation_rrtm.f90 + +version 0.9.8 + - Better compatibility with IFS: added dr_hook, nulout, + nulerr, abor1 + - easy_netcdf into utilities library + - Revised the variable name convention in radiation/*.f90 so + that can be converted to IFS coding norms if required + +version 0.9.7 + - Added Fu (1996) and Fu et al. (1998) ice optics + +version 0.9.6 + - Implemented aerosols + +version 0.9.5 + - Implemented ice optics + +version 0.9.4 + - Combined clear-sky calculations into single spartacus call + - Fixed the optimized matrix operations for shortwave sparsity + +version 0.9.3 + - Fixed ozone in standard atmosphere profiles + - Fixed bug in Meador-Weaver direct transmittance calculation + +version 0.9.2 + - First beta release Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/COPYING =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/COPYING (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/COPYING (revision 6016) @@ -0,0 +1,1 @@ +For copyright and licensing information, see the file NOTICE. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/LICENSE =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/LICENSE (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/LICENSE (revision 6016) @@ -0,0 +1,190 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + Copyright 1996-2018 ECMWF + + 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. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile (revision 6016) @@ -0,0 +1,199 @@ +# ecRad Makefile - read the README file before editing + +############################# +### --- CONFIGURATION --- ### +############################# + +# Use the nf-config utility, if available, to set the NETCDF_INCLUDE +# and NETCDF_LIB flags +HAVE_NFCONFIG := $(shell nf-config --version 2> /dev/null) +ifdef HAVE_NFCONFIG +$(info *** Using nf-config to obtain NetCDF flags) +NETCDF_INCLUDE = $(shell nf-config --fflags) +NETCDF_LIB = $(shell nf-config --flibs) +ifeq ($(shell nf-config --has-nc4),yes) +NETCDF4 = 1 +endif +else +$(info *** nf-config not found) +endif + +# make can be invoked using "make PROFILE=" in which case your +# local configuration parameters will be obtained from +# Makefile_include. +ifndef PROFILE +$(info *** No "PROFILE" variable provided, assuming "gfortran") +PROFILE = gfortran +endif + +# Include a platform-specific makefile that defines FC, FCFLAGS and +# LIBS +include Makefile_include.$(PROFILE) + +# Check for presence of the NETCDF_INCLUDE and NETCDF_LIB flags +ifndef NETCDF_INCLUDE +$(info *** You may need to set NETCDF_INCLUDE manually) +endif +ifndef NETCDF_LIB +$(info *** You may need to set NETCDF_LIB manually) +endif + +# Add single-precision flag if SINGLE_PRECISION=1 was given on the +# "make" command line +ifdef SINGLE_PRECISION +CPPFLAGS += -DPARKIND1_SINGLE +endif + +# If PRINT_ENTRAPMENT_DATA=1 was given on the "make" command line +# then the SPARTACUS shortwave solver will write data to fort.101 and +# fort.102 +ifdef PRINT_ENTRAPMENT_DATA +CPPFLAGS += -DPRINT_ENTRAPMENT_DATA +endif +# For backwards compatibility we allow the following as well +ifdef PRINT_ENCROACHMENT_DATA +CPPFLAGS += -DPRINT_ENTRAPMENT_DATA +endif +# Allow the capability to write NetCDF4/HDF5 files, provided the code +# is compiled against the NetCDF4 library +ifdef NETCDF4 +$(info *** Building with NetCDF4/HDF5 support) +CPPFLAGS += -DNC_NETCDF4 +endif + +# Consolidate flags +export FC +export FCFLAGS = $(WARNFLAGS) $(BASICFLAGS) $(CPPFLAGS) -I../include \ + $(OPTFLAGS) $(DEBUGFLAGS) $(NETCDF_INCLUDE) $(OMPFLAG) +export LIBS = $(LDFLAGS) -L../lib -lradiation -lutilities \ + -lifsrrtm -lifsaux $(FCLIBS) $(NETCDF_LIB) $(OMPFLAG) + +# Do we include Dr Hook from ECMWF's fiat library? +ifdef FIATDIR +# Prepend location of yomhook.mod module file from fiat library, so +# that it is found in preference to the dummy one in ecRad +FCFLAGS := -I$(FIATDIR)/module/fiat $(FCFLAGS) +# Append fiat library (usually shared: libfiat.so) +LIBS += -L$(FIATDIR)/lib -Wl,-rpath,$(FIATDIR)/lib -lfiat +else +# Dummy Dr Hook library +LIBS += -ldrhook +endif + + +############################# +### --- BUILD TARGETS --- ### +############################# + +all: build + +help: + @echo "Usage:" + @echo " make PROFILE=" + @echo "where is one of gfortran, pgi, intel or cray (see Makefile_include.)" + @echo "Other possible arguments are:" + @echo " DEBUG=1 Compile with debug settings on and optimizations off" + @echo " SINGLE_PRECISION=1 Compile with single precision" + @echo " FIATDIR=/my/path Compile with Dr Hook, specifying the directory containing lib/libfiat.so and module/fiat/yomhook.mod" + @echo " test Run test cases in test directory" + @echo " clean Remove all compiled files" + +ifndef FIATDIR +build: directories libifsaux libdummydrhook libutilities libifsrrtm \ + libradiation driver ifsdriver symlinks +libradiation libutilities: libdummydrhook +else +# Note that if we are using Dr Hook from the fiat library we don't +# want to create mod/yomhook.mod as this can sometimes be found before +# the one in the fiat directory leading to an error at link stage +build: directories libifsaux libutilities libifsrrtm libradiation \ + driver ifsdriver symlinks +endif + +# git cannot store empty directories so they may need to be created +directories: mod lib +mod: + mkdir -p mod +lib: + mkdir -p lib + +deps: clean-deps + cd ifsaux && $(MAKE) deps + cd ifsrrtm && $(MAKE) deps + cd ifs && $(MAKE) deps + +clean-deps: + rm -f include/*.intfb.h + +libifs: libradiation + cd ifs && $(MAKE) + +libifsaux: + cd ifsaux && $(MAKE) + +libdummydrhook: libifsaux + cd drhook && $(MAKE) dummy + +libutilities: libifsaux + cd utilities && $(MAKE) + +libifsrrtm: libifsaux + cd ifsrrtm && $(MAKE) + +libradiation: libifsrrtm libutilities libifsaux + cd radiation && $(MAKE) + +driver: libifsaux libifsrrtm libutilities libradiation + cd driver && $(MAKE) driver + +ifsdriver: libifsaux libifsrrtm libutilities libradiation libifs + cd driver && $(MAKE) ifs_driver + +test_programs: driver + cd driver && $(MAKE) test_programs + +symlinks: clean-symlinks + cd practical && ln -s ../bin/ecrad + cd practical && ln -s ../data + +test: test_ifs test_i3rc test_ckdmip + +test_ifs: driver + cd test/ifs && $(MAKE) test + +test_i3rc: driver + cd test/i3rc && $(MAKE) test + +test_ckdmip: + cd test/ckdmip && $(MAKE) test + +clean: clean-tests clean-toplevel clean-utilities clean-mods clean-symlinks + +clean-tests: + cd test/ifs && $(MAKE) clean + cd test/i3rc && $(MAKE) clean + cd test/ckdmip && $(MAKE) clean + +clean-toplevel: + cd radiation && $(MAKE) clean + cd driver && $(MAKE) clean + +clean-utilities: + cd ifsaux && $(MAKE) clean + cd utilities && $(MAKE) clean + cd ifsrrtm && $(MAKE) clean + cd drhook && $(MAKE) clean + cd ifs && $(MAKE) clean + +clean-mods: + rm -f mod/*.mod + +clean-symlinks: + rm -f practical/ecrad practical/data + +clean-autosaves: + rm -f *~ .gitignore~ */*~ */*/*~ + +.PHONY: all build help deps clean-deps libifsaux libdummydrhook libutilities libifsrrtm \ + libradiation driver symlinks clean clean-toplevel test test_ifs ifsdriver \ + test_i3rc clean-tests clean-utilities clean-mods clean-symlinks Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile.in =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile.in (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile.in (revision 6016) @@ -0,0 +1,303 @@ +# Path to the directory with the source files: +srcdir:= @srcdir@ + +# Path to the directory with the Fortran module files: +moddir:= mod + +# Paths to the installation directories: +prefix= @prefix@ +exec_prefix= @exec_prefix@ + +# Package tarname: +PACKAGE_TARNAME= @PACKAGE_NAME@-@PACKAGE_VERSION@ + +# Utilities: +SHELL= @SHELL@ +FC= @FC@ +PYTHON= @PYTHON@ +DEPLIST= ${PYTHON} $(srcdir)/mkhelper/deplist.py +DEPGEN= ${PYTHON} $(srcdir)/mkhelper/depgen.py --src-root='@srcdir@' --pp-enable --pp-eval-expr \ + --pp-inc-flag='@FCINCFLAG_PP@' --pp-inc-order='@FCINCORDER_PP@' --pp-macro-flag='@FCDEF_PP@' \ + --fc-enable --fc-mod-ext='@FCMODEXT@.proxy' --fc-mod-upper='@FCMODUC@' --fc-inc-flag='@FCINCFLAG@' \ + --fc-inc-order='@FCINCORDER@' --fc-mod-dir-flag='@FCMODOUT@' --fc-external-mods='@DEPGEN_EXTERNAL_MODS@' +MODCMP= ${PYTHON} $(srcdir)/mkhelper/fortmodcmp.py +AR= @AR@ +ARFLAGS= @ARFLAGS@ +INSTALL= @INSTALL@ +INSTALL_DATA= @INSTALL_DATA@ +GIT= git +TAR= tar +BZIP2 = bzip2 + +# Fortran compiler and flags: +FCFLAGS= @FCMODINC@$(moddir) @FCMODOUT@$(moddir) @FCINCFLAG_PP@$(srcdir)/include @NETCDF_FCFLAGS@ @FCFLAGS@ +LDFLAGS= @LDFLAGS@ +LIBS= @NETCDF_FCLIBS@ @LIBS@ + +# Silent rule prefixes: +V= @DEFAULT_VERBOSITY@ +ifeq ($(V), 0) +silent_FC= @echo " FC " $@; +silent_MKDIR= @echo " MKDIR " $(@D); +silent_DEPGEN= @echo " DEPGEN " $@; +silent_AR= @echo " AR " $@; +endif + +lib_LIBRARIES:= libifsaux.a libifsrrtm.a libradiation.a libutilities.a + +ignored_SOURCES:= \ + ifsrrtm/rrtm_ecrt_140gp_mcica.F90 \ + ifsrrtm/rrtm_rrtm_140gp_mcica.F90 \ + ifsrrtm/srtm_gas_optical_depth_test.F90 \ + ifsrrtm/srtm_spcvrt_mcica.F90 \ + ifsrrtm/srtm_srtm_224gp_mcica.F90 \ + radiation/radiation_adding_ica_sw_test.F90 \ + radiation/radiation_adding_ica_sw_test2.F90 \ + radiation/radiation_ice_optics_baran2016.F90 \ + radiation/radiation_psrad.F90 \ + radiation/radiation_psrad_rrtm.F90 + +libifsaux_a_SOURCES:= $(filter-out $(ignored_SOURCES),$(patsubst $(srcdir)/%,%,$(shell find $(srcdir)/ifsaux -name '*.F90'))) +libifsrrtm_a_SOURCES:= $(filter-out $(ignored_SOURCES),$(patsubst $(srcdir)/%,%,$(shell find $(srcdir)/ifsrrtm -name '*.F90'))) +libradiation_a_SOURCES:= $(filter-out $(ignored_SOURCES),$(patsubst $(srcdir)/%,%,$(shell find $(srcdir)/radiation -name '*.F90'))) +libutilities_a_SOURCES:= $(filter-out $(ignored_SOURCES),$(patsubst $(srcdir)/%,%,$(shell find $(srcdir)/utilities -name '*.F90'))) + +all_SOURCES:= $(libifsaux_a_SOURCES) $(libifsrrtm_a_SOURCES) $(libradiation_a_SOURCES) $(libutilities_a_SOURCES) + +# Dependency files: +deps:= $(addsuffix .d,$(all_SOURCES)) + +# Stamp files of the building subdirectories: +dirstamps= $(addsuffix .dirstamp, $(sort $(dir $(deps)))) $(moddir)/.dirstamp + +# PGI cross-file function inlining via an inline library: +INLIB= @DEFAULT_INLIB@ +ifeq ($(INLIB), 1) + +# Additional silence prefixes: +ifeq ($(V), 0) +silent_FCEX= @echo " FC (EX) " $@; +silent_FCIN= @echo " FC (IL) " $@; +endif + +# Name of the inline library (a directory): +inlib_name:= ecrad.il + +# Additional compiler flags enabling the inline library generation: +inlib_extract_FCFLAGS:= -Mextract=lib:$(inlib_name),reshape,name:adding_ica_sw,name:beta2alpha,name:calc_fluxes_no_scattering_lw,name:calc_ice_optics_baran,name:calc_ice_optics_baran2016,name:calc_ice_optics_baran2017,name:calc_ice_optics_fu_lw,name:calc_ice_optics_fu_sw,name:calc_ice_optics_yi_lw,name:calc_ice_optics_yi_sw,name:calc_liq_optics_lindner_li,name:calc_liq_optics_slingo,name:calc_liq_optics_socrates,name:calc_no_scattering_transmittance_lw,name:calc_ref_trans_lw,name:calc_ref_trans_sw,name:calc_two_stream_gammas_lw,name:calc_two_stream_gammas_sw,name:cloud_generator_acc,name:delta_eddington_extensive,name:delta_eddington_scat_od,name:fast_adding_ica_lw,name:initialize_acc,name:radiation_liquid_optics_socrates,name:uniform_distribution_acc + + +# Additional compiler flags enabling the inline library usage: +inlib_inline_FCFLAGS:= -Minline=lib:$(inlib_name),reshape + +# List of source files containing functions that need to be inlined: +inlib_SOURCES:= \ + radiation/radiation_adding_ica_lw.F90 \ + radiation/radiation_adding_ica_sw.F90 \ + radiation/radiation_aerosol_optics.F90 \ + radiation/radiation_cloud_generator_acc.F90 \ + radiation/radiation_cloud_optics.F90 \ + radiation/radiation_ice_optics_baran.F90 \ + radiation/radiation_ice_optics_baran2017.F90 \ + radiation/radiation_ice_optics_fu.F90 \ + radiation/radiation_ice_optics_yi.F90 \ + radiation/radiation_liquid_optics_slingo.F90 \ + radiation/radiation_liquid_optics_socrates.F90 \ + radiation/radiation_two_stream.F90 \ + radiation/radiation_random_numbers.F90 + + #radiation/radiation_cloud_cover.F90 \ # leads to cyclic dependency, missing inlinling is acceptable for now, affected: beta2alpha + +# List of files where we need to manually limit GPU register usage +inlib_limit_registers_OBJECTS:= \ + radiation/radiation_mcica_acc_lw.o \ + radiation/radiation_mcica_acc_sw.o + +# And limiting flags +inlib_limit_registers_FCFLAGS:= -gpu=maxregcount:96 + +######################################## + +# Object files that correspond to the source files in $(inlib_SOURCES): +inlib_objs:= $(inlib_SOURCES:.F90=.@OBJEXT@) + +# List of objects that are generated using the inline library: +inlib_target_objs:= $(filter %.@OBJEXT@,$(shell $(DEPLIST) -p $(inlib_objs) -f $(deps))) + +# To avoid circular dependencies, we need to account for situations when we +# have a dependency A -> B -> C, where A and C belong to $(inlib_objs) but B +# does not. In order to get all such B files and include them into +# $(inlib_objs), we find the intersection of two sets: dependencies +# (prerequisites) and dependents (targets) of $(inlib_objs): +inlib_objs:= $(filter $(inlib_target_objs),$(shell $(DEPLIST) -t $(inlib_objs) -f $(deps))) + +# The commented code below generates a warning message if the list of source +# files to be included into the inline library is automatically extended: +# +# inlib_extra_objs = $(filter-out $(inlib_SOURCES:.F90=.@OBJEXT@),$(inlib_objs)) +# ifneq ($(inlib_extra_objs),) +# $(warning Additional files to be included into the inline library: $(inlib_extra_objs:.@OBJEXT@=.F90)) +# endif + +# Now we need to create a list of Fortran module files that must be created +# before any of the object files $(inlib_objs) gets generated. First, we need a +# subset of dependency files that correspond to $(inlib_objs): +inlib_deps:= $(inlib_objs:.@OBJEXT@=.F90.d) + +# List of Fortran module files that at least on element of $(inlib_objs) +# depends on: +inlib_mods:= $(filter %.@FCMODEXT@.proxy,$(shell $(DEPLIST) -f $(inlib_deps))) + +# List of Fortran modules declared in source files that correspond to +# $(inlib_objs): +inlib_internal_mods:= $(filter %.@FCMODEXT@.proxy,$(shell $(DEPLIST) -p $(inlib_objs) -f $(inlib_deps))) + +# List of Fortran modules that must be created before the inline library: +inlib_prereq_mods:= $(filter-out $(inlib_internal_mods),$(inlib_mods)) + +endif # INLIB == 1 + +# Selective search path: +vpath %.F90 $(srcdir) + +# Disable built-in suffix rules: +.SUFFIXES: +# Targets not associated with files: +.PHONY: all depend dummy-depend mostlyclean clean distclean \ + maintainer-clean install install-libs install-mods dist \ + check sanitize-mod-proxies +# Targets that do not need the inclusion of the dependency files: +NO_INC_TARGETS:= depend dummy-depend mostlyclean clean distclean \ + maintainer-clean dist +# Keep directory stamps: +.PRECIOUS: $(dirstamps) + +# Default rule: +all: $(lib_LIBRARIES) + +# Explicit dependency generation rule: +depend: $(deps) + +# Delete the results of compilation and linking: +mostlyclean: $(bundled_subdirs) + rm -f $(lib_LIBRARIES) $(all_SOURCES:.F90=.@OBJEXT@) + rm -f $(moddir)/*.@FCMODEXT@ $(moddir)/*.@FCMODEXT@.proxy + rm -f $(notdir $(all_SOURCES:.F90=.i)) + test x'$(INLIB)' != x1 || rm -rf $(inlib_name) + +# Delete files generated at the building stage: +clean: mostlyclean + +# Delete everything generated at the configure stage (and clean the created directories if they are empty): +distclean: clean + find . -name '*.pyc' -delete -o -name '*.pyo' -delete -o -name '__pycache__' -delete + rm -f $(deps) $(dirstamps) + @for dir in ifsaux ifsrrtm radiation utilities $(moddir); do \ + if test -d "$$dir"; then \ + echo "find '$$dir' -type d -empty -delete"; \ + find "$$dir" -type d -empty -delete; \ + fi; \ + done + rm -f config.log config.status Makefile + +# Delete files generated at the autoreconf stage: +maintainer-clean: distclean + rm -rf autom4te.cache + +# Installation rules: +install: all install-libs install-mods + +# Check rule: +check: all + +# Tarball creation rule: +dist: + @if test ! -e @top_srcdir@/.git; then echo "'@top_srcdir@' is not a git repository" >&2; exit 1; fi + $(GIT) -C @top_srcdir@ archive --prefix=$(PACKAGE_TARNAME)/ --format tar -o @abs_top_builddir@/$(PACKAGE_TARNAME).tar HEAD + rm -f $(PACKAGE_TARNAME).tar.bz2 && BZIP2=$${BZIP2--9} $(BZIP2) $(PACKAGE_TARNAME).tar + +ifeq ($(INLIB), 1) + +# Pattern- and target-specific assignments are propagated to the prerequisites +# and override the global assignments. Therefore, we introduce the following +# match-anything pattern assignments to prevent that (the eval/value combination +# is required to keep the original global values of the variables without +# changing their flavors, i.e. keep them recursively expanded): +${eval %: silent_FC= $(value silent_FC)} +${eval %: FCFLAGS= $(value FCFLAGS)} + +# Target-specific variables for objects that use the inline library: +$(inlib_target_objs): silent_FC= $(silent_FCIN) +$(inlib_target_objs): FCFLAGS+= $(inlib_inline_FCFLAGS) +$(inlib_limit_registers_OBJECTS): FCFLAGS+= $(inlib_limit_registers_FCFLAGS) + +# All object that can be built with the inline library depend on it: +$(inlib_target_objs): $(inlib_name) + +# The inline library generation rule. Note that the source files are provided +# to the compiler in the topological order. We also have to delete the partially +# generated library if the compiler fails: +$(inlib_name): $(inlib_prereq_mods) $(inlib_objs:.@OBJEXT@=.F90) + $(silent_FCEX)rm -rf $@ && $(FC) $(FCFLAGS) $(inlib_extract_FCFLAGS) @FCFLAGS_F90@ $(filter-out $(inlib_prereq_mods),$^) || (ec=$$?; rm -rf $@; exit $$ec) + +endif # INLIB == 1 + +# Fortran compilation rule: +%.@OBJEXT@: %.F90 | $(dirstamps) + $(silent_FC)$(FC) -o $@ -c $(FCFLAGS) @FCFLAGS_F90@ $< + +# Static library generation rule: +%.a: + $(silent_AR)rm -f $@ && $(AR) $(ARFLAGS) $@ $^ + +# Fortran module file rule: +$(moddir)/%.@FCMODEXT@.proxy:| sanitize-mod-proxies + @if test -z '$<'; then \ + echo "Cannot find Fortran source file providing module '$(basename $(@F:.proxy=))'." >&2; \ + else \ + if test ! -f '$(@:.proxy=)'; then rm -f '$<'; $(MAKE) '$<'; fi; \ + if cmp '$@' '$(@:.proxy=)' >/dev/null 2>&1 || $(MODCMP) '$@' '$(@:.proxy=)' @FC_VENDOR@ 2>/dev/null; then :; \ + else cp '$(@:.proxy=)' '$@' 2>/dev/null; fi; \ + fi + +# Delete all Fortran module proxy files that do not have an existing module to +# be a proxy of, i.e. if .proxy exists but does not, +# delete .proxy: +sanitize-mod-proxies: + @rm -f $(filter-out $(addsuffix .proxy,$(wildcard $(moddir)/*.@FCMODEXT@)),$(wildcard $(moddir)/*.@FCMODEXT@.proxy)) + +# Directory creation rule: +%/.dirstamp: + $(silent_MKDIR)@MKDIR_P@ $(@D) && touch $@ + +# Fortran dependency generation rule: +%.F90.d: %.F90 Makefile | $(dirstamps) + $(silent_DEPGEN)$(DEPGEN) -o $@ --obj-name $(@:.F90.d=.@OBJEXT@) -i $< -- $(FCFLAGS) + +# Dummy dependency file generation rule (called by config.status): +dummy-depend: | $(dirstamps) + @for file in $(deps); do \ + test -e "$$file" || touch "$$file"; \ + done + +# Library installation rule: +install-libs: $(lib_LIBRARIES) + $(INSTALL) -d $(DESTDIR)@libdir@ && $(INSTALL_DATA) $^ $(DESTDIR)@libdir@ + +# Fortran module files installation rule: +install-mods: $(filter %.@FCMODEXT@.proxy,$(shell $(DEPLIST) -f $(deps))) + $(INSTALL) -d $(DESTDIR)@includedir@ && $(INSTALL_DATA) $(basename $^) $(DESTDIR)@includedir@ + +libifsaux.a: $(libifsaux_a_SOURCES:.F90=.@OBJEXT@) +libifsrrtm.a: $(libifsrrtm_a_SOURCES:.F90=.@OBJEXT@) +libradiation.a: $(libradiation_a_SOURCES:.F90=.@OBJEXT@) +libutilities.a: $(libutilities_a_SOURCES:.F90=.@OBJEXT@) + +current_targets:= $(strip $(MAKECMDGOALS)) +ifeq (,$(current_targets)) +current_targets:= all +endif + +ifneq (,$(filter-out $(NO_INC_TARGETS),$(current_targets))) +include $(deps) +endif Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.cray =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.cray (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.cray (revision 6016) @@ -0,0 +1,21 @@ +# This is a Makefile for the Cray compiler: run "make PROFILE=cray". + +FC = ftn +CPPFLAGS = + +ifndef DEBUG +OPTFLAGS = -hflex_mp=conservative -hfp1 -hadd_paren -hnocaf +else +OPTFLAGS = -O0 -hfp1 +endif + +WARNFLAGS = +BASICFLAGS = -emf -J../mod -p../mod + +# We used to have the flag "-hbyteswapio" here because the RRTM input +# files are big endian Fortran unformatted files, but now the file +# ordering has been specified at the OPEN command so no compiler flags +# are needed. +LDFLAGS = -Ktrap=fp -Wl,--as-needed -dynamic +DEBUGFLAGS = +OMPFLAG = -homp Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.ecmwf =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.ecmwf (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.ecmwf (revision 6016) @@ -0,0 +1,13 @@ +$(info *******************************************************************************) +$(info *** ECMWF/gfortran) +$(info *******************************************************************************) + +include Makefile_include.gfortran + +ifndef NETCDF_INCLUDE +$(error You need to run "module load netcdf" first) +endif + +ifdef OMP_NUM_THREADS +$(warning Type "unset OMP_NUM_THREADS" for best performance when running the radiation code) +endif Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.gfortran =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.gfortran (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.gfortran (revision 6016) @@ -0,0 +1,42 @@ +# Fortran compiler executable -*- Makefile -*- +FC = gfortran + +# Tell the compiler to accept C-preprocessor directives +CPPFLAGS = -cpp + +# Basic flags such as where to write module files. We used to have the +# flag "-fconvert=big-endian" here because the RRTM input files are +# big endian Fortran unformatted files, but now the file ordering has +# been specified at the OPEN command so no compiler flags are needed. +BASICFLAGS = -J../mod -fno-range-check + +# OpenMP flag; type "make OMPFLAG=-DNO_OPENMP" to compile with OpenMP +# disabled +OMPFLAG = -fopenmp + +ifndef DEBUG +# --NORMAL CONFIGURATION-- + +# Optimization flags +OPTFLAGS = -O3 +# -march=native + +# Warning flags: all except those that warn about unused stuff +WARNFLAGS = -Wall -Wno-unused-label -Wno-unused-dummy-argument -Wno-unused-variable + +# Debugging flags, such as "-g" to store debugging symbols, and +# instructions to abort if certain floating-point exceptions occur +DEBUGFLAGS = -g -ffpe-trap=invalid,zero,overflow + +else +# --DEBUGGING CONFIGURATION-- +OPTFLAGS = -O0 +WARNFLAGS = -Wall +DEBUGFLAGS = -g -ffpe-trap=invalid,zero,overflow -fcheck=bounds -finit-real=snan -fbacktrace + +endif + +ifdef GPROF +# Add gprof output +DEBUGFLAGS += -pg +endif Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.intel =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.intel (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.intel (revision 6016) @@ -0,0 +1,28 @@ +# This is a Makefile for the Intel compiler: run "make +# PROFILE=intel". Note that by default the Intel compiler puts arrays +# on the stack, which is likely to cause a stack overflow - hence the +# use of "-heap-arrays" which puts them on the heap like most other +# compilers. If you remove this argument you will likely need to set +# the environment variable OMP_STACKSIZE to 64MB. + +FC = ifort +CC = icc +CPPFLAGS = + +ifndef DEBUG +OPTFLAGS = -O3 +else +OPTFLAGS = -O0 -check bounds -init=snan +endif + +LDFLAGS = -lrt +WARNFLAGS = -warn all + +# We used to have the flag "-convert big_endian" here because the RRTM +# input files are big endian Fortran unformatted files, but now the +# file ordering has been specified at the OPEN command so no compiler +# flags are needed. +BASICFLAGS = -module ../mod -fpe0 -fp-model precise -ftz -fp-speculation safe -heap-arrays + +DEBUGFLAGS = -g +OMPFLAG = -qopenmp -qopenmp-lib=compat Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.intel_atos =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.intel_atos (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.intel_atos (revision 6016) @@ -0,0 +1,40 @@ +# This is a Makefile for the Intel compiler on ECMWF's Atos +# supercomputer: run "make PROFILE=intel_atos". Note that by default +# the Intel compiler puts arrays on the stack, which is likely to +# cause a stack overflow - hence the use of "-heap-arrays" which puts +# them on the heap like most other compilers. If you remove this +# argument you will likely need to set the environment variable +# OMP_STACKSIZE to 64MB. +ifdef RUN_THESE_ON_COMMAND_LINE_FIRST + module load prgenv/intel + module load intel/2021.4.0 + module load intel-mpi/2021.4.0 + module load intel-mkl/19.0.5 + module load netcdf4/4.7.4 + module load hdf5/1.10.6 + unset OMP_NUM_THREADS +endif + +FC = ifort +CC = icc +CPPFLAGS = + +ifndef DEBUG +OPTFLAGS = -O2 -march=core-avx2 -no-fma +else +OPTFLAGS = -O0 -check bounds -init=snan +endif + +LDFLAGS = -lrt +WARNFLAGS = -warn all + +# We used to have the flag "-convert big_endian" here because the RRTM +# input files are big endian Fortran unformatted files, but now the +# file ordering has been specified at the OPEN command so no compiler +# flags are needed. +BASICFLAGS = -module ../mod -fpe0 -assume byterecl -align array64byte \ + -traceback -fpic -fp-model precise -heap-arrays \ + -fp-speculation=safe -fast-transcendentals -ftz \ + -finline-functions -finline-limit=1500 -Winline -assume realloc_lhs +DEBUGFLAGS = -g +OMPFLAG = -qopenmp -qopenmp-threadprivate=compat Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.pgi =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.pgi (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.pgi (revision 6016) @@ -0,0 +1,18 @@ +FC = pgf90 +CPPFLAGS = -Mpreprocess + +ifndef DEBUG +OPTFLAGS = -O3 -acc -ta=nvidia +else +OPTFLAGS = -O0 +endif + +WARNFLAGS = -Minform=inform + +# We used to have the flag "-Mbyteswapio" here because the RRTM input +# files are big endian Fortran unformatted files and most machines are +# now little endian, but now the file ordering has been specified at +# the OPEN command so no compiler flags are needed. +BASICFLAGS = -module ../mod +DEBUGFLAGS = -g +OMPFLAG = -mp=nonuma Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.uor =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.uor (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/Makefile_include.uor (revision 6016) @@ -0,0 +1,8 @@ +$(info *******************************************************************************) +$(info *** UoR/pgi-fortran: ensure you have typed "setup pgi13.6; setup nco-4.4.3") +$(info *******************************************************************************) + +include Makefile_include.pgi + +NETCDF_INCLUDE = -I/home/swrhgnrj/include +NETCDF_LIB = -L/home/swrhgnrj/lib -lnetcdf -Wl,-Bstatic -lnetcdff -Wl,-Bdynamic Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/NOTICE =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/NOTICE (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/NOTICE (revision 6016) @@ -0,0 +1,21 @@ +ecRad - Modular atmospheric radiation scheme, (C) Copyright 2014- +ECMWF. This software is licensed under the terms of the Apache +Licence Version 2.0 which can be obtained at +http://www.apache.org/licenses/LICENSE-2.0. In applying this licence, +ECMWF does not waive the privileges and immunities granted to it by +virtue of its status as an intergovernmental organisation nor does it +submit to any jurisdiction. + +The ifsrrtm directory of this package includes a modified version of +the gas optics part of the Rapid Radiative Transfer Model for GCMS +(RRTMG). RRTMG was developed at Atmospheric & Environmental Research +(AER), Inc., Lexington, Massachusetts and is available under the +"3-clause BSD" license; for details, see ifsrrtm/AER-BSD3-LICENSE. + +bin/drhook_merge_walltime.pl is from Eckhard Tschirschnitz, Cray, +2006. + +For the use in ICON, the following changes have been made to the original ecRad code: +- OpenACC port for the use of ecRad on GPU architectures +- Code optimizations to improve performance on vector architectures +- Replace yomhook with ecradhook to avoid linking conflicts with other ECMWF software used by ICON Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/README.md =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/README.md (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/README.md (revision 6016) @@ -0,0 +1,258 @@ +# ECRAD - ECMWF atmospheric radiation scheme + +This document last updated 9 June 2022 + +Robin Hogan + +For more complete information about compilation and usage of ecRad, +please see the documentation on the +[ecRad web site](https://confluence.ecmwf.int/display/ECRAD). + + +## INTRODUCTION + +This package contains the offline version of a radiation scheme +suitable for use in atmospheric weather and climate models. The code +is designed to be extensible and flexible. For example, the gas +optics, cloud optics and solver are completely separated (see +`radiation/radiation_interface.F90` where they are called in sequence), +thereby facilitating future changes where different gas models or +solvers may be switched in and out independently. The offline code is +parallelized using OpenMP. + +Five solvers are currently available: + +1. The Monte Carlo Independent Column Approximation (McICA) of Pincus +et al. (2003). This is is a now widely used method for treating cloud +structure efficiently. The implementation in this package is more +efficient than the one currently operational in the ECMWF model, and +produces less noise in partially cloudy situations. Note that since +McICA is stocastic, individual flux profiles using McICA may differ +simply due to random variations in the sampling of the cloud field. + +2. The Tripleclouds scheme of Shonk and Hogan (2008). This represents +cloud structure by dividing each layer into three regions, one clear +and two cloudy with different optical depth. It is somewhat slower +than McICA but does not generate noise. + +3. The Speedy Algorithm for Radiative Transfer through Cloud Sides +(SPARTACUS) of Hogan et al. (JGR 2016). This is a method for +efficiently treating 3D radiative effects associated with clouds. It +uses the same differential equations proposed by Hogan and Shonk (JAS +2013), but solves them using a matrix exponential method that is much +more elegant than their method, and is also here extended to the +longwave (see Schaefer et al., JGR 2016). It also incorporates the +Tripleclouds methodology of Shonk and Hogan (2008) to represent cloud +inhomogeneity. + +4. A homogeneous (plane parallel) solver in which clouds are assumed +to fill the gridbox horizontally. This is useful for computing +Independent Column Approximation benchmarks. + +5. A "cloudless" solver if your focus is on clear skies. + +Two gas optics models are available: + +1. The Rapid Radiative Transfer Model for GCMs (RRTMG), the +implementation being that from the ECMWF Integrated Forecasting System +(IFS). + +2. The ECMWF Correlated k-Distribution (ecCKD) scheme (since ecRad +1.5), which uses a flexible discretization of the spectrum that is +read from a file at run-time. + + +## PACKAGE OVERVIEW + +The subdirectories are as follows: + +- `radiation` - the ecRad souce code + +- `ifsaux` - source code providing a (sometimes dummy) IFS environment + +- `ifsrrtm` - the IFS implementation of the RRTMG gas optics scheme + +- `utilities` - source code for useful utilities, such as reading netCDF + files + +- `drhook` - dummy version of the Dr Hook profiling system + +- `driver` - the source code for the offline driver program + +- `ifs` - slightly modified source files from the IFS that are used to provide inputs to + ecRad, but not used in this offline version except if you compile the ecrad_ifs_driver executable + +- `mod` - where Fortran module files are written + +- `lib` - where the static libraries are written + +- `bin` - where the executable ecrad is written + +- `data` - contains configuration data read at run-time + +- `test` - test cases including Matlab code to plot the outputs + +- `include` - automatically generated interface blocks for non-module routines + +- `practical` - exercises to get started with ecRad + + +## TO COMPILE + +1. Ensure you have a reasonably recent Fortran compiler - it needs to +support modules with `contains` and `procedure` statements for +example. Ensure you have the Fortran netCDF library installed +(versions 3 or 4) and that the module file is compatible with your +Fortran compiler. + +2. You can compile the code using + + make PROFILE= + + where `` is one of `gfortran`, `pgi`, `cray` or `intel`. + This will read the system-specific configurations from the file + `Makefile_include.`. If you omit the `PROFILE=` option then + `gfortran` will be assumed. If you have a compiler other than these + then create such a file for your compiler following the example in + `Makefile_include.gfortran`. Two additional profiles are provided, + `ecmwf` which builds on the `gfortran` profile and `uor` + (University of Reading) which is built on the `pgi` profile. + + If the compile is successful then static libraries should appear in + the `lib` directory, and then the executable `bin/ecrad`. + +3. To clean-up, type `make clean`. To build an unoptimized version + for debugging, you can do + + make PROFILE= DEBUG=1 + + or you can specifically override the variables in `Makefile_include.` + using, for example + + make PROFILE= OPTFLAGS=-O0 DEBUGFLAGS="-g -pg" + + To compile in single precision add `SINGLE_PRECISION=1` to the + `make` command line. To compile with the Dr Hook profiling system, + first install ECMWF's [fiat library]([ecRad web + site](https://github.com/ecmwf-ifs/fiat), then add + `FIATDIR=/path/to/fiat` to the `make` command line, such that the + files `$FIATDIR/lib/libfiat.so` and + `$FIATDIR/module/fiat/yomhook.mod` can be found at build time. + + +## TO TEST + +The offline driver is run via + + ecrad + +where the radiation scheme is configured using the Fortran namelist +file ``, and the inputs and outputs are in netCDF +format. + +The `practical` directory contains a set of practical exercises to +help new users become familiar with the capabilities of ecRad. Start +by reading the instructions in `practical/ecrad_practical.pdf`. + +The `test/ifs` directory contains a pole-to-pole slice of +low-resolution IFS model data in a form to use as input to the offline +version of ecRad. It includes aerosols extracted from the CAMS +climatology used operationally since IFS Cycle 43R3. Typing `make +test` in this directory runs a number of configurations of ecRad +described in the Makefile. The Matlab script `plot_ifs.m` can be used +to visualize the results. The file +`ecrad_meridian_default_out_REFERENCE.nc` contains a reference version +of the output file `ecrad_meridian_default_out.nc` (case "a"), which +you can compare to be sure your compilation is working as +expected. This case has essentially been superceded by the slice in the +`practical` directory. + +The `test/i3rc` directory contains the 1D profile of the I3RC cumulus +test case used by Hogan et al. (2016). Typing `make test` in this +directory runs the various 1D and 3D configurations of ecRad. The +Matlab script `plot_i3rc.m` can then be used to visualize the results, +reproducing three of the figures from Hogan et al. (2016). Note that +you will need to ensure that a reasonably up-to-date version of the +`nco` tools are available and in your path. This test involves +running the duplicate_profiles.sh script, which duplicates the single +profile in `i3rc_mls_cumulus.nc`, each with a different solar zenith +angle. + +The `test/surface` directory contains tests of the surface tile types, +although this is under development and so nothing here is guaranteed +to work. + +Alternatively, type `make test` in the top-level directory to run all +cases. + +In addition to writing the output file, a file containing the +intermediate radiative properties of the atmosphere for each g-point +can be stored in `radiative_properties.nc` (edit the config namelist to +enable this), but note that the g-points have been reordered in +approximate order of optical depth if the SPARTACUS solver is chosen. + + +## LICENCE + +(C) Copyright 2014- ECMWF. + +This software is licensed under the terms of the Apache Licence Version 2.0 +which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +In applying this licence, ECMWF does not waive the privileges and immunities +granted to it by virtue of its status as an intergovernmental organisation +nor does it submit to any jurisdiction. +Copyright statements are given in the file NOTICE. + +The ifsrrtm directory of this package includes a modified version of +the gas optics part of the Rapid Radiative Transfer Model for GCMS +(RRTMG). RRTMG was developed at Atmospheric & Environmental Research +(AER), Inc., Lexington, Massachusetts and is available under the +"3-clause BSD" license; for details, see ifsrrtm/AER-BSD3-LICENSE. + + +## PUBLICATIONS + +The ecRad radiation scheme itself is described here: + + - Hogan, R. J., and A. Bozzo, 2018: A flexible and efficient radiation +scheme for the ECMWF model. J. Adv. Modeling Earth Syst., 10, 1990-2008, +doi:10.1029/2018MS001364. + + - Hogan, R. J., and A. Bozzo, 2016: ECRAD: A new radiation scheme for +the IFS. ECMWF Technical Memorandum number 787, 35pp: +http://www.ecmwf.int/en/elibrary/16901-ecrad-new-radiation-scheme-ifs + +A two-part paper is published in Journal of Geophysics Research +describing the SPARTACUS technique: + + - Schäfer, S. A. K., R. J. Hogan, C. Klinger, J.-C. Chiu and B. Mayer, +2016: Representing 3D cloud-radiation effects in two-stream schemes: 1. Longwave considerations and effective cloud edge length. +J. Geophys. Res., 121, 8567-8582. +http://www.met.reading.ac.uk/~swrhgnrj/publications/spartacus_part1.pdf + + - Hogan, R. J., S. A. K. Schäfer, C. Klinger, J.-C. Chiu and B. Mayer, +2016: Representing 3D cloud-radiation effects in two-stream schemes: 2. Matrix formulation and broadband evaluation. J. Geophys. Res., 121, +8583-8599. +http://www.met.reading.ac.uk/~swrhgnrj/publications/spartacus_part2.pdf + +More recent developments on the shortwave SPARTACUS solver, available +since ecRad 1.1.10, are described here: + + - Hogan, R. J., M. D. Fielding, H. W. Barker, N. Villefranque and +S. A. K. Schäfer, 2019: Entrapment: An important mechanism to explain +the shortwave 3D radiative effect of clouds. J. Atmos. Sci., 76, +2123–2141. + +The ecCKD gas optics scheme is described here: + + - Hogan, R. J., and M. Matricardi, 2022: a tool for generating fast +k-distribution gas-optics models for weather and climate +applications. J. Adv. Modeling Earth Sys., in review. + + +## CONTACT + +Please email Robin Hogan with any queries or bug +fixes, but note that ECMWF does not commit to providing support to +users of this software. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/TODO =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/TODO (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/TODO (revision 6016) @@ -0,0 +1,36 @@ +FEATURES + - Option to have more McICA columns to reduce noise + - Compute UV index when sufficient UV bands + +LONGER TERM FEATURES + - Option to provide date, time, longitude and latitude from which the + IFS values will be calculated of: solar zenith angle, trace gas and + aerosol mixing ratio, and cloud effective ratio + - Incorporate RRTMGP + - Solar cycle in spectral irradiance + +INTERFACE + - Rename "do_3d" as it is misleading + - Add deallocate method for config type + - Column is last array argument for all input and output arrays? + - Why are the flux%*_band variables dimensioned (g,col,lev) not (g,lev,col)? + +ECCKD AND GENERALIZED CLOUD/AEROSOL + +DOCUMENTATION + - Add chapters on API, internal structure and underpinning science + +MISC + - Definition of Tdir in two_stream + +DIFFERENCES IN IFS VERSION OF ECRAD + - Several files contain easy_netcdf_with_read_mpi instead of + easy_netcdf (radiation_aerosol_optics_data, + radiation_cloud_optics_data, radiation_pdf_sampler) + - radiation_cloud_generator.F90 uses SIMD routine to sample PDF + - radiation_delta_eddington.h contains SIMD routine + - radiation_interface.F90 and radiation_ifs_rrtm.F90 take YDERAD + arguments, the latter has other differences + - radiation_constants should use IFS values? + +KNOWN BUGS Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/aclocal.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/aclocal.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/aclocal.m4 (revision 6016) @@ -0,0 +1,25 @@ +# generated automatically by aclocal 1.16.5 -*- Autoconf -*- + +# Copyright (C) 1996-2021 Free Software Foundation, Inc. + +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) +m4_include([m4/acx_compiler_simple.m4]) +m4_include([m4/acx_fc_endianness.m4]) +m4_include([m4/acx_fc_include.m4]) +m4_include([m4/acx_fc_line_length.m4]) +m4_include([m4/acx_fc_module.m4]) +m4_include([m4/acx_fc_pp.m4]) +m4_include([m4/acx_lang_lib.m4]) +m4_include([m4/acx_lang_macro.m4]) +m4_include([m4/acx_lang_package.m4]) +m4_include([m4/acx_prog_search.m4]) +m4_include([m4/asx_common.m4]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/create_practical.sh =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/create_practical.sh (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/create_practical.sh (revision 6016) @@ -0,0 +1,35 @@ +#!/bin/bash +# +# (C) Copyright 2020- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + +# This script sits in the bin directory of an ecRad distribution. To +# create an ecRad practical session in the present working directory, +# type the full path to this script. It will then copy over the +# relevant files or create symbolic links. + +# Stop if an error occurs +set -ex + +ECRADDIR=$(dirname $0)/.. +PRACDIR=$ECRADDIR/practical + +ln -s -f $ECRADDIR/bin/ecrad +ln -s -f $ECRADDIR/data +ln -s -f $PRACDIR/era5slice.nc +ln -s -f $PRACDIR/ecrad_practical.pdf + +cp -a -f $PRACDIR/ecradplot . +cp -f $PRACDIR/plot_*.py $PRACDIR/compare_*.py . +cp -f $PRACDIR/clean.sh $PRACDIR/config.nam $PRACDIR/README . + +set +ex + +echo +echo "*** You are now ready to start the ecRad practical - congratulations! ***" Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/drhook_merge_walltime.pl =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/drhook_merge_walltime.pl (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/drhook_merge_walltime.pl (revision 6016) @@ -0,0 +1,239 @@ +#!/usr/bin/perl + +# +# drhook_merge_walltime.pl +# +# For merging wall clock time results from different MPI-tasks +# i.e. DR_HOOK_OPT=prof +# +# Original script by Eckhard Tschirschnitz, Cray, 2006 (Mflop/s) +# +# Usage: cat drhook.* | perl -w drhook_merge_walltime.pl +# + +use strict; +use warnings; + +# this expects concatenated dr_hook listings (wall clock time listings) + +my $bignum = 999999999; + +my $skip = 1; +my $str = "THRESHOLD_PERCENT"; +my $threshold_percent = exists($ENV{$str}) ? $ENV{$str} : 0.1; +my $tottim = 0; + +my $maxwall = 0; +my $minwall = $bignum; +my $avgwall = 0; +my $stdevwall = 0; + +my $nproc = 0; # no of MPI-tasks +my $maxomp = 0; # max. no of OpenMP-threads encountered +my $exe = ""; # the name of the executable + +my %nself = (); +my %sumself = (); +my %sum2self = (); +my %maxself = (); +my %minself = (); +my %ompself = (); + +my %numcalls = (); + +my %taskhits = (); +my %omphits = (); + +RECORD: for (<>) { + chomp; # get rid of the newline character + + next RECORD if (m/^\s*$/); # a blank line + + if (m/^\s*Profiling\b/) { + if ($nproc == 0) { + $exe = $1 if (m/program='([^\'].*)'/); + } + $nproc++; + $skip = 1; + } + elsif (m/^\s+Wall-time\s+is\s+(\S+)\s+/) { + my $value = $1; + $maxwall = $value if ($value > $maxwall); + $minwall = $value if ($value < $minwall); + $avgwall += $value; + $stdevwall += $value * $value; + $skip = 1; + } + elsif (m/^\s+1\s+/) { # the first record of (any) file encountered + &CumulativeUpdate(); + %ompself = (); + $skip = 0; + } + + next RECORD if ($skip); + + # rank %time cumul self total #_of_calls self:ms/call tot:ms/call routine_name + if (m/^\s+\S+\s+\S+\s+\S+\s+(\S+)\s+\S+\s+(\S+)\s+\S+\s+\S+\s+(.*)\s*/) { + my $self = $1; + my $ncalls = $2; + my $name = $3; + my $tid = 0; + $name =~ s/\s+//g; + $name =~ s/^[*]//; + #print "$self $name\n"; + if ($name =~ m/^(.*)[@](\d+)/) { + $tid = $2; + $maxomp = $tid if ($tid > $maxomp); + $name = $1; + } + unless (exists($sumself{$name})) { + $nself{$name} = 0; + $sumself{$name} = 0; + $sum2self{$name} = 0; + $maxself{$name} = 0; + $minself{$name} = $bignum; + $numcalls{$name} = 0; + $taskhits{$name} = 0; + $omphits{$name} = 0; + } + $numcalls{$name} += $ncalls; + $taskhits{$name} += 1 if ($tid == 1); + $omphits{$name} += 1; + + # Account the most expensive OpenMP thread only per $name label + $ompself{$name} = 0 unless (exists($ompself{$name})); + $ompself{$name} = $self if ($self > $ompself{$name}); + } +} + +if ($nproc > 0) { + # One final time ... + &CumulativeUpdate(); + + print STDOUT "The name of the executable : $exe\n"; + print STDOUT "Number of MPI-tasks : $nproc\n"; + print STDOUT "Number of OpenMP-threads : $maxomp\n"; + print STDOUT "export $str : $threshold_percent%\n"; + $avgwall /= $nproc; + if ($nproc > 1) { + $stdevwall = ($stdevwall - $nproc * $avgwall * $avgwall)/($nproc - 1); + $stdevwall = ($stdevwall > 0) ? sqrt($stdevwall) : 0; # be careful with rounding of errors + } + else { + $stdevwall = 0; + } + #printf STDOUT ("Total time (average) : %.3f secs \n", $avgwall); + printf STDOUT ("Wall-times over %d MPI-tasks (secs) : Min=%.3f, Max=%.3f, Avg=%.3f, StDev=%.3f\n", + $nproc, $minwall, $maxwall, $avgwall, $stdevwall); + my $avgpercent = $threshold_percent * $avgwall / 100.0; + + printf STDOUT ("Routines whose average time > %.2f%% (%.3f secs) of the total average will be included in the listing\n", + $threshold_percent,$avgpercent); + + printf STDOUT ("%7s %10s %10s %10s %8s %8s %12s %13s %8s %8s : %s\n", + "Avg-%", "Avg.secs", + "Min.secs", "Max.secs", "St.dev", + "Imbal-%", + "# of calls", + "Avg.msec/call", + "Tasks", + "OpenMP", + "Name-of-the-routine"); + + open(PIPE,"|sort -nr|sed 's/ %/%/'"); + + # Values accounted for + my $acc_avgpercent = 0; + my $acc_avgtime = 0; + my $acc_maxtime = 0; + my $acc_mintime = $bignum; + + foreach my $name (keys %sumself) { + my $value = $sumself{$name}; + my $navg = $nself{$name}; + my $avgself = $value/$navg; + if ($avgself > $avgpercent) { + my $percent = $value/$tottim*100; + my $stdev = 0; + if ($navg > 1) { + $stdev = $sum2self{$name}; + $stdev = ($stdev - $navg * $avgself * $avgself)/($navg - 1); + $stdev = ($stdev > 0) ? sqrt($stdev) : 0; # be careful with rounding of errors + } + printf PIPE ("%6.2f %% %10.3f %10.3f %10.3f %8.3f %7.2f%% %12.0f %13.3f %8d %8d : %s\n", + $percent, $avgself, + $minself{$name},$maxself{$name},$stdev, + ($maxself{$name} - $minself{$name})/$maxself{$name}*100, + $numcalls{$name}, + $avgself / $numcalls{$name} * 1000.0, + $taskhits{$name}, + $omphits{$name} / $taskhits{$name}, + $name); + # Update values accounted for + $acc_avgpercent += $percent; + $acc_avgtime += $avgself; + $acc_mintime = $minself{$name} if ($acc_mintime > $minself{$name}); + $acc_maxtime = $maxself{$name} if ($acc_maxtime < $maxself{$name}); + } + } + close(PIPE); + printf STDOUT ("%6.2f%% %10.3f %10.3f %10.3f\n", + $acc_avgpercent,$acc_avgtime, + $acc_mintime, $acc_maxtime); +} + +exit 0; + +sub CumulativeUpdate { + foreach my $name (keys %ompself) { + my $self = $ompself{$name}; + $nself{$name} += 1; + $sumself{$name} += $self; + $sum2self{$name} += $self * $self; + $maxself{$name} = $self if ($self > $maxself{$name}); + $minself{$name} = $self if ($self < $minself{$name}); + $tottim += $self; + } +} + +# A sample of typical output +__DATA__ +The name of the executable : /lustre/tmp/saarines/rundir/LUMO/19/fmiopt/teho.gnu/h1/N7+1.T140+20xt1xh1.dcmp_10x14.ppn_20+20.nproma_60.hgp_undef.fmiopt-534667/MASTERODB +Number of MPI-tasks : 140 +Number of OpenMP-threads : 1 +export THRESHOLD_PERCENT : 0.2% +Wall-times over 140 MPI-tasks (secs) : Min=399.410, Max=400.320, Avg=399.876, StDev=0.220 +Routines whose average time > 0.20% (0.800 secs) of the total average will be included in the listing + Avg-% Avg.secs Min.secs Max.secs St.dev Imbal-% # of calls Avg.msec/call Tasks OpenMP : Name-of-the-routine + 5.32% 21.270 19.341 24.105 0.920 19.76% 10598700 0.002 140 1 : LAITRI + 5.18% 20.730 16.166 23.143 1.239 30.15% 698740 0.030 140 1 : VDFHGHTNHL + 5.06% 20.215 0.469 70.180 14.105 99.33% 8540 2.367 140 1 : SLCOMM + 4.12% 16.474 12.309 17.213 0.952 28.49% 933656 0.018 140 1 : FPCINCAPE + 3.61% 14.429 11.903 16.617 0.774 28.37% 698740 0.021 140 1 : INITAPLPAR + 3.02% 12.055 0.671 45.288 10.498 98.52% 6860 1.757 140 1 : SLCOMM2A + 2.72% 10.875 5.275 16.432 2.938 67.90% 698740 0.016 140 1 : RAIN_ICE + 2.70% 10.793 4.965 18.614 3.433 73.33% 698740 0.015 140 1 : RAIN_ICE:RAIN_ICE_SEDIMENTATION_STAT + 2.55% 10.182 9.763 10.552 0.212 7.48% 25340 0.402 140 1 : TRMTOL + 2.54% 10.169 8.510 10.509 0.444 19.02% 698740 0.015 140 1 : APL_AROME + 2.51% 10.054 8.519 10.192 0.421 16.41% 1397480 0.007 140 1 : COMPUTE_FUNCTION_THERMO_MF + 2.51% 10.038 8.181 11.849 1.156 30.96% 25340 0.396 140 1 : TRLTOG + 2.31% 9.252 5.219 21.083 4.795 75.25% 21000 0.441 140 1 : TRLTOM + 1.93% 7.711 1.976 24.881 6.385 92.06% 22540 0.342 140 1 : TRGTOL + 1.91% 7.653 3.985 12.186 2.001 67.30% 698740 0.011 140 1 : RAIN_ICE:RAIN_ICE_SLOW + 1.84% 7.364 6.510 7.976 0.403 18.38% 1413160 0.005 140 1 : ELARCHE + 1.46% 5.825 3.269 8.145 1.265 59.86% 71300 0.082 140 1 : RRTM_RTRN1A_140GP + 1.33% 5.301 4.389 5.637 0.229 22.14% 5589920 0.001 140 1 : TRIDIAG_MASSFLUX + 1.30% 5.208 4.416 5.282 0.218 16.40% 1397480 0.004 140 1 : TURB:COMPUTE_FUNCTION_THERMO + 1.25% 4.997 4.445 5.741 0.406 22.57% 9260880 0.001 140 1 : RPASSF + 1.12% 4.489 3.801 4.562 0.189 16.68% 698740 0.006 140 1 : ACTQSAT + 0.93% 3.699 2.879 4.401 0.341 34.58% 698740 0.005 140 1 : CONDENSATION + 0.90% 3.588 0.507 9.260 1.812 94.52% 698740 0.005 140 1 : RAIN_ICE:RAIN_ICE_FAST_RG + +etc. + + 0.23% 0.922 0.891 0.978 0.025 8.90% 718900 0.001 140 1 : SIPTP + 0.21% 0.840 0.583 1.262 0.160 53.80% 13440 0.063 140 1 : ESEIMPLS + 0.21% 0.834 0.691 0.878 0.037 21.30% 698740 0.001 140 1 : LATTEX + 0.21% 0.825 0.698 0.845 0.035 17.40% 112297500 0.000 140 1 : SWTT1 + 0.18% 0.893 0.000 1.548 0.567 100.00% 477554 0.002 113 1 : ECUME_FLUX + 85.41% 341.669 0.000 70.180 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/fcm-make-interfaces.cfg =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/fcm-make-interfaces.cfg (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/fcm-make-interfaces.cfg (revision 6016) @@ -0,0 +1,37 @@ +# (C) Copyright 2011- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + +# FCM configuration file used to auto-generate interface files +# for F77 and F90 files. +# Interface files will have the extention "@P_SUFFIX@" +# Results will be in a directory "interfaces/include" relative to cwd + +# Usage: fcm make --config-file= \ +# interfaces.ns-incl="" + +$SRC{?} = $HERE + +step.class[interfaces] = build +steps = interfaces + +interfaces.target{task} = ext-iface + +interfaces.source = $SRC + +# Exclude all +interfaces.ns-excl = / + +# Include some +# interfaces.ns-incl = + +# Extention of interface files +interfaces.prop{file-ext.f90-interface} = .intfb.h + +# Do not follow includes +interfaces.prop{no-dep.f.module} = * +interfaces.prop{no-dep.include} = * Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_deps.sh =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_deps.sh (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_deps.sh (revision 6016) @@ -0,0 +1,23 @@ +#!/bin/sh +# +# (C) Copyright 2015- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + + +EXT="parkind1.o|yomhook.o|yomcst.o|yomdyncore.o|yomlun.o|abor1.o|yomtag.o|mpl_module.o|yommp0.o" + +while [ "$1" ] +do + DEPS=$(egrep -i '^[ \t]*use' $1 | awk '-F[ ,]' '{print $2".o"}' | tr '[:upper:]' '[:lower:]' | egrep -v "$EXT" | tr '\n' ' ') + if [ "$DEPS" ] + then + echo $1 | awk -F. '{print $1"'".o: $DEPS"'"}' + fi + shift +done Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_dummy_includes.sh =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_dummy_includes.sh (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_dummy_includes.sh (revision 6016) @@ -0,0 +1,21 @@ +#!/bin/sh +# +# (C) Copyright 2015- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + + +while [ "$1" ] +do + HEADERS=$(grep '^#include' $1 | awk '-F"' '{print $2}') + for FILE in $HEADERS + do + touch ../include/$FILE + done + shift +done Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_intfbl.1.pl =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_intfbl.1.pl (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/bin/make_intfbl.1.pl (revision 6016) @@ -0,0 +1,140 @@ +#!/usr/bin/perl +#!/usr/local/apps/perl/current/bin/perl +# +# (C) Copyright 2010- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + +# Modified to cope with rttov files which have built in interface +# blocks that just need to be parsed out. +# Paul Burton 2010 + +use strict; +use warnings; +#use lib "/home/rd/rdx/bin/prepifs/perl"; +use Fortran90_stuff; +use Data::Dumper; +$Data::Dumper::Indent = 1; + +my $rttov_intf=0; + +{ + my (@files); + (@files) = @ARGV; + &setup_parse(); + my $locintfbldir=$ENV{LOC_INTFBDIR} or die "LOC_INTFBDIR not defined "; + my $intfbldir=$ENV{INTFBDIR} or die "INTFBDIR not defined "; + our $study_called; + FILE:for (@files) { + my (@interface_block); + my (@line_hash); + chomp; + # Read in lines from file + my $fname = $_; + + my $int_block_fname=$fname; + $int_block_fname=~s/\.F90/.intfb.h/; + $int_block_fname=~s#.*/(.+)$#$1#; + my $ofname=$intfbldir.'/'.$int_block_fname; + my $nfname=$locintfbldir.'/'.$int_block_fname; + +# Do nothing if file hasn't changed since intfb already created + + if ( (-f $nfname) && + ( (stat($nfname))[9] > (stat($fname))[9] )) { + print "INTERFACE BLOCK $int_block_fname UP TO DATE\n"; + next FILE; + } + +# skip .h files, Nils + my $base = $_; + ( $base = $fname ) =~ s/\.(\w+)\s*$//; + my $suffix = $1; + next if ( $suffix eq "h" ); +# end Nils + my @statements=(); + my %prog_info=(); + my @lines = &readfile($fname); + + $rttov_intf=0; + if ($fname=~/^satrad\//) { + if (grep(/^!INTF_END/,@lines)) { + print "Working on rttov file $fname\n"; + $rttov_intf=1; + &create_rttov_interface_block(\@lines,\@interface_block,\%prog_info); + } else { + # satrad file without INTF_END marker - ignore + print "Ignoring satrad file $fname (no INTF_END marker)\n"; + next; + } + } else { + print "Working on file $fname\n"; + &expcont(\@lines,\@statements); + $study_called=0; + &study(\@statements,\%prog_info); +# print Dumper(\%prog_info); + } + unless($prog_info{is_module}) { + if ($rttov_intf) { + @lines=@interface_block; + } else { + &create_interface_block(\@statements,\@interface_block); + &cont_lines(\@interface_block,\@lines,\@line_hash); + } + if ( -f $nfname ) { + my @nldlines=&readfile($nfname); + if(&eq_array(\@nldlines, \@lines)){ + print "INTERFACE BLOCK $int_block_fname NOT UPDATED \n" ; + next FILE; + } + } + if ( -f $ofname ) { + my @oldlines=&readfile($ofname); + if(&eq_array(\@oldlines, \@lines)){ + print "INTERFACE BLOCK $int_block_fname UNCHANGED \n" ; + next FILE; + } + } + print "WRITE INTERFACE BLOCK $int_block_fname \n"; + print "$nfname \n"; + &writefile($nfname,\@lines); + } + } +} +sub eq_array { + my ($ra, $rb) = @_; + return 0 unless $#$ra == $#$rb; + for my $i (0..$#$ra) { + return 0 unless $ra->[$i] eq $rb->[$i]; + } + return 1; +} + +sub create_rttov_interface_block { + my ($lines,$intfblk,$prog_info)=(@_); + my ($line,$on,$what,@intf); + $on=1; + $what=""; + for $line (@{$lines}) { + $on=1 if ($line=~/^\s*!\s*INTF_ON\s*$/); + $on=0 if ($line=~/^\s*!\s*INTF_OFF\s*$/); + last if ($line=~/^\s*!INTF_END\s*$/); + if ($what eq "") { + $what="SUBROUTINE" if ($line=~/^\s*SUBROUTINE/i); + $what="FUNCTION" if ($line=~/\s*FUNCTION/i); + $what="MODULE" if ($line=~/^\s*MODULE/i); + $what="PROGRAM" if ($line=~/^\s*PROGRAM/i); + } + next if ($line=~/^\s*!/ || $line=~/^\s*$/ || !$on ); + push(@intf,$line); + } + die "Cannot guess if file contains a SUBROUTINE or FUNCTION.\n" unless $what; + $prog_info->{is_module}=1 if ($what eq "MODULE"); + @{$intfblk}=("INTERFACE\n",@intf,"END $what\n","END INTERFACE\n"); +} + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/config/install-sh =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/config/install-sh (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/config/install-sh (revision 6016) @@ -0,0 +1,527 @@ +#!/bin/sh +# install - install a program, script, or datafile + +scriptversion=2011-11-20.07; # UTC + +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. +# +# Copyright (C) 1994 X Consortium +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# +# FSF changes to this file are in the public domain. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# 'make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. + +nl=' +' +IFS=" "" $nl" + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit=${DOITPROG-} +if test -z "$doit"; then + doit_exec=exec +else + doit_exec=$doit +fi + +# Put in absolute file names if you don't have them in your path; +# or use environment vars. + +chgrpprog=${CHGRPPROG-chgrp} +chmodprog=${CHMODPROG-chmod} +chownprog=${CHOWNPROG-chown} +cmpprog=${CMPPROG-cmp} +cpprog=${CPPROG-cp} +mkdirprog=${MKDIRPROG-mkdir} +mvprog=${MVPROG-mv} +rmprog=${RMPROG-rm} +stripprog=${STRIPPROG-strip} + +posix_glob='?' +initialize_posix_glob=' + test "$posix_glob" != "?" || { + if (set -f) 2>/dev/null; then + posix_glob= + else + posix_glob=: + fi + } +' + +posix_mkdir= + +# Desired mode of installed file. +mode=0755 + +chgrpcmd= +chmodcmd=$chmodprog +chowncmd= +mvcmd=$mvprog +rmcmd="$rmprog -f" +stripcmd= + +src= +dst= +dir_arg= +dst_arg= + +copy_on_change=false +no_target_directory= + +usage="\ +Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE + or: $0 [OPTION]... SRCFILES... DIRECTORY + or: $0 [OPTION]... -t DIRECTORY SRCFILES... + or: $0 [OPTION]... -d DIRECTORIES... + +In the 1st form, copy SRCFILE to DSTFILE. +In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. +In the 4th, create DIRECTORIES. + +Options: + --help display this help and exit. + --version display version info and exit. + + -c (ignored) + -C install only if different (preserve the last data modification time) + -d create directories instead of installing files. + -g GROUP $chgrpprog installed files to GROUP. + -m MODE $chmodprog installed files to MODE. + -o USER $chownprog installed files to USER. + -s $stripprog installed files. + -t DIRECTORY install into DIRECTORY. + -T report an error if DSTFILE is a directory. + +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG + RMPROG STRIPPROG +" + +while test $# -ne 0; do + case $1 in + -c) ;; + + -C) copy_on_change=true;; + + -d) dir_arg=true;; + + -g) chgrpcmd="$chgrpprog $2" + shift;; + + --help) echo "$usage"; exit $?;; + + -m) mode=$2 + case $mode in + *' '* | *' '* | *' +'* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; + + -o) chowncmd="$chownprog $2" + shift;; + + -s) stripcmd=$stripprog;; + + -t) dst_arg=$2 + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + shift;; + + -T) no_target_directory=true;; + + --version) echo "$0 $scriptversion"; exit $?;; + + --) shift + break;; + + -*) echo "$0: invalid option: $1" >&2 + exit 1;; + + *) break;; + esac + shift +done + +if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then + # When -d is used, all remaining arguments are directories to create. + # When -t is used, the destination is already specified. + # Otherwise, the last argument is the destination. Remove it from $@. + for arg + do + if test -n "$dst_arg"; then + # $@ is not empty: it contains at least $arg. + set fnord "$@" "$dst_arg" + shift # fnord + fi + shift # arg + dst_arg=$arg + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + done +fi + +if test $# -eq 0; then + if test -z "$dir_arg"; then + echo "$0: no input file specified." >&2 + exit 1 + fi + # It's OK to call 'install-sh -d' without argument. + # This can happen when creating conditional directories. + exit 0 +fi + +if test -z "$dir_arg"; then + do_exit='(exit $ret); exit $ret' + trap "ret=129; $do_exit" 1 + trap "ret=130; $do_exit" 2 + trap "ret=141; $do_exit" 13 + trap "ret=143; $do_exit" 15 + + # Set umask so as not to create temps with too-generous modes. + # However, 'strip' requires both read and write access to temps. + case $mode in + # Optimize common cases. + *644) cp_umask=133;; + *755) cp_umask=22;; + + *[0-7]) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw='% 200' + fi + cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; + *) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw=,u+rw + fi + cp_umask=$mode$u_plus_rw;; + esac +fi + +for src +do + # Protect names problematic for 'test' and other utilities. + case $src in + -* | [=\(\)!]) src=./$src;; + esac + + if test -n "$dir_arg"; then + dst=$src + dstdir=$dst + test -d "$dstdir" + dstdir_status=$? + else + + # Waiting for this to be detected by the "$cpprog $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dst_arg"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + dst=$dst_arg + + # If destination is a directory, append the input filename; won't work + # if double slashes aren't ignored. + if test -d "$dst"; then + if test -n "$no_target_directory"; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 + fi + dstdir=$dst + dst=$dstdir/`basename "$src"` + dstdir_status=0 + else + # Prefer dirname, but fall back on a substitute if dirname fails. + dstdir=` + (dirname "$dst") 2>/dev/null || + expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$dst" : 'X\(//\)[^/]' \| \ + X"$dst" : 'X\(//\)$' \| \ + X"$dst" : 'X\(/\)' \| . 2>/dev/null || + echo X"$dst" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q' + ` + + test -d "$dstdir" + dstdir_status=$? + fi + fi + + obsolete_mkdir_used=false + + if test $dstdir_status != 0; then + case $posix_mkdir in + '') + # Create intermediate dirs using mode 755 as modified by the umask. + # This is like FreeBSD 'install' as of 1997-10-28. + umask=`umask` + case $stripcmd.$umask in + # Optimize common cases. + *[2367][2367]) mkdir_umask=$umask;; + .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; + + *[0-7]) + mkdir_umask=`expr $umask + 22 \ + - $umask % 100 % 40 + $umask % 20 \ + - $umask % 10 % 4 + $umask % 2 + `;; + *) mkdir_umask=$umask,go-w;; + esac + + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + case $umask in + *[123567][0-7][0-7]) + # POSIX mkdir -p sets u+wx bits regardless of umask, which + # is incompatible with FreeBSD 'install' when (umask & 300) != 0. + ;; + *) + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 + + if (umask $mkdir_umask && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + ls_ld_tmpdir=`ls -ld "$tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/d" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null + fi + trap '' 0;; + esac;; + esac + + if + $posix_mkdir && ( + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + ) + then : + else + + # The umask is ridiculous, or mkdir does not conform to POSIX, + # or it failed possibly due to a race condition. Create the + # directory the slow way, step by step, checking for races as we go. + + case $dstdir in + /*) prefix='/';; + [-=\(\)!]*) prefix='./';; + *) prefix='';; + esac + + eval "$initialize_posix_glob" + + oIFS=$IFS + IFS=/ + $posix_glob set -f + set fnord $dstdir + shift + $posix_glob set +f + IFS=$oIFS + + prefixes= + + for d + do + test X"$d" = X && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask=$mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ + done + + if test -n "$prefixes"; then + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true + fi + fi + fi + + if test -n "$dir_arg"; then + { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && + { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || + test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 + else + + # Make a couple of temp file names in the proper directory. + dsttmp=$dstdir/_inst.$$_ + rmtmp=$dstdir/_rm.$$_ + + # Trap to clean up those temp files at exit. + trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 + + # Copy the file name to the temp name. + (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $cpprog $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && + { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && + { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && + + # If -C, don't bother to copy if it wouldn't change the file. + if $copy_on_change && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + + eval "$initialize_posix_glob" && + $posix_glob set -f && + set X $old && old=:$2:$4:$5:$6 && + set X $new && new=:$2:$4:$5:$6 && + $posix_glob set +f && + + test "$old" = "$new" && + $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 + then + rm -f "$dsttmp" + else + # Rename the file to the real destination. + $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || + + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. + { + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + fi || exit 1 + + trap '' 0 + fi +done + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC" +# time-stamp-end: "; # UTC" +# End: Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/configure =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/configure (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/configure (revision 6016) @@ -0,0 +1,4722 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.69 for ecrad 1.1.0. +# +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME='ecrad' +PACKAGE_TARNAME='ecrad' +PACKAGE_VERSION='1.1.0' +PACKAGE_STRING='ecrad 1.1.0' +PACKAGE_BUGREPORT='' +PACKAGE_URL='https://confluence.ecmwf.int/display/ECRAD' + +ac_unique_file="radiation/radiation_flux.F90" +ac_subst_vars='LTLIBOBJS +LIBOBJS +MKDIR_P +INSTALL_DATA +INSTALL_SCRIPT +INSTALL_PROGRAM +PYTHON +ARFLAGS +AR +DEPGEN_EXTERNAL_MODS +NETCDF_FCLIBS +NETCDF_FCFLAGS +DEFAULT_INLIB +DEFAULT_VERBOSITY +FCDEF_PP +FCINCORDER_PP +FCINCFLAG_PP +FCINCORDER +FCINCFLAG +FCMODOUT +FCMODINC +FCMODUC +FCMODEXT +FC_VENDOR +FCFLAGS_F90 +OBJEXT +EXEEXT +ac_ct_FC +LDFLAGS +FCFLAGS +FC +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +enable_silent_rules +enable_single_precision +enable_pgi_inlib +with_netcdf_root +with_netcdf_include +with_netcdf_lib +' + ac_precious_vars='build_alias +host_alias +target_alias +FC +FCFLAGS +LDFLAGS +LIBS +NETCDF_FCFLAGS +NETCDF_FCLIBS +AR +ARFLAGS +PYTHON' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures ecrad 1.1.0 to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/ecrad] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF +_ACEOF +fi + +if test -n "$ac_init_help"; then + case $ac_init_help in + short | recursive ) echo "Configuration of ecrad 1.1.0:";; + esac + cat <<\_ACEOF + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-silent-rules less verbose build output (undo: "make V=1") + [default=yes] + --enable-single-precision + switch to single precision [default=no] + --enable-pgi-inlib enable PGI cross-file function inlining via an + inline library (undo: "make INLIB=0") [default=auto] + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-netcdf-root=NETCDF_ROOT + root search path for NetCDF headers and libraries + --with-netcdf-include=DIR + search path for NetCDF headers [NETCDF_ROOT/include] + --with-netcdf-lib=DIR search path for NetCDF libraries [NETCDF_ROOT/lib] + +Some influential environment variables: + FC Fortran compiler command + FCFLAGS Fortran compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + NETCDF_FCFLAGS + exact Fortran compiler flags enabling NetCDF + NETCDF_FCLIBS + exact linker flags enabling NetCDF when linking with Fortran + compiler + AR archiver command + ARFLAGS archiver flags + PYTHON Python interpreter command + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to the package provider. +ecrad home page: . +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +ecrad configure 1.1.0 +generated by GNU Autoconf 2.69 + +Copyright (C) 2012 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_fc_try_compile LINENO +# --------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_fc_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_fc_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_fc_try_compile + +# ac_fn_fc_try_link LINENO +# ------------------------ +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_fc_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_fc_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_fc_try_link +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by ecrad $as_me 1.1.0, which was +generated by GNU Autoconf 2.69. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +ac_aux_dir= +for ac_dir in config "$srcdir"/config; do + if test -f "$ac_dir/install-sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f "$ac_dir/install.sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f "$ac_dir/shtool"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + as_fn_error $? "cannot find install-sh, install.sh, or shtool in config \"$srcdir\"/config" "$LINENO" 5 +fi + +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. +ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. +ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. + + + + +# Check whether --enable-silent-rules was given. +if test "${enable_silent_rules+set}" = set; then : + enableval=$enable_silent_rules; if test x"$enableval" != xno; then : + enable_silent_rules=yes +fi +else + enable_silent_rules=yes +fi + + +# Check whether --enable-single-precision was given. +if test "${enable_single_precision+set}" = set; then : + enableval=$enable_single_precision; if test x"$enableval" != xno; then : + enable_single_precision=yes +fi +else + enable_single_precision=no +fi + + +# Check whether --enable-pgi-inlib was given. +if test "${enable_pgi_inlib+set}" = set; then : + enableval=$enable_pgi_inlib; if test x"$enableval" != xno && test x"$enableval" != xauto; then : + enable_pgi_inlib=yes +fi +else + enable_pgi_inlib=auto +fi + + +ac_ext=${ac_fc_srcext-f} +ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' +ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_fc_compiler_gnu +if test -n "$ac_tool_prefix"; then + for ac_prog in gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor xlf90 f90 pgf90 pghpf epcf90 g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_FC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$FC"; then + ac_cv_prog_FC="$FC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_FC="$ac_tool_prefix$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +FC=$ac_cv_prog_FC +if test -n "$FC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $FC" >&5 +$as_echo "$FC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$FC" && break + done +fi +if test -z "$FC"; then + ac_ct_FC=$FC + for ac_prog in gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor xlf90 f90 pgf90 pghpf epcf90 g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_FC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_FC"; then + ac_cv_prog_ac_ct_FC="$ac_ct_FC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_FC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_FC=$ac_cv_prog_ac_ct_FC +if test -n "$ac_ct_FC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FC" >&5 +$as_echo "$ac_ct_FC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$ac_ct_FC" && break +done + + if test "x$ac_ct_FC" = x; then + FC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + FC=$ac_ct_FC + fi +fi + + +# Provide some information about the compiler. +$as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done +rm -f a.out + +cat > conftest.$ac_ext <<_ACEOF + program main + + end +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the Fortran compiler works" >&5 +$as_echo_n "checking whether the Fortran compiler works... " >&6; } +ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else + ac_file='' +fi +if test -z "$ac_file"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +$as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "Fortran compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler default output file name" >&5 +$as_echo_n "checking for Fortran compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +$as_echo "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +$as_echo_n "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat > conftest.$ac_ext <<_ACEOF + program main + open(unit=9,file='conftest.out') + close(unit=9) + + end +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +$as_echo_n "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run Fortran compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +$as_echo "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 +$as_echo_n "checking for suffix of object files... " >&6; } +if ${ac_cv_objext+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat > conftest.$ac_ext <<_ACEOF + program main + + end +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +$as_echo "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +# If we don't use `.F' as extension, the preprocessor is not run on the +# input file. (Note that this only needs to work for GNU compilers.) +ac_save_ext=$ac_ext +ac_ext=F +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran compiler" >&5 +$as_echo_n "checking whether we are using the GNU Fortran compiler... " >&6; } +if ${ac_cv_fc_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat > conftest.$ac_ext <<_ACEOF + program main +#ifndef __GNUC__ + choke me +#endif + + end +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + ac_compiler_gnu=yes +else + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_fc_compiler_gnu=$ac_compiler_gnu + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_compiler_gnu" >&5 +$as_echo "$ac_cv_fc_compiler_gnu" >&6; } +ac_ext=$ac_save_ext +ac_test_FCFLAGS=${FCFLAGS+set} +ac_save_FCFLAGS=$FCFLAGS +FCFLAGS= +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $FC accepts -g" >&5 +$as_echo_n "checking whether $FC accepts -g... " >&6; } +if ${ac_cv_prog_fc_g+:} false; then : + $as_echo_n "(cached) " >&6 +else + FCFLAGS=-g +cat > conftest.$ac_ext <<_ACEOF + program main + + end +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + ac_cv_prog_fc_g=yes +else + ac_cv_prog_fc_g=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_g" >&5 +$as_echo "$ac_cv_prog_fc_g" >&6; } +if test "$ac_test_FCFLAGS" = set; then + FCFLAGS=$ac_save_FCFLAGS +elif test $ac_cv_prog_fc_g = yes; then + if test "x$ac_cv_fc_compiler_gnu" = xyes; then + FCFLAGS="-g -O2" + else + FCFLAGS="-g" + fi +else + if test "x$ac_cv_fc_compiler_gnu" = xyes; then + FCFLAGS="-O2" + else + FCFLAGS= + fi +fi + +if test $ac_compiler_gnu = yes; then + GFC=yes +else + GFC= +fi +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + +ac_ext=${ac_fc_srcext-f} +ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' +ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_fc_compiler_gnu + + + acx_ext_save=$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler flag needed to compile preprocessed .F90 files" >&5 +$as_echo_n "checking for Fortran compiler flag needed to compile preprocessed .F90 files... " >&6; } +if ${acx_cv_fc_pp_srcext_F90+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_ext=F90 +ac_fcflags_pp_srcext_save=$ac_fcflags_srcext +ac_fcflags_srcext= +acx_cv_fc_pp_srcext_F90=unknown +case $ac_ext in #( + [fF]77) ac_try=f77-cpp-input;; #( + *) ac_try=f95-cpp-input;; +esac +for ac_flag in none -ftpp -fpp -Tf "-fpp -Tf" -xpp=fpp -Mpreprocess "-e T" "-e Z" \ + -cpp -xpp=cpp -qsuffix=cpp=F90 "-x $ac_try" +cpp -Cpp; do + test "x$ac_flag" != xnone && ac_fcflags_srcext="$ac_flag" + cat > conftest.$ac_ext <<_ACEOF + program main + +#if 0 +#include + choke me +#endif + end +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + cat > conftest.$ac_ext <<_ACEOF + program main + +#if 1 +#include + choke me +#endif + end +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + +else + acx_cv_fc_pp_srcext_F90=$ac_flag; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +done +rm -f conftest.$ac_objext conftest.F90 +ac_fcflags_srcext=$ac_fcflags_pp_srcext_save + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_pp_srcext_F90" >&5 +$as_echo "$acx_cv_fc_pp_srcext_F90" >&6; } +if test "x$acx_cv_fc_pp_srcext_F90" = xunknown; then + : +else + ac_fc_srcext=F90 + if test "x$acx_cv_fc_pp_srcext_F90" = xnone; then + ac_fcflags_srcext="" + FCFLAGS_F90="" + else + ac_fcflags_srcext=$acx_cv_fc_pp_srcext_F90 + FCFLAGS_F90=$acx_cv_fc_pp_srcext_F90 + fi + + +fi + + if test "x$acx_cv_fc_pp_srcext_F90" = xunknown; then : + ac_ext=$acx_ext_save + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to detect Fortran compiler flag needed to compile preprocessed .F90 files +See \`config.log' for more details" "$LINENO" 5; } +else + ac_ext=$ac_fc_srcext + +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler vendor" >&5 +$as_echo_n "checking for Fortran compiler vendor... " >&6; } +if ${acx_cv_fc_compiler_vendor+:} false; then : + $as_echo_n "(cached) " >&6 +else + if $FC --version 2>/dev/null | grep '^\(ifort\|ifx\) (IFORT)' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=intel +elif $FC -V 2>&1 | grep '^NAG Fortran Compiler Release' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=nag +elif $FC -V 2>/dev/null| grep '^Copyright.*\(The Portland Group\|NVIDIA CORPORATION\)' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=portland +elif $FC -V 2>&1 | grep '^Cray Fortran' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=cray +elif $FC --version 2>&1 | grep '^Copyright.*NEC Corporation' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=nec +elif $FC --version 2>/dev/null | grep '^GNU Fortran' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=gnu +elif $FC --version 2>&1 | grep '^AMD clang version' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=amd +elif $FC -V 2>&1 | grep '^f18 compiler' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=flang +elif $FC --version 2>&1 | grep 'clang version' >/dev/null 2>&1; then : + acx_cv_fc_compiler_vendor=flang +else + acx_cv_fc_compiler_vendor=unknown +fi + rm -f a.out a.out.dSYM a.exe b.out +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_compiler_vendor" >&5 +$as_echo "$acx_cv_fc_compiler_vendor" >&6; } + +FC_VENDOR=$acx_cv_fc_compiler_vendor + + + acx_fc_line_length_none_in_cache=no + if ${acx_cv_fc_line_length_unlimited+:} false; then : + case $acx_cv_fc_line_length_unlimited in #( + none) : + acx_fc_line_length_none_in_cache=yes ;; #( + '') : + acx_cv_fc_line_length_unlimited=none ;; #( + *) : + ;; +esac +fi + acx_save_FCFLAGS=$FCFLAGS + ac_fc_line_len_string=unlimited + ac_fc_line_len=0 + ac_fc_line_length_test=' + subroutine longer_than_132(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,'\ +'arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,arg17,arg18,arg19)' +: ${ac_fc_line_len_string=$ac_fc_line_len} +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran flag needed to accept $ac_fc_line_len_string column source lines" >&5 +$as_echo_n "checking for Fortran flag needed to accept $ac_fc_line_len_string column source lines... " >&6; } +if ${acx_cv_fc_line_length_unlimited+:} false; then : + $as_echo_n "(cached) " >&6 +else + acx_cv_fc_line_length_unlimited=unknown +ac_fc_line_length_FCFLAGS_save=$FCFLAGS +for ac_flag in none \ + -ffree-line-length-none -ffixed-line-length-none \ + -ffree-line-length-huge \ + -ffree-line-length-$ac_fc_line_len \ + -ffixed-line-length-$ac_fc_line_len \ + -qfixed=$ac_fc_line_len -Mextend \ + -$ac_fc_line_len -extend_source \ + -W$ac_fc_line_len -W +extend_source +es -wide --wide -w -e \ + -f -Wf,-f -xline +do + test "x$ac_flag" != xnone && FCFLAGS="$ac_fc_line_length_FCFLAGS_save $ac_flag" + cat > conftest.$ac_ext <<_ACEOF +$ac_fc_line_length_test + implicit integer (a) + end subroutine +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + acx_cv_fc_line_length_unlimited=$ac_flag; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +done +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +FCFLAGS=$ac_fc_line_length_FCFLAGS_save + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_line_length_unlimited" >&5 +$as_echo "$acx_cv_fc_line_length_unlimited" >&6; } +if test "x$acx_cv_fc_line_length_unlimited" = xunknown; then + : +else + if test "x$acx_cv_fc_line_length_unlimited" != xnone; then + FCFLAGS="$FCFLAGS $acx_cv_fc_line_length_unlimited" + fi + +fi + + + FCFLAGS=$acx_save_FCFLAGS + if test "x$acx_cv_fc_line_length_unlimited$acx_fc_line_length_none_in_cache" = xnoneno; then : + acx_cv_fc_line_length_unlimited= +fi + if test "x$acx_cv_fc_line_length_unlimited" = xunknown; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to detect Fortran compiler flag needed to accept unlimited column source lines +See \`config.log' for more details" "$LINENO" 5; } +else + if test -n "$acx_cv_fc_line_length_unlimited"; then : + as_fn_append FCFLAGS " $acx_cv_fc_line_length_unlimited" +fi +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler module file naming template" >&5 +$as_echo_n "checking for Fortran compiler module file naming template... " >&6; } + if ${acx_cv_fc_module_naming_upper+:} false && ${acx_cv_fc_module_naming_ext+:} false; then : + $as_echo_n "(cached) " >&6 +else + as_dir=conftest.dir; as_fn_mkdir_p + cd conftest.dir + cat > conftest.$ac_ext <<_ACEOF + module conftest_module + implicit none + public + contains + subroutine conftest_routine + end subroutine + end module +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + case "$acx_cv_fc_module_naming_upper" in #( + yes) : + acx_tmp='CONFTEST_MODULE.*' + acx_cv_fc_module_naming_ext=unknown ;; #( + no) : + acx_tmp='conftest_module.*' + acx_cv_fc_module_naming_ext=unknown ;; #( + *) : + if ${acx_cv_fc_module_naming_ext+:} false; then : + acx_tmp="CONFTEST_MODULE.$acx_cv_fc_module_naming_ext conftest_module.$acx_cv_fc_module_naming_ext" + acx_cv_fc_module_naming_upper=unknown +else + acx_tmp='CONFTEST_MODULE.* conftest_module.*' + acx_cv_fc_module_naming_upper=unknown + acx_cv_fc_module_naming_ext=unknown +fi ;; +esac + acx_tmp=`ls $acx_tmp 2>/dev/null` + if test 1 -eq `$as_echo "$acx_tmp" | wc -l` 2>/dev/null; then : + case "$acx_tmp" in #( + CONFTEST_MODULE.*) : + acx_cv_fc_module_naming_upper=yes + acx_cv_fc_module_naming_ext=`echo $acx_tmp | sed -n 's,CONFTEST_MODULE\.,,p'` ;; #( + conftest_module.*) : + acx_cv_fc_module_naming_upper=no + acx_cv_fc_module_naming_ext=`echo $acx_tmp | sed -n 's,conftest_module\.,,p'` ;; #( + *) : + ;; +esac +fi +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + cd .. + rm -rf conftest.dir +fi + if test "x$acx_cv_fc_module_naming_upper" = xunknown || test "x$acx_cv_fc_module_naming_ext" = xunknown; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unknown" >&5 +$as_echo "unknown" >&6; } + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to detect Fortran compiler module file naming template +See \`config.log' for more details" "$LINENO" 5; } +else + if test "x$acx_cv_fc_module_naming_upper" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: NAME.$acx_cv_fc_module_naming_ext" >&5 +$as_echo "NAME.$acx_cv_fc_module_naming_ext" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: name.$acx_cv_fc_module_naming_ext" >&5 +$as_echo "name.$acx_cv_fc_module_naming_ext" >&6; } +fi + FCMODEXT="$acx_cv_fc_module_naming_ext" + + FCMODUC="$acx_cv_fc_module_naming_upper" + +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler flag needed to specify search paths for module files" >&5 +$as_echo_n "checking for Fortran compiler flag needed to specify search paths for module files... " >&6; } +if ${acx_cv_fc_module_in_flag+:} false; then : + $as_echo_n "(cached) " >&6 +else + acx_cv_fc_module_in_flag=unknown +mkdir conftest.dir +cd conftest.dir +cat > conftest.$ac_ext <<_ACEOF + + module conftest_module + implicit none + public + contains + subroutine conftest_routine + write(*,'(a)') 'gotcha!' + end subroutine + end module +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + cd .. + ac_fc_module_flag_FCFLAGS_save=$FCFLAGS + for ac_flag in -M -I '-I ' '-M ' -p '-mod ' '-module ' '-Am -I'; do + FCFLAGS="$ac_fc_module_flag_FCFLAGS_save ${ac_flag}conftest.dir ${ac_flag}conftest.dir" + cat > conftest.$ac_ext <<_ACEOF + + program main + use conftest_module, only : conftest_routine + implicit none + call conftest_routine + end program +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + acx_cv_fc_module_in_flag="$ac_flag" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + if test "$acx_cv_fc_module_in_flag" != unknown; then + break + fi + done + FCFLAGS=$ac_fc_module_flag_FCFLAGS_save + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -rf conftest.dir + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_module_in_flag" >&5 +$as_echo "$acx_cv_fc_module_in_flag" >&6; } +if test "$acx_cv_fc_module_in_flag" != unknown; then + : +else + : +fi + if test "x$acx_cv_fc_module_in_flag" = xunknown; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to detect Fortran compiler flag needed to specify search paths for module files +See \`config.log' for more details" "$LINENO" 5; } +else + FCMODINC="$acx_cv_fc_module_in_flag" + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler flag needed to specify output path for module files" >&5 +$as_echo_n "checking for Fortran compiler flag needed to specify output path for module files... " >&6; } +if ${acx_cv_fc_module_out_flag+:} false; then : + $as_echo_n "(cached) " >&6 +else + mkdir conftest.dir conftest.dir/sub +cd conftest.dir +acx_cv_fc_module_out_flag=unknown +ac_fc_module_output_flag_FCFLAGS_save=$FCFLAGS +for ac_flag in -J '-J ' -fmod= -moddir= +moddir= -qmoddir= '-mdir ' '-mod ' \ + '-module ' -M '-Am -M' '-e m -J '; do + FCFLAGS="$ac_fc_module_output_flag_FCFLAGS_save ${ac_flag}sub" + cat > conftest.$ac_ext <<_ACEOF + + module conftest_module + implicit none + public + contains + subroutine conftest_routine + write(*,'(a)') 'gotcha!' + end subroutine + end module +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + cd sub + cat > conftest.$ac_ext <<_ACEOF + + program main + use conftest_module, only : conftest_routine + implicit none + call conftest_routine + end program +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + acx_cv_fc_module_out_flag="$ac_flag" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + cd .. + if test "$acx_cv_fc_module_out_flag" != unknown; then + break + fi +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +done +FCFLAGS=$ac_fc_module_output_flag_FCFLAGS_save +cd .. +rm -rf conftest.dir + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_module_out_flag" >&5 +$as_echo "$acx_cv_fc_module_out_flag" >&6; } +if test "$acx_cv_fc_module_out_flag" != unknown; then + : +else + : +fi + if test "x$acx_cv_fc_module_out_flag" = xunknown; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to detect Fortran compiler flag needed to specify output path for module files +See \`config.log' for more details" "$LINENO" 5; } +else + FCMODOUT="$acx_cv_fc_module_out_flag" + +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler flag needed to specify search paths for the \"INCLUDE\" statement" >&5 +$as_echo_n "checking for Fortran compiler flag needed to specify search paths for the \"INCLUDE\" statement... " >&6; } +if ${acx_cv_fc_ftn_include_flag+:} false; then : + $as_echo_n "(cached) " >&6 +else + acx_cv_fc_ftn_include_flag=unknown + as_dir=conftest.dir; as_fn_mkdir_p + cat > conftest.$ac_ext <<_ACEOF + program main + + end +_ACEOF + mv conftest.$ac_ext conftest.dir/conftest.inc + cat > conftest.$ac_ext <<_ACEOF + include "conftest.inc" + +_ACEOF + acx_save_FCFLAGS=$FCFLAGS + for acx_flag in -I '-I '; do + FCFLAGS="$acx_save_FCFLAGS ${acx_flag}conftest.dir" + if ac_fn_fc_try_link "$LINENO"; then : + acx_cv_fc_ftn_include_flag=$acx_flag +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + test "x$acx_cv_fc_ftn_include_flag" != xunknown && break + done + FCFLAGS=$acx_save_FCFLAGS + rm -f conftest.$ac_ext + rm -rf conftest.dir +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_ftn_include_flag" >&5 +$as_echo "$acx_cv_fc_ftn_include_flag" >&6; } + + if test "x$acx_cv_fc_ftn_include_flag" = xunknown; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to detect Fortran compiler flag needed to specify search paths for the \"INCLUDE\" statement +See \`config.log' for more details" "$LINENO" 5; } +else + FCINCFLAG="$acx_cv_fc_ftn_include_flag" + +fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler search path order for the \"INCLUDE\" statement" >&5 +$as_echo_n "checking for Fortran compiler search path order for the \"INCLUDE\" statement... " >&6; } +if ${acx_cv_fc_ftn_include_order+:} false; then : + $as_echo_n "(cached) " >&6 +else + acx_cv_fc_ftn_include_order= + if test "x$cross_compiling" = xno; then : + as_dir=conftest.dir/src/inc; as_fn_mkdir_p + as_dir=conftest.dir/build; as_fn_mkdir_p + as_dir=conftest.dir/src/inc2; as_fn_mkdir_p + cat > conftest.$ac_ext <<_ACEOF + program main + include "conftest.inc" + + end +_ACEOF + cp conftest.$ac_ext conftest.dir/build/conftest.$ac_ext + mv conftest.$ac_ext conftest.dir/src/conftest.$ac_ext + cat > conftest.$ac_ext <<_ACEOF + include "conftest.write" + +_ACEOF + mv conftest.$ac_ext conftest.dir/src/inc2/conftest.inc + set "src" "/src/" "flg" "/src/inc/" "inc" "/src/inc2/" "cwd" "/build/" + while test $# != 0; do + cat > conftest.$ac_ext <<_ACEOF + write(*,"(a)") "${1}" +_ACEOF + shift; mv conftest.$ac_ext conftest.dir${1}conftest.write; shift + done + cd conftest.dir/build + acx_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS ${acx_cv_fc_ftn_include_flag}../src/inc ${acx_cv_fc_ftn_include_flag}../src/inc2" + acx_save_ac_link=$ac_link + ac_link=`$as_echo "$ac_link" | sed 's%conftest\.\$ac_ext%../src/&%'` + while :; do + if ac_fn_fc_try_link "$LINENO"; then : + acx_exec_result=`./conftest$ac_exeext` + if test $? -eq 0; then : + case $acx_exec_result in #( + src) : + rm -f ../src/conftest.write ;; #( + inc) : + rm -f ../src/inc2/conftest.write ;; #( + cwd) : + rm -f ./conftest.write ;; #( + flg) : + rm -f ../src/inc/conftest.write ../src/inc2/conftest.write ;; #( + *) : + break ;; +esac + if test -z "$acx_cv_fc_ftn_include_order"; then : + acx_cv_fc_ftn_include_order=$acx_exec_result +else + as_fn_append acx_cv_fc_ftn_include_order ",$acx_exec_result" +fi + rm -f conftest$ac_exeext +else + break +fi +else + break +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + done + ac_link=$acx_save_ac_link + FCFLAGS=$acx_save_FCFLAGS + cd ../.. + rm -rf conftest.dir +fi + if test -z "$acx_cv_fc_ftn_include_order"; then : + acx_cv_fc_ftn_include_order=unknown +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_ftn_include_order" >&5 +$as_echo "$acx_cv_fc_ftn_include_order" >&6; } + if test "x$acx_cv_fc_ftn_include_order" = xunknown; then : + FCINCORDER='src,flg' + +else + FCINCORDER="$acx_cv_fc_ftn_include_order" + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler flag needed to specify search paths for the quoted form of the \"#include\" directive" >&5 +$as_echo_n "checking for Fortran compiler flag needed to specify search paths for the quoted form of the \"#include\" directive... " >&6; } +if ${acx_cv_fc_pp_include_flag+:} false; then : + $as_echo_n "(cached) " >&6 +else + acx_cv_fc_pp_include_flag=unknown + as_dir=conftest.dir; as_fn_mkdir_p + cat > conftest.$ac_ext <<_ACEOF + program main + + end +_ACEOF + mv conftest.$ac_ext conftest.dir/conftest.inc + cat > conftest.$ac_ext <<_ACEOF +#include "conftest.inc" + +_ACEOF + acx_save_FCFLAGS=$FCFLAGS + for acx_flag in -I '-I ' '-WF,-I' '-Wp,-I'; do + FCFLAGS="$acx_save_FCFLAGS ${acx_flag}conftest.dir" + if ac_fn_fc_try_link "$LINENO"; then : + acx_cv_fc_pp_include_flag=$acx_flag +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + test "x$acx_cv_fc_pp_include_flag" != xunknown && break + done + FCFLAGS=$acx_save_FCFLAGS + rm -f conftest.$ac_ext + rm -rf conftest.dir +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_pp_include_flag" >&5 +$as_echo "$acx_cv_fc_pp_include_flag" >&6; } + + if test "x$acx_cv_fc_pp_include_flag" = xunknown; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to detect Fortran compiler flag needed to specify search paths for the quoted form of the \"#include\" directive +See \`config.log' for more details" "$LINENO" 5; } +else + FCINCFLAG_PP="$acx_cv_fc_pp_include_flag" + +fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler search path order for the quoted form of the \"#include\" directive" >&5 +$as_echo_n "checking for Fortran compiler search path order for the quoted form of the \"#include\" directive... " >&6; } +if ${acx_cv_fc_pp_include_order+:} false; then : + $as_echo_n "(cached) " >&6 +else + acx_cv_fc_pp_include_order= + if test "x$cross_compiling" = xno; then : + as_dir=conftest.dir/src/inc; as_fn_mkdir_p + as_dir=conftest.dir/build; as_fn_mkdir_p + as_dir=conftest.dir/src/inc2; as_fn_mkdir_p + cat > conftest.$ac_ext <<_ACEOF + program main +#include "conftest.inc" + + end +_ACEOF + cp conftest.$ac_ext conftest.dir/build/conftest.$ac_ext + mv conftest.$ac_ext conftest.dir/src/conftest.$ac_ext + cat > conftest.$ac_ext <<_ACEOF +#include "conftest.write" + +_ACEOF + mv conftest.$ac_ext conftest.dir/src/inc2/conftest.inc + set "src" "/src/" "flg" "/src/inc/" "inc" "/src/inc2/" "cwd" "/build/" + while test $# != 0; do + cat > conftest.$ac_ext <<_ACEOF + write(*,"(a)") "${1}" +_ACEOF + shift; mv conftest.$ac_ext conftest.dir${1}conftest.write; shift + done + cd conftest.dir/build + acx_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS ${acx_cv_fc_pp_include_flag}../src/inc ${acx_cv_fc_pp_include_flag}../src/inc2" + acx_save_ac_link=$ac_link + ac_link=`$as_echo "$ac_link" | sed 's%conftest\.\$ac_ext%../src/&%'` + while :; do + if ac_fn_fc_try_link "$LINENO"; then : + acx_exec_result=`./conftest$ac_exeext` + if test $? -eq 0; then : + case $acx_exec_result in #( + src) : + rm -f ../src/conftest.write ;; #( + inc) : + rm -f ../src/inc2/conftest.write ;; #( + cwd) : + rm -f ./conftest.write ;; #( + flg) : + rm -f ../src/inc/conftest.write ../src/inc2/conftest.write ;; #( + *) : + break ;; +esac + if test -z "$acx_cv_fc_pp_include_order"; then : + acx_cv_fc_pp_include_order=$acx_exec_result +else + as_fn_append acx_cv_fc_pp_include_order ",$acx_exec_result" +fi + rm -f conftest$ac_exeext +else + break +fi +else + break +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + done + ac_link=$acx_save_ac_link + FCFLAGS=$acx_save_FCFLAGS + cd ../.. + rm -rf conftest.dir +fi + if test -z "$acx_cv_fc_pp_include_order"; then : + acx_cv_fc_pp_include_order=unknown +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_pp_include_order" >&5 +$as_echo "$acx_cv_fc_pp_include_order" >&6; } + if test "x$acx_cv_fc_pp_include_order" = xunknown; then : + FCINCORDER_PP='inc,flg' + +else + FCINCORDER_PP="$acx_cv_fc_pp_include_order" + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler flag needed to define a preprocessor macro" >&5 +$as_echo_n "checking for Fortran compiler flag needed to define a preprocessor macro... " >&6; } +if ${acx_cv_fc_macro_flag+:} false; then : + $as_echo_n "(cached) " >&6 +else + acx_cv_fc_macro_flag=unknown + cat > conftest.$ac_ext <<_ACEOF + program main +#ifndef CONFTEST_ONE + choke me +#endif +#if CONFTEST_TWO != 42 + choke me +#endif + end +_ACEOF + acx_save_FCFLAGS=$FCFLAGS + for acx_lang_macro_flag in -D; do + FCFLAGS="${acx_save_FCFLAGS} ${acx_lang_macro_flag}CONFTEST_ONE ${acx_lang_macro_flag}CONFTEST_TWO=42" + if ac_fn_fc_try_compile "$LINENO"; then : + acx_cv_fc_macro_flag=$acx_lang_macro_flag +fi +rm -f core conftest.err conftest.$ac_objext + test "x$acx_cv_fc_macro_flag" != xunknown && break + done + rm -f conftest.$ac_ext + FCFLAGS=$acx_save_FCFLAGS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_macro_flag" >&5 +$as_echo "$acx_cv_fc_macro_flag" >&6; } + if test "x$acx_cv_fc_macro_flag" = xunknown; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to detect Fortran compiler flag needed to define a preprocessor macro +See \`config.log' for more details" "$LINENO" 5; } +else + FCDEF_PP="$acx_cv_fc_macro_flag" + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for endianness of the target system" >&5 +$as_echo_n "checking for endianness of the target system... " >&6; } + if ${acx_cv_fc_endianness_real+:} false; then : + $as_echo_n "(cached) " >&6 +else + acx_cv_fc_endianness_real=unknown + free_fmt=' + real(dp) :: b(2) = (/11436526043186408342932917319490312838905855& + &2118841611962449784525241959417255606719874468829884522246508686& + &0799336906947500199989578974774280030598291952243399484779227378& + &5162269613202128034599963034475950452228997847642131801671155898& + &01738240.0_dp,0.0_dp/)' + fixed_fmt=' + real(dp) :: b(2) = (/11436526043186408342932917319490312838905855 + + 2118841611962449784525241959417255606719874468829884522246508686 + + 0799336906947500199989578974774280030598291952243399484779227378 + + 5162269613202128034599963034475950452228997847642131801671155898 + + 01738240.0_dp,0.0_dp/)' + for acx_tmp in "$free_fmt" "$fixed_fmt"; do + cat > conftest.$ac_ext <<_ACEOF + subroutine conftest(i, a) + implicit none + integer, parameter :: dp = SELECTED_REAL_KIND(13,300) + integer :: i + real(dp) :: a +$acx_tmp + a = b(i) + end subroutine +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + for acx_tmp in mkhElper replEhkm lpermkhE; do + if grep "$acx_tmp" conftest.$ac_objext >/dev/null; then : + if test "x$acx_cv_fc_endianness_real" = xunknown; then : + acx_cv_fc_endianness_real=$acx_tmp +else + acx_cv_fc_endianness_real=unknown + break +fi +fi + done +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + test 0 -eq "$ac_retval" && break + done + +fi + + acx_tmp=unknown + case $acx_cv_fc_endianness_real in #( + mkhElper) : + acx_tmp='little-endian' ;; #( + replEhkm) : + acx_tmp='big-endian' ;; #( + lpermkhE) : + acx_tmp='half little-endian, half big-endian' ;; #( + *) : + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_tmp" >&5 +$as_echo "$acx_tmp" >&6; } + if test "x$acx_tmp" = xunknown; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unable to detect the endianness of the target system" >&5 +$as_echo "$as_me: WARNING: unable to detect the endianness of the target system" >&2;} +else + case $acx_cv_fc_endianness_real in #( + replEhkm) : + ;; #( + mkhElper) : + as_fn_append FCFLAGS " ${acx_cv_fc_macro_flag}__ECRAD_LITTLE_ENDIAN" ;; #( + *) : + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: the endianness of the target system is not supported" >&5 +$as_echo "$as_me: WARNING: the endianness of the target system is not supported" >&2;} ;; +esac +fi + +if test "x$enable_silent_rules" = xyes; then : + DEFAULT_VERBOSITY=0 + +else + DEFAULT_VERBOSITY=1 + +fi + +if test "x$enable_single_precision" = xyes; then : + as_fn_append FCFLAGS " ${acx_cv_fc_macro_flag}SINGLE_PRECISION" +fi + +case $enable_pgi_inlib in #( + auto) : + if test "x$acx_cv_fc_compiler_vendor" = xportland; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: PGI cross-file function inlining via an inline library is enabled because $FC is recognized as the PGI compiler: disable the inlining if required (--disable-pgi-inlib)" >&5 +$as_echo "$as_me: PGI cross-file function inlining via an inline library is enabled because $FC is recognized as the PGI compiler: disable the inlining if required (--disable-pgi-inlib)" >&6;} + enable_pgi_inlib=yes +else + enable_pgi_inlib=no +fi ;; #( + yes) : + if test x"$acx_cv_fc_compiler_vendor" != xportland; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: PGI cross-file function inlining via an inline library is enabled but $FC is not recognized as the PGI compiler: it is strongly recommended to disable the compiler-specific feature (--disable-pgi-inlib)" >&5 +$as_echo "$as_me: WARNING: PGI cross-file function inlining via an inline library is enabled but $FC is not recognized as the PGI compiler: it is strongly recommended to disable the compiler-specific feature (--disable-pgi-inlib)" >&2;} +fi ;; #( + *) : + ;; +esac + +if test "x$enable_pgi_inlib" = xyes; then : + DEFAULT_INLIB=1 + +else + DEFAULT_INLIB=0 + +fi + + +# Check whether --with-netcdf-root was given. +if test "${with_netcdf_root+set}" = set; then : + withval=$with_netcdf_root; +fi + + +# Check whether --with-netcdf-include was given. +if test "${with_netcdf_include+set}" = set; then : + withval=$with_netcdf_include; +else + if ${with_netcdf_root+:} false; then : + with_netcdf_include="${with_netcdf_root}/include" +fi +fi + + + if ${with_netcdf_include+:} false; then : + for acx_flag in "$FCMODINC"; do + case " "$acx_fc_NetCDF_inc_search_args" " in #( + *" ""${acx_flag}${with_netcdf_include}"" "*) : + ;; #( + " "" ") : + as_fn_append acx_fc_NetCDF_inc_search_args "${acx_flag}${with_netcdf_include}" ;; #( + *) : + as_fn_append acx_fc_NetCDF_inc_search_args " "; as_fn_append acx_fc_NetCDF_inc_search_args "${acx_flag}${with_netcdf_include}" ;; +esac + done +fi + + +# Check whether --with-netcdf-lib was given. +if test "${with_netcdf_lib+set}" = set; then : + withval=$with_netcdf_lib; +else + if ${with_netcdf_root+:} false; then : + with_netcdf_lib="${with_netcdf_root}/lib" +fi +fi + + + if ${with_netcdf_lib+:} false; then : + for acx_flag in -L; do + case " "$acx_fc_NetCDF_lib_search_args" " in #( + *" ""${acx_flag}${with_netcdf_lib}"" "*) : + ;; #( + " "" ") : + as_fn_append acx_fc_NetCDF_lib_search_args "${acx_flag}${with_netcdf_lib}" ;; #( + *) : + as_fn_append acx_fc_NetCDF_lib_search_args " "; as_fn_append acx_fc_NetCDF_lib_search_args "${acx_flag}${with_netcdf_lib}" ;; +esac + done +fi + + +DEPGEN_EXTERNAL_MODS=netcdf + + +acx_save_FCFLAGS=$FCFLAGS +NETCDF_FCFLAGS=${NETCDF_FCFLAGS-$acx_fc_NetCDF_inc_search_args} +FCFLAGS="$NETCDF_FCFLAGS $acx_save_FCFLAGS" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran module NETCDF" >&5 +$as_echo_n "checking for Fortran module NETCDF... " >&6; } +if ${acx_cv_fc_module_NETCDF+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat > conftest.$ac_ext <<_ACEOF + program main + use netcdf + end +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + acx_cv_fc_module_NETCDF=yes +else + acx_cv_fc_module_NETCDF=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_fc_module_NETCDF" >&5 +$as_echo "$acx_cv_fc_module_NETCDF" >&6; } + if test "x$acx_cv_fc_module_NETCDF" = xyes; then : + acx_fc_lib_search=NF90_OPEN + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for linker flags enabling Fortran function $acx_fc_lib_search" >&5 +$as_echo_n "checking for linker flags enabling Fortran function $acx_fc_lib_search... " >&6; } + if { as_var=acx_cv_fc_lib_func_`$as_echo "$acx_fc_lib_search" | $as_tr_sh`; eval \${$as_var+:} false; }; then : + $as_echo_n "(cached) " >&6 +else + cat > conftest.$ac_ext <<_ACEOF + program main + use netcdf, only: nf90_open, NF90_NOWRITE + implicit none + integer :: status, ncid + status = nf90_open('conftest.nc', NF90_NOWRITE, ncid) + end +_ACEOF + acx_save_LIBS=$LIBS + if ${NETCDF_FCLIBS+:} false; then : + set dummy "$NETCDF_FCLIBS" +else + set dummy '' "$acx_fc_NetCDF_lib_search_args -lnetcdff" "$acx_fc_NetCDF_lib_search_args -lnetcdff -lnetcdf" +fi + shift + for acx_libs in "$@"; do + LIBS="$acx_libs $acx_save_LIBS" + if ac_fn_fc_try_link "$LINENO"; then : + eval acx_cv_fc_lib_func_`$as_echo "$acx_fc_lib_search" | $as_tr_sh`=\$acx_libs +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + if { as_var=acx_cv_fc_lib_func_`$as_echo "$acx_fc_lib_search" | $as_tr_sh`; eval \${$as_var+:} false; }; then : + break +fi + done + rm -f conftest.$ac_ext + LIBS=$acx_save_LIBS +fi + + if { as_var=acx_cv_fc_lib_func_`$as_echo "$acx_fc_lib_search" | $as_tr_sh`; eval \${$as_var+:} false; }; then : + if test -n "`eval 'as_val=${'acx_cv_fc_lib_func_\`$as_echo "$acx_fc_lib_search" | $as_tr_sh\`'};$as_echo "$as_val"'`"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: `eval 'as_val=${'acx_cv_fc_lib_func_\`$as_echo "$acx_fc_lib_search" | $as_tr_sh\`'};$as_echo "$as_val"'`" >&5 +$as_echo "`eval 'as_val=${'acx_cv_fc_lib_func_\`$as_echo "$acx_fc_lib_search" | $as_tr_sh\`'};$as_echo "$as_val"'`" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } +fi + NETCDF_FCLIBS=$acx_cv_fc_lib_func_NF90_OPEN + acx_have_netcdf=yes +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unknown" >&5 +$as_echo "unknown" >&6; } + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to find linker flags enabling Fortran function $acx_fc_lib_search +See \`config.log' for more details" "$LINENO" 5; } +fi + +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "Fortran module 'NETCDF' is not available +See \`config.log' for more details" "$LINENO" 5; } +fi + +FCFLAGS=$acx_save_FCFLAGS + + + +ARFLAGS=${ARFLAGS-cr} + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ar" >&5 +$as_echo_n "checking for ar... " >&6; } + if ${acx_cv_prog_AR+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ${AR+:} false; then : + set dummy "$AR" +else + set dummy ar +fi + shift + for acx_candidate in "$@"; do + cat > conftest.$ac_ext <<_ACEOF + program main + + end +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + acx_ar_try="$acx_candidate ${ARFLAGS} libconftest.a conftest.$ac_objext >&5" + { { ac_try="$acx_ar_try" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$acx_ar_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + rm -f libconftest.a +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + test "$ac_status" -eq 0 >/dev/null 2>&1 + if test $? -eq 0; then : + acx_cv_prog_AR=$acx_candidate + break +fi + done +fi + + if ${acx_cv_prog_AR+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_prog_AR" >&5 +$as_echo "$acx_cv_prog_AR" >&6; } + AR=$acx_cv_prog_AR +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unknown" >&5 +$as_echo "unknown" >&6; } + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to find ar +See \`config.log' for more details" "$LINENO" 5; } +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for python" >&5 +$as_echo_n "checking for python... " >&6; } + if ${acx_cv_prog_PYTHON+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ${PYTHON+:} false; then : + set dummy "$PYTHON" +else + set dummy python python3 +fi + shift + for acx_candidate in "$@"; do + acx_python_try="$acx_candidate $srcdir/mkhelper/depgen.py -h >&5" + { { ac_try="$acx_python_try" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$acx_python_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if test $? -eq 0; then : + acx_cv_prog_PYTHON=$acx_candidate + break +fi + done +fi + + if ${acx_cv_prog_PYTHON+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $acx_cv_prog_PYTHON" >&5 +$as_echo "$acx_cv_prog_PYTHON" >&6; } + PYTHON=$acx_cv_prog_PYTHON +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unknown" >&5 +$as_echo "unknown" >&6; } + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "unable to find python +See \`config.log' for more details" "$LINENO" 5; } +fi + + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AmigaOS /C/install, which installs bootblocks on floppy discs +# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# OS/2's system install, which has a completely different semantic +# ./install, which can be erroneously created by make from ./install.sh. +# Reject install programs that cannot install multiple files. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 +$as_echo_n "checking for a BSD-compatible install... " >&6; } +if test -z "$INSTALL"; then +if ${ac_cv_path_install+:} false; then : + $as_echo_n "(cached) " >&6 +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + # Account for people who put trailing slashes in PATH elements. +case $as_dir/ in #(( + ./ | .// | /[cC]/* | \ + /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ + ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ + /usr/ucb/* ) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + # Don't use installbsd from OSF since it installs stuff as root + # by default. + for ac_prog in ginstall scoinst install; do + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then + if test $ac_prog = install && + grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + : + elif test $ac_prog = install && + grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # program-specific install script used by HP pwplus--don't use. + : + else + rm -rf conftest.one conftest.two conftest.dir + echo one > conftest.one + echo two > conftest.two + mkdir conftest.dir + if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && + test -s conftest.one && test -s conftest.two && + test -s conftest.dir/conftest.one && + test -s conftest.dir/conftest.two + then + ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" + break 3 + fi + fi + fi + done + done + ;; +esac + + done +IFS=$as_save_IFS + +rm -rf conftest.one conftest.two conftest.dir + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL=$ac_cv_path_install + else + # As a last resort, use the slow shell script. Don't cache a + # value for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the value is a relative name. + INSTALL=$ac_install_sh + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 +$as_echo "$INSTALL" >&6; } + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a thread-safe mkdir -p" >&5 +$as_echo_n "checking for a thread-safe mkdir -p... " >&6; } +if test -z "$MKDIR_P"; then + if ${ac_cv_path_mkdir+:} false; then : + $as_echo_n "(cached) " >&6 +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in mkdir gmkdir; do + for ac_exec_ext in '' $ac_executable_extensions; do + as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext" || continue + case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( + 'mkdir (GNU coreutils) '* | \ + 'mkdir (coreutils) '* | \ + 'mkdir (fileutils) '4.1*) + ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext + break 3;; + esac + done + done + done +IFS=$as_save_IFS + +fi + + test -d ./--version && rmdir ./--version + if test "${ac_cv_path_mkdir+set}" = set; then + MKDIR_P="$ac_cv_path_mkdir -p" + else + # As a last resort, use the slow shell script. Don't cache a + # value for MKDIR_P within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the value is a relative name. + MKDIR_P="$ac_install_sh -d" + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 +$as_echo "$MKDIR_P" >&6; } + + +ac_config_files="$ac_config_files Makefile" + + +ac_config_commands="$ac_config_commands depfiles" + + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +# +# If the first sed substitution is executed (which looks for macros that +# take arguments), then branch to the quote section. Otherwise, +# look for a macro that doesn't take arguments. +ac_script=' +:mline +/\\$/{ + N + s,\\\n,, + b mline +} +t clear +:clear +s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g +t quote +s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g +t quote +b any +:quote +s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g +s/\[/\\&/g +s/\]/\\&/g +s/\$/$$/g +H +:any +${ + g + s/^\n// + s/\n/ /g + p +} +' +DEFS=`sed -n "$ac_script" confdefs.h` + + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by ecrad $as_me 1.1.0, which was +generated by GNU Autoconf 2.69. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" +config_commands="$ac_config_commands" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + +Configuration files: +$config_files + +Configuration commands: +$config_commands + +Report bugs to the package provider. +ecrad home page: ." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +ecrad config.status 1.1.0 +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2012 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +INSTALL='$INSTALL' +MKDIR_P='$MKDIR_P' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h | --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; + "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + + +eval set X " :F $CONFIG_FILES :C $CONFIG_COMMANDS" +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + + case $INSTALL in + [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; + *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; + esac + ac_MKDIR_P=$MKDIR_P + case $MKDIR_P in + [\\/$]* | ?:[\\/]* ) ;; + */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; + esac +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +s&@INSTALL@&$ac_INSTALL&;t t +s&@MKDIR_P@&$ac_MKDIR_P&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + + + :C) { $as_echo "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5 +$as_echo "$as_me: executing $ac_file commands" >&6;} + ;; + esac + + + case $ac_file$ac_mode in + "depfiles":C) ${MAKE-make} dummy-depend >/dev/null 2>&5 + sleep 1 + touch Makefile ;; + + esac +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/configure.ac =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/configure.ac (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/configure.ac (revision 6016) @@ -0,0 +1,151 @@ +AC_PREREQ([2.69]) +AC_INIT([ecrad], [1.1.0], [], [], + [https://confluence.ecmwf.int/display/ECRAD]) +AC_CONFIG_MACRO_DIR([m4]) +m4_pattern_forbid([^A[SC]X_])dnl +AC_CONFIG_AUX_DIR([config]) +AC_CONFIG_SRCDIR([radiation/radiation_flux.F90]) + +AC_ARG_ENABLE([silent-rules], + [AC_HELP_STRING([--enable-silent-rules], + [less verbose build output (undo: "make V=1") @<:@default=yes@:>@])], + [AS_IF([test x"$enableval" != xno], [enable_silent_rules=yes])], + [enable_silent_rules=yes]) + +AC_ARG_ENABLE([single-precision], + [AC_HELP_STRING([--enable-single-precision], + [switch to single precision @<:@default=no@:>@])], + [AS_IF([test x"$enableval" != xno], [enable_single_precision=yes])], + [enable_single_precision=no]) + +AC_ARG_ENABLE([pgi-inlib], + [AC_HELP_STRING([--enable-pgi-inlib], + [enable PGI cross-file function inlining via an inline library (undo: +"make INLIB=0") @<:@default=auto@:>@])], + [AS_IF([test x"$enableval" != xno && test x"$enableval" != xauto], + [enable_pgi_inlib=yes])], + [enable_pgi_inlib=auto]) + +AC_PROG_FC +AC_LANG([Fortran]) +ACX_FC_PP_SRCEXT([F90]) +ACX_COMPILER_FC_VENDOR_SIMPLE +AC_SUBST([FC_VENDOR], [$acx_cv_fc_compiler_vendor]) + +ACX_FC_LINE_LENGTH([unlimited]) + +ACX_FC_MODULE_NAMING( + [AC_SUBST([FCMODEXT], ["$acx_cv_fc_module_naming_ext"]) + AC_SUBST([FCMODUC], ["$acx_cv_fc_module_naming_upper"])]) + +ACX_FC_MODULE_IN_FLAG([AC_SUBST([FCMODINC], ["$acx_cv_fc_module_in_flag"])]) +ACX_FC_MODULE_OUT_FLAG([AC_SUBST([FCMODOUT], ["$acx_cv_fc_module_out_flag"])]) + +ACX_FC_INCLUDE_FLAG([AC_SUBST([FCINCFLAG], ["$acx_cv_fc_ftn_include_flag"])]) +ACX_FC_INCLUDE_ORDER( + [AC_SUBST([FCINCORDER], ["$acx_cv_fc_ftn_include_order"])], + [AC_SUBST([FCINCORDER], ['src,flg'])]) + +ACX_FC_INCLUDE_FLAG_PP( + [AC_SUBST([FCINCFLAG_PP], ["$acx_cv_fc_pp_include_flag"])]) +ACX_FC_INCLUDE_ORDER_PP( + [AC_SUBST([FCINCORDER_PP], ["$acx_cv_fc_pp_include_order"])], + [AC_SUBST([FCINCORDER_PP], ['inc,flg'])]) + +ACX_LANG_MACRO_FLAG([AC_SUBST([FCDEF_PP], ["$acx_cv_fc_macro_flag"])]) + +ACX_FC_ENDIANNESS_REAL( +dnl Kind of the double-precision real variables that are read from the binary +dnl files (JPRD from ifsaux/parkind1.F90): + [SELECTED_REAL_KIND(13,300)], + [AS_CASE([$acx_cv_fc_endianness_real], +dnl Big-endian: + [replEhkm], [], +dnl Little-endian: + [mkhElper], + [AS_VAR_APPEND([FCFLAGS], + [" ${acx_cv_fc_macro_flag}__ECRAD_LITTLE_ENDIAN"])], +dnl Unsupported mixed-endian: + [AC_MSG_WARN([the endianness of the target system is not supported])])], + [AC_MSG_WARN([unable to detect the endianness of the target system])]) + +AS_VAR_IF([enable_silent_rules], [yes], + [AC_SUBST([DEFAULT_VERBOSITY], [0])], + [AC_SUBST([DEFAULT_VERBOSITY], [1])]) + +AS_VAR_IF([enable_single_precision], [yes], + [AS_VAR_APPEND([FCFLAGS], [" ${acx_cv_fc_macro_flag}SINGLE_PRECISION"])]) + +AS_CASE([$enable_pgi_inlib], + [auto], + [AS_VAR_IF([acx_cv_fc_compiler_vendor], [portland], + [AC_MSG_NOTICE([PGI cross-file function inlining via an inline library dnl +is enabled because $FC is recognized as the PGI compiler: disable the dnl +inlining if required (--disable-pgi-inlib)]) + enable_pgi_inlib=yes], + [enable_pgi_inlib=no])], + [yes], + [AS_IF([test x"$acx_cv_fc_compiler_vendor" != xportland], + [AC_MSG_WARN([PGI cross-file function inlining via an inline library is dnl +enabled but $FC is not recognized as the PGI compiler: it is strongly dnl +recommended to disable the compiler-specific feature dnl +(--disable-pgi-inlib)])])]) + +AS_VAR_IF([enable_pgi_inlib], [yes], + [AC_SUBST([DEFAULT_INLIB], [1])], + [AC_SUBST([DEFAULT_INLIB], [0])]) + +ACX_LANG_PACKAGE_INIT([NetCDF], ["$FCMODINC"], [-L]) +AC_SUBST([DEPGEN_EXTERNAL_MODS], [netcdf]) + +dnl Check for NetCDF +acx_save_FCFLAGS=$FCFLAGS +NETCDF_FCFLAGS=${NETCDF_FCFLAGS-$acx_fc_NetCDF_inc_search_args} +FCFLAGS="$NETCDF_FCFLAGS $acx_save_FCFLAGS" +ACX_FC_MODULE_CHECK([netcdf], + [ACX_LANG_LIB_SEARCH([NETCDF_FCLIBS], [nf90_open], + [ASX_PREPEND_LDFLAGS([$acx_fc_NetCDF_lib_search_args], + [-lnetcdff], [-lnetcdff -lnetcdf])], + [NETCDF_FCLIBS=$acx_cv_fc_lib_func_NF90_OPEN + acx_have_netcdf=yes], [], + [AC_LANG_PROGRAM([], +[[ use netcdf, only: nf90_open, NF90_NOWRITE + implicit none + integer :: status, ncid + status = nf90_open('conftest.nc', NF90_NOWRITE, ncid)]])])], []) +FCFLAGS=$acx_save_FCFLAGS + +dnl Check for AR and ARFLAGS +AC_ARG_VAR([AR], [archiver command]) +AC_ARG_VAR([ARFLAGS], [archiver flags]) +ARFLAGS=${ARFLAGS-cr} +ACX_PROG_SEARCH([AR], [ar], + [AC_COMPILE_IFELSE([AC_LANG_PROGRAM], + [acx_ar_try="$acx_candidate ${ARFLAGS} libconftest.a dnl +conftest.$ac_objext >&AS_MESSAGE_LOG_FD" + _AC_DO_VAR([acx_ar_try]) + rm -f libconftest.a]) + test "$ac_status" -eq 0 >/dev/null 2>&1], + [AR=$acx_cv_prog_AR]) + +dnl Check for PYTHON +AC_ARG_VAR([PYTHON], [Python interpreter command])dnl +ACX_PROG_SEARCH([PYTHON], [python python3], + [acx_python_try="$acx_candidate $srcdir/mkhelper/depgen.py -h dnl +>&AS_MESSAGE_LOG_FD" + _AC_DO_VAR([acx_python_try])], + [PYTHON=$acx_cv_prog_PYTHON]) + +AC_PROG_INSTALL +AC_PROG_MKDIR_P + +AC_CONFIG_FILES([Makefile]) + +dnl An additional step to generate dummy dependencies: +AC_CONFIG_COMMANDS([depfiles], + [${MAKE-make} dummy-depend >/dev/null 2>&AS_MESSAGE_LOG_FD + sleep 1 + touch Makefile]) + +AC_OUTPUT + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/drhook/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/drhook/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/drhook/Makefile (revision 6016) @@ -0,0 +1,18 @@ +LIBDRHOOK = ../lib/libdrhook.a + +all: dummy + +# Dummy version of Dr Hook creates the YOMHOOK module but the DR_HOOK +# routine does nothing +dummy: $(LIBDRHOOK) + +$(LIBDRHOOK): yomhook_dummy.o + ar -r $(LIBDRHOOK) yomhook_dummy.o + +%.o: %.F90 + $(FC) $(FCFLAGS) -c $< -o $@ + +clean: + rm -f *.o $(LIBDRHOOK) + +.PHONY: dummy Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/drhook/yomhook_dummy.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/drhook/yomhook_dummy.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/drhook/yomhook_dummy.F90 (revision 6016) @@ -0,0 +1,34 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! DR_HOOK is a profiling and debugging system for the IFS, and should +! be called at the beginning and end of each subroutine. This is a +! dummy implementation for offline packages. + +module yomhook + + public + + save + + integer, parameter :: jphook = selected_real_kind(13,300) + logical :: lhook = .false. + +contains + + subroutine dr_hook(proc_name, iswitch, proc_key) + + character(len=*), intent(in) :: proc_name + integer, intent(in) :: iswitch + real(jphook), intent(inout) :: proc_key + ! Do nothing! + + end subroutine dr_hook + +end module yomhook Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/Makefile (revision 6016) @@ -0,0 +1,53 @@ +TEST_PROGRAMS = test_cloud_generator test_spartacus_math \ + test_aerosol_optics_description test_random_number_generator \ + test_fast_expm + +# In dependency order: +SOURCES = ecrad_driver_read_input.F90 \ + ecrad_driver_config.F90 + +OBJECTS := $(SOURCES:.F90=.o) +EXECUTABLE = ../bin/ecrad +IFS_EXECUTABLE = ../bin/ecrad_ifs +IFS_BLOCKED_EXECUTABLE = ../bin/ecrad_ifs_blocked + +all: driver ifs_driver test_programs + +driver: $(EXECUTABLE) + +ifs_driver: $(IFS_EXECUTABLE) $(IFS_BLOCKED_EXECUTABLE) + +test_programs: $(TEST_PROGRAMS) + +# Link ecrad executable; add "-lifs" if you want to use the "satur" +# routine in ecrad_driver.F90 +$(EXECUTABLE): $(OBJECTS) ../lib/*.a ecrad_driver.o + $(FC) $(FCFLAGS) ecrad_driver.o $(OBJECTS) $(LIBS) -o $(EXECUTABLE) + +$(IFS_EXECUTABLE): $(OBJECTS) ../lib/*.a ecrad_ifs_driver.o + $(FC) $(FCFLAGS) ecrad_ifs_driver.o $(OBJECTS) -lifs $(LIBS) -o $(IFS_EXECUTABLE) + +$(IFS_BLOCKED_EXECUTABLE): $(OBJECTS) ../lib/*.a ecrad_ifs_driver_blocked.o + $(FC) $(FCFLAGS) ifs_blocking.o ecrad_ifs_driver_blocked.o $(OBJECTS) -lifs $(LIBS) -o $(IFS_BLOCKED_EXECUTABLE) + +test_%: test_%.F90 ../lib/*.a + $(FC) $(FCFLAGS) $< $(LIBS) -o $@ + +#$(TEST): $(TEST).F90 ../lib/*.a +# $(FC) $(FCFLAGS) $(TEST).F90 $(LIBS) -o $(TEST) + +# Note that the dependence on mod files can mean that rerunning "make" +# recreates the executable +%.o: %.F90 ../lib/*.a + $(FC) $(FCFLAGS) -c $< + +clean: + rm -f *.o $(EXECUTABLE) $(IFS_EXECUTABLE) $(IFS_BLOCKED_EXECUTABLE) \ + $(TEST_PROGRAMS) + +ecrad_driver.o: ecrad_driver_config.o ecrad_driver_read_input.o +ecrad_ifs_driver.o: ecrad_driver_config.o ecrad_driver_read_input.o +ecrad_ifs_driver_blocked.o: ecrad_driver_config.o ecrad_driver_read_input.o ifs_blocking.o +ecrad_driver_read_input.o ifs_blocking.o: ecrad_driver_config.o + +.PHONY: driver ifs_driver test_programs all Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver.F90 (revision 6016) @@ -0,0 +1,399 @@ +! ecrad_driver.F90 - Driver for offline ECRAD radiation scheme +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! ECRAD is the radiation scheme used in the ECMWF Integrated +! Forecasting System in cycle 43R3 and later. Several solvers are +! available, including McICA, Tripleclouds and SPARTACUS (the Speedy +! Algorithm for Radiative Transfer through Cloud Sides, a modification +! of the two-stream formulation of shortwave and longwave radiative +! transfer to account for 3D radiative effects). Gas optical +! properties are provided by the RRTM-G gas optics scheme. + +! This program takes three arguments: +! 1) Namelist file to configure the radiation calculation +! 2) Name of a NetCDF file containing one or more atmospheric profiles +! 3) Name of output NetCDF file + +program ecrad_driver + + ! -------------------------------------------------------- + ! Section 1: Declarations + ! -------------------------------------------------------- + use parkind1, only : jprb, jprd ! Working/double precision + + use radiation_io, only : nulout + use radiation_interface, only : setup_radiation, radiation, set_gas_units + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type, & + & IVolumeMixingRatio, IMassMixingRatio, & + & IH2O, ICO2, IO3, IN2O, ICO, ICH4, IO2, ICFC11, ICFC12, & + & IHCFC22, ICCl4, GasName, GasLowerCaseName, NMaxGases + use radiation_cloud, only : cloud_type + use radiation_aerosol, only : aerosol_type + use radiation_flux, only : flux_type + use radiation_save, only : save_fluxes, save_net_fluxes, & + & save_inputs, save_sw_diagnostics + use radiation_general_cloud_optics, only : save_general_cloud_optics + use ecrad_driver_config, only : driver_config_type + use ecrad_driver_read_input, only : read_input + use easy_netcdf + use print_matrix_mod, only : print_matrix + + implicit none + + ! Uncomment this if you want to use the "satur" routine below +!#include "satur.intfb.h" + + ! The NetCDF file containing the input profiles + type(netcdf_file) :: file + + ! Derived types for the inputs to the radiation scheme + type(config_type) :: config + type(single_level_type) :: single_level + type(thermodynamics_type) :: thermodynamics + type(gas_type) :: gas + type(cloud_type) :: cloud + type(aerosol_type) :: aerosol + + ! Configuration specific to this driver + type(driver_config_type) :: driver_config + + ! Derived type containing outputs from the radiation scheme + type(flux_type) :: flux + + integer :: ncol, nlev ! Number of columns and levels + integer :: istartcol, iendcol ! Range of columns to process + + ! Name of file names specified on command line + character(len=512) :: file_name + integer :: istatus ! Result of command_argument_count + + ! For parallel processing of multiple blocks + integer :: jblock, nblock ! Block loop index and number + + ! Mapping matrix for shortwave spectral diagnostics + real(jprb), allocatable :: sw_diag_mapping(:,:) + +#ifndef NO_OPENMP + ! OpenMP functions + integer, external :: omp_get_thread_num + real(kind=jprd), external :: omp_get_wtime + ! Start/stop time in seconds + real(kind=jprd) :: tstart, tstop +#endif + + ! For demonstration of get_sw_weights later on + ! Ultraviolet weightings + !integer :: nweight_uv + !integer :: iband_uv(100) + !real(jprb) :: weight_uv(100) + ! Photosynthetically active radiation weightings + !integer :: nweight_par + !integer :: iband_par(100) + !real(jprb) :: weight_par(100) + + ! Loop index for repeats (for benchmarking) + integer :: jrepeat + + ! Are any variables out of bounds? + logical :: is_out_of_bounds + +! integer :: iband(20), nweights +! real(jprb) :: weight(20) + + + ! -------------------------------------------------------- + ! Section 2: Configure + ! -------------------------------------------------------- + + ! Check program called with correct number of arguments + if (command_argument_count() < 3) then + stop 'Usage: ecrad config.nam input_file.nc output_file.nc' + end if + + ! Use namelist to configure the radiation calculation + call get_command_argument(1, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of namelist file as string of length < 512' + end if + + ! Read "radiation" namelist into radiation configuration type + call config%read(file_name=file_name) + + ! Read "radiation_driver" namelist into radiation driver config type + call driver_config%read(file_name) + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') '-------------------------- OFFLINE ECRAD RADIATION SCHEME --------------------------' + write(nulout,'(a)') 'Copyright (C) 2014- ECMWF' + write(nulout,'(a)') 'Contact: Robin Hogan (r.j.hogan@ecmwf.int)' +#ifdef PARKIND1_SINGLE + write(nulout,'(a)') 'Floating-point precision: single' +#else + write(nulout,'(a)') 'Floating-point precision: double' +#endif + call config%print(driver_config%iverbose) + end if + + ! Albedo/emissivity intervals may be specified like this + !call config%define_sw_albedo_intervals(6, & + ! & [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, & + ! & 1.19_jprb, 2.38e-6_jprb], [1,2,3,4,5,6], & + ! & do_nearest=.false.) + !call config%define_lw_emiss_intervals(3, & + ! & [8.0e-6_jprb, 13.0e-6_jprb], [1,2,1], & + ! & do_nearest=.false.) + + ! If monochromatic aerosol properties are required, then the + ! wavelengths can be specified (in metres) as follows - these can be + ! whatever you like for the general aerosol optics, but must match + ! the monochromatic values in the aerosol input file for the older + ! aerosol optics + !call config%set_aerosol_wavelength_mono( & + ! & [3.4e-07_jprb, 3.55e-07_jprb, 3.8e-07_jprb, 4.0e-07_jprb, 4.4e-07_jprb, & + ! & 4.69e-07_jprb, 5.0e-07_jprb, 5.32e-07_jprb, 5.5e-07_jprb, 6.45e-07_jprb, & + ! & 6.7e-07_jprb, 8.0e-07_jprb, 8.58e-07_jprb, 8.65e-07_jprb, 1.02e-06_jprb, & + ! & 1.064e-06_jprb, 1.24e-06_jprb, 1.64e-06_jprb, 2.13e-06_jprb, 1.0e-05_jprb]) + + ! Setup the radiation scheme: load the coefficients for gas and + ! cloud optics, currently from RRTMG + call setup_radiation(config) + + ! Demonstration of how to get weights for UV and PAR fluxes + !if (config%do_sw) then + ! call config%get_sw_weights(0.2e-6_jprb, 0.4415e-6_jprb,& + ! & nweight_uv, iband_uv, weight_uv,& + ! & 'ultraviolet') + ! call config%get_sw_weights(0.4e-6_jprb, 0.7e-6_jprb,& + ! & nweight_par, iband_par, weight_par,& + ! & 'photosynthetically active radiation, PAR') + !end if + + ! Optionally compute shortwave spectral diagnostics in + ! user-specified wavlength intervals + if (driver_config%n_sw_diag > 0) then + if (.not. config%do_surface_sw_spectral_flux) then + stop 'Error: shortwave spectral diagnostics require do_surface_sw_spectral_flux=true' + end if + call config%get_sw_mapping(driver_config%sw_diag_wavelength_bound(1:driver_config%n_sw_diag+1), & + & sw_diag_mapping, 'user-specified diagnostic intervals') + !if (driver_config%iverbose >= 3) then + ! call print_matrix(sw_diag_mapping, 'Shortwave diagnostic mapping', nulout) + !end if + end if + + if (driver_config%do_save_aerosol_optics) then + call config%aerosol_optics%save('aerosol_optics.nc', iverbose=driver_config%iverbose) + end if + + if (driver_config%do_save_cloud_optics .and. config%use_general_cloud_optics) then + call save_general_cloud_optics(config, 'hydrometeor_optics', iverbose=driver_config%iverbose) + end if + + ! -------------------------------------------------------- + ! Section 3: Read input data file + ! -------------------------------------------------------- + + ! Get NetCDF input file name + call get_command_argument(2, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of input NetCDF file as string of length < 512' + end if + + ! Open the file and configure the way it is read + call file%open(trim(file_name), iverbose=driver_config%iverbose) + + ! Get NetCDF output file name + call get_command_argument(3, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of output NetCDF file as string of length < 512' + end if + + ! 2D arrays are assumed to be stored in the file with height varying + ! more rapidly than column index. Specifying "true" here transposes + ! all 2D arrays so that the column index varies fastest within the + ! program. + call file%transpose_matrices(.true.) + + ! Read input variables from NetCDF file + call read_input(file, config, driver_config, ncol, nlev, & + & single_level, thermodynamics, & + & gas, cloud, aerosol) + + ! Close input file + call file%close() + + ! Compute seed from skin temperature residual + ! single_level%iseed = int(1.0e9*(single_level%skin_temperature & + ! & -int(single_level%skin_temperature))) + + ! Set first and last columns to process + if (driver_config%iendcol < 1 .or. driver_config%iendcol > ncol) then + driver_config%iendcol = ncol + end if + + if (driver_config%istartcol > driver_config%iendcol) then + write(nulout,'(a,i0,a,i0,a,i0,a)') '*** Error: requested column range (', & + & driver_config%istartcol, & + & ' to ', driver_config%iendcol, ') is out of the range in the data (1 to ', & + & ncol, ')' + stop 1 + end if + + ! Store inputs + if (driver_config%do_save_inputs) then + call save_inputs('inputs.nc', config, single_level, thermodynamics, & + & gas, cloud, aerosol, & + & lat=spread(0.0_jprb,1,ncol), & + & lon=spread(0.0_jprb,1,ncol), & + & iverbose=driver_config%iverbose) + end if + + ! -------------------------------------------------------- + ! Section 4: Call radiation scheme + ! -------------------------------------------------------- + + ! Ensure the units of the gas mixing ratios are what is required + ! by the gas absorption model + call set_gas_units(config, gas) + + ! Compute saturation with respect to liquid (needed for aerosol + ! hydration) call... + call thermodynamics%calc_saturation_wrt_liquid(driver_config%istartcol,driver_config%iendcol) + + ! ...or alternatively use the "satur" function in the IFS (requires + ! adding -lifs to the linker command line) but note that this + ! computes saturation with respect to ice at colder temperatures, + ! which is almost certainly incorrect + !allocate(thermodynamics%h2o_sat_liq(ncol,nlev)) + !call satur(driver_config%istartcol, driver_config%iendcol, ncol, 1, nlev, .false., & + ! 0.5_jprb * (thermodynamics.pressure_hl(:,1:nlev)+thermodynamics.pressure_hl(:,2:nlev)), & + ! 0.5_jprb * (thermodynamics.temperature_hl(:,1:nlev)+thermodynamics.temperature_hl(:,2:nlev)), & + ! thermodynamics%h2o_sat_liq, 2) + + ! Check inputs are within physical bounds, printing message if not + is_out_of_bounds = gas%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. single_level%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. thermodynamics%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. cloud%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. aerosol%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) + + ! Allocate memory for the flux profiles, which may include arrays + ! of dimension n_bands_sw/n_bands_lw, so must be called after + ! setup_radiation + call flux%allocate(config, 1, ncol, nlev) + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') 'Performing radiative transfer calculations' + end if + + ! Option of repeating calculation multiple time for more accurate + ! profiling +#ifndef NO_OPENMP + tstart = omp_get_wtime() +#endif + do jrepeat = 1,driver_config%nrepeat + + if (driver_config%do_parallel) then + ! Run radiation scheme over blocks of columns in parallel + + ! Compute number of blocks to process + nblock = (driver_config%iendcol - driver_config%istartcol & + & + driver_config%nblocksize) / driver_config%nblocksize + + !$OMP PARALLEL DO PRIVATE(istartcol, iendcol) SCHEDULE(RUNTIME) + do jblock = 1, nblock + ! Specify the range of columns to process. + istartcol = (jblock-1) * driver_config%nblocksize & + & + driver_config%istartcol + iendcol = min(istartcol + driver_config%nblocksize - 1, & + & driver_config%iendcol) + + if (driver_config%iverbose >= 3) then +#ifndef NO_OPENMP + write(nulout,'(a,i0,a,i0,a,i0)') 'Thread ', omp_get_thread_num(), & + & ' processing columns ', istartcol, '-', iendcol +#else + write(nulout,'(a,i0,a,i0)') 'Processing columns ', istartcol, '-', iendcol +#endif + end if + + ! Call the ECRAD radiation scheme + call radiation(ncol, nlev, istartcol, iendcol, config, & + & single_level, thermodynamics, gas, cloud, aerosol, flux) + + end do + !$OMP END PARALLEL DO + + else + ! Run radiation scheme serially + if (driver_config%iverbose >= 3) then + write(nulout,'(a,i0,a)') 'Processing ', ncol, ' columns' + end if + + ! Call the ECRAD radiation scheme + call radiation(ncol, nlev, driver_config%istartcol, driver_config%iendcol, & + & config, single_level, thermodynamics, gas, cloud, aerosol, flux) + + end if + + end do + +#ifndef NO_OPENMP + tstop = omp_get_wtime() + write(nulout, '(a,g12.5,a)') 'Time elapsed in radiative transfer: ', tstop-tstart, ' seconds' +#endif + + ! -------------------------------------------------------- + ! Section 5: Check and save output + ! -------------------------------------------------------- + + is_out_of_bounds = flux%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol) + + ! Store the fluxes in the output file + if (.not. driver_config%do_save_net_fluxes) then + call save_fluxes(file_name, config, thermodynamics, flux, & + & iverbose=driver_config%iverbose, is_hdf5_file=driver_config%do_write_hdf5, & + & experiment_name=driver_config%experiment_name, & + & is_double_precision=driver_config%do_write_double_precision) + else + call save_net_fluxes(file_name, config, thermodynamics, flux, & + & iverbose=driver_config%iverbose, is_hdf5_file=driver_config%do_write_hdf5, & + & experiment_name=driver_config%experiment_name, & + & is_double_precision=driver_config%do_write_double_precision) + end if + + if (driver_config%n_sw_diag > 0) then + ! Store spectral fluxes in user-defined intervals in a second + ! output file + call save_sw_diagnostics(driver_config%sw_diag_file_name, config, & + & driver_config%sw_diag_wavelength_bound(1:driver_config%n_sw_diag+1), & + & sw_diag_mapping, flux, iverbose=driver_config%iverbose, & + & is_hdf5_file=driver_config%do_write_hdf5, & + & experiment_name=driver_config%experiment_name, & + & is_double_precision=driver_config%do_write_double_precision) + end if + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') '------------------------------------------------------------------------------------' + end if + +end program ecrad_driver Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver_config.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver_config.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver_config.F90 (revision 6016) @@ -0,0 +1,411 @@ +! ecrad_driver_config.F90 - Configure driver for offline ecRad radiation scheme +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int + +module ecrad_driver_config + + use parkind1, only : jprb + + implicit none + + public + + ! Max length of "experiment" global attribute + integer, parameter :: NMaxStringLength = 2000 + + ! Maximum number of spectral diagnostics + integer, parameter :: NMaxSpectralDiag = 256 + + type driver_config_type + + ! Parallel settings + logical :: do_parallel + integer :: nblocksize ! Number of columns processed at once + + ! Override values from the radiation_override namelist (mostly + ! related to clouds): these will override any values in the + ! NetCDF data file (or scale them) + real(jprb) :: fractional_std_override + real(jprb) :: overlap_decorr_length_override + real(jprb) :: high_inv_effective_size_override = -1.0_jprb ! m-1 + real(jprb) :: middle_inv_effective_size_override = -1.0_jprb ! m-1 + real(jprb) :: low_inv_effective_size_override = -1.0_jprb ! m-1 + real(jprb) :: effective_size_scaling + real(jprb) :: sw_albedo_override + real(jprb) :: lw_emissivity_override + real(jprb) :: q_liq_scaling, q_ice_scaling + real(jprb) :: cloud_fraction_scaling + real(jprb) :: overlap_decorr_length_scaling + real(jprb) :: skin_temperature_override ! K + real(jprb) :: solar_irradiance_override ! W m-2 + real(jprb) :: solar_cycle_multiplier_override + real(jprb) :: cos_sza_override + real(jprb) :: cloud_inhom_separation_factor = 1.0_jprb + real(jprb) :: cloud_separation_scale_surface = -1.0_jprb + real(jprb) :: cloud_separation_scale_toa = -1.0_jprb + real(jprb) :: cloud_separation_scale_power = 1.0_jprb + real(jprb) :: h2o_scaling = 1.0_jprb + real(jprb) :: co2_scaling = 1.0_jprb + real(jprb) :: o3_scaling = 1.0_jprb + real(jprb) :: co_scaling = 1.0_jprb + real(jprb) :: ch4_scaling = 1.0_jprb + real(jprb) :: n2o_scaling = 1.0_jprb + real(jprb) :: o2_scaling = 1.0_jprb + real(jprb) :: cfc11_scaling = 1.0_jprb + real(jprb) :: cfc12_scaling = 1.0_jprb + real(jprb) :: hcfc22_scaling = 1.0_jprb + real(jprb) :: ccl4_scaling = 1.0_jprb + real(jprb) :: no2_scaling = 1.0_jprb + + ! Optional monotonically increasing wavelength bounds (m) for + ! shortwave spectral flux diagnostics, to be written to + ! sw_diagnostic_file_name + real(jprb) :: sw_diag_wavelength_bound(NMaxSpectralDiag+1) = -1.0_jprb + + ! Name of file to write shortwave spectral diagnostics to, but + ! only if sw_diag_wavelength_bound is populated via the namelist + character(len=NMaxStringLength) :: sw_diag_file_name = 'sw_diagnostics.nc' + + ! Number of shortwave diagnostics, worked out from first + ! unassigned value in sw_diag_wavelength_bound after reading + ! namelist + integer :: n_sw_diag + + ! Volume mixing ratios (m3 m-3) in model layers (or equivalently + ! mole fractions (mol mol-1)) are typically stored in the input + ! file with a name like co2_vmr, but the suffix can be overridden + ! by the user + character(len=32) :: vmr_suffix_str = '_vmr' + + ! Process a limited number of columns (iendcol=0 indicates to + ! process from istartcol up to the end) + integer :: istartcol, iendcol + + ! Save inputs in "inputs.nc" + logical :: do_save_inputs + + ! Save aerosol optical properties to "aerosol_optics.nc" + logical :: do_save_aerosol_optics + + ! Save aerosol optical properties to "hydrometeor_optics*.nc" + logical :: do_save_cloud_optics + + ! Save only net and surface/TOA fluxes, rather than up and down + logical :: do_save_net_fluxes + + ! Do we ignore the inv_inhom_effective_size variable and instead + ! assume the scale of cloud inhomogeneities is the same as the + ! scale of the clouds themselves? + logical :: do_ignore_inhom_effective_size = .false. + + ! Number of repeats (for benchmarking) + integer :: nrepeat + + ! Do we correct unphysical inputs (e.g. negative gas concentrations)? + logical :: do_correct_unphysical_inputs = .false. + + ! Do we write NetCDF4/HDF5 file format, needed for very large + ! files? + logical :: do_write_hdf5 = .false. + + ! Do we write fluxes in double precision? + logical :: do_write_double_precision = .false. + + ! Name of the experiment, to save in output file + character(len=NMaxStringLength) :: experiment_name = '' + + ! Control verbosity in driver routine: 0=none (no output to + ! standard output; write to standard error only if an error + ! occurs), 1=warning, 2=info, 3=progress, 4=detailed, 5=debug + integer :: iverbose + + contains + procedure :: read => read_config_from_namelist + + end type driver_config_type + +contains + + !--------------------------------------------------------------------- + ! This subroutine reads configuration data from a namelist file, and + ! anything that is not in the namelists will be set to default + ! values. If optional output argument "is_success" is present, then on + ! error (e.g. missing file) it will be set to .false.; if this + ! argument is missing then on error the program will be aborted. + subroutine read_config_from_namelist(this, file_name, is_success) + + use radiation_io, only : nulerr, radiation_abort + + class(driver_config_type), intent(inout) :: this + character(*), intent(in) :: file_name + logical, intent(out), optional :: is_success + + integer :: iosopen ! Status after calling open + + ! Override and scaling values + real(jprb) :: fractional_std + real(jprb) :: overlap_decorr_length + real(jprb) :: inv_effective_size + real(jprb) :: high_inv_effective_size + real(jprb) :: middle_inv_effective_size + real(jprb) :: low_inv_effective_size + real(jprb) :: effective_size_scaling + real(jprb) :: sw_albedo + real(jprb) :: lw_emissivity + real(jprb) :: q_liquid_scaling, q_ice_scaling + real(jprb) :: cloud_fraction_scaling + real(jprb) :: overlap_decorr_length_scaling + real(jprb) :: skin_temperature + real(jprb) :: cos_solar_zenith_angle + real(jprb) :: solar_irradiance_override + real(jprb) :: solar_cycle_multiplier_override + real(jprb) :: cloud_inhom_separation_factor + real(jprb) :: cloud_separation_scale_surface + real(jprb) :: cloud_separation_scale_toa + real(jprb) :: cloud_separation_scale_power + real(jprb) :: h2o_scaling + real(jprb) :: co2_scaling + real(jprb) :: o3_scaling + real(jprb) :: co_scaling + real(jprb) :: ch4_scaling + real(jprb) :: n2o_scaling + real(jprb) :: o2_scaling + real(jprb) :: cfc11_scaling + real(jprb) :: cfc12_scaling + real(jprb) :: hcfc22_scaling + real(jprb) :: ccl4_scaling + real(jprb) :: no2_scaling + real(jprb) :: sw_diag_wavelength_bound(NMaxSpectralDiag+1) + character(len=NMaxStringLength) :: sw_diag_file_name + character(len=32) :: vmr_suffix_str + character(len=NMaxStringLength) :: experiment_name + + ! Parallel settings + logical :: do_parallel + integer :: nblocksize + + logical :: do_save_inputs, do_save_aerosol_optics, do_save_net_fluxes, & + & do_save_cloud_optics, do_ignore_inhom_effective_size, & + & do_correct_unphysical_inputs, do_write_hdf5, & + & do_write_double_precision + integer :: nrepeat + + ! Process a limited number of columns (iendcol=0 indicates to + ! process from istartcol up to the end) + integer :: istartcol, iendcol + + ! Verbosity + integer :: iverbose + + ! Are we going to override the effective size? + logical :: do_override_eff_size + + ! Loop index + integer :: jdiag + + namelist /radiation_driver/ fractional_std, & + & overlap_decorr_length, inv_effective_size, sw_albedo, & + & high_inv_effective_size, middle_inv_effective_size, & + & low_inv_effective_size, cloud_inhom_separation_factor, & + & effective_size_scaling, cos_solar_zenith_angle, & + & lw_emissivity, q_liquid_scaling, q_ice_scaling, & + & istartcol, iendcol, solar_irradiance_override, & + & solar_cycle_multiplier_override, & + & cloud_fraction_scaling, overlap_decorr_length_scaling, & + & skin_temperature, do_parallel, nblocksize, iverbose, & + & nrepeat, do_save_inputs, do_ignore_inhom_effective_size, & + & do_save_aerosol_optics, do_save_net_fluxes, do_save_cloud_optics, & + & cloud_separation_scale_toa, cloud_separation_scale_surface, & + & cloud_separation_scale_power, do_correct_unphysical_inputs, & + & do_write_hdf5, h2o_scaling, co2_scaling, o3_scaling, co_scaling, & + & ch4_scaling, o2_scaling, cfc11_scaling, cfc12_scaling, & + & hcfc22_scaling, no2_scaling, n2o_scaling, ccl4_scaling, & + & vmr_suffix_str, experiment_name, do_write_double_precision, & + & sw_diag_wavelength_bound, sw_diag_file_name + + ! Default values + do_parallel = .true. + do_save_inputs = .false. + do_save_aerosol_optics = .false. + do_save_cloud_optics = .false. + do_save_net_fluxes = .false. + do_ignore_inhom_effective_size = .false. + nblocksize = 8 + + ! Negative values indicate no override will take place + fractional_std = -1.0_jprb + overlap_decorr_length = -1.0_jprb + inv_effective_size = -1.0_jprb + high_inv_effective_size = -1.0_jprb + middle_inv_effective_size = -1.0_jprb + low_inv_effective_size = -1.0_jprb + effective_size_scaling = -1.0_jprb + sw_albedo = -1.0_jprb + lw_emissivity = -1.0_jprb + q_liquid_scaling = -1.0_jprb + q_ice_scaling = -1.0_jprb + cloud_fraction_scaling = -1.0_jprb + overlap_decorr_length_scaling = -1.0_jprb + skin_temperature = -1.0_jprb + cos_solar_zenith_angle = -1.0_jprb + solar_irradiance_override = -1.0_jprb + solar_cycle_multiplier_override = -2.0e6_jprb + cloud_inhom_separation_factor = 1.0_jprb + cloud_separation_scale_toa = -1.0_jprb + cloud_separation_scale_surface = -1.0_jprb + cloud_separation_scale_power = 1.0_jprb + h2o_scaling = 1.0_jprb + co2_scaling = 1.0_jprb + o3_scaling = 1.0_jprb + co_scaling = 1.0_jprb + ch4_scaling = 1.0_jprb + n2o_scaling = 1.0_jprb + o2_scaling = 1.0_jprb + cfc11_scaling = 1.0_jprb + cfc12_scaling = 1.0_jprb + hcfc22_scaling = 1.0_jprb + ccl4_scaling = 1.0_jprb + no2_scaling = 1.0_jprb + vmr_suffix_str = '_vmr'; + iverbose = 2 ! Default verbosity is "warning" + istartcol = 0 + iendcol = 0 + nrepeat = 1 + do_correct_unphysical_inputs = .false. + do_write_hdf5 = .false. + do_write_double_precision = .false. + experiment_name = '' + sw_diag_wavelength_bound = this%sw_diag_wavelength_bound + sw_diag_file_name = this%sw_diag_file_name + + ! Open the namelist file and read the radiation_driver namelist + open(unit=10, iostat=iosopen, file=trim(file_name)) + if (iosopen /= 0) then + ! An error occurred + if (present(is_success)) then + is_success = .false. + ! We now continue the subroutine so that the default values + ! are placed in the config structure + else + write(nulerr,'(a,a,a)') '*** Error: namelist file "', & + & trim(file_name), '" not found' + call radiation_abort('Driver configuration error') + end if + else + ! Read the radiation_driver namelist, noting that it is not an + ! error if this namelist is not present, provided all the required + ! variables are present in the NetCDF data file instead + read(unit=10, nml=radiation_driver) + close(unit=10) + end if + + ! Copy namelist data into configuration object + this%do_parallel = do_parallel + this%do_save_inputs = do_save_inputs + this%do_save_aerosol_optics = do_save_aerosol_optics + this%do_save_cloud_optics = do_save_cloud_optics + this%do_save_net_fluxes = do_save_net_fluxes + this%do_ignore_inhom_effective_size = do_ignore_inhom_effective_size + this%nblocksize = nblocksize + this%iverbose = iverbose + this%nrepeat = nrepeat + if (istartcol < 1) then + this%istartcol = 1 + else + this%istartcol = istartcol + end if + if (iendcol < 1) then + this%iendcol = 0 + else + this%iendcol = iendcol + end if + + ! Set override values + this%fractional_std_override = fractional_std + this%overlap_decorr_length_override = overlap_decorr_length + + do_override_eff_size = .false. + if (inv_effective_size >= 0.0_jprb) then + this%high_inv_effective_size_override = inv_effective_size + this%middle_inv_effective_size_override = inv_effective_size + this%low_inv_effective_size_override = inv_effective_size + end if + if (high_inv_effective_size >= 0.0_jprb) then + this%high_inv_effective_size_override = high_inv_effective_size + do_override_eff_size = .true. + end if + if (middle_inv_effective_size >= 0.0_jprb) then + this%middle_inv_effective_size_override = middle_inv_effective_size + do_override_eff_size = .true. + end if + if (low_inv_effective_size >= 0.0_jprb) then + this%low_inv_effective_size_override = low_inv_effective_size + do_override_eff_size = .true. + end if + + if (do_override_eff_size & + & .and. (this%high_inv_effective_size_override < 0.0_jprb & + .or. this%middle_inv_effective_size_override < 0.0_jprb & + .or. this%low_inv_effective_size_override < 0.0_jprb)) then + write(nulerr,'(a)') '*** Error: inverse effective cloud size not specified for high, middle and low clouds"' + call radiation_abort('Driver configuration error') + end if + + this%effective_size_scaling = effective_size_scaling + this%sw_albedo_override = sw_albedo + this%lw_emissivity_override = lw_emissivity + this%q_liq_scaling = q_liquid_scaling + this%q_ice_scaling = q_ice_scaling + this%cloud_fraction_scaling = cloud_fraction_scaling + this%overlap_decorr_length_scaling = overlap_decorr_length_scaling + this%skin_temperature_override = skin_temperature + this%cos_sza_override = cos_solar_zenith_angle + this%solar_irradiance_override = solar_irradiance_override + this%solar_cycle_multiplier_override = solar_cycle_multiplier_override + this%cloud_inhom_separation_factor = cloud_inhom_separation_factor + this%cloud_separation_scale_toa = cloud_separation_scale_toa + this%cloud_separation_scale_surface = cloud_separation_scale_surface + this%cloud_separation_scale_power = cloud_separation_scale_power + this%do_correct_unphysical_inputs = do_correct_unphysical_inputs + this%do_write_hdf5 = do_write_hdf5 + this%do_write_double_precision = do_write_double_precision + this%h2o_scaling = h2o_scaling + this%co2_scaling = co2_scaling + this%o3_scaling = o3_scaling + this%co_scaling = co_scaling + this%ch4_scaling = ch4_scaling + this%n2o_scaling = n2o_scaling + this%o2_scaling = o2_scaling + this%cfc11_scaling = cfc11_scaling + this%cfc12_scaling = cfc12_scaling + this%hcfc22_scaling = hcfc22_scaling + this%ccl4_scaling = ccl4_scaling + this%no2_scaling = no2_scaling + this%vmr_suffix_str = trim(vmr_suffix_str) + this%experiment_name= trim(experiment_name) + + this%sw_diag_file_name = trim(sw_diag_file_name) + this%sw_diag_wavelength_bound = sw_diag_wavelength_bound + ! Work out number of shortwave diagnostics from first negative + ! wavelength bound, noting that the number of diagnostics is one + ! fewer than the number of valid bounds + do jdiag = 0,NMaxSpectralDiag + if (this%sw_diag_wavelength_bound(jdiag+1) < 0.0_jprb) then + this%n_sw_diag = max(0,jdiag-1) + exit + end if + end do + + end subroutine read_config_from_namelist + +end module ecrad_driver_config Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver_read_input.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver_read_input.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_driver_read_input.F90 (revision 6016) @@ -0,0 +1,624 @@ +! ecrad_driver_read_input.F90 - Read input structures from NetCDF file +! +! (C) Copyright 2018- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int + +module ecrad_driver_read_input + + public + +contains + + subroutine read_input(file, config, driver_config, ncol, nlev, & + & single_level, thermodynamics, & + & gas, cloud, aerosol) + + use parkind1, only : jprb, jpim + use radiation_io, only : nulout + use radiation_config, only : config_type, ISolverSPARTACUS + use ecrad_driver_config, only : driver_config_type + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type, & + & IVolumeMixingRatio, IMassMixingRatio, & + & IH2O, ICO2, IO3, IN2O, ICO, ICH4, IO2, ICFC11, ICFC12, & + & IHCFC22, ICCl4, INO2, GasName, GasLowerCaseName, NMaxGases + use radiation_cloud, only : cloud_type + use radiation_aerosol, only : aerosol_type + use easy_netcdf, only : netcdf_file + + implicit none + + type(netcdf_file), intent(in) :: file + type(config_type), intent(in) :: config + type(driver_config_type), intent(in) :: driver_config + type(single_level_type), intent(inout) :: single_level + type(thermodynamics_type), intent(inout) :: thermodynamics + type(gas_type), intent(inout) :: gas + type(cloud_type), target, intent(inout) :: cloud + type(aerosol_type), intent(inout) :: aerosol + + ! Number of columns and levels of input data + integer, intent(out) :: ncol, nlev + + integer :: ngases ! Num of gases with concs described in 2D + integer :: nwellmixedgases ! Num of globally well-mixed gases + + ! Mixing ratio of gases described in 2D (ncol,nlev); this is + ! volume mixing ratio (m3/m3) except for water vapour and ozone + ! for which it is mass mixing ratio (kg/kg) + real(jprb), allocatable, dimension(:,:) :: gas_mr + + ! Volume mixing ratio (m3/m3) of globally well-mixed gases + real(jprb) :: well_mixed_gas_vmr + + ! Name of gas concentration variable in the file + character(40) :: gas_var_name + + ! Cloud overlap decorrelation length (m) + real(jprb), parameter :: decorr_length_default = 2000.0_jprb + + ! General property to be read and then modified before used in an + ! ecRad structure + real(jprb), allocatable, dimension(:,:) :: prop_2d + + integer :: jgas ! Loop index for reading gases + integer :: irank ! Dimensions of gas data + + ! Can we scale cloud size using namelist parameters? No if the + ! cloud size came from namelist parameters in the first place, yes + ! if it came from the NetCDF file in the first place + logical :: is_cloud_size_scalable + + ! The following calls read in the data, allocating memory for 1D and + ! 2D arrays. The program will stop if any variables are not found. + + ! Pressure and temperature (SI units) are on half-levels, i.e. of + ! length (ncol,nlev+1) + call file%get('pressure_hl', thermodynamics%pressure_hl) + call file%get('temperature_hl',thermodynamics%temperature_hl) + + ! Extract array dimensions + ncol = size(thermodynamics%pressure_hl,1) + nlev = size(thermodynamics%pressure_hl,2)-1 + + if (driver_config%solar_irradiance_override > 0.0_jprb) then + ! Optional override of solar irradiance + single_level%solar_irradiance = driver_config%solar_irradiance_override + if (driver_config%iverbose >= 2) then + write(nulout,'(a,f10.1)') ' Overriding solar irradiance with ', & + & driver_config%solar_irradiance_override + end if + else if (file%exists('solar_irradiance')) then + call file%get('solar_irradiance', single_level%solar_irradiance) + else + single_level%solar_irradiance = 1366.0_jprb + if (driver_config%iverbose >= 1 .and. config%do_sw) then + write(nulout,'(a,g10.3,a)') 'Warning: solar irradiance set to ', & + & single_level%solar_irradiance, ' W m-2' + end if + end if + + ! Configure the amplitude of the spectral variations in solar + ! output associated with the 11-year solar cycle: +1.0 means solar + ! maximum, -1.0 means solar minimum, 0.0 means use the mean solar + ! spectrum. + if (driver_config%solar_cycle_multiplier_override > -1.0e6_jprb) then + single_level%spectral_solar_cycle_multiplier & + & = driver_config%solar_cycle_multiplier_override + if (driver_config%iverbose >= 2) then + write(nulout,'(a,f10.1)') ' Overriding solar spectral multiplier with ', & + & driver_config%solar_cycle_multiplier_override + end if + else if (file%exists('solar_spectral_multiplier')) then + call file%get('spectral_solar_cycle_multiplier', single_level%spectral_solar_cycle_multiplier) + else + single_level%spectral_solar_cycle_multiplier = 0.0_jprb + end if + + if (driver_config%cos_sza_override >= 0.0_jprb) then + ! Optional override of cosine of solar zenith angle + allocate(single_level%cos_sza(ncol)) + single_level%cos_sza = driver_config%cos_sza_override + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3)') ' Overriding cosine of the solar zenith angle with ', & + & driver_config%cos_sza_override + end if + else if (file%exists('cos_solar_zenith_angle')) then + ! Single-level variables, all with dimensions (ncol) + call file%get('cos_solar_zenith_angle',single_level%cos_sza) + else if (.not. config%do_sw) then + ! If cos_solar_zenith_angle not present and shortwave radiation + ! not to be performed, we create an array of zeros as some gas + ! optics schemes still need to be run in the shortwave + allocate(single_level%cos_sza(ncol)) + single_level%cos_sza = 0.0_jprb + else + write(nulout,'(a,a)') '*** Error: cos_solar_zenith_angle not provided' + stop + end if + + if (config%do_clouds) then + + ! -------------------------------------------------------- + ! Read cloud properties needed by most solvers + ! -------------------------------------------------------- + + ! Read cloud descriptors with dimensions (ncol, nlev) + call file%get('cloud_fraction',cloud%fraction) + + ! Fractional standard deviation of in-cloud water content + if (file%exists('fractional_std')) then + call file%get('fractional_std', cloud%fractional_std) + end if + + ! Cloud water content and effective radius may be provided + ! generically, in which case they have dimensions (ncol, nlev, + ! ntype) + if (file%exists('q_hydrometeor')) then + call file%get('q_hydrometeor', cloud%mixing_ratio, ipermute=[2,1,3]) ! kg/kg + call file%get('re_hydrometeor', cloud%effective_radius, ipermute=[2,1,3]) ! m + else + ! Ice and liquid properties provided in separate arrays + allocate(cloud%mixing_ratio(ncol,nlev,2)) + allocate(cloud%effective_radius(ncol,nlev,2)) + call file%get('q_liquid', prop_2d) ! kg/kg + cloud%mixing_ratio(:,:,1) = prop_2d + call file%get('q_ice', prop_2d) ! kg/kg + cloud%mixing_ratio(:,:,2) = prop_2d + call file%get('re_liquid', prop_2d) ! m + cloud%effective_radius(:,:,1) = prop_2d + call file%get('re_ice', prop_2d) ! m + cloud%effective_radius(:,:,2) = prop_2d + end if + ! For backwards compatibility, associate pointers for liquid and + ! ice to the first and second slices of cloud%mixing_ratio and + ! cloud%effective_radius + cloud%q_liq => cloud%mixing_ratio(:,:,1) + cloud%q_ice => cloud%mixing_ratio(:,:,2) + cloud%re_liq => cloud%effective_radius(:,:,1) + cloud%re_ice => cloud%effective_radius(:,:,2) + cloud%ntype = size(cloud%mixing_ratio,3) + + ! Simple initialization of the seeds for the Monte Carlo scheme + call single_level%init_seed_simple(1,ncol) + ! Overwrite with user-specified values if available + if (file%exists('iseed')) then + call file%get('iseed', single_level%iseed) + end if + + ! Cloud overlap parameter + if (file%exists('overlap_param')) then + call file%get('overlap_param', cloud%overlap_param) + end if + + ! Optional scaling of liquid water mixing ratio + if (driver_config%q_liq_scaling >= 0.0_jprb & + & .and. driver_config%q_liq_scaling /= 1.0_jprb) then + cloud%q_liq = cloud%q_liq * driver_config%q_liq_scaling + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3)') ' Scaling liquid water mixing ratio by a factor of ', & + & driver_config%q_liq_scaling + end if + end if + + ! Optional scaling of ice water mixing ratio + if (driver_config%q_ice_scaling >= 0.0_jprb .and. driver_config%q_ice_scaling /= 1.0_jprb) then + cloud%q_ice = cloud%q_ice * driver_config%q_ice_scaling + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3)') ' Scaling ice water mixing ratio by a factor of ', & + & driver_config%q_ice_scaling + end if + end if + + ! Optional scaling of cloud fraction + if (driver_config%cloud_fraction_scaling >= 0.0_jprb & + & .and. driver_config%cloud_fraction_scaling /= 1.0_jprb) then + cloud%fraction = cloud%fraction * driver_config%cloud_fraction_scaling + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3)') ' Scaling cloud_fraction by a factor of ', & + & driver_config%cloud_fraction_scaling + end if + end if + + ! Cloud overlap is currently treated by an overlap decorrelation + ! length (m) that is constant everywhere, and specified in one + ! of the namelists + if (driver_config%overlap_decorr_length_override > 0.0_jprb) then + ! Convert overlap decorrelation length to overlap parameter between + ! adjacent layers, stored in cloud%overlap_param + call cloud%set_overlap_param(thermodynamics, & + & driver_config%overlap_decorr_length_override) + else if (.not. allocated(cloud%overlap_param)) then + if (driver_config%iverbose >= 1) then + write(nulout,'(a,g10.3,a)') 'Warning: overlap decorrelation length set to ', & + & decorr_length_default, ' m' + end if + call cloud%set_overlap_param(thermodynamics, decorr_length_default) + else if (driver_config%overlap_decorr_length_scaling > 0.0_jprb) then + ! Scale the overlap decorrelation length by taking the overlap + ! parameter to a power + ! where (cloud%overlap_param > 0.99_jprb) cloud%overlap_param = 0.99_jprb + + where (cloud%overlap_param > 0.0_jprb) + cloud%overlap_param = cloud%overlap_param**(1.0_jprb & + & / driver_config%overlap_decorr_length_scaling) + end where + + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3)') ' Scaling overlap decorrelation length by a factor of ', & + & driver_config%overlap_decorr_length_scaling + end if + else if (driver_config%overlap_decorr_length_scaling == 0.0_jprb) then + cloud%overlap_param = 0.0_jprb + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') ' Setting overlap decorrelation length to zero (random overlap)' + end if + end if + + ! Cloud inhomogeneity is specified by the fractional standard + ! deviation of cloud water content, that is currently constant + ! everywhere (and the same for water and ice). The following copies + ! this constant into the cloud%fractional_std array. + if (driver_config%fractional_std_override >= 0.0_jprb) then + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3,a)') ' Overriding cloud fractional standard deviation with ', & + & driver_config%fractional_std_override + end if + call cloud%create_fractional_std(ncol, nlev, & + & driver_config%fractional_std_override) + else if (.not. allocated(cloud%fractional_std)) then + call cloud%create_fractional_std(ncol, nlev, 0.0_jprb) + if (driver_config%iverbose >= 1) then + write(nulout,'(a)') 'Warning: cloud optical depth fractional standard deviation set to zero' + end if + end if + + ! -------------------------------------------------------- + ! Read cloud properties needed by SPARTACUS + ! -------------------------------------------------------- + + if (config%i_solver_sw == ISolverSPARTACUS & + & .or. config%i_solver_lw == ISolverSPARTACUS) then + + ! 3D radiative effects are governed by the length of cloud + ! edge per area of gridbox, which is characterized by the + ! inverse of the cloud effective size (m-1). Order of + ! precedence: (1) effective size namelist overrides, (2) + ! separation namelist overrides, (3) inv_cloud_effective_size + ! present in NetCDF, (4) inv_cloud_effective_separation + ! present in NetCDF. Only in the latter two cases may the + ! effective size be scaled by the namelist variable + ! "effective_size_scaling". + + is_cloud_size_scalable = .false. ! Default for cases (1) and (2) + + if (driver_config%low_inv_effective_size_override >= 0.0_jprb & + & .or. driver_config%middle_inv_effective_size_override >= 0.0_jprb & + & .or. driver_config%high_inv_effective_size_override >= 0.0_jprb) then + ! (1) Cloud effective size specified in namelist + + ! First check all three ranges provided + if (driver_config%low_inv_effective_size_override < 0.0_jprb & + & .or. driver_config%middle_inv_effective_size_override < 0.0_jprb & + & .or. driver_config%high_inv_effective_size_override < 0.0_jprb) then + write(nulout,'(a,a)') '*** Error: if one of [low|middle|high]_inv_effective_size_override', & + & ' is provided then all must be' + stop + end if + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3,a)') ' Overriding inverse cloud effective size with:' + write(nulout,'(a,g10.3,a)') ' ', driver_config%low_inv_effective_size_override, & + & ' m-1 (low clouds)' + write(nulout,'(a,g10.3,a)') ' ', driver_config%middle_inv_effective_size_override, & + & ' m-1 (mid-level clouds)' + write(nulout,'(a,g10.3,a)') ' ', driver_config%high_inv_effective_size_override, & + & ' m-1 (high clouds)' + end if + call cloud%create_inv_cloud_effective_size_eta(ncol, nlev, & + & thermodynamics%pressure_hl, & + & driver_config%low_inv_effective_size_override, & + & driver_config%middle_inv_effective_size_override, & + & driver_config%high_inv_effective_size_override, 0.8_jprb, 0.45_jprb) + + else if (driver_config%cloud_separation_scale_surface > 0.0_jprb & + & .and. driver_config%cloud_separation_scale_toa > 0.0_jprb) then + ! (2) Cloud separation scale provided in namelist + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') ' Effective cloud separation parameterized versus eta:' + write(nulout,'(a,f8.1,a)') ' ', & + & driver_config%cloud_separation_scale_surface, ' m at the surface' + write(nulout,'(a,f8.1,a)') ' ', & + & driver_config%cloud_separation_scale_toa, ' m at top-of-atmosphere' + write(nulout,'(a,f6.2)') ' Eta power is', & + & driver_config%cloud_separation_scale_power + write(nulout,'(a,f6.2)') ' Inhomogeneity separation scaling is', & + & driver_config%cloud_inhom_separation_factor + end if + call cloud%param_cloud_effective_separation_eta(ncol, nlev, & + & thermodynamics%pressure_hl, & + & driver_config%cloud_separation_scale_surface, & + & driver_config%cloud_separation_scale_toa, & + & driver_config%cloud_separation_scale_power, & + & driver_config%cloud_inhom_separation_factor) + + else if (file%exists('inv_cloud_effective_size')) then + ! (3) NetCDF file contains cloud effective size + + is_cloud_size_scalable = .true. + + call file%get('inv_cloud_effective_size', cloud%inv_cloud_effective_size) + ! For finer control we can specify the effective size for + ! in-cloud inhomogeneities as well + if (file%exists('inv_inhom_effective_size')) then + if (.not. driver_config%do_ignore_inhom_effective_size) then + call file%get('inv_inhom_effective_size', cloud%inv_inhom_effective_size) + else + if (driver_config%iverbose >= 1) then + write(nulout,'(a)') 'Ignoring inv_inhom_effective_size so treated as equal to inv_cloud_effective_size' + write(nulout,'(a)') 'Warning: ...this is unlikely to be accurate for cloud fraction near one' + end if + end if + else + if (driver_config%iverbose >= 1) then + write(nulout,'(a)') 'Warning: inv_inhom_effective_size not set so treated as equal to inv_cloud_effective_size' + write(nulout,'(a)') 'Warning: ...this is unlikely to be accurate for cloud fraction near one' + end if + end if + + else if (file%exists('inv_cloud_effective_separation')) then + ! (4) Alternative way to specify cloud scale + + is_cloud_size_scalable = .true. + + call file%get('inv_cloud_effective_separation', prop_2d) + allocate(cloud%inv_cloud_effective_size(ncol,nlev)) + allocate(cloud%inv_inhom_effective_size(ncol,nlev)) + where (cloud%fraction > config%cloud_fraction_threshold & + & .and. cloud%fraction < 1.0_jprb - config%cloud_fraction_threshold) + ! Convert effective cloud separation to effective cloud + ! size, noting divisions rather than multiplications + ! because we're working in terms of inverse sizes + cloud%inv_cloud_effective_size = prop_2d / sqrt(cloud%fraction*(1.0_jprb-cloud%fraction)) + elsewhere + cloud%inv_cloud_effective_size = 0.0_jprb + end where + if (file%exists('inv_inhom_effective_separation')) then + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') ' Effective size of clouds and their inhomogeneities being computed from input' + write(nulout,'(a)') ' ...variables inv_cloud_effective_separation and inv_inhom_effective_separation' + end if + call file%get('inv_inhom_effective_separation', prop_2d) + where (cloud%fraction > config%cloud_fraction_threshold) + ! Convert effective separation of cloud inhomogeneities + ! to effective size of cloud inhomogeneities, assuming + ! here that the Tripleclouds treatment of cloud + ! inhomogeneity will divide the cloudy part of the area + ! into regions of equal area + cloud%inv_inhom_effective_size = prop_2d & + & / sqrt(0.5_jprb*cloud%fraction * (1.0_jprb-0.5_jprb*cloud%fraction)) + elsewhere + cloud%inv_inhom_effective_size = 0.0_jprb + end where + else + ! Assume that the effective separation of cloud + ! inhomogeneities is equal to that of clouds but + ! multiplied by a constant provided by the user; note that + ! prop_2d at this point contains + ! inv_cloud_effective_separation + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') ' Effective size of clouds being computed from inv_cloud_effective_separation' + write(nulout,'(a,f6.2,a)') ' ...and multiplied by ', driver_config%cloud_inhom_separation_factor, & + & ' to get effective size of inhomogeneities' + end if + where (cloud%fraction > config%cloud_fraction_threshold) + ! Note divisions rather than multiplications because + ! we're working in terms of inverse sizes + cloud%inv_inhom_effective_size = (1.0_jprb / driver_config%cloud_inhom_separation_factor) * prop_2d & + & / sqrt(0.5_jprb*cloud%fraction * (1.0_jprb-0.5_jprb*cloud%fraction)) + elsewhere + cloud%inv_inhom_effective_size = 0.0_jprb + end where + end if ! exists inv_inhom_effective_separation + deallocate(prop_2d) + + else + + write(nulout,'(a)') '*** Error: SPARTACUS solver specified but cloud size not, either in namelist or input file' + stop + + end if ! Select method of specifying cloud effective size + + ! In cases (3) and (4) above the effective size obtained from + ! the NetCDF may be scaled by a namelist variable + if (is_cloud_size_scalable .and. driver_config%effective_size_scaling > 0.0_jprb) then + ! Scale cloud effective size + cloud%inv_cloud_effective_size = cloud%inv_cloud_effective_size & + & / driver_config%effective_size_scaling + if (allocated(cloud%inv_inhom_effective_size)) then + if (driver_config%iverbose >= 2) then + write(nulout, '(a,g10.3)') ' Scaling effective size of clouds and their inhomogeneities with ', & + & driver_config%effective_size_scaling + end if + cloud%inv_inhom_effective_size = cloud%inv_inhom_effective_size & + & / driver_config%effective_size_scaling + else + if (driver_config%iverbose >= 2) then + write(nulout, '(a,g10.3)') ' Scaling cloud effective size with ', & + & driver_config%effective_size_scaling + end if + end if + end if + + end if ! Using SPARTACUS solver + + end if ! do_cloud + + ! -------------------------------------------------------- + ! Read surface properties + ! -------------------------------------------------------- + + single_level%is_simple_surface = .true. + + ! Single-level variable with dimensions (ncol) + if (file%exists('skin_temperature')) then + call file%get('skin_temperature',single_level%skin_temperature) ! K + else + allocate(single_level%skin_temperature(ncol)) + single_level%skin_temperature(1:ncol) = thermodynamics%temperature_hl(1:ncol,nlev+1) + if (driver_config%iverbose >= 1 .and. config%do_lw & + & .and. driver_config%skin_temperature_override < 0.0_jprb) then + write(nulout,'(a)') 'Warning: skin temperature set equal to lowest air temperature' + end if + end if + + if (driver_config%sw_albedo_override >= 0.0_jprb) then + ! Optional override of shortwave albedo + allocate(single_level%sw_albedo(ncol,1)) + single_level%sw_albedo = driver_config%sw_albedo_override + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3)') ' Overriding shortwave albedo with ', & + & driver_config%sw_albedo_override + end if + !if (allocated(single_level%sw_albedo_direct)) then + ! single_level%sw_albedo_direct = driver_config%sw_albedo_override + !end if + else + ! Shortwave albedo is stored with dimensions (ncol,nalbedobands) + if (file%get_rank('sw_albedo') == 1) then + ! ...but if in the NetCDF file it has only dimension (ncol), in + ! order that nalbedobands is correctly set to 1, we need to turn + ! off transposition + call file%get('sw_albedo', single_level%sw_albedo, do_transp=.false.) + if (file%exists('sw_albedo_direct')) then + call file%get('sw_albedo_direct', single_level%sw_albedo_direct, do_transp=.false.) + end if + else + call file%get('sw_albedo', single_level%sw_albedo, do_transp=.true.) + if (file%exists('sw_albedo_direct')) then + call file%get('sw_albedo_direct', single_level%sw_albedo_direct, do_transp=.true.) + end if + end if + end if + + ! Longwave emissivity + if (driver_config%lw_emissivity_override >= 0.0_jprb) then + ! Optional override of longwave emissivity + allocate(single_level%lw_emissivity(ncol,1)) + single_level%lw_emissivity = driver_config%lw_emissivity_override + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3)') ' Overriding longwave emissivity with ', & + & driver_config%lw_emissivity_override + end if + else + if (file%get_rank('lw_emissivity') == 1) then + call file%get('lw_emissivity',single_level%lw_emissivity, do_transp=.false.) + else + call file%get('lw_emissivity',single_level%lw_emissivity, do_transp=.true.) + end if + end if + + ! Optional override of skin temperature + if (driver_config%skin_temperature_override >= 0.0_jprb) then + single_level%skin_temperature = driver_config%skin_temperature_override + if (driver_config%iverbose >= 2) then + write(nulout,'(a,g10.3)') ' Overriding skin_temperature with ', & + & driver_config%skin_temperature_override + end if + end if + + ! -------------------------------------------------------- + ! Read aerosol and gas concentrations + ! -------------------------------------------------------- + + if (config%use_aerosols) then + ! Load aerosol data + call file%get('aerosol_mmr', aerosol%mixing_ratio, ipermute=[2,3,1]); + ! Store aerosol level bounds + aerosol%istartlev = lbound(aerosol%mixing_ratio, 2) + aerosol%iendlev = ubound(aerosol%mixing_ratio, 2) + end if + + ! Load in gas volume mixing ratios, which can be either 2D arrays + ! (varying with height and column) or 0D scalars (constant volume + ! mixing ratio everywhere). + ngases = 0 ! Gases with varying mixing ratio + nwellmixedgases = 0 ! Gases with constant mixing ratio + + ! Water vapour and ozone are always in terms of mass mixing ratio + ! (kg/kg) and always 2D arrays with dimensions (ncol,nlev), unlike + ! other gases (see below) + + call gas%allocate(ncol, nlev) + + ! Loop through all radiatively important gases + do jgas = 1,NMaxGases + if (jgas == IH2O) then + if (file%exists('q')) then + call file%get('q', gas_mr) + call gas%put(IH2O, IMassMixingRatio, gas_mr) + else if (file%exists('h2o_mmr')) then + call file%get('h2o_mmr', gas_mr) + call gas%put(IH2O, IMassMixingRatio, gas_mr) + else + call file%get('h2o' // trim(driver_config%vmr_suffix_str), gas_mr); + call gas%put(IH2O, IVolumeMixingRatio, gas_mr) + end if + else if (jgas == IO3) then + if (file%exists('o3_mmr')) then + call file%get('o3_mmr', gas_mr) + call gas%put(IO3, IMassMixingRatio, gas_mr) + else + call file%get('o3' // trim(driver_config%vmr_suffix_str), gas_mr) + call gas%put(IO3, IVolumeMixingRatio, gas_mr) + end if + else + ! Find number of dimensions of the variable holding gas "jgas" in + ! the input file, where the following function returns -1 if the + ! gas is not found + gas_var_name = trim(GasLowerCaseName(jgas)) // trim(driver_config%vmr_suffix_str) + irank = file%get_rank(trim(gas_var_name)) + ! Note that if the gas is not present then a warning will have + ! been issued, and irank will be returned as -1 + if (irank == 0) then + ! Store this as a well-mixed gas + call file%get(trim(gas_var_name), well_mixed_gas_vmr) + call gas%put_well_mixed(jgas, IVolumeMixingRatio, well_mixed_gas_vmr) + else if (irank == 2) then + call file%get(trim(gas_var_name), gas_mr) + call gas%put(jgas, IVolumeMixingRatio, gas_mr) + else if (irank > 0) then + write(nulout,'(a,a,a)') '*** Error: ', trim(gas_var_name), ' does not have 0 or 2 dimensions' + stop + end if + end if + if (allocated(gas_mr)) deallocate(gas_mr) + end do + + ! Scale gas concentrations if needed + call gas%scale(IH2O, driver_config%h2o_scaling, driver_config%iverbose >= 2) + call gas%scale(ICO2, driver_config%co2_scaling, driver_config%iverbose >= 2) + call gas%scale(IO3, driver_config%o3_scaling, driver_config%iverbose >= 2) + call gas%scale(IN2O, driver_config%n2o_scaling, driver_config%iverbose >= 2) + call gas%scale(ICO, driver_config%co_scaling, driver_config%iverbose >= 2) + call gas%scale(ICH4, driver_config%ch4_scaling, driver_config%iverbose >= 2) + call gas%scale(IO2, driver_config%o2_scaling, driver_config%iverbose >= 2) + call gas%scale(ICFC11, driver_config%cfc11_scaling, driver_config%iverbose >= 2) + call gas%scale(ICFC12, driver_config%cfc12_scaling, driver_config%iverbose >= 2) + call gas%scale(IHCFC22, driver_config%hcfc22_scaling, driver_config%iverbose >= 2) + call gas%scale(ICCL4, driver_config%ccl4_scaling, driver_config%iverbose >= 2) + call gas%scale(INO2, driver_config%no2_scaling, driver_config%iverbose >= 2) + + end subroutine read_input + +end module ecrad_driver_read_input Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_ifs_driver.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_ifs_driver.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_ifs_driver.F90 (revision 6016) @@ -0,0 +1,478 @@ +! ecrad_ifs_driver.F90 - Driver for offline ECRAD radiation scheme +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! ECRAD is the radiation scheme used in the ECMWF Integrated +! Forecasting System in cycle 43R3 and later. Several solvers are +! available, including McICA, Tripleclouds and SPARTACUS (the Speedy +! Algorithm for Radiative Transfer through Cloud Sides, a modification +! of the two-stream formulation of shortwave and longwave radiative +! transfer to account for 3D radiative effects). Gas optical +! properties are provided by the RRTM-G gas optics scheme. + +! This program takes three arguments: +! 1) Namelist file to configure the radiation calculation, but note +! that only the radiation_config group is read +! 2) Name of a NetCDF file containing one or more atmospheric profiles +! 3) Name of output NetCDF file +! +! This version uses the infrastructure of the IFS, such as computing +! effective radius and cloud overlap from latitude and other +! variables. To configure ecRad in this version you need to edit +! ifs/yoerad.F90 in the ecRad package, but these options can be +! overridden with the "radiation" namelist. This file requires the +! input data to have compatible settings, e.g. the right number of +! aerosol variables, and surface albedo/emissivity bands; a test file +! satisfying this requirement is test/ifs/ecrad_meridian.nc in the +! ecRad package. +! +! Note that the purpose of this file is simply to demonstrate the use +! of the setup_radiation_scheme and radiation_scheme routines; all the +! rest is using the offline ecRad driver containers to read a NetCDF +! file to memory and pass it into these routines. + +program ecrad_ifs_driver + + ! -------------------------------------------------------- + ! Section 1: Declarations + ! -------------------------------------------------------- + use parkind1, only : jprb, jprd ! Working/double precision + + use radiation_io, only : nulout + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type, IMassMixingRatio, & + & IH2O, ICO2, IO3, IN2O, INO2, ICO, ICH4, IO2, ICFC11, ICFC12, & + & IHCFC22, ICCl4 + use radiation_cloud, only : cloud_type + use radiation_aerosol, only : aerosol_type + use radiation_flux, only : flux_type + use radiation_save, only : save_net_fluxes + use radiation_setup, only : tradiation, setup_radiation_scheme + use radiation_constants, only : Pi + use ecrad_driver_config, only : driver_config_type + use ecrad_driver_read_input, only : read_input + use easy_netcdf + + implicit none + +#include "radiation_scheme.intfb.h" + + ! The NetCDF file containing the input profiles + type(netcdf_file) :: file + + ! Configuration for the radiation scheme, IFS style + type(tradiation) :: yradiation + + ! Derived types for the inputs to the radiation scheme + type(single_level_type) :: single_level + type(thermodynamics_type) :: thermodynamics + type(gas_type) :: gas + type(cloud_type) :: cloud + type(aerosol_type) :: aerosol + + ! Configuration specific to this driver + type(driver_config_type) :: driver_config + + ! Derived type containing outputs from the radiation scheme + type(flux_type) :: flux + + ! Additional arrays passed to radiation_scheme + real(jprb), allocatable, dimension(:) :: ccn_land, ccn_sea, sin_latitude, longitude_rad, land_frac + real(jprb), allocatable, dimension(:,:) :: pressure_fl, temperature_fl, zeros + real(jprb), allocatable, dimension(:,:,:) :: tegen_aerosol + real(jprb), allocatable, dimension(:) :: flux_sw_direct_normal, flux_uv, flux_par, flux_par_clear, & + & flux_incoming, emissivity_out + real(jprb), allocatable, dimension(:,:) :: flux_diffuse_band, flux_direct_band + real(jprb), allocatable, dimension(:,:) :: cloud_fraction, cloud_q_liq, cloud_q_ice + + integer :: ncol, nlev ! Number of columns and levels + integer :: istartcol, iendcol ! Range of columns to process + + ! Name of file names specified on command line + character(len=512) :: file_name + integer :: istatus ! Result of command_argument_count + + ! For parallel processing of multiple blocks + integer :: jblock, nblock ! Block loop index and number + +#ifndef NO_OPENMP + ! OpenMP functions + integer, external :: omp_get_thread_num + real(kind=jprd), external :: omp_get_wtime + ! Start/stop time in seconds + real(kind=jprd) :: tstart, tstop +#endif + + ! For demonstration of get_sw_weights later on + ! Ultraviolet weightings + !integer :: nweight_uv + !integer :: iband_uv(100) + !real(jprb) :: weight_uv(100) + ! Photosynthetically active radiation weightings + !integer :: nweight_par + !integer :: iband_par(100) + !real(jprb) :: weight_par(100) + + ! Loop index for repeats (for benchmarking) + integer :: jrepeat + + ! Are any variables out of bounds? + logical :: is_out_of_bounds + +! integer :: iband(20), nweights +! real(jprb) :: weight(20) + + + ! -------------------------------------------------------- + ! Section 2: Configure + ! -------------------------------------------------------- + + ! Check program called with correct number of arguments + if (command_argument_count() < 3) then + stop 'Usage: ecrad config.nam input_file.nc output_file.nc' + end if + + ! Use namelist to configure the radiation calculation + call get_command_argument(1, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of namelist file as string of length < 512' + end if + + ! Read "radiation_driver" namelist into radiation driver config type + call driver_config%read(file_name) + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') '-------------------------- OFFLINE ECRAD RADIATION SCHEME --------------------------' + write(nulout,'(a)') 'Copyright (C) 2014- ECMWF' + write(nulout,'(a)') 'Contact: Robin Hogan (r.j.hogan@ecmwf.int)' +#ifdef PARKIND1_SINGLE + write(nulout,'(a)') 'Floating-point precision: single' +#else + write(nulout,'(a)') 'Floating-point precision: double' +#endif + end if + + ! Albedo/emissivity intervals may be specified like this + !call config%define_sw_albedo_intervals(6, & + ! & [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, & + ! & 1.19_jprb, 2.38e-6_jprb], [1,2,3,4,5,6], & + ! & do_nearest=.false.) + !call config%define_lw_emiss_intervals(3, & + ! & [8.0e-6_jprb, 13.0e-6_jprb], [1,2,1], & + ! & do_nearest=.false.) + + ! If monochromatic aerosol properties are required, then the + ! wavelengths can be specified (in metres) as follows - these can be + ! whatever you like for the general aerosol optics, but must match + ! the monochromatic values in the aerosol input file for the older + ! aerosol optics + !call config%set_aerosol_wavelength_mono( & + ! & [3.4e-07_jprb, 3.55e-07_jprb, 3.8e-07_jprb, 4.0e-07_jprb, 4.4e-07_jprb, & + ! & 4.69e-07_jprb, 5.0e-07_jprb, 5.32e-07_jprb, 5.5e-07_jprb, 6.45e-07_jprb, & + ! & 6.7e-07_jprb, 8.0e-07_jprb, 8.58e-07_jprb, 8.65e-07_jprb, 1.02e-06_jprb, & + ! & 1.064e-06_jprb, 1.24e-06_jprb, 1.64e-06_jprb, 2.13e-06_jprb, 1.0e-05_jprb]) + + call yradiation%rad_config%read(file_name=file_name) + + ! Setup aerosols + if (yradiation%rad_config%use_aerosols) then + yradiation%yrerad%naermacc = 1 ! MACC-derived aerosol climatology on a NMCLAT x NMCLON grid + else + yradiation%yrerad%naermacc = 0 + endif + + ! Setup the radiation scheme: load the coefficients for gas and + ! cloud optics, currently from RRTMG + call setup_radiation_scheme(yradiation, .true., file_name=file_name) + ! Or call without specifying the namelist filename, in which case + ! the default settings are from yoerad.F90 + !call setup_radiation_scheme(yradiation, .true.) + + ! Demonstration of how to get weights for UV and PAR fluxes + !if (config%do_sw) then + ! call config%get_sw_weights(0.2e-6_jprb, 0.4415e-6_jprb,& + ! & nweight_uv, iband_uv, weight_uv,& + ! & 'ultraviolet') + ! call config%get_sw_weights(0.4e-6_jprb, 0.7e-6_jprb,& + ! & nweight_par, iband_par, weight_par,& + ! & 'photosynthetically active radiation, PAR') + !end if + + ! -------------------------------------------------------- + ! Section 3: Read input data file + ! -------------------------------------------------------- + + ! Get NetCDF input file name + call get_command_argument(2, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of input NetCDF file as string of length < 512' + end if + + ! Open the file and configure the way it is read + call file%open(trim(file_name), iverbose=driver_config%iverbose) + + ! Get NetCDF output file name + call get_command_argument(3, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of output NetCDF file as string of length < 512' + end if + + ! 2D arrays are assumed to be stored in the file with height varying + ! more rapidly than column index. Specifying "true" here transposes + ! all 2D arrays so that the column index varies fastest within the + ! program. + call file%transpose_matrices(.true.) + + ! Read input variables from NetCDF file, noting that cloud overlap + ! and effective radius are ignored + call read_input(file, yradiation%rad_config, driver_config, ncol, nlev, & + & single_level, thermodynamics, & + & gas, cloud, aerosol) + + ! Latitude is used for cloud overlap and ice effective radius + if (file%exists('lat')) then + call file%get('lat', sin_latitude) + sin_latitude = sin(sin_latitude * Pi/180.0_jprb) + else + allocate(sin_latitude(ncol)) + sin_latitude = 0.0_jprb + end if + + if (file%exists('lon')) then + call file%get('lon', longitude_rad) + longitude_rad = longitude_rad * Pi/180.0_jprb + else + allocate(longitude_rad(ncol)) + longitude_rad = 0.0_jprb + end if + + ! Close input file + call file%close() + + ! Convert gas units to mass-mixing ratio + call gas%set_units(IMassMixingRatio) + + ! Compute seed from skin temperature residual + ! single_level%iseed = int(1.0e9*(single_level%skin_temperature & + ! & -int(single_level%skin_temperature))) + + ! Set first and last columns to process + if (driver_config%iendcol < 1 .or. driver_config%iendcol > ncol) then + driver_config%iendcol = ncol + end if + + if (driver_config%istartcol > driver_config%iendcol) then + write(nulout,'(a,i0,a,i0,a,i0,a)') '*** Error: requested column range (', & + & driver_config%istartcol, & + & ' to ', driver_config%iendcol, ') is out of the range in the data (1 to ', & + & ncol, ')' + stop 1 + end if + + ! -------------------------------------------------------- + ! Section 4: Call radiation scheme + ! -------------------------------------------------------- + + ! Compute saturation with respect to liquid (needed for aerosol + ! hydration) call + ! call thermodynamics%calc_saturation_wrt_liquid(driver_config%istartcol,driver_config%iendcol) + + ! Check inputs are within physical bounds, printing message if not + is_out_of_bounds = gas%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. single_level%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. thermodynamics%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. cloud%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. aerosol%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) + + ! Allocate memory for the flux profiles, which may include arrays + ! of dimension n_bands_sw/n_bands_lw, so must be called after + ! setup_radiation + call flux%allocate(yradiation%rad_config, 1, ncol, nlev) + + ! set relevant fluxes to zero + flux%lw_up(:,:) = 0._jprb + flux%lw_dn(:,:) = 0._jprb + flux%sw_up(:,:) = 0._jprb + flux%sw_dn(:,:) = 0._jprb + flux%sw_dn_direct(:,:) = 0._jprb + flux%lw_up_clear(:,:) = 0._jprb + flux%lw_dn_clear(:,:) = 0._jprb + flux%sw_up_clear(:,:) = 0._jprb + flux%sw_dn_clear(:,:) = 0._jprb + flux%sw_dn_direct_clear(:,:) = 0._jprb + + flux%lw_dn_surf_canopy(:,:) = 0._jprb + flux%sw_dn_diffuse_surf_canopy(:,:) = 0._jprb + flux%sw_dn_direct_surf_canopy(:,:) = 0._jprb + flux%lw_derivatives(:,:) = 0._jprb + + ! Allocate memory for additional arrays + allocate(ccn_land(ncol)) + allocate(ccn_sea(ncol)) + allocate(land_frac(ncol)) + allocate(pressure_fl(ncol,nlev)) + allocate(temperature_fl(ncol,nlev)) + allocate(zeros(ncol,nlev)) + allocate(tegen_aerosol(ncol,6,nlev)) + allocate(flux_sw_direct_normal(ncol)) + allocate(flux_uv(ncol)) + allocate(flux_par(ncol)) + allocate(flux_par_clear(ncol)) + allocate(flux_incoming(ncol)) + allocate(emissivity_out(ncol)) + allocate(flux_diffuse_band(ncol,yradiation%yrerad%nsw)) + allocate(flux_direct_band(ncol,yradiation%yrerad%nsw)) + allocate(cloud_fraction(ncol,nlev)) + allocate(cloud_q_liq(ncol,nlev)) + allocate(cloud_q_ice(ncol,nlev)) + + ccn_land = yradiation%yrerad%rccnlnd + ccn_sea = yradiation%yrerad%rccnsea + tegen_aerosol = 0.0_jprb + pressure_fl = 0.5_jprb * (thermodynamics%pressure_hl(:,1:nlev)+thermodynamics%pressure_hl(:,2:nlev+1)) + temperature_fl = 0.5_jprb * (thermodynamics%temperature_hl(:,1:nlev)+thermodynamics%temperature_hl(:,2:nlev+1)) + zeros = 0.0_jprb ! Dummy snow/rain water mixing ratios + + if (yradiation%rad_config%do_clouds) then + cloud_fraction = cloud%fraction + cloud_q_liq = cloud%q_liq + cloud_q_ice = cloud%q_ice + else + cloud_fraction = 0.0_jprb + cloud_q_liq = 0.0_jprb + cloud_q_ice = 0.0_jprb + endif + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') 'Performing radiative transfer calculations' + end if + + ! Option of repeating calculation multiple time for more accurate + ! profiling +#ifndef NO_OPENMP + tstart = omp_get_wtime() +#endif + do jrepeat = 1,driver_config%nrepeat + +! if (driver_config%do_parallel) then + ! Run radiation scheme over blocks of columns in parallel + + ! Compute number of blocks to process + nblock = (driver_config%iendcol - driver_config%istartcol & + & + driver_config%nblocksize) / driver_config%nblocksize + + !$OMP PARALLEL DO PRIVATE(istartcol, iendcol) SCHEDULE(RUNTIME) + do jblock = 1, nblock + ! Specify the range of columns to process. + istartcol = (jblock-1) * driver_config%nblocksize & + & + driver_config%istartcol + iendcol = min(istartcol + driver_config%nblocksize - 1, & + & driver_config%iendcol) + + if (driver_config%iverbose >= 3) then +#ifndef NO_OPENMP + write(nulout,'(a,i0,a,i0,a,i0)') 'Thread ', omp_get_thread_num(), & + & ' processing columns ', istartcol, '-', iendcol +#else + write(nulout,'(a,i0,a,i0)') 'Processing columns ', istartcol, '-', iendcol +#endif + end if + + ! Call the ECRAD radiation scheme; note that we are simply + ! passing arrays in rather than ecRad structures, which are + ! used here just for convenience + call radiation_scheme(yradiation, istartcol, iendcol, ncol, nlev, size(aerosol%mixing_ratio,3), & + & single_level%solar_irradiance, single_level%cos_sza, single_level%skin_temperature, & + & single_level%sw_albedo, single_level%sw_albedo_direct, single_level%lw_emissivity, & + & ccn_land, ccn_sea, longitude_rad, sin_latitude, land_frac, pressure_fl, temperature_fl, & + & thermodynamics%pressure_hl, thermodynamics%temperature_hl, & + & gas%mixing_ratio(:,:,IH2O), gas%mixing_ratio(:,:,ICO2), & + & gas%mixing_ratio(:,:,ICH4), gas%mixing_ratio(:,:,IN2O), gas%mixing_ratio(:,:,INO2), & + & gas%mixing_ratio(:,:,ICFC11), gas%mixing_ratio(:,:,ICFC12), gas%mixing_ratio(:,:,IHCFC22), & + & gas%mixing_ratio(:,:,ICCl4), gas%mixing_ratio(:,:,IO3), cloud_fraction, cloud_q_liq, & + & cloud_q_ice, zeros, zeros, tegen_aerosol, aerosol%mixing_ratio, flux%sw_up, flux%lw_up, & + & flux%sw_up_clear, flux%lw_up_clear, flux%sw_dn(:,nlev+1), flux%lw_dn(:,nlev+1), & + & flux%sw_dn_clear(:,nlev+1), flux%lw_dn_clear(:,nlev+1), & + & flux%sw_dn_direct(:,nlev+1), flux%sw_dn_direct_clear(:,nlev+1), flux_sw_direct_normal, & + & flux_uv, flux_par, & + & flux_par_clear, flux%sw_dn(:,1), emissivity_out, flux%lw_derivatives, flux_diffuse_band, & + & flux_direct_band) + end do + !$OMP END PARALLEL DO + +! else + ! Run radiation scheme serially +! if (driver_config%iverbose >= 3) then +! write(nulout,'(a,i0,a)') 'Processing ', ncol, ' columns' +! end if + + ! Call the ECRAD radiation scheme +! call radiation_scheme(ncol, nlev, driver_config%istartcol, driver_config%iendcol, & +! & config, single_level, thermodynamics, gas, cloud, aerosol, flux) + +! end if + + end do + + ! "up" fluxes are actually net fluxes at this point - we modify the + ! upwelling flux so that net=dn-up, while the TOA and surface + ! downwelling fluxes are correct. + flux%sw_up = -flux%sw_up + flux%sw_up(:,1) = flux%sw_up(:,1)+flux%sw_dn(:,1) + flux%sw_up(:,nlev+1) = flux%sw_up(:,nlev+1)+flux%sw_dn(:,nlev+1) + + flux%lw_up = -flux%lw_up + flux%lw_up(:,1) = flux%lw_up(:,1)+flux%lw_dn(:,1) + flux%lw_up(:,nlev+1) = flux%lw_up(:,nlev+1)+flux%lw_dn(:,nlev+1) + + flux%sw_up_clear = -flux%sw_up_clear + flux%sw_up_clear(:,1) = flux%sw_up_clear(:,1)+flux%sw_dn_clear(:,1) + flux%sw_up_clear(:,nlev+1) = flux%sw_up_clear(:,nlev+1)+flux%sw_dn_clear(:,nlev+1) + + flux%lw_up_clear = -flux%lw_up_clear + flux%lw_up_clear(:,1) = flux%lw_up_clear(:,1)+flux%lw_dn_clear(:,1) + flux%lw_up_clear(:,nlev+1) = flux%lw_up_clear(:,nlev+1)+flux%lw_dn_clear(:,nlev+1) + +#ifndef NO_OPENMP + tstop = omp_get_wtime() + write(nulout, '(a,g12.5,a)') 'Time elapsed in radiative transfer: ', tstop-tstart, ' seconds' +#endif + + ! -------------------------------------------------------- + ! Section 5: Check and save output + ! -------------------------------------------------------- + + ! This is unreliable because only the net fluxes are valid: + !is_out_of_bounds = flux%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol) + + ! Store the fluxes in the output file + yradiation%rad_config%do_surface_sw_spectral_flux = .false. + yradiation%rad_config%do_canopy_fluxes_sw = .false. + yradiation%rad_config%do_canopy_fluxes_lw = .false. + + call save_net_fluxes(file_name, yradiation%rad_config, thermodynamics, flux, & + & iverbose=driver_config%iverbose, is_hdf5_file=driver_config%do_write_hdf5, & + & experiment_name=driver_config%experiment_name, & + & is_double_precision=driver_config%do_write_double_precision) + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') '------------------------------------------------------------------------------------' + end if + +end program ecrad_ifs_driver Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_ifs_driver_blocked.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_ifs_driver_blocked.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ecrad_ifs_driver_blocked.F90 (revision 6016) @@ -0,0 +1,501 @@ +! ecrad_ifs_driver_blocked.F90 - Driver for offline ECRAD radiation scheme +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! ECRAD is the radiation scheme used in the ECMWF Integrated +! Forecasting System in cycle 43R3 and later. Several solvers are +! available, including McICA, Tripleclouds and SPARTACUS (the Speedy +! Algorithm for Radiative Transfer through Cloud Sides, a modification +! of the two-stream formulation of shortwave and longwave radiative +! transfer to account for 3D radiative effects). Gas optical +! properties are provided by the RRTM-G gas optics scheme. + +! This program takes three arguments: +! 1) Namelist file to configure the radiation calculation, but note +! that only the radiation_config group is read +! 2) Name of a NetCDF file containing one or more atmospheric profiles +! 3) Name of output NetCDF file +! +! This version uses the infrastructure of the IFS, such as computing +! effective radius and cloud overlap from latitude and other +! variables. To configure ecRad in this version you need to edit +! ifs/yoerad.F90 in the ecRad package, but these options can be +! overridden with the "radiation" namelist. This file requires the +! input data to have compatible settings, e.g. the right number of +! aerosol variables, and surface albedo/emissivity bands; a test file +! satisfying this requirement is test/ifs/ecrad_meridian.nc in the +! ecRad package. +! +! Note that the purpose of this file is simply to demonstrate the use +! of the setup_radiation_scheme and radiation_scheme routines as well +! as the use of a blocked memory layout to improve cache efficiency; +! all the rest is using the offline ecRad driver containers to read +! a NetCDF file to memory and pass it into these routines. + +program ecrad_ifs_driver + + ! -------------------------------------------------------- + ! Section 1: Declarations + ! -------------------------------------------------------- + use parkind1, only : jprb, jprd ! Working/double precision + + use radiation_io, only : nulout + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type, IMassMixingRatio, & + & IH2O, ICO2, IO3, IN2O, INO2, ICO, ICH4, IO2, ICFC11, ICFC12, & + & IHCFC22, ICCl4 + use radiation_cloud, only : cloud_type + use radiation_aerosol, only : aerosol_type + use radiation_flux, only : flux_type + use radiation_save, only : save_net_fluxes + use radiation_setup, only : tradiation, setup_radiation_scheme + use radiation_constants, only : Pi + use ecrad_driver_config, only : driver_config_type + use ecrad_driver_read_input, only : read_input + use easy_netcdf + use ifs_blocking + + implicit none + +#include "radiation_scheme.intfb.h" + + ! The NetCDF file containing the input profiles + type(netcdf_file) :: file + + ! Configuration for the radiation scheme, IFS style + type(tradiation) :: yradiation + + ! Derived types for the inputs to the radiation scheme + type(single_level_type) :: single_level + type(thermodynamics_type) :: thermodynamics + type(gas_type) :: gas + type(cloud_type) :: cloud + type(aerosol_type) :: aerosol + + ! Configuration specific to this driver + type(driver_config_type) :: driver_config + + ! Derived type containing outputs from the radiation scheme + type(flux_type) :: flux + + ! Additional arrays passed to radiation_scheme + real(jprb), allocatable, dimension(:) :: ccn_land, ccn_sea, sin_latitude, longitude_rad, land_frac + real(jprb), allocatable, dimension(:,:) :: pressure_fl, temperature_fl + real(jprb), allocatable, dimension(:) :: flux_sw_direct_normal, flux_uv, flux_par, flux_par_clear, & + & emissivity_out + real(jprb), allocatable, dimension(:,:) :: flux_diffuse_band, flux_direct_band + + ! Bespoke data types to set-up the blocked memory layout + type(ifs_config_type) :: ifs_config + real(kind=jprb), allocatable :: zrgp(:,:,:) ! monolithic IFS data structure + integer, allocatable :: iseed(:,:) ! Seed for random number generator + + integer :: ncol, nlev ! Number of columns and levels + integer :: nproma ! block size + + ! Name of file names specified on command line + character(len=512) :: file_name + integer :: istatus ! Result of command_argument_count + +#ifndef NO_OPENMP + ! OpenMP functions + integer, external :: omp_get_thread_num + real(kind=jprd), external :: omp_get_wtime + ! Start/stop time in seconds + real(kind=jprd) :: tstart, tstop +#endif + + ! For demonstration of get_sw_weights later on + ! Ultraviolet weightings + !integer :: nweight_uv + !integer :: iband_uv(100) + !real(jprb) :: weight_uv(100) + ! Photosynthetically active radiation weightings + !integer :: nweight_par + !integer :: iband_par(100) + !real(jprb) :: weight_par(100) + + ! Loop index for repeats (for benchmarking) + integer :: jrepeat + + ! Loop index + integer :: jrl, ibeg, iend, il, ib + + ! Are any variables out of bounds? + logical :: is_out_of_bounds + +! integer :: iband(20), nweights +! real(jprb) :: weight(20) + + + ! -------------------------------------------------------- + ! Section 2: Configure + ! -------------------------------------------------------- + + ! Check program called with correct number of arguments + if (command_argument_count() < 3) then + stop 'Usage: ecrad config.nam input_file.nc output_file.nc' + end if + + ! Use namelist to configure the radiation calculation + call get_command_argument(1, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of namelist file as string of length < 512' + end if + + ! Read "radiation_driver" namelist into radiation driver config type + call driver_config%read(file_name) + nproma = driver_config%nblocksize + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') '-------------------------- OFFLINE ECRAD RADIATION SCHEME --------------------------' + write(nulout,'(a)') 'Copyright (C) 2014- ECMWF' + write(nulout,'(a)') 'Contact: Robin Hogan (r.j.hogan@ecmwf.int)' +#ifdef PARKIND1_SINGLE + write(nulout,'(a)') 'Floating-point precision: single' +#else + write(nulout,'(a)') 'Floating-point precision: double' +#endif + end if + + ! Albedo/emissivity intervals may be specified like this + !call config%define_sw_albedo_intervals(6, & + ! & [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, & + ! & 1.19_jprb, 2.38e-6_jprb], [1,2,3,4,5,6], & + ! & do_nearest=.false.) + !call config%define_lw_emiss_intervals(3, & + ! & [8.0e-6_jprb, 13.0e-6_jprb], [1,2,1], & + ! & do_nearest=.false.) + + ! If monochromatic aerosol properties are required, then the + ! wavelengths can be specified (in metres) as follows - these can be + ! whatever you like for the general aerosol optics, but must match + ! the monochromatic values in the aerosol input file for the older + ! aerosol optics + !call config%set_aerosol_wavelength_mono( & + ! & [3.4e-07_jprb, 3.55e-07_jprb, 3.8e-07_jprb, 4.0e-07_jprb, 4.4e-07_jprb, & + ! & 4.69e-07_jprb, 5.0e-07_jprb, 5.32e-07_jprb, 5.5e-07_jprb, 6.45e-07_jprb, & + ! & 6.7e-07_jprb, 8.0e-07_jprb, 8.58e-07_jprb, 8.65e-07_jprb, 1.02e-06_jprb, & + ! & 1.064e-06_jprb, 1.24e-06_jprb, 1.64e-06_jprb, 2.13e-06_jprb, 1.0e-05_jprb]) + + call yradiation%rad_config%read(file_name=file_name) + + ! Setup aerosols + if (yradiation%rad_config%use_aerosols) then + yradiation%yrerad%naermacc = 1 ! MACC-derived aerosol climatology on a NMCLAT x NMCLON grid + else + yradiation%yrerad%naermacc = 0 + endif + + ! Setup the radiation scheme: load the coefficients for gas and + ! cloud optics, currently from RRTMG + call setup_radiation_scheme(yradiation, .true., file_name=file_name) + ! Or call without specifying the namelist filename, in which case + ! the default settings are from yoerad.F90 + !call setup_radiation_scheme(yradiation, .true.) + + ! Demonstration of how to get weights for UV and PAR fluxes + !if (config%do_sw) then + ! call config%get_sw_weights(0.2e-6_jprb, 0.4415e-6_jprb,& + ! & nweight_uv, iband_uv, weight_uv,& + ! & 'ultraviolet') + ! call config%get_sw_weights(0.4e-6_jprb, 0.7e-6_jprb,& + ! & nweight_par, iband_par, weight_par,& + ! & 'photosynthetically active radiation, PAR') + !end if + + ! -------------------------------------------------------- + ! Section 3: Read input data file + ! -------------------------------------------------------- + + ! Get NetCDF input file name + call get_command_argument(2, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of input NetCDF file as string of length < 512' + end if + + ! Open the file and configure the way it is read + call file%open(trim(file_name), iverbose=driver_config%iverbose) + + ! Get NetCDF output file name + call get_command_argument(3, file_name, status=istatus) + if (istatus /= 0) then + stop 'Failed to read name of output NetCDF file as string of length < 512' + end if + + ! 2D arrays are assumed to be stored in the file with height varying + ! more rapidly than column index. Specifying "true" here transposes + ! all 2D arrays so that the column index varies fastest within the + ! program. + call file%transpose_matrices(.true.) + + ! Read input variables from NetCDF file, noting that cloud overlap + ! and effective radius are ignored + call read_input(file, yradiation%rad_config, driver_config, ncol, nlev, & + & single_level, thermodynamics, & + & gas, cloud, aerosol) + + ! Latitude is used for cloud overlap and ice effective radius + if (file%exists('lat')) then + call file%get('lat', sin_latitude) + sin_latitude = sin(sin_latitude * Pi/180.0_jprb) + else + allocate(sin_latitude(ncol)) + sin_latitude = 0.0_jprb + end if + + if (file%exists('lon')) then + call file%get('lon', longitude_rad) + longitude_rad = longitude_rad * Pi/180.0_jprb + else + allocate(longitude_rad(ncol)) + longitude_rad = 0.0_jprb + end if + + ! Close input file + call file%close() + + ! Convert gas units to mass-mixing ratio + call gas%set_units(IMassMixingRatio) + + ! Compute seed from skin temperature residual + ! single_level%iseed = int(1.0e9*(single_level%skin_temperature & + ! & -int(single_level%skin_temperature))) + + ! Set first and last columns to process + if (driver_config%iendcol < 1 .or. driver_config%iendcol > ncol) then + driver_config%iendcol = ncol + end if + + if (driver_config%istartcol > driver_config%iendcol) then + write(nulout,'(a,i0,a,i0,a,i0,a)') '*** Error: requested column range (', & + & driver_config%istartcol, & + & ' to ', driver_config%iendcol, ') is out of the range in the data (1 to ', & + & ncol, ')' + stop 1 + end if + + ! -------------------------------------------------------- + ! Section 4: Call radiation scheme + ! -------------------------------------------------------- + + ! Compute saturation with respect to liquid (needed for aerosol + ! hydration) call + ! call thermodynamics%calc_saturation_wrt_liquid(driver_config%istartcol,driver_config%iendcol) + + ! Check inputs are within physical bounds, printing message if not + is_out_of_bounds = gas%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. single_level%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. thermodynamics%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. cloud%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) & + & .or. aerosol%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol, & + & driver_config%do_correct_unphysical_inputs) + + ! Allocate memory for the flux profiles, which may include arrays + ! of dimension n_bands_sw/n_bands_lw, so must be called after + ! setup_radiation + call flux%allocate(yradiation%rad_config, 1, ncol, nlev) + + ! set relevant fluxes to zero + flux%lw_up(:,:) = 0._jprb + flux%lw_dn(:,:) = 0._jprb + flux%sw_up(:,:) = 0._jprb + flux%sw_dn(:,:) = 0._jprb + flux%sw_dn_direct(:,:) = 0._jprb + flux%lw_up_clear(:,:) = 0._jprb + flux%lw_dn_clear(:,:) = 0._jprb + flux%sw_up_clear(:,:) = 0._jprb + flux%sw_dn_clear(:,:) = 0._jprb + flux%sw_dn_direct_clear(:,:) = 0._jprb + + flux%lw_dn_surf_canopy(:,:) = 0._jprb + flux%sw_dn_diffuse_surf_canopy(:,:) = 0._jprb + flux%sw_dn_direct_surf_canopy(:,:) = 0._jprb + flux%lw_derivatives(:,:) = 0._jprb + + ! Allocate memory for additional arrays + allocate(ccn_land(ncol)) + allocate(ccn_sea(ncol)) + allocate(land_frac(ncol)) + allocate(pressure_fl(ncol,nlev)) + allocate(temperature_fl(ncol,nlev)) + allocate(flux_sw_direct_normal(ncol)) + allocate(flux_uv(ncol)) + allocate(flux_par(ncol)) + allocate(flux_par_clear(ncol)) + allocate(emissivity_out(ncol)) + allocate(flux_diffuse_band(ncol,yradiation%yrerad%nsw)) + allocate(flux_direct_band(ncol,yradiation%yrerad%nsw)) + + ccn_land = yradiation%yrerad%rccnlnd + ccn_sea = yradiation%yrerad%rccnsea + pressure_fl = 0.5_jprb * (thermodynamics%pressure_hl(:,1:nlev)+thermodynamics%pressure_hl(:,2:nlev+1)) + temperature_fl = 0.5_jprb * (thermodynamics%temperature_hl(:,1:nlev)+thermodynamics%temperature_hl(:,2:nlev+1)) + + ! -------------------------------------------------------- + ! Section 4a: Reshuffle into blocked memory layout + ! -------------------------------------------------------- + + call ifs_setup_indices(driver_config, ifs_config, yradiation, nlev) + call ifs_copy_inputs_to_blocked(driver_config, ifs_config, yradiation,& + & ncol, nlev, single_level, thermodynamics, gas, cloud, aerosol,& + & sin_latitude, longitude_rad, land_frac, pressure_fl, temperature_fl,& + & zrgp, iseed=iseed) + + ! -------------------------------------------------------- + ! Section 4b: Call radiation_scheme with blocked memory data + ! -------------------------------------------------------- + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') 'Performing radiative transfer calculations' + end if + + ! Option of repeating calculation multiple time for more accurate + ! profiling +#ifndef NO_OPENMP + tstart = omp_get_wtime() +#endif + do jrepeat = 1,driver_config%nrepeat + +! if (driver_config%do_parallel) then + ! Run radiation scheme over blocks of columns in parallel + + !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& + !$OMP&PRIVATE(JRL,IBEG,IEND,IL,IB) + do jrl=1,ncol,nproma + ibeg=jrl + iend=min(ibeg+nproma-1,ncol) + il=iend-ibeg+1 + ib=(jrl-1)/nproma+1 + + if (driver_config%iverbose >= 3) then +#ifndef NO_OPENMP + write(nulout,'(a,i0,a,i0,a,i0)') 'Thread ', omp_get_thread_num(), & + & ' processing columns ', ibeg, '-', iend +#else + write(nulout,'(a,i0,a,i0)') 'Processing columns ', ibeg, '-', iend +#endif + end if + + ! Call the ECRAD radiation scheme + call radiation_scheme & + & (yradiation, & + & 1, il, nproma, & ! startcol, endcol, ncol + & nlev, size(aerosol%mixing_ratio,3), & ! nlev, naerosols + & single_level%solar_irradiance, & ! solar_irrad + ! array inputs + & zrgp(1,ifs_config%iamu0,ib), zrgp(1,ifs_config%its,ib), & ! mu0, skintemp + & zrgp(1,ifs_config%iald,ib) , zrgp(1,ifs_config%ialp,ib), & ! albedo_dif, albedo_dir + & zrgp(1,ifs_config%iemiss,ib), & ! spectral emissivity + & zrgp(1,ifs_config%iccnl,ib), zrgp(1,ifs_config%iccno,ib) ,& ! CCN concentration, land and sea + & zrgp(1,ifs_config%igelam,ib),zrgp(1,ifs_config%igemu,ib), & ! longitude, sine of latitude + & zrgp(1,ifs_config%islm,ib), & ! land sea mask + & zrgp(1,ifs_config%ipr,ib), zrgp(1,ifs_config%iti,ib), & ! full level pressure and temperature + & zrgp(1,ifs_config%iaprs,ib), zrgp(1,ifs_config%ihti,ib), & ! half-level pressure and temperature + & zrgp(1,ifs_config%iwv,ib), zrgp(1,ifs_config%iico2,ib), & + & zrgp(1,ifs_config%iich4,ib), zrgp(1,ifs_config%iin2o,ib), & + & zrgp(1,ifs_config%ino2,ib), zrgp(1,ifs_config%ic11,ib), & + & zrgp(1,ifs_config%ic12,ib), zrgp(1,ifs_config%ic22,ib), & + & zrgp(1,ifs_config%icl4,ib), zrgp(1,ifs_config%ioz,ib), & + & zrgp(1,ifs_config%iclc,ib), zrgp(1,ifs_config%ilwa,ib), & + & zrgp(1,ifs_config%iiwa,ib), zrgp(1,ifs_config%irwa,ib), & + & zrgp(1,ifs_config%iswa,ib), & + & zrgp(1,ifs_config%iaer,ib), zrgp(1,ifs_config%iaero,ib), & + ! flux outputs + & zrgp(1,ifs_config%ifrso,ib), zrgp(1,ifs_config%ifrth,ib), & + & zrgp(1,ifs_config%iswfc,ib), zrgp(1,ifs_config%ilwfc,ib),& + & zrgp(1,ifs_config%ifrsod,ib),zrgp(1,ifs_config%ifrted,ib), & + & zrgp(1,ifs_config%ifrsodc,ib),zrgp(1,ifs_config%ifrtedc,ib),& + & zrgp(1,ifs_config%ifdir,ib), zrgp(1,ifs_config%icdir,ib), & + & zrgp(1,ifs_config%isudu,ib), & + & zrgp(1,ifs_config%iuvdf,ib), zrgp(1,ifs_config%iparf,ib), & + & zrgp(1,ifs_config%iparcf,ib),zrgp(1,ifs_config%itincf,ib), & + & zrgp(1,ifs_config%iemit,ib) ,zrgp(1,ifs_config%ilwderivative,ib), & + & zrgp(1,ifs_config%iswdiffuseband,ib), zrgp(1,ifs_config%iswdirectband,ib)& + & ) + end do + !$OMP END PARALLEL DO + +! else + ! Run radiation scheme serially +! if (driver_config%iverbose >= 3) then +! write(nulout,'(a,i0,a)') 'Processing ', ncol, ' columns' +! end if + + ! Call the ECRAD radiation scheme +! call radiation_scheme(ncol, nlev, driver_config%istartcol, driver_config%iendcol, & +! & config, single_level, thermodynamics, gas, cloud, aerosol, flux) + +! end if + + end do + +#ifndef NO_OPENMP + tstop = omp_get_wtime() + write(nulout, '(a,g12.5,a)') 'Time elapsed in radiative transfer: ', tstop-tstart, ' seconds' +#endif + + ! -------------------------------------------------------- + ! Section 4c: Copy fluxes from blocked memory data + ! -------------------------------------------------------- + + call ifs_copy_fluxes_from_blocked(driver_config, ifs_config, yradiation, ncol, nlev,& + & zrgp, flux, flux_sw_direct_normal, flux_uv, flux_par, flux_par_clear, & + & emissivity_out, flux_diffuse_band, flux_direct_band) + + ! "up" fluxes are actually net fluxes at this point - we modify the + ! upwelling flux so that net=dn-up, while the TOA and surface + ! downwelling fluxes are correct. + flux%sw_up = -flux%sw_up + flux%sw_up(:,1) = flux%sw_up(:,1)+flux%sw_dn(:,1) + flux%sw_up(:,nlev+1) = flux%sw_up(:,nlev+1)+flux%sw_dn(:,nlev+1) + + flux%lw_up = -flux%lw_up + flux%lw_up(:,1) = flux%lw_up(:,1)+flux%lw_dn(:,1) + flux%lw_up(:,nlev+1) = flux%lw_up(:,nlev+1)+flux%lw_dn(:,nlev+1) + + flux%sw_up_clear = -flux%sw_up_clear + flux%sw_up_clear(:,1) = flux%sw_up_clear(:,1)+flux%sw_dn_clear(:,1) + flux%sw_up_clear(:,nlev+1) = flux%sw_up_clear(:,nlev+1)+flux%sw_dn_clear(:,nlev+1) + + flux%lw_up_clear = -flux%lw_up_clear + flux%lw_up_clear(:,1) = flux%lw_up_clear(:,1)+flux%lw_dn_clear(:,1) + flux%lw_up_clear(:,nlev+1) = flux%lw_up_clear(:,nlev+1)+flux%lw_dn_clear(:,nlev+1) + + ! -------------------------------------------------------- + ! Section 5: Check and save output + ! -------------------------------------------------------- + + ! This is unreliable because only the net fluxes are valid: + !is_out_of_bounds = flux%out_of_physical_bounds(driver_config%istartcol, driver_config%iendcol) + + ! Store the fluxes in the output file + yradiation%rad_config%do_surface_sw_spectral_flux = .false. + yradiation%rad_config%do_canopy_fluxes_sw = .false. + yradiation%rad_config%do_canopy_fluxes_lw = .false. + + call save_net_fluxes(file_name, yradiation%rad_config, thermodynamics, flux, & + & iverbose=driver_config%iverbose, is_hdf5_file=driver_config%do_write_hdf5, & + & experiment_name=driver_config%experiment_name, & + & is_double_precision=driver_config%do_write_double_precision) + + if (driver_config%iverbose >= 2) then + write(nulout,'(a)') '------------------------------------------------------------------------------------' + end if + +end program ecrad_ifs_driver Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ifs_blocking.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ifs_blocking.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/ifs_blocking.F90 (revision 6016) @@ -0,0 +1,577 @@ +! ifs_blocking.F90 - Reshuffle ecRad data into an NPROMA-blocked data structure +! +! (C) Copyright 2022- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Balthasar Reuter +! Email: balthasar.reuter@ecmwf.int +! + +module ifs_blocking + + use parkind1, only : jprb, jpim ! Working precision, integer type + + implicit none + + public + + type :: ifs_config_type + ! Offsets in ZRGP + integer :: igi, imu0, iamu0, iemiss, its, islm, iccnl, & + & ibas, itop, igelam, igemu, iclon, islon, iald, ialp, iti, ipr, iqs, iwv, iclc, ilwa, & + & iiwa, iswa, irwa, irra, idp, ioz, iecpo3, ihpr, iaprs, ihti, iaero, ifrsod, icdir, & + & ifrted, ifrsodc, ifrtedc, iemit, isudu, iuvdf, iparf, iparcf, itincf, ifdir, ifdif, & + & ilwderivative, iswdirectband, iswdiffuseband, ifrso, iswfc, ifrth, ilwfc, iaer, & + & iich4, iin2o, ino2, ic11, ic12, igix, iico2, iccno, ic22, icl4 + integer :: ire_liq, ire_ice, ioverlap + integer :: ifldstot + end type ifs_config_type + +contains + +integer(kind=jpim) function indrad(knext,kflds,lduse) + + integer(kind=jpim), intent(inout) :: knext + integer(kind=jpim), intent(in) :: kflds + logical, intent(in) :: lduse + + if( lduse ) then + indrad=knext + knext=knext+kflds + else + indrad=-99999999 + endif + +end function indrad + +subroutine ifs_setup_indices (driver_config, ifs_config, yradiation, nlev) + + use radiation_io, only : nulout + use ecrad_driver_config, only : driver_config_type + use radiation_setup, only : tradiation + + ! Configuration specific to this driver + type(driver_config_type), intent(in) :: driver_config + type(ifs_config_type), intent(inout) :: ifs_config + + ! Configuration for the radiation scheme, IFS style + type(tradiation), intent(inout) :: yradiation + + integer, intent(inout) :: nlev + + integer :: ifldsin, ifldsout, inext, iinbeg, iinend, ioutbeg, ioutend + logical :: llactaero + logical :: lldebug + + ! Extract some config values + lldebug=(driver_config%iverbose>4) ! debug + llactaero = .false. + if(yradiation%rad_config%n_aerosol_types > 0 .and.& + & yradiation%rad_config%n_aerosol_types <= 21 .and. yradiation%yrerad%naermacc == 0) then + llactaero = .true. + endif + + ! + ! RADINTG + ! + + ! INITIALISE INDICES FOR VARIABLE + + ! INDRAD is a CONTAIN'd function (now a module function) + + inext =1 + iinbeg =1 ! start of input variables + ifs_config%igi =indrad(inext,1,lldebug) + ifs_config%imu0 =indrad(inext,1,.true.) + ifs_config%iamu0 =indrad(inext,1,.true.) + ifs_config%iemiss =indrad(inext,yradiation%yrerad%nlwemiss,.true.) + ifs_config%its =indrad(inext,1,.true.) + ifs_config%islm =indrad(inext,1,.true.) + ifs_config%iccnl =indrad(inext,1,.true.) + ifs_config%iccno =indrad(inext,1,.true.) + ifs_config%ibas =indrad(inext,1,.true.) + ifs_config%itop =indrad(inext,1,.true.) + ifs_config%igelam =indrad(inext,1,.true.) + ifs_config%igemu =indrad(inext,1,.true.) + ifs_config%iclon =indrad(inext,1,.true.) + ifs_config%islon =indrad(inext,1,.true.) + ifs_config%iald =indrad(inext,yradiation%yrerad%nsw,.true.) + ifs_config%ialp =indrad(inext,yradiation%yrerad%nsw,.true.) + ifs_config%iti =indrad(inext,nlev,.true.) + ifs_config%ipr =indrad(inext,nlev,.true.) + ifs_config%iqs =indrad(inext,nlev,.true.) + ifs_config%iwv =indrad(inext,nlev,.true.) + ifs_config%iclc =indrad(inext,nlev,.true.) + ifs_config%ilwa =indrad(inext,nlev,.true.) + ifs_config%iiwa =indrad(inext,nlev,.true.) + ifs_config%iswa =indrad(inext,nlev,.true.) + ifs_config%irwa =indrad(inext,nlev,.true.) + ifs_config%irra =indrad(inext,nlev,.true.) + ifs_config%idp =indrad(inext,nlev,.true.) + ifs_config%ioz =indrad(inext,nlev,.false.) + ifs_config%iecpo3 =indrad(inext,nlev ,.false.) + ifs_config%ihpr =indrad(inext,nlev+1,.true.) ! not used in ecrad + ifs_config%iaprs =indrad(inext,nlev+1,.true.) + ifs_config%ihti =indrad(inext,nlev+1,.true.) + ifs_config%iaero =indrad(inext,yradiation%rad_config%n_aerosol_types*nlev,& + & llactaero .and. yradiation%yrerad%naermacc==0) + + iinend =inext-1 ! end of input variables + + ioutbeg=inext ! start of output variables + if (yradiation%yrerad%naermacc == 1) then + ifs_config%iaero = indrad(inext,yradiation%rad_config%n_aerosol_types*nlev,& + & yradiation%yrerad%ldiagforcing) + endif + ifs_config%ifrsod =indrad(inext,1,.true.) + ifs_config%ifrted =indrad(inext,yradiation%yrerad%nlwout,.true.) + ifs_config%ifrsodc=indrad(inext,1,.true.) + ifs_config%ifrtedc=indrad(inext,1,.true.) + ifs_config%iemit =indrad(inext,1,.true.) + ifs_config%isudu =indrad(inext,1,.true.) + ifs_config%iuvdf =indrad(inext,1,.true.) + ifs_config%iparf =indrad(inext,1,.true.) + ifs_config%iparcf =indrad(inext,1,.true.) + ifs_config%itincf =indrad(inext,1,.true.) + ifs_config%ifdir =indrad(inext,1,.true.) + ifs_config%ifdif =indrad(inext,1,.true.) + ifs_config%icdir =indrad(inext,1,.true.) + ifs_config%ilwderivative =indrad(inext,nlev+1, yradiation%yrerad%lapproxlwupdate) + ifs_config%iswdirectband =indrad(inext,yradiation%yrerad%nsw,yradiation%yrerad%lapproxswupdate) + ifs_config%iswdiffuseband=indrad(inext,yradiation%yrerad%nsw,yradiation%yrerad%lapproxswupdate) + ifs_config%ifrso =indrad(inext,nlev+1,.true.) + ifs_config%iswfc =indrad(inext,nlev+1,.true.) + ifs_config%ifrth =indrad(inext,nlev+1,.true.) + ifs_config%ilwfc =indrad(inext,nlev+1,.true.) + ifs_config%iaer =indrad(inext,6*nlev,yradiation%yrerad%ldiagforcing) + ifs_config%ioz =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%iico2 =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%iich4 =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%iin2o =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%ino2 =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%ic11 =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%ic12 =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%ic22 =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%icl4 =indrad(inext,nlev,yradiation%yrerad%ldiagforcing) + ifs_config%igix =indrad(inext,1,lldebug) + + ioutend=inext-1 ! end of output variables + + ! start of local variables + if(.not.yradiation%yrerad%ldiagforcing) then + if (yradiation%rad_config%n_aerosol_types == 0 .or. yradiation%yrerad%naermacc == 1) then + ifs_config%iaero = indrad(inext,yradiation%rad_config%n_aerosol_types*nlev,.true.) + endif + ifs_config%iaer =indrad(inext,nlev*6,.true.) + ifs_config%ioz =indrad(inext,nlev,.true.) + ifs_config%iico2 =indrad(inext,nlev,.true.) + ifs_config%iich4 =indrad(inext,nlev,.true.) + ifs_config%iin2o =indrad(inext,nlev,.true.) + ifs_config%ino2 =indrad(inext,nlev,.true.) + ifs_config%ic11 =indrad(inext,nlev,.true.) + ifs_config%ic12 =indrad(inext,nlev,.true.) + ifs_config%ic22 =indrad(inext,nlev,.true.) + ifs_config%icl4 =indrad(inext,nlev,.true.) + endif + ! end of local variables + + ! start of standalone inputs workaround variables + ifs_config%ire_liq =indrad(inext,nlev,.true.) + ifs_config%ire_ice =indrad(inext,nlev,.true.) + ifs_config%ioverlap =indrad(inext,nlev-1,.true.) + ! end of standalone inputs workaround variables + + ifldsin = iinend - iinbeg +1 + ifldsout= ioutend-ioutbeg +1 + ifs_config%ifldstot= inext - 1 + + if( lldebug )then + write(nulout,'("imu0 =",i0)')ifs_config%imu0 + write(nulout,'("iamu0 =",i0)')ifs_config%iamu0 + write(nulout,'("iemiss =",i0)')ifs_config%iemiss + write(nulout,'("its =",i0)')ifs_config%its + write(nulout,'("islm =",i0)')ifs_config%islm + write(nulout,'("iccnl =",i0)')ifs_config%iccnl + write(nulout,'("iccno =",i0)')ifs_config%iccno + write(nulout,'("ibas =",i0)')ifs_config%ibas + write(nulout,'("itop =",i0)')ifs_config%itop + write(nulout,'("igelam =",i0)')ifs_config%igelam + write(nulout,'("igemu =",i0)')ifs_config%igemu + write(nulout,'("iclon =",i0)')ifs_config%iclon + write(nulout,'("islon =",i0)')ifs_config%islon + write(nulout,'("iald =",i0)')ifs_config%iald + write(nulout,'("ialp =",i0)')ifs_config%ialp + write(nulout,'("iti =",i0)')ifs_config%iti + write(nulout,'("ipr =",i0)')ifs_config%ipr + write(nulout,'("iqs =",i0)')ifs_config%iqs + write(nulout,'("iwv =",i0)')ifs_config%iwv + write(nulout,'("iclc =",i0)')ifs_config%iclc + write(nulout,'("ilwa =",i0)')ifs_config%ilwa + write(nulout,'("iiwa =",i0)')ifs_config%iiwa + write(nulout,'("iswa =",i0)')ifs_config%iswa + write(nulout,'("irwa =",i0)')ifs_config%irwa + write(nulout,'("irra =",i0)')ifs_config%irra + write(nulout,'("idp =",i0)')ifs_config%idp + write(nulout,'("ioz =",i0)')ifs_config%ioz + write(nulout,'("iecpo3 =",i0)')ifs_config%iecpo3 + write(nulout,'("ihpr =",i0)')ifs_config%ihpr + write(nulout,'("iaprs =",i0)')ifs_config%iaprs + write(nulout,'("ihti =",i0)')ifs_config%ihti + write(nulout,'("ifrsod =",i0)')ifs_config%ifrsod + write(nulout,'("ifrted =",i0)')ifs_config%ifrted + write(nulout,'("ifrsodc=",i0)')ifs_config%ifrsodc + write(nulout,'("ifrtedc=",i0)')ifs_config%ifrtedc + write(nulout,'("iemit =",i0)')ifs_config%iemit + write(nulout,'("isudu =",i0)')ifs_config%isudu + write(nulout,'("iuvdf =",i0)')ifs_config%iuvdf + write(nulout,'("iparf =",i0)')ifs_config%iparf + write(nulout,'("iparcf =",i0)')ifs_config%iparcf + write(nulout,'("itincf =",i0)')ifs_config%itincf + write(nulout,'("ifdir =",i0)')ifs_config%ifdir + write(nulout,'("ifdif =",i0)')ifs_config%ifdif + write(nulout,'("icdir =",i0)')ifs_config%icdir + write(nulout,'("ilwderivative =",i0)')ifs_config%ilwderivative + write(nulout,'("iswdirectband =",i0)')ifs_config%iswdirectband + write(nulout,'("iswdiffuseband =",i0)')ifs_config%iswdiffuseband + write(nulout,'("ifrso =",i0)')ifs_config%ifrso + write(nulout,'("iswfc =",i0)')ifs_config%iswfc + write(nulout,'("ifrth =",i0)')ifs_config%ifrth + write(nulout,'("ilwfc =",i0)')ifs_config%ilwfc + write(nulout,'("igi =",i0)')ifs_config%igi + write(nulout,'("iaer =",i0)')ifs_config%iaer + write(nulout,'("iaero =",i0)')ifs_config%iaero + write(nulout,'("iico2 =",i0)')ifs_config%iico2 + write(nulout,'("iich4 =",i0)')ifs_config%iich4 + write(nulout,'("iin2o =",i0)')ifs_config%iin2o + write(nulout,'("ino2 =",i0)')ifs_config%ino2 + write(nulout,'("ic11 =",i0)')ifs_config%ic11 + write(nulout,'("ic12 =",i0)')ifs_config%ic12 + write(nulout,'("ic22 =",i0)')ifs_config%ic22 + write(nulout,'("icl4 =",i0)')ifs_config%icl4 + write(nulout,'("ire_liq=",i0)')ifs_config%ire_liq + write(nulout,'("ire_ice=",i0)')ifs_config%ire_ice + write(nulout,'("ioverlap=",i0)')ifs_config%ioverlap + write(nulout,'("ifldsin =",i0)')ifldsin + write(nulout,'("ifldsout=",i0)')ifldsout + write(nulout,'("ifldstot=",i0)')ifs_config%ifldstot + endif + +end subroutine ifs_setup_indices + +subroutine ifs_copy_inputs_to_blocked ( & + & driver_config, ifs_config, yradiation, ncol, nlev, & + & single_level, thermodynamics, gas, cloud, aerosol, & + & sin_latitude, longitude_rad, land_frac, pressure_fl, temperature_fl, & + & zrgp, thermodynamics_out, iseed) + + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type, IMassMixingRatio, & + & IH2O, ICO2, IO3, IN2O, ICH4, ICFC11, ICFC12, IHCFC22, ICCL4 + use radiation_cloud, only : cloud_type + use radiation_aerosol, only : aerosol_type + use ecrad_driver_config, only : driver_config_type + use radiation_setup, only : tradiation + + implicit none + + ! Configuration specific to this driver + type(driver_config_type), intent(in) :: driver_config + + type(ifs_config_type), intent(in) :: ifs_config + + ! Configuration for the radiation scheme, IFS style + type(tradiation), intent(in) :: yradiation + + integer, intent(in) :: ncol, nlev ! Number of columns and levels + + ! Derived types for the inputs to the radiation scheme + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type), intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + type(cloud_type), intent(in) :: cloud + type(aerosol_type), intent(in) :: aerosol + + ! Additional input data, required for effective radii calculation + real(jprb), dimension(:), intent(in) :: sin_latitude, longitude_rad, land_frac + real(jprb), dimension(:,:), intent(in) :: pressure_fl, temperature_fl + + ! monolithic IFS data structure to pass to radiation scheme + real(kind=jprb), intent(out), allocatable :: zrgp(:,:,:) + + ! Empty thermodynamics type to store pressure_hl for output at the end + type(thermodynamics_type), intent(inout), optional :: thermodynamics_out + + ! Seed for random number generator + integer, intent(out), allocatable, optional :: iseed(:,:) + + ! number of column blocks, block size + integer :: ngpblks, nproma + + integer :: jrl, ibeg, iend, il, ib, ifld, jemiss, jalb, jlev, joff, jaer + + ! Extract some config values + nproma=driver_config%nblocksize ! nproma size + ngpblks=(ncol-1)/nproma+1 ! number of column blocks + + ! Allocate blocked data structure + allocate(zrgp(nproma,ifs_config%ifldstot,ngpblks)) + if(present(thermodynamics_out)) allocate(thermodynamics_out%pressure_hl(ncol,nlev+1)) + if(present(iseed)) allocate(iseed(nproma,ngpblks)) + + ! First touch + !$OMP PARALLEL DO SCHEDULE(RUNTIME)& + !$OMP&PRIVATE(IB,IFLD) + do ib=1,ngpblks + do ifld=1,ifs_config%ifldstot + zrgp(:,ifld,ib) = 0._jprb + enddo + if(present(iseed)) iseed(:,ib) = 0 + enddo + !$OMP END PARALLEL DO + + associate(yderad=>yradiation%yrerad, rad_config=>yradiation%rad_config) + + ! REPLACED ich4 with iich4 due to clash + ! REPLACED in2o with iin2o due to clash + ! REPLACED ico2 with iico2 due to clash + + ! ------------------------------------------------------- + ! + ! INPUT LOOP + ! + ! ------------------------------------------------------- + + !$OMP PARALLEL DO SCHEDULE(RUNTIME)& + !$OMP&PRIVATE(JRL,IBEG,IEND,IL,IB,JAER,JOFF,JLEV,JALB) + do jrl=1,ncol,nproma + + ibeg=jrl + iend=min(ibeg+nproma-1,ncol) + il=iend-ibeg+1 + ib=(jrl-1)/nproma+1 + + !* RADINTG: 3. PREPARE INPUT ARRAYS + + ! zrgp(1:il,imu0,ib) = ??? + zrgp(1:il,ifs_config%iamu0,ib) = single_level%cos_sza(ibeg:iend) ! cosine of solar zenith ang (mu0) + + do jemiss=1,yderad%nlwemiss + zrgp(1:il,ifs_config%iemiss+jemiss-1,ib) = single_level%lw_emissivity(ibeg:iend,jemiss) + enddo + + zrgp(1:il,ifs_config%its,ib) = single_level%skin_temperature(ibeg:iend) ! skin temperature + zrgp(1:il,ifs_config%islm,ib) = land_frac(ibeg:iend) ! land-sea mask + zrgp(1:il,ifs_config%iccnl,ib) = yderad%rccnlnd ! CCN over land + zrgp(1:il,ifs_config%iccno,ib) = yderad%rccnsea ! CCN over sea + ! zrgp(1:il,ibas,ib) = ??? + ! zrgp(1:il,itop,ib) = ??? + zrgp(1:il,ifs_config%igelam,ib) = longitude_rad(ibeg:iend) ! longitude + zrgp(1:il,ifs_config%igemu,ib) = sin_latitude(ibeg:iend) ! sine of latitude + ! zrgp(1:il,iclon,ib) = ??? + ! zrgp(1:il,islon,ib) = ??? + + do jalb=1,yderad%nsw + zrgp(1:il,ifs_config%iald+jalb-1,ib) = single_level%sw_albedo(ibeg:iend,jalb) + enddo + + if (allocated(single_level%sw_albedo_direct)) then + do jalb=1,yderad%nsw + zrgp(1:il,ifs_config%ialp+jalb-1,ib) = single_level%sw_albedo_direct(ibeg:iend,jalb) + end do + else + do jalb=1,yderad%nsw + zrgp(1:il,ifs_config%ialp+jalb-1,ib) = single_level%sw_albedo(ibeg:iend,jalb) + end do + end if + + do jlev=1,nlev + zrgp(1:il,ifs_config%iti+jlev-1,ib) = temperature_fl(ibeg:iend,jlev) ! full level temperature + zrgp(1:il,ifs_config%ipr+jlev-1,ib) = pressure_fl(ibeg:iend,jlev) ! full level pressure + ! zrgp(1:il,iqs+jlev-1,ib) = ??? + enddo + + do jlev=1,nlev + zrgp(1:il,ifs_config%iwv+jlev-1,ib) = gas%mixing_ratio(ibeg:iend,jlev,IH2O) ! this is already in MassMixingRatio units + if (rad_config%do_clouds) then + zrgp(1:il,ifs_config%iclc+jlev-1,ib) = cloud%fraction(ibeg:iend,jlev) + zrgp(1:il,ifs_config%ilwa+jlev-1,ib) = cloud%q_liq(ibeg:iend,jlev) + zrgp(1:il,ifs_config%iiwa+jlev-1,ib) = cloud%q_ice(ibeg:iend,jlev) + else + zrgp(1:il,ifs_config%iclc+jlev-1,ib) = 0._jprb + zrgp(1:il,ifs_config%ilwa+jlev-1,ib) = 0._jprb + zrgp(1:il,ifs_config%iiwa+jlev-1,ib) = 0._jprb + endif + zrgp(1:il,ifs_config%iswa+jlev-1,ib) = 0._jprb ! snow + zrgp(1:il,ifs_config%irwa+jlev-1,ib) = 0._jprb ! rain + + ! zrgp(1:il,irra+jlev-1,ib) = ??? + ! zrgp(1:il,idp+jlev-1,ib) = ??? + ! zrgp(1:il,ifsd+jlev-1,ib) = ??? + ! zrgp(1:il,iecpo3+jlev-1,ib) = ??? + enddo + + zrgp(1:il,ifs_config%iaer:ifs_config%iaer+nlev,ib) = 0._jprb ! old aerosol, not used + if (yderad%naermacc == 1) then + joff=ifs_config%iaero + do jaer=1,rad_config%n_aerosol_types + do jlev=1,nlev + zrgp(1:il,joff,ib) = aerosol%mixing_ratio(ibeg:iend,jlev,jaer) + joff=joff+1 + enddo + enddo + endif + + do jlev=1,nlev+1 + ! zrgp(1:il,ihpr+jlev-1,ib) = ??? + zrgp(1:il,ifs_config%iaprs+jlev-1,ib) = thermodynamics%pressure_hl(ibeg:iend,jlev) + zrgp(1:il,ifs_config%ihti+jlev-1,ib) = thermodynamics%temperature_hl(ibeg:iend,jlev) + enddo + + ! -- by default, globally averaged concentrations (mmr) + call gas%get(ICO2, IMassMixingRatio, zrgp(1:il,ifs_config%iico2:ifs_config%iico2+nlev-1,ib), istartcol=ibeg) + call gas%get(ICH4, IMassMixingRatio, zrgp(1:il,ifs_config%iich4:ifs_config%iich4+nlev-1,ib), istartcol=ibeg) + call gas%get(IN2O, IMassMixingRatio, zrgp(1:il,ifs_config%iin2o:ifs_config%iin2o+nlev-1,ib), istartcol=ibeg) + call gas%get(ICFC11, IMassMixingRatio, zrgp(1:il,ifs_config%ic11:ifs_config%ic11+nlev-1,ib), istartcol=ibeg) + call gas%get(ICFC12, IMassMixingRatio, zrgp(1:il,ifs_config%ic12:ifs_config%ic12+nlev-1,ib), istartcol=ibeg) + call gas%get(IHCFC22,IMassMixingRatio, zrgp(1:il,ifs_config%ic22:ifs_config%ic22+nlev-1,ib), istartcol=ibeg) + call gas%get(ICCL4, IMassMixingRatio, zrgp(1:il,ifs_config%icl4:ifs_config%icl4+nlev-1,ib), istartcol=ibeg) + call gas%get(IO3, IMassMixingRatio, zrgp(1:il,ifs_config%ioz:ifs_config%ioz+nlev-1,ib), istartcol=ibeg) + ! convert ozone kg/kg to Pa*kg/kg + ! do jlev=1,nlev + ! zrgp(1:il,ifs_config%ioz+jlev-1,ib) = zrgp(1:il,ifs_config%ioz+jlev-1,ib) & + ! & * (thermodynamics%pressure_hl(ibeg:iend,jlev+1) & + ! & - thermodynamics%pressure_hl(ibeg:iend,jlev)) + ! enddo + + ! local workaround variables for standalone input files + if (rad_config%do_clouds) then + do jlev=1,nlev + ! missing full-level temperature and pressure as well as land-sea-mask + zrgp(1:il,ifs_config%ire_liq+jlev-1,ib) = cloud%re_liq(ibeg:iend,jlev) + zrgp(1:il,ifs_config%ire_ice+jlev-1,ib) = cloud%re_ice(ibeg:iend,jlev) + enddo + do jlev=1,nlev-1 + ! for the love of it, I can't figure this one out. Probably to do with + ! my crude approach of setting PGEMU? + zrgp(1:il,ifs_config%ioverlap+jlev-1,ib) = cloud%overlap_param(ibeg:iend,jlev) + enddo + if(present(iseed)) iseed(1:il,ib) = single_level%iseed(ibeg:iend) + else + do jlev=1,nlev + ! missing full-level temperature and pressure as well as land-sea-mask + zrgp(1:il,ifs_config%ire_liq+jlev-1,ib) = 0._jprb + zrgp(1:il,ifs_config%ire_ice+jlev-1,ib) = 0._jprb + enddo + do jlev=1,nlev-1 + zrgp(1:il,ifs_config%ioverlap+jlev-1,ib) = 0._jprb + enddo + if(present(iseed)) iseed(1:il,ib) = 0 + endif ! do_clouds + enddo + !$OMP END PARALLEL DO + + ! Store pressure for output + if(present(thermodynamics_out)) thermodynamics_out%pressure_hl(:,:) = thermodynamics%pressure_hl(:,:) + + end associate + +end subroutine ifs_copy_inputs_to_blocked + +subroutine ifs_copy_fluxes_from_blocked(& + & driver_config, ifs_config, yradiation, ncol, nlev,& + & zrgp, flux, flux_sw_direct_normal, flux_uv, flux_par, flux_par_clear,& + & emissivity_out, flux_diffuse_band, flux_direct_band) + use ecrad_driver_config, only : driver_config_type + use radiation_setup, only : tradiation + use radiation_flux, only : flux_type + + ! Configuration specific to this driver + type(driver_config_type), intent(in) :: driver_config + + type(ifs_config_type), intent(in) :: ifs_config + + ! Configuration for the radiation scheme, IFS style + type(tradiation), intent(in) :: yradiation + + integer, intent(in) :: ncol, nlev ! Number of columns and levels + + ! monolithic IFS data structure passed to radiation scheme + real(kind=jprb), intent(inout), allocatable :: zrgp(:,:,:) + + ! Derived type containing outputs from the radiation scheme + type(flux_type), intent(inout) :: flux + + ! Additional output fluxes as arrays + real(jprb), dimension(:), intent(inout) :: flux_sw_direct_normal, flux_uv, flux_par,& + & flux_par_clear, emissivity_out + real(jprb), dimension(:,:), intent(inout) :: flux_diffuse_band, flux_direct_band + + ! number of column blocks, block size + integer :: ngpblks, nproma + + integer :: jrl, ibeg, iend, il, ib, jlev, jg + + ! Extract some config values + nproma=driver_config%nblocksize ! nproma size + ngpblks=(ncol-1)/nproma+1 ! number of column blocks + + ! ------------------------------------------------------- + ! + ! OUTPUT LOOP + ! + ! ------------------------------------------------------- + + !$OMP PARALLEL DO SCHEDULE(RUNTIME)& + !$OMP&PRIVATE(JRL,IBEG,IEND,IL,IB,JLEV,JG) + do jrl=1,ncol,nproma + ibeg=jrl + iend=min(ibeg+nproma-1,ncol) + il=iend-ibeg+1 + ib=(jrl-1)/nproma+1 + + do jlev=1,nlev+1 + flux%sw_up(ibeg:iend,jlev) = zrgp(1:il,ifs_config%ifrso+jlev-1,ib) + flux%lw_up(ibeg:iend,jlev) = zrgp(1:il,ifs_config%ifrth+jlev-1,ib) + flux%sw_up_clear(ibeg:iend,jlev) = zrgp(1:il,ifs_config%iswfc+jlev-1,ib) + flux%lw_up_clear(ibeg:iend,jlev) = zrgp(1:il,ifs_config%ilwfc+jlev-1,ib) + if (yradiation%yrerad%lapproxlwupdate) then + flux%lw_derivatives(ibeg:iend,jlev) = zrgp(1:il,ifs_config%ilwderivative+jlev-1,ib) + else + flux%lw_derivatives(ibeg:iend,jlev) = 0.0_jprb + endif + end do + flux%sw_dn(ibeg:iend,nlev+1) = zrgp(1:il,ifs_config%ifrsod,ib) + flux%lw_dn(ibeg:iend,nlev+1) = zrgp(1:il,ifs_config%ifrted,ib) + flux%sw_dn_clear(ibeg:iend,nlev+1) = zrgp(1:il,ifs_config%ifrsodc,ib) + flux%lw_dn_clear(ibeg:iend,nlev+1) = zrgp(1:il,ifs_config%ifrtedc,ib) + flux%sw_dn_direct(ibeg:iend,nlev+1) = zrgp(1:il,ifs_config%ifdir,ib) + flux%sw_dn_direct_clear(ibeg:iend,nlev+1) = zrgp(1:il,ifs_config%icdir,ib) + flux_sw_direct_normal(ibeg:iend) = zrgp(1:il,ifs_config%isudu,ib) + flux_uv(ibeg:iend) = zrgp(1:il,ifs_config%iuvdf,ib) + flux_par(ibeg:iend) = zrgp(1:il,ifs_config%iparf,ib) + flux_par_clear(ibeg:iend) = zrgp(1:il,ifs_config%iparcf,ib) + flux%sw_dn(ibeg:iend,1) = zrgp(1:il,ifs_config%itincf,ib) + emissivity_out(ibeg:iend) = zrgp(1:il,ifs_config%iemit,ib) + if (yradiation%yrerad%lapproxswupdate) then + do jg=1,yradiation%yrerad%nsw + flux_diffuse_band(ibeg:iend,jg) = zrgp(1:il,ifs_config%iswdiffuseband+jg-1,ib) + flux_direct_band(ibeg:iend,jg) = zrgp(1:il,ifs_config%iswdirectband+jg-1,ib) + end do + else + flux_diffuse_band(ibeg:iend,:) = 0.0_jprb + flux_direct_band(ibeg:iend,:) = 0.0_jprb + endif + end do + + deallocate(zrgp) + +end subroutine ifs_copy_fluxes_from_blocked + +end module ifs_blocking Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_aerosol_optics_description.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_aerosol_optics_description.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_aerosol_optics_description.F90 (revision 6016) @@ -0,0 +1,48 @@ +! (C) Copyright 2022- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +! Program to test the functionality of the +! radiation_aerosol_optics_description module. Usage is for example: +! "test_aerosol_optics_description aerosol_ifs_49R1.nc" +program test_aerosol_optics_description + + use radiation_aerosol_optics_description + + type(aerosol_optics_description_type) :: aer_desc + + character(len=512) :: file_name + + integer :: istatus + + call get_command_argument(1, file_name, status=istatus) + if (istatus /= 0) then + stop 'Usage: test_aerosol_optics_description ' + end if + + call aer_desc%read(file_name=file_name) + + ! These two should issue a warning that the aerosol type is ambiguous + print *, 'DD: ', aer_desc%get_index('DD',.false.) + print *, 'DD (bin=2): ', aer_desc%get_index('DD',.false.,ibin=2) + ! Indicate preferred aerosol optical model, after which further + ! calls will prefer one particular model + print *, 'preferred_optical_model(DD,Fouquart)' + call aer_desc%preferred_optical_model('DD','Fouquart') + print *, 'DD (bin=2): ', aer_desc%get_index('DD',.false.,ibin=2) + print *, 'DD (bin=2,model=Woodward): ', aer_desc%get_index('DD',.false.,ibin=2,optical_model_str="Woodward") + print *, 'DD (bin=2,model=Woodward2001): ', aer_desc%get_index('DD',.false.,ibin=2,optical_model_str="Woodward2001") + ! This should fail to find a match, returning zero + print *, 'DD (model=Nobody): ', aer_desc%get_index('DD',.false.,optical_model_str="Nobody") + print *, 'SS (bin=3): ', aer_desc%get_index('SS',.true.,ibin=3) + +end program test_aerosol_optics_description Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_cloud_generator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_cloud_generator.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_cloud_generator.F90 (revision 6016) @@ -0,0 +1,67 @@ +! (C) Copyright 2017- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +program test_cloud_generator + + use parkind1, only : jprb + use radiation_cloud_generator, only : cloud_generator + use radiation_pdf_sampler, only : pdf_sampler_type + use radiation_cloud_cover, only : & + & IOverlapMaximumRandom, IOverlapExponentialRandom, IOverlapExponential + + implicit none + + integer, parameter :: ncol = 2000 + integer, parameter :: nlev = 137 + integer, parameter :: i_overlap_scheme = IOverlapExponential + real(jprb), parameter :: scale_height = 8000.0_jprb + real(jprb), parameter :: cloud_inhom_decorr_scaling = 0.5_jprb + real(jprb), parameter :: frac_threshold = 1.0e-6_jprb + + real(jprb) :: cloud_fraction(nlev), overlap_param(nlev-1), fractional_std(nlev) +! real(jprb) :: pressure_hl(nlev+1) + +! real(jprb) :: decorrelation_length + + real(jprb) :: od_scaling(ncol,nlev) + real(jprb) :: total_cloud_cover + + integer :: iseed + + integer :: jcol, jlev + + type(pdf_sampler_type) :: pdf_sampler + + iseed = 1 + cloud_fraction = 0.0_jprb + overlap_param = 0.9_jprb + fractional_std = 1.0_jprb ! Value up to 45R1 + + ! Insert cloud layers + cloud_fraction(115:125) = 0.1_jprb !0.5_jprb + cloud_fraction(20:100) = 0.1_jprb !0.75_jprb + + call pdf_sampler%setup('data/mcica_gamma.nc', iverbose=0) + + call cloud_generator(ncol, nlev, i_overlap_scheme, & + & iseed, frac_threshold, & + & cloud_fraction, overlap_param, & + & cloud_inhom_decorr_scaling, & + & fractional_std, pdf_sampler, & + & od_scaling, total_cloud_cover) + + do jlev = 1,nlev + do jcol = 1,ncol + write(6,'(f5.2,a)',advance='no') od_scaling(jcol,jlev), ' ' + end do + write(6,*) + end do + + +end program test_cloud_generator Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_fast_expm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_fast_expm.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_fast_expm.F90 (revision 6016) @@ -0,0 +1,24 @@ +program test_fast_expm + ! Test the fast matrix exponential exchange routine used for + ! SPARTACUS shortwave entrapment calculations, but which can fail in + ! single precision for very specific inputs leading to the matrix + ! having two repeated eigenvalues + + use parkind1, only : jprb + + use radiation_matrix, only : fast_expm_exchange_3 + + real(jprb) :: a(1), b(1), c(1), d(1), r(1,3,3) + + a = 9.0408579E-02_jprb + b = 9.2716664E-07_jprb + c = 2.2503915E-03_jprb + d = 8.8152386E-02_jprb + + call fast_expm_exchange_3(1,1,a(1:1),b(1:1),c(1:1),d(1:1),r) + + print *, r + print *, 0.0000001 + print *, epsilon(1.0_jprb) + +end program test_fast_expm Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_random_number_generator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_random_number_generator.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_random_number_generator.F90 (revision 6016) @@ -0,0 +1,38 @@ +program test_random_number_generator + + ! This program tests the radiation random number generator - the + ! Minstd generator should produce the same results whether or not + ! working floating-point precision (jprb) is single precision (4) or + ! double (8) + + use parkind1, only : jprb, jpim, jpib + use radiation_random_numbers, only : rng_type, IRngMinstdVector, IRngNative + + integer(jpim), parameter :: streammax = 512 + + ! Choose between two types of random number generator + !integer(jpim), parameter :: IRngType = IRngNative + integer(jpim), parameter :: IRngType = IRngMinstdVector + + type(rng_type) :: random_number_generator + real(jprb) :: vec(streammax) + integer :: jl + + print *, 'working_fp_precision = ', jprb + + if (IRngType == IRngNative) then + print *, "rng_type = 'native'" + else + print *, "rng_type = 'native'" + end if + + call random_number_generator%initialize(itype=IRngType, iseed=212075152, & + & nmaxstreams=streammax) + do jl = 1,1 + print *, 'initial_state = [ ', int(random_number_generator%istate(1:streammax),jpib), ' ]' + call random_number_generator%uniform_distribution(vec) + print *, 'uniform_deviates = [ ', vec, ' ]' + print *, 'final_state = [ ', int(random_number_generator%istate(1:streammax),jpib), ' ]' + end do + +end program test_random_number_generator Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_spartacus_math.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_spartacus_math.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/driver/test_spartacus_math.F90 (revision 6016) @@ -0,0 +1,157 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +! This simple program tests the functioning of the matrix operations +! in the radiation_matrix module + +program test_spartacus_math + + use parkind1 + use radiation_matrix + + implicit none + + integer, parameter :: n = 10, m = 3 + + real(jprb), dimension(n,m,m) :: A, B, C + real(jprb), dimension(n,m) :: v, w + + ! Terms in exchange matrix + real(jprb), dimension(n) :: aa, bb, cc, dd + + integer :: j + + A = -1.0_jprb + A(:,1,1) = 10.0_jprb + A(:,2,2) = 5.0_jprb + A(:,2,1) = -0.5_jprb + + B = 2.0_jprb + B(:,1,1) = -1.4_jprb + B(:,2,1) = 1.0e4_jprb + + v(:,1) = 2.0_jprb + v(:,2) = 3.0_jprb + if (m == 3) then + v(:,m) = -1.5_jprb + A(:,m,m) = 4.5 + end if + + write(*,*) 'A =' + do j = 1,m + write(*,*) A(1,j,:) + end do + + write(*,*) 'B =' + do j = 1,m + write(*,*) B(1,j,:) + end do + + write(*,*) 'v = ', v(1,:) + + C = mat_x_mat(n,n,m,A,B) + w = mat_x_vec(n,n,m,A,v) + + write(*,*) 'C = A*B =' + do j = 1,m + write(*,*) C(1,j,:) + end do + write(*,*) 'w = A*v = ', w(1,:) + + w = solve_vec(n,n,m,A,v) + C = solve_mat(n,n,m,A,B) + + + write(*,*) 'C = A\B =' + do j = 1,m + write(*,*) C(1,j,:) + end do + write(*,*) 'w = A\v = ', w(1,:) + + call expm(n,n,m,A,IMatrixPatternDense) + + write(*,*) 'expm(A) =' + do j = 1,m + write(*,*) A(1,j,:) + end do + + ! Test fast_expm_exchange_3 + aa = 2.0_jprb + bb = 3.0_jprb + cc = 5.0_jprb + dd = 7.0_jprb + + if (m == 2) then + + call fast_expm_exchange(n,n,aa,bb,A) + + write(*,*) 'fast_expm(A) = ' + do j = 1,m + write(*,*) A(1,j,:) + end do + + A = 0.0_jprb + A(:,1,1) = -aa + A(:,2,1) = aa + A(:,1,2) = bb + A(:,2,2) = -bb + + call expm(n,n,m,A,IMatrixPatternDense) + + write(*,*) 'expm(A) = ' + do j = 1,m + write(*,*) A(1,j,:) + end do + + ! Test zeros lead to identity matrix + aa = 0.0_jprb + call fast_expm_exchange(n,n,aa,aa,A) + + write(*,*) 'expm(zeros) = ' + do j = 1,m + write(*,*) A(1,j,:) + end do + + else + + call fast_expm_exchange(n,n,aa,bb,cc,dd,A) + + write(*,*) 'fast_expm(A) = ' + do j = 1,m + write(*,*) A(1,j,:) + end do + + A = 0.0_jprb + A(:,1,1) = -aa + A(:,2,1) = aa + A(:,1,2) = bb + A(:,2,2) = -bb-cc + A(:,3,2) = cc + A(:,2,3) = dd + A(:,3,3) = -dd + + call expm(n,n,m,A,IMatrixPatternDense) + + write(*,*) 'expm(A) = ' + do j = 1,m + write(*,*) A(1,j,:) + end do + + ! Test zeros lead to identity matrix + aa = 0.0_jprb + call fast_expm_exchange(n,n,aa,aa,aa,aa,A) + + write(*,*) 'expm(zeros) = ' + do j = 1,m + write(*,*) A(1,j,:) + end do + + end if + +end program test_spartacus_math Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/Makefile (revision 6016) @@ -0,0 +1,33 @@ +SOURCES = ice_effective_radius.F90 liquid_effective_radius.F90 \ + radiation_scheme.F90 radiation_setup.F90 yoerdu.F90 \ + yomrip.F90 yoephy.F90 yoecld.F90 yoe_spectral_planck.F90 \ + cloud_overlap_decorr_len.F90 yoerad.F90 yoethf.F90 satur.F90 + +OBJECTS := $(SOURCES:.F90=.o) +LIBIFS = ../lib/libifs.a + +all: $(LIBIFS) + +deps: includes + +$(LIBIFS): $(OBJECTS) + ar r $(LIBIFS) $(OBJECTS) + +%.o: %.F90 ../lib/libifsaux.a ../lib/libradiation.a + $(FC) $(FCFLAGS) -c $< + +includes: + fcm make --config-file=../bin/fcm-make-interfaces.cfg interfaces.ns-incl=ifs interfaces.source=$(shell dirname $(realpath $(firstword $(MAKEFILE_LIST))))/.. + +clean: + rm -f *.o $(LIBIFS) + +.PHONY: deps includes clean-deps + +liquid_effective_radius.o: yoerdu.o +radiation_scheme.o: radiation_setup.o +radiation_setup.o: yoephy.o +cloud_overlap_decorr_len.o: yoecld.o +cos_sza.o ice_effective_radius.o liquid_effective_radius.o radiation_scheme.o radiation_setup.o: yoerad.o +yoerad.o: yoe_spectral_planck.o +satur.o: yoethf.o Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/cloud_overlap_decorr_len.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/cloud_overlap_decorr_len.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/cloud_overlap_decorr_len.F90 (revision 6016) @@ -0,0 +1,126 @@ +SUBROUTINE CLOUD_OVERLAP_DECORR_LEN & + & (KIDIA, KFDIA, KLON, PGEMU, KDECOLAT, & + & PDECORR_LEN_EDGES_KM, PDECORR_LEN_WATER_KM, PDECORR_LEN_RATIO) + +! CLOUD_OVERLAP_DECORR_LEN +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! PURPOSE +! ------- +! Calculate the cloud overlap decorrelation length as a function of +! latitude for use in the radiation scheme +! +! INTERFACE +! --------- +! CLOUD_OVERLAP_DECORR_LEN is called from RADLSWR and RADIATION_SCHEME +! +! AUTHOR +! ------ +! Robin Hogan, ECMWF (using code extracted from radlswr.F90) +! Original: 2016-02-16 +! +! MODIFICATIONS +! ------------- +! +! ------------------------------------------------------------------- + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMCST , ONLY : RPI +USE YOECLD , ONLY : RDECORR_CF, RDECORR_CW + +! ------------------------------------------------------------------- + +IMPLICIT NONE + +! INPUT ARGUMENTS + +! *** Array dimensions and ranges +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA ! Start column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA ! End column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KLON ! Number of columns + +! *** Configuration variable controlling the overlap scheme +INTEGER(KIND=JPIM),INTENT(IN) :: KDECOLAT + +! *** Single-level variables +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) ! Sine of latitude + +! OUTPUT ARGUMENTS + +! *** Decorrelation lengths for cloud edges and cloud water content, +! *** in km +REAL(KIND=JPRB), INTENT(OUT) :: PDECORR_LEN_EDGES_KM(KLON) +REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_WATER_KM(KLON) + +! Ratio of water-content to cloud-edge decorrelation lengths +REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_RATIO + +! LOCAL VARIABLES + +REAL(KIND=JPRB) :: ZRADIANS_TO_DEGREES, ZABS_LAT_DEG, ZCOS_LAT + +INTEGER(KIND=JPIM) :: JL + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('CLOUD_OVERLAP_DECORR_LEN',0,ZHOOK_HANDLE) + +! ------------------------------------------------------------------- + +IF (KDECOLAT == 0) THEN + + ! Decorrelation lengths are constant values + PDECORR_LEN_EDGES_KM(KIDIA:KFDIA) = RDECORR_CF + IF (PRESENT(PDECORR_LEN_WATER_KM)) THEN + PDECORR_LEN_WATER_KM(KIDIA:KFDIA) = RDECORR_CW + ENDIF + IF (PRESENT(PDECORR_LEN_RATIO)) THEN + PDECORR_LEN_RATIO = RDECORR_CW / RDECORR_CF + ENDIF + +ELSE + + ZRADIANS_TO_DEGREES = 180.0_JPRB / RPI + + IF (KDECOLAT == 1) THEN + ! Shonk et al. (2010) Eq. 13 formula + DO JL = KIDIA,KFDIA + ZABS_LAT_DEG = ABS(ASIN(PGEMU(JL)) * ZRADIANS_TO_DEGREES) + PDECORR_LEN_EDGES_KM(JL) = 2.899_JPRB - 0.02759_JPRB * ZABS_LAT_DEG + ENDDO + ELSE ! KDECOLAT == 2 + DO JL = KIDIA,KFDIA + ! Shonk et al. (2010) but smoothed over the equator + ZCOS_LAT = COS(ASIN(PGEMU(JL))) + PDECORR_LEN_EDGES_KM(JL) = 0.75_JPRB + 2.149_JPRB * ZCOS_LAT*ZCOS_LAT + ENDDO + ENDIF + + ! Both KDECOLAT = 1 and 2 assume that the decorrelation length for + ! cloud water content is half that for cloud edges + IF (PRESENT(PDECORR_LEN_WATER_KM)) THEN + PDECORR_LEN_WATER_KM(KIDIA:KFDIA) = PDECORR_LEN_EDGES_KM(KIDIA:KFDIA) * 0.5_JPRB + ENDIF + + IF (PRESENT(PDECORR_LEN_RATIO)) THEN + PDECORR_LEN_RATIO = 0.5_JPRB + ENDIF + +ENDIF + +! ------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('CLOUD_OVERLAP_DECORR_LEN',1,ZHOOK_HANDLE) + +END SUBROUTINE CLOUD_OVERLAP_DECORR_LEN Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/cos_sza.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/cos_sza.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/cos_sza.F90 (revision 6016) @@ -0,0 +1,339 @@ +SUBROUTINE COS_SZA(KSTART,KEND,KCOL,PGEMU,PGELAM,LDRADIATIONTIMESTEP,PMU0) + +!**** *COS_SZA* +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Purpose. +! -------- +! Compute the cosine of the solar zenith angle. Note that this +! is needed for three different things: (1) as input to the +! radiation scheme in which it is used to compute the path +! length of the direct solar beam through the atmosphere, (2) +! every timestep to scale the solar fluxes by the incoming +! solar radiation at top-of-atmosphere, and (3) to compute the +! albedo of the ocean. For (1) we ideally want an average +! value for the duration of a radiation timestep while for (2) +! we want an average value for the duration of a model +! timestep. + +!** Interface. +! ---------- +! *CALL* *COS_SZA(...) + +! Explicit arguments : +! ------------------ +! PGEMU - Sine of latitude +! PGELAM - Geographic longitude in radians +! LDRadiationTimestep - Is this for a radiation timestep? +! PMU0 - Output cosine of solar zenith angle + +! Implicit arguments : +! -------------------- +! YRRIP%RWSOVR, RWSOVRM - Solar time for model/radiation timesteps +! RCODECM, RSIDECM - Sine/cosine of solar declination +! YRERAD%LAverageSZA - Average solar zenith angle in time interval? +! YRRIP%TSTEP - Model timestep in seconds +! YRERAD%NRADFR - Radiation frequency in timesteps + +! Method. +! ------- +! Compute cosine of the solar zenith angle, mu0, from lat, lon +! and solar time using standard formula. If +! YRERAD%LAverageSZA=FALSE then this is done at a single time, +! which is assumed to be the mid-point of either the model or +! the radiation timestep. If YRERAD%LAverageSZA=TRUE then we +! compute the average over the model timestep exactly by first +! computing sunrise/sunset times. For radiation timesteps, mu0 +! is to be used to compute the path length of the direct solar +! beam through the atmosphere, and the fluxes are subsequently +! weighted by mu0. Therefore night-time values are not used, +! so we average mu0 only when the sun is above the horizon. + +! Externals. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS +! +! See also: Zhou, L., M. Zhang, Q. Bao, and Y. Liu (2015), On +! the incident solar radiation in CMIP5 +! models. Geophys. Res. Lett., 42, 1930–1935. doi: +! 10.1002/2015GL063239. + +! Author. +! ------- +! Robin Hogan, ECMWF, May 2015 + +! Modifications: +! -------------- + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE YOMCST , ONLY : RPI, RDAY +USE YOMRIP , ONLY : YRRIP +USE YOERIP , ONLY : YRERIP +USE YOERAD , ONLY : YRERAD +USE YOMLUN , ONLY : NULOUT + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KSTART ! Start column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KEND ! Last column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KCOL ! Number of columns in arrays +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KCOL) ! Sine of latitude +REAL(KIND=JPRB), INTENT(IN) :: PGELAM(KCOL)! Longitude in radians +LOGICAL, INTENT(IN) :: LDRADIATIONTIMESTEP ! Is this for a radiation timestep? +REAL(KIND=JPRB), INTENT(OUT) :: PMU0(KCOL) ! Cosine of solar zenith angle + +! Solar time at the start and end of the time interval +REAL(KIND=JPRB) :: ZSOLARTIMESTART, ZSOLARTIMEEND + +! The time of half a model/radiation timestep, in radians +REAL(KIND=JPRB) :: ZHALFTIMESTEP + +! For efficiency we precompute sin(solar declination)*sin(latitude) +REAL(KIND=JPRB) :: ZSINDECSINLAT(KSTART:KEND) +!...and cos(solar declination)*cos(latitude) +REAL(KIND=JPRB) :: ZCOSDECCOSLAT(KSTART:KEND) +! ...and cosine of latitude +REAL(KIND=JPRB) :: ZCOSLAT(KSTART:KEND) + +! Tangent of solar declination +REAL(KIND=JPRB) :: ZTANDEC + +! Hour angles (=local solar time in radians plus pi) +REAL(KIND=JPRB) :: ZHOURANGLESTART, ZHOURANGLEEND +REAL(KIND=JPRB) :: ZHOURANGLESUNSET, ZCOSHOURANGLESUNSET + +INTEGER(KIND=JPIM) :: JCOL ! Column index + +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('COS_SZA',0,ZHOOK_HANDLE) + +! An average solar zenith angle can only be computed if the solar time +! is centred on the time interval +IF (YRERAD%LAVERAGESZA .AND. .NOT. YRERAD%LCENTREDTIMESZA) THEN + WRITE(NULOUT,*) 'ERROR IN COS_SZA: LAverageSZA=TRUE but LCentredTimeSZA=FALSE' + CALL ABOR1('COS_SZA: ABOR1 CALLED') +ENDIF + +DO JCOL = KSTART,KEND + ZCOSLAT(JCOL) = SQRT(1.0_JPRB - PGEMU(JCOL)**2) +ENDDO + +IF (LDRADIATIONTIMESTEP) THEN + ! Compute the effective cosine of solar zenith angle for a radiation + ! timestep + + ! Precompute quantities that may be used more than once + DO JCOL = KSTART,KEND + ZSINDECSINLAT(JCOL) = YRERIP%RSIDECM * PGEMU(JCOL) + ZCOSDECCOSLAT(JCOL) = YRERIP%RCODECM * ZCOSLAT(JCOL) + ENDDO + + IF (.NOT. YRERAD%LAVERAGESZA) THEN + ! Original method: compute the value at the centre of the + ! radiation timestep (assuming that LCentredTimeSZA=TRUE - see + ! updtim.F90) + DO JCOL = KSTART,KEND + ! It would be more efficient to do it like this... + ! PMU0(JCOL)=MAX(0.0_JPRB, ZSinDecSinLat(JCOL) & + ! & - ZCosDecCosLat(JCOL) * COS(YRERIP%RWSOVRM + PGELAM(JCOL))) + ! ...but for bit reproducibility with previous cycle we do it + ! like this: + PMU0(JCOL) = MAX(0.0_JPRB, ZSINDECSINLAT(JCOL) & + & - YRERIP%RCODECM*COS(YRERIP%RWSOVRM)*ZCOSLAT(JCOL)*COS(PGELAM(JCOL)) & + & + YRERIP%RCODECM*SIN(YRERIP%RWSOVRM)*ZCOSLAT(JCOL)*SIN(PGELAM(JCOL))) + ENDDO + + ELSE + ! Compute the average MU0 for the period of the radiation + ! timestep, excluding times when the sun is below the horizon + + ! First compute the sine and cosine of the times of the start and + ! end of the radiation timestep + ZHALFTIMESTEP = YRRIP%TSTEP * REAL(YRERAD%NRADFR) * RPI / RDAY + ZSOLARTIMESTART = YRERIP%RWSOVRM - ZHALFTIMESTEP + ZSOLARTIMEEND = YRERIP%RWSOVRM + ZHALFTIMESTEP + + ! Compute tangent of solar declination, with check in case someone + ! simulates a planet completely tipped over + ZTANDEC = YRERIP%RSIDECM / MAX(YRERIP%RCODECM, 1.0E-12) + + DO JCOL = KSTART,KEND + ! Sunrise equation: cos(hour angle at sunset) = + ! -tan(declination)*tan(latitude) + ZCOSHOURANGLESUNSET = -ZTANDEC * PGEMU(JCOL) & + & / MAX(ZCOSLAT(JCOL), 1.0E-12) + IF (ZCOSHOURANGLESUNSET > 1.0) THEN + ! Perpetual darkness + PMU0(JCOL) = 0.0_JPRB + ELSE + ! Compute hour angle at start and end of time interval, + ! ensuring that the hour angle of the centre of the time + ! window is in the range -PI to +PI (equivalent to ensuring + ! that local solar time = solar time + longitude is in the + ! range 0 to 2PI) + IF (YRERIP%RWSOVRM + PGELAM(JCOL) < 2.0_JPRB*RPI) THEN + ZHOURANGLESTART = ZSOLARTIMESTART + PGELAM(JCOL) - RPI + ZHOURANGLEEND = ZSOLARTIMEEND + PGELAM(JCOL) - RPI + ELSE + ZHOURANGLESTART = ZSOLARTIMESTART + PGELAM(JCOL) - 3.0_JPRB*RPI + ZHOURANGLEEND = ZSOLARTIMEEND + PGELAM(JCOL) - 3.0_JPRB*RPI + ENDIF + + IF (ZCOSHOURANGLESUNSET >= -1.0) THEN + ! Not perpetual daylight or perpetual darkness, so we need + ! to check for sunrise or sunset lying within the time + ! interval + ZHOURANGLESUNSET = ACOS(ZCOSHOURANGLESUNSET) + IF (ZHOURANGLEEND <= -ZHOURANGLESUNSET & + & .OR. ZHOURANGLESTART >= ZHOURANGLESUNSET) THEN + ! The time interval is either completely before sunrise or + ! completely after sunset + PMU0(JCOL) = 0.0_JPRB + CYCLE + ENDIF + + ! Bound the start and end hour angles by sunrise and sunset + ZHOURANGLESTART = MAX(-ZHOURANGLESUNSET, & + & MIN(ZHOURANGLESTART, ZHOURANGLESUNSET)) + ZHOURANGLEEND = MAX(-ZHOURANGLESUNSET, & + & MIN(ZHOURANGLEEND, ZHOURANGLESUNSET)) + ENDIF + + IF (ZHOURANGLEEND - ZHOURANGLESTART > 1.0E-8) THEN + ! Compute average MU0 in the interval ZHourAngleStart to + ! ZHourAngleEnd + PMU0(JCOL) = ZSINDECSINLAT(JCOL) & + & + (ZCOSDECCOSLAT(JCOL) & + & * (SIN(ZHOURANGLEEND) - SIN(ZHOURANGLESTART))) & + & / (ZHOURANGLEEND - ZHOURANGLESTART) + + ! Just in case... + IF (PMU0(JCOL) < 0.0_JPRB) THEN + PMU0(JCOL) = 0.0_JPRB + ENDIF + ELSE + ! Too close to sunrise/sunset for a reliable calculation + PMU0(JCOL) = 0.0_JPRB + ENDIF + + ENDIF + ENDDO + ENDIF + +ELSE + ! Compute the cosine of solar zenith angle for a model timestep + + ! Precompute quantities that may be used more than once + DO JCOL = KSTART,KEND + ZSINDECSINLAT(JCOL) = YRRIP%RSIDEC * PGEMU(JCOL) + ZCOSDECCOSLAT(JCOL) = YRRIP%RCODEC * ZCOSLAT(JCOL) + ENDDO + + IF (.NOT. YRERAD%LAVERAGESZA) THEN + ! Original method: compute the value at the centre of the + ! model timestep + DO JCOL = KSTART,KEND + ! It would be more efficient to do it like this... + ! PMU0(JCOL) = MAX(0.0_JPRB, ZSinDecSinLat(JCOL) & + ! & - ZCosDecCosLat(JCOL)*COS(YRRIP%RWSOVR + PGELAM(JCOL))) + ! ...but for bit reproducibility with previous cycle we do it + ! like this: + PMU0(JCOL) = MAX(0.0_JPRB, ZSINDECSINLAT(JCOL) & + & - YRRIP%RCODEC*COS(YRRIP%RWSOVR)*ZCOSLAT(JCOL)*COS(PGELAM(JCOL)) & + & + YRRIP%RCODEC*SIN(YRRIP%RWSOVR)*ZCOSLAT(JCOL)*SIN(PGELAM(JCOL))) + ENDDO + + ELSE + ! Compute the average MU0 for the period of the model timestep + + ! First compute the sine and cosine of the times of the start and + ! end of the model timestep + ZHALFTIMESTEP = YRRIP%TSTEP * RPI / RDAY + ZSOLARTIMESTART = YRRIP%RWSOVR - ZHALFTIMESTEP + ZSOLARTIMEEND = YRRIP%RWSOVR + ZHALFTIMESTEP + + ! Compute tangent of solar declination, with check in case someone + ! simulates a planet completely tipped over + ZTANDEC = YRRIP%RSIDEC / MAX(YRRIP%RCODEC, 1.0E-12) + + DO JCOL = KSTART,KEND + ! Sunrise equation: cos(hour angle at sunset) = + ! -tan(declination)*tan(latitude) + ZCOSHOURANGLESUNSET = -ZTANDEC * PGEMU(JCOL) & + & / MAX(ZCOSLAT(JCOL), 1.0E-12) + IF (ZCOSHOURANGLESUNSET > 1.0) THEN + ! Perpetual darkness + PMU0(JCOL) = 0.0_JPRB + ELSE + ! Compute hour angle at start and end of time interval, + ! ensuring that the hour angle of the centre of the time + ! window is in the range -PI to +PI (equivalent to ensuring + ! that local solar time = solar time + longitude is in the + ! range 0 to 2PI) + IF (YRRIP%RWSOVR + PGELAM(JCOL) < 2.0_JPRB*RPI) THEN + ZHOURANGLESTART = ZSOLARTIMESTART + PGELAM(JCOL) - RPI + ZHOURANGLEEND = ZSOLARTIMEEND + PGELAM(JCOL) - RPI + ELSE + ZHOURANGLESTART = ZSOLARTIMESTART + PGELAM(JCOL) - 3.0_JPRB*RPI + ZHOURANGLEEND = ZSOLARTIMEEND + PGELAM(JCOL) - 3.0_JPRB*RPI + ENDIF + + IF (ZCOSHOURANGLESUNSET >= -1.0) THEN + ! Not perpetual daylight or perpetual darkness, so we need + ! to check for sunrise or sunset lying within the time + ! interval + ZHOURANGLESUNSET = ACOS(ZCOSHOURANGLESUNSET) + IF (ZHOURANGLEEND <= -ZHOURANGLESUNSET & + & .OR. ZHOURANGLESTART >= ZHOURANGLESUNSET) THEN + ! The time interval is either completely before sunrise or + ! completely after sunset + PMU0(JCOL) = 0.0_JPRB + CYCLE + ENDIF + + ! Bound the start and end hour angles by sunrise and sunset + ZHOURANGLESTART = MAX(-ZHOURANGLESUNSET, & + & MIN(ZHOURANGLESTART, ZHOURANGLESUNSET)) + ZHOURANGLEEND = MAX(-ZHOURANGLESUNSET, & + & MIN(ZHOURANGLEEND, ZHOURANGLESUNSET)) + ENDIF + + ! Compute average MU0 in the model timestep, although the + ! numerator considers only the time from ZHourAngleStart to + ! ZHourAngleEnd that the sun is above the horizon + PMU0(JCOL) = (ZSINDECSINLAT(JCOL) * (ZHOURANGLEEND-ZHOURANGLESTART) & + & + ZCOSDECCOSLAT(JCOL)*(SIN(ZHOURANGLEEND)-SIN(ZHOURANGLESTART))) & + & / (2.0_JPRB * ZHALFTIMESTEP) + + ! This shouldn't ever result in negative values, but just in + ! case + IF (PMU0(JCOL) < 0.0_JPRB) THEN + PMU0(JCOL) = 0.0_JPRB + ENDIF + + ENDIF + ENDDO + ENDIF + +ENDIF + + +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('COS_SZA',1,ZHOOK_HANDLE) +END SUBROUTINE COS_SZA Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/easy_netcdf_read_mpi.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/easy_netcdf_read_mpi.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/easy_netcdf_read_mpi.F90 (revision 6016) @@ -0,0 +1,316 @@ +! easy_netcdf_read_mpi.f90 - Read netcdf file on one task and share with other tasks +! +! (C) Copyright 2017- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module easy_netcdf_read_mpi + + use easy_netcdf, only : netcdf_file_raw => netcdf_file + use parkind1, only : jpim, jprb + use radiation_io, only : nulout, nulerr, my_abort => radiation_abort + + implicit none + + ! MPI tag for radiation and physics communication + integer(kind=jpim), parameter :: mtagrad = 2800 + + !--------------------------------------------------------------------- + ! An object of this type provides convenient read or write access to + ! a NetCDF file + type netcdf_file + type(netcdf_file_raw) :: file + logical :: is_master_task = .true. + contains + procedure :: open => open_netcdf_file + procedure :: close => close_netcdf_file + procedure :: get_real_scalar + procedure :: get_real_vector + procedure :: get_real_matrix + procedure :: get_real_array3 + generic :: get => get_real_scalar, get_real_vector, & + & get_real_matrix, get_real_array3 + procedure :: get_global_attribute + + procedure :: set_verbose + procedure :: transpose_matrices + procedure :: exists + end type netcdf_file + +contains + + ! --- GENERIC SUBROUTINES --- + + !--------------------------------------------------------------------- + ! Open a NetCDF file with name "file_name", optionally specifying the + ! verbosity level (0-5) + subroutine open_netcdf_file(this, file_name, iverbose) + + USE MPL_MODULE, ONLY : MPL_BROADCAST, MPL_MYRANK + + class(netcdf_file) :: this + character(len=*), intent(in) :: file_name + integer, intent(in), optional :: iverbose + + integer :: istatus + + ! Store verbosity level in object + if (present(iverbose)) then + this%file%iverbose = iverbose + else + ! By default announce files being opened and closed, but not + ! variables read/written + this%file%iverbose = 2 + end if + + ! By default we don't transpose 2D arrays on read + this%file%do_transpose_2d = .false. + + if (MPL_MYRANK() == 1) then + this%is_master_task = .true. + call this%file%open(file_name, iverbose) + else + this%is_master_task = .false. + end if + + end subroutine open_netcdf_file + + + !--------------------------------------------------------------------- + ! Close the NetCDF file + subroutine close_netcdf_file(this) + class(netcdf_file) :: this + integer :: istatus + + if (this%is_master_task) then + call this%file%close() + end if + + end subroutine close_netcdf_file + + + !--------------------------------------------------------------------- + ! Set the verbosity level from 0 to 5, where the codes have the + ! following meaning: 0=errors only, 1=warning, 2=info, 3=progress, + ! 4=detailed, 5=debug + subroutine set_verbose(this, ival) + class(netcdf_file) :: this + integer, optional :: ival + + if (present(ival)) then + this%file%iverbose = ival + else + this%file%iverbose = 2 + end if + + end subroutine set_verbose + + + + !--------------------------------------------------------------------- + ! Specify whether 2D arrays should be transposed on read + subroutine transpose_matrices(this, do_transpose) + class(netcdf_file) :: this + logical, optional :: do_transpose + + if (present(do_transpose)) then + this%file%do_transpose_2d = do_transpose + else + this%file%do_transpose_2d = .true. + end if + + end subroutine transpose_matrices + + + + ! --- READING SUBROUTINES --- + + !--------------------------------------------------------------------- + ! Return true if the variable is present, false otherwise + function exists(this, var_name) result(is_present) + + USE MPL_MODULE, ONLY : MPL_BROADCAST, MPL_NPROC + + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + + logical :: is_present + + if (this%is_master_task) then + is_present = this%file%exists(var_name) + end if + + if (MPL_NPROC() > 1) then + CALL MPL_BROADCAST(is_present, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:EXISTS') + end if + + end function exists + + + !--------------------------------------------------------------------- + ! The method "get" will read either a scalar, vector or matrix + ! depending on the rank of the output argument. This version reads a + ! scalar. + subroutine get_real_scalar(this, var_name, scalar) + + USE MPL_MODULE, ONLY : MPL_BROADCAST, MPL_NPROC + + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(out) :: scalar + + if (this%is_master_task) then + call this%file%get(var_name, scalar) + end if + + if (MPL_NPROC() > 1) then + CALL MPL_BROADCAST(scalar, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:GET_REAL_SCALAR') + end if + + end subroutine get_real_scalar + + + !--------------------------------------------------------------------- + ! Read a 1D array into "vector", which must be allocatable and will + ! be reallocated if necessary + subroutine get_real_vector(this, var_name, vector) + + USE MPL_MODULE, ONLY : MPL_BROADCAST, MPL_NPROC + + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), allocatable, intent(out) :: vector(:) + + integer :: n ! Length of vector + + n = 0 + + if (this%is_master_task) then + call this%file%get(var_name, vector) + n = size(vector) + end if + + if (MPL_NPROC() > 1) then + CALL MPL_BROADCAST(n, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:GET_REAL_VECTOR:SIZE') + + if (.not. this%is_master_task) then + allocate(vector(n)) + end if + + CALL MPL_BROADCAST(vector, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:GET_REAL_VECTOR') + end if + + end subroutine get_real_vector + + + !--------------------------------------------------------------------- + ! Read 2D array into "matrix", which must be allocatable and will be + ! reallocated if necessary. Whether to transpose is specifed by the + ! final optional argument, but can also be specified by the + ! do_transpose_2d class data member. + subroutine get_real_matrix(this, var_name, matrix, do_transp) + + USE MPL_MODULE, ONLY : MPL_BROADCAST, MPL_NPROC + + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), allocatable, intent(out) :: matrix(:,:) + logical, optional, intent(in):: do_transp ! Transpose data? + + integer :: n(2) + + n = 0 + + if (this%is_master_task) then + call this%file%get(var_name, matrix, do_transp) + n = shape(matrix) + end if + + if (MPL_NPROC() > 1) then + CALL MPL_BROADCAST(n, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:GET_REAL_MATRIX:SIZE') + + if (.not. this%is_master_task) then + allocate(matrix(n(1),n(2))) + end if + + CALL MPL_BROADCAST(matrix, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:GET_REAL_MATRIX') + end if + + end subroutine get_real_matrix + + + !--------------------------------------------------------------------- + ! Read 3D array into "var", which must be allocatable and will be + ! reallocated if necessary. Whether to pemute is specifed by the + ! final optional argument + subroutine get_real_array3(this, var_name, var, ipermute) + + USE MPL_MODULE, ONLY : MPL_BROADCAST, MPL_NPROC + + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), allocatable, intent(out) :: var(:,:,:) + integer, optional, intent(in) :: ipermute(3) + + integer :: n(3) + + n = 0 + + if (this%is_master_task) then + call this%file%get(var_name, var, ipermute) + n = shape(var) + end if + + if (MPL_NPROC() > 1) then + CALL MPL_BROADCAST(n, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:GET_REAL_ARRAY3:SIZE') + + if (.not. this%is_master_task) then + allocate(var(n(1),n(2),n(3))) + end if + + CALL MPL_BROADCAST(var, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:GET_REAL_ARRAY3') + end if + + end subroutine get_real_array3 + + + !--------------------------------------------------------------------- + ! Get a global attribute as a character string + subroutine get_global_attribute(this, attr_name, attr_str) + + USE MPL_MODULE, ONLY : MPL_BROADCAST, MPL_NPROC + + class(netcdf_file) :: this + + character(len=*), intent(in) :: attr_name + character(len=*), intent(inout) :: attr_str + + if (this%is_master_task) then + call this%file%get_global_attribute(attr_name, attr_str) + end if + + if (MPL_NPROC() > 1) then + CALL MPL_BROADCAST(attr_str, mtagrad, 1, & + & CDSTRING='EASY_NETCDF_READ_MPI:GET_GLOBAL_ATTRIBUTE') + end if + + end subroutine get_global_attribute + +end module easy_netcdf_read_mpi Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/fcttim.func.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/fcttim.func.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/fcttim.func.h (revision 6016) @@ -0,0 +1,57 @@ +! (C) Copyright 1989- ECMWF. +! (C) Copyright 1989- Meteo-France. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +! ------------------------------------------------------------------ + +! - Time functions +! the descriptions are in the annex 1 of the documentation + +! TIME + +! NDD : extraxt dd from ccaammdd +! NMM : extract mm from ccaammdd +! NAA : extract aa from ccaammdd +! NCCAA : extract ccaa from ccaammdd +! NAMD : extract aammdd from ccaammdd +! NCENT : return centuary of ccaammdd +! NYEARC: returns year of the centuary from ccaammdd +! NCONSTRUCT_DATE : returns ccaammdd given centuary,year,month and day +! NCTH : turn seconds into hours +! RTIME : returns the time of the model (in seconds of course!) +! RINCDAY : length of a day (in seconds) + +INTEGER(KIND=JPIM) :: NDD,NMM,NCCAA,NAA,NAMD,NCTH,NZZAA,NZZMM,NCENT,NYEARC,& +&NCONSTRUCT_DATE +REAL(KIND=JPRD) :: RJUDAT,RTIME +REAL(KIND=JPRB) :: RINCDAY +INTEGER(KIND=JPIM) :: KGRDAT,KSEC,KAAAA,KMM,KDD,KSS +INTEGER(KIND=JPIM) :: KCENT,KYEARC,KMONTH,KDAY + +NDD(KGRDAT) =MOD(KGRDAT,100) +NMM(KGRDAT) =MOD((KGRDAT-NDD(KGRDAT))/100,100) +NCCAA(KGRDAT)=KGRDAT/10000 +NAA(KGRDAT)=MOD(NCCAA(KGRDAT),100) +NAMD(KGRDAT)=MOD(KGRDAT,1000000) +NCTH(KSEC)=KSEC/3600 +NCENT(KGRDAT)=NCCAA(KGRDAT)/100+MIN(NAA(KGRDAT),1) +NYEARC(KGRDAT)=NAA(KGRDAT)+100*(1-MIN(NAA(KGRDAT),1)) +NCONSTRUCT_DATE(KCENT,KYEARC,KMONTH,KDAY)=& +&(KCENT-1)*10**6+KYEARC*10**4+KMONTH*10**2+KDAY + +NZZAA(KAAAA,KMM)=KAAAA-( (1-SIGN(1,KMM-3))/2 ) +NZZMM(KMM)=KMM+6*(1-SIGN(1,KMM-3)) +RJUDAT(KAAAA,KMM,KDD)=1720994.5_JPRD + REAL(& + &2-NZZAA(KAAAA,KMM)/100 + (NZZAA(KAAAA,KMM)/100)/4 & +&+ INT(365.25_JPRD*REAL(NZZAA(KAAAA,KMM),JPRD))& +&+ INT(30.601_JPRD*REAL(NZZMM(KMM)+1,JPRD))& +&+ KDD,JPRD) +RTIME(KAAAA,KMM,KDD,KSS,RINCDAY)=(RJUDAT(KAAAA,KMM,KDD)-2451545._JPRD)& + &*RINCDAY+REAL(KSS,JPRD) +! ------------------------------------------------------------- Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/fcttre.func.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/fcttre.func.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/fcttre.func.h (revision 6016) @@ -0,0 +1,184 @@ +! (C) Copyright 1988- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +!* +! ------------------------------------------------------------------ + +! This COMDECK includes the Thermodynamical functions for the cy39 +! ECMWF Physics package. +! Consistent with YOMCST Basic physics constants, assuming the +! partial pressure of water vapour is given by a first order +! Taylor expansion of Qs(T) w.r.t. to Temperature, using constants +! in YOETHF +! Two sets of functions are available. In the first set only the +! cases water or ice are distinguished by temperature. This set +! consists of the functions FOEDELTA,FOEEW,FOEDE and FOELH. +! The second set considers, besides the two cases water and ice +! also a mix of both for the temperature range RTICE < T < RTWAT. +! This set contains FOEALFA,FOEEWM,FOEDEM,FOELDCPM and FOELHM. +! FKOOP modifies the ice saturation mixing ratio for homogeneous +! nucleation. FOE_DEWM_DT provides an approximate first derivative +! of FOEEWM. + +! Depending on the consideration of mixed phases either the first +! set (e.g. surface, post-processing) or the second set +! (e.g. clouds, condensation, convection) should be used. + +! ------------------------------------------------------------------ +! ***************************************************************** + +! NO CONSIDERATION OF MIXED PHASES + +! ***************************************************************** +REAL(KIND=JPRB) :: FOEDELTA +REAL(KIND=JPRB) :: PTARE +FOEDELTA (PTARE) = MAX (0.0_JPRB,SIGN(1.0_JPRB,PTARE-RTT)) + +! FOEDELTA = 1 water +! FOEDELTA = 0 ice + +! THERMODYNAMICAL FUNCTIONS . + +! Pressure of water vapour at saturation +! INPUT : PTARE = TEMPERATURE +REAL(KIND=JPRB) :: FOEEW,FOEDE,FOEDESU,FOELH,FOELDCP +FOEEW ( PTARE ) = R2ES*EXP (& + &(R3LES*FOEDELTA(PTARE)+R3IES*(1.0_JPRB-FOEDELTA(PTARE)))*(PTARE-RTT)& +&/ (PTARE-(R4LES*FOEDELTA(PTARE)+R4IES*(1.0_JPRB-FOEDELTA(PTARE))))) + +FOEDE ( PTARE ) = & + &(FOEDELTA(PTARE)*R5ALVCP+(1.0_JPRB-FOEDELTA(PTARE))*R5ALSCP)& +&/ (PTARE-(R4LES*FOEDELTA(PTARE)+R4IES*(1.0_JPRB-FOEDELTA(PTARE))))**2 + +FOEDESU ( PTARE ) = & + &(FOEDELTA(PTARE)*R5LES+(1.0_JPRB-FOEDELTA(PTARE))*R5IES)& +&/ (PTARE-(R4LES*FOEDELTA(PTARE)+R4IES*(1.0_JPRB-FOEDELTA(PTARE))))**2 + +FOELH ( PTARE ) =& + &FOEDELTA(PTARE)*RLVTT + (1.0_JPRB-FOEDELTA(PTARE))*RLSTT + +FOELDCP ( PTARE ) = & + &FOEDELTA(PTARE)*RALVDCP + (1.0_JPRB-FOEDELTA(PTARE))*RALSDCP + +! ***************************************************************** + +! CONSIDERATION OF MIXED PHASES + +! ***************************************************************** + +! FOEALFA is calculated to distinguish the three cases: + +! FOEALFA=1 water phase +! FOEALFA=0 ice phase +! 0 < FOEALFA < 1 mixed phase + +! INPUT : PTARE = TEMPERATURE +REAL(KIND=JPRB) :: FOEALFA +FOEALFA (PTARE) = MIN(1.0_JPRB,((MAX(RTICE,MIN(RTWAT,PTARE))-RTICE)& + &*RTWAT_RTICE_R)**2) + + +! Pressure of water vapour at saturation +! INPUT : PTARE = TEMPERATURE +REAL(KIND=JPRB) :: FOEEWM,FOEDEM,FOELDCPM,FOELHM,FOE_DEWM_DT +FOEEWM ( PTARE ) = R2ES *& + &(FOEALFA(PTARE)*EXP(R3LES*(PTARE-RTT)/(PTARE-R4LES))+& + &(1.0_JPRB-FOEALFA(PTARE))*EXP(R3IES*(PTARE-RTT)/(PTARE-R4IES))) + +FOE_DEWM_DT( PTARE ) = R2ES * ( & + & R3LES*FOEALFA(PTARE)*EXP(R3LES*(PTARE-RTT)/(PTARE-R4LES)) & + & *(RTT-R4LES)/(PTARE-R4LES)**2 + & + & R3IES*(1.0-FOEALFA(PTARE))*EXP(R3IES*(PTARE-RTT)/(PTARE-R4IES)) & + & *(RTT-R4IES)/(PTARE-R4IES)**2) + +FOEDEM ( PTARE ) = FOEALFA(PTARE)*R5ALVCP*(1.0_JPRB/(PTARE-R4LES)**2)+& + &(1.0_JPRB-FOEALFA(PTARE))*R5ALSCP*(1.0_JPRB/(PTARE-R4IES)**2) + +FOELDCPM ( PTARE ) = FOEALFA(PTARE)*RALVDCP+& + &(1.0_JPRB-FOEALFA(PTARE))*RALSDCP + +FOELHM ( PTARE ) =& + &FOEALFA(PTARE)*RLVTT+(1.0_JPRB-FOEALFA(PTARE))*RLSTT + + +! Temperature normalization for humidity background change of variable +! INPUT : PTARE = TEMPERATURE +REAL(KIND=JPRB) :: FOETB +FOETB ( PTARE )=FOEALFA(PTARE)*R3LES*(RTT-R4LES)*(1.0_JPRB/(PTARE-R4LES)**2)+& + &(1.0_JPRB-FOEALFA(PTARE))*R3IES*(RTT-R4IES)*(1.0_JPRB/(PTARE-R4IES)**2) + +! ------------------------------------------------------------------ +! ***************************************************************** + +! CONSIDERATION OF DIFFERENT MIXED PHASE FOR CONV + +! ***************************************************************** + +! FOEALFCU is calculated to distinguish the three cases: + +! FOEALFCU=1 water phase +! FOEALFCU=0 ice phase +! 0 < FOEALFCU < 1 mixed phase + +! INPUT : PTARE = TEMPERATURE +REAL(KIND=JPRB) :: FOEALFCU +FOEALFCU (PTARE) = MIN(1.0_JPRB,((MAX(RTICECU,MIN(RTWAT,PTARE))& +&-RTICECU)*RTWAT_RTICECU_R)**2) + + +! Pressure of water vapour at saturation +! INPUT : PTARE = TEMPERATURE +REAL(KIND=JPRB) :: FOEEWMCU,FOEDEMCU,FOELDCPMCU,FOELHMCU +FOEEWMCU ( PTARE ) = R2ES *& + &(FOEALFCU(PTARE)*EXP(R3LES*(PTARE-RTT)/(PTARE-R4LES))+& + &(1.0_JPRB-FOEALFCU(PTARE))*EXP(R3IES*(PTARE-RTT)/(PTARE-R4IES))) + +FOEDEMCU ( PTARE )=FOEALFCU(PTARE)*R5ALVCP*(1.0_JPRB/(PTARE-R4LES)**2)+& + &(1.0_JPRB-FOEALFCU(PTARE))*R5ALSCP*(1.0_JPRB/(PTARE-R4IES)**2) + +FOELDCPMCU ( PTARE ) = FOEALFCU(PTARE)*RALVDCP+& + &(1.0_JPRB-FOEALFCU(PTARE))*RALSDCP + +FOELHMCU ( PTARE ) =& + &FOEALFCU(PTARE)*RLVTT+(1.0_JPRB-FOEALFCU(PTARE))*RLSTT +! ------------------------------------------------------------------ + +! Pressure of water vapour at saturation +! This one is for the WMO definition of saturation, i.e. always +! with respect to water. +! +! Duplicate to FOEELIQ and FOEEICE for separate ice variable +! FOEELIQ always respect to water +! FOEEICE always respect to ice +! FOEELIQ2ICE is the ratio of vapour pressures over water and ice +! (analytically simplified to avoid a suspected Cray compiler bug and using a single call to exp) +! (could use FOEEW and FOEEWMO, but naming convention unclear) +! FOELSON returns e wrt liquid water using D Sonntag (1994, Met. Zeit.) +! - now recommended for use with radiosonde data (WMO CIMO guide, 2014) +! unlike the FOEE functions does not include 1/(RETV+1.0_JPRB) factor + +REAL(KIND=JPRB) :: FOEEWMO, FOEELIQ, FOEEICE, FOEELIQ2ICE, FOELSON +FOEEWMO( PTARE ) = R2ES*EXP(R3LES*(PTARE-RTT)/(PTARE-R4LES)) +FOEELIQ( PTARE ) = R2ES*EXP(R3LES*(PTARE-RTT)/(PTARE-R4LES)) +FOEEICE( PTARE ) = R2ES*EXP(R3IES*(PTARE-RTT)/(PTARE-R4IES)) +FOEELIQ2ICE( PTARE ) = EXP( (PTARE-RTT)*(R3LES/(PTARE-R4LES) - R3IES/(PTARE-R4IES))) +FOELSON( PTARE ) = EXP( -6096.9385_JPRB/PTARE + 21.2409642_JPRB & + - 2.711193E-2_JPRB * PTARE & + + 1.673952E-5_JPRB * PTARE**2 & + + 2.433502_JPRB * LOG(PTARE)) + +REAL(KIND=JPRB) :: FOEEWM_V,FOEEWMCU_V,FOELES_V,FOEIES_V +REAL(KIND=JPRB) :: EXP1,EXP2 + FOELES_V(PTARE)=R3LES*(PTARE-RTT)/(PTARE-R4LES) + FOEIES_V(PTARE)=R3IES*(PTARE-RTT)/(PTARE-R4IES) + FOEEWM_V( PTARE,EXP1,EXP2 )=R2ES*(FOEALFA(PTARE)*EXP1+ & + & (1.0_JPRB-FOEALFA(PTARE))*EXP2) + FOEEWMCU_V ( PTARE,EXP1,EXP2 ) = R2ES*(FOEALFCU(PTARE)*EXP1+& + &(1.0_JPRB-FOEALFCU(PTARE))*EXP2) + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/ice_effective_radius.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/ice_effective_radius.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/ice_effective_radius.F90 (revision 6016) @@ -0,0 +1,176 @@ +SUBROUTINE ICE_EFFECTIVE_RADIUS & + & (YDERAD,KIDIA, KFDIA, KLON, KLEV, & + & PPRESSURE, PTEMPERATURE, PCLOUD_FRAC, PQ_ICE, PQ_SNOW, PGEMU, & + & PRE_UM) !, PPERT) + +! ICE_EFFECTIVE_RADIUS +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! PURPOSE +! ------- +! Calculate effective radius of ice clouds +! +! AUTHOR +! ------ +! Robin Hogan, ECMWF (using code extracted from radlswr.F90) +! Original: 2016-02-24 +! +! MODIFICATIONS +! ------------- +! +! +! ------------------------------------------------------------------- + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOERAD , ONLY : TERAD +USE YOMLUN , ONLY : NULERR +USE YOMCST , ONLY : RD, RTT + +! ------------------------------------------------------------------- + +IMPLICIT NONE + +! INPUT ARGUMENTS + +! *** Array dimensions and ranges +TYPE(TERAD) ,INTENT(IN) :: YDERAD +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA ! Start column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA ! End column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KLON ! Number of columns +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV ! Number of levels + +! *** Variables on model levels +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE(KLON,KLEV) ! (Pa) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE(KLON,KLEV) ! (K) +REAL(KIND=JPRB), INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV) ! (kg/kg) +REAL(KIND=JPRB), INTENT(IN) :: PQ_ICE(KLON,KLEV) ! (kg/kg) +REAL(KIND=JPRB), INTENT(IN) :: PQ_SNOW(KLON,KLEV) ! (kg/kg) + +! *** Single level variable +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) ! Sine of latitude + +! OUTPUT ARGUMENT +! Effective radius +REAL(KIND=JPRB), INTENT(OUT) :: PRE_UM(KLON,KLEV) ! (microns) + +! OPTIONAL INPUT ARGUMENT +! SPP perturbation pattern +! REAL(KIND=JPRB), INTENT(IN), OPTIONAL :: PPERT(KLON,YSPP%N2DRAD) + +! LOCAL VARIABLES + +REAL(KIND=JPRB) :: ZIWC_INCLOUD_GM3 ! In-cloud ice+snow water content in g m-3 +REAL(KIND=JPRB) :: ZAIR_DENSITY_GM3 ! Air density in g m-3 + +REAL(KIND=JPRB) :: ZTEMPERATURE_C ! Temperature, degrees Celcius +REAL(KIND=JPRB) :: ZAIWC, ZBIWC ! Factors in empirical relationship +REAL(KIND=JPRB) :: ZDEFAULT_RE_UM ! Default effective radius in microns +REAL(KIND=JPRB) :: ZDIAMETER_UM ! Effective diameter in microns + +! Min effective diameter in microns; may vary with latitude +REAL(KIND=JPRB) :: ZMIN_DIAMETER_UM(KLON) + +INTEGER(KIND=JPIM) :: JL, JK + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------- + +#include "abor1.intfb.h" + +! ------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('ICE_EFFECTIVE_RADIUS',0,ZHOOK_HANDLE) + +! ------------------------------------------------------------------- + +SELECT CASE(YDERAD%NRADIP) +CASE(0) + ! Ice effective radius fixed at 40 microns + PRE_UM(KIDIA:KFDIA,:) = 40.0_JPRB + +CASE(1,2) + ! Ice effective radius from Liou and Ou (1994) + DO JK = 1,KLEV + DO JL = KIDIA,KFDIA + ! Convert Kelvin to Celcius, preventing positive numbers + ZTEMPERATURE_C = MIN(PTEMPERATURE(JL,JK) - RTT, -0.1_JPRB) + ! Liou and Ou's empirical formula + PRE_UM(JL,JK) = 326.3_JPRB + ZTEMPERATURE_C * (12.42_JPRB& + & + ZTEMPERATURE_C * (0.197_JPRB + ZTEMPERATURE_C * 0.0012_JPRB)) + IF (YDERAD%NRADIP == 1) THEN + ! Original Liou and Ou (1994) bounds of 40-130 microns + PRE_UM(JL,JK) = MAX(PRE_UM(JL,JK), 40.0_JPRB) + PRE_UM(JL,JK) = MIN(PRE_UM(JL,JK),130.0_JPRB) + ELSE + ! Formulation following Jakob, Klein modifications to ice + ! content + PRE_UM(JL,JK) = MAX(PRE_UM(JL,JK), 30.0_JPRB) + PRE_UM(JL,JK) = MIN(PRE_UM(JL,JK), 60.0_JPRB) + ENDIF + ENDDO + ENDDO + +CASE(3) + ! Ice effective radius = f(T,IWC) from Sun and Rikus (1999), revised + ! by Sun (2001) + + ! Default effective radius is computed from an effective diameter of + ! 80 microns; note that multiplying by re2de actually converts from + ! effective diameter to effective radius. + ZDEFAULT_RE_UM = 80.0_JPRB * YDERAD%RRE2DE + + ! Minimum effective diameter may vary with latitude + IF (YDERAD%NMINICE == 0) THEN + ! Constant effective diameter + ZMIN_DIAMETER_UM(KIDIA:KFDIA) = YDERAD%RMINICE + ELSE + ! Ice effective radius varies with latitude, smaller at poles + DO JL = KIDIA,KFDIA + ZMIN_DIAMETER_UM(JL) = 20.0_JPRB + (YDERAD%RMINICE - 20.0_JPRB)& + & * COS(ASIN(PGEMU(JL))) + ENDDO + ENDIF + + DO JK = 1,KLEV + DO JL = KIDIA,KFDIA + IF (PCLOUD_FRAC(JL,JK) > 0.001_JPRB& + & .AND. (PQ_ICE(JL,JK)+PQ_SNOW(JL,JK)) > 0.0_JPRB) THEN + ZAIR_DENSITY_GM3 = 1000.0_JPRB * PPRESSURE(JL,JK) / (RD*PTEMPERATURE(JL,JK)) + ZIWC_INCLOUD_GM3 = ZAIR_DENSITY_GM3 * (PQ_ICE(JL,JK) + PQ_SNOW(JL,JK))& + & / PCLOUD_FRAC(JL,JK) + ZTEMPERATURE_C = PTEMPERATURE(JL,JK) - RTT + ! Sun, 2001 (corrected from Sun & Rikus, 1999) + ZAIWC = 45.8966_JPRB * ZIWC_INCLOUD_GM3**0.2214_JPRB + ZBIWC = 0.7957_JPRB * ZIWC_INCLOUD_GM3**0.2535_JPRB + ZDIAMETER_UM = (1.2351_JPRB + 0.0105_JPRB * ZTEMPERATURE_C)& + & * (ZAIWC + ZBIWC*(PTEMPERATURE(JL,JK) - 83.15_JPRB)) + + ZDIAMETER_UM = MIN ( MAX( ZDIAMETER_UM, ZMIN_DIAMETER_UM(JL)), 155.0_JPRB) + PRE_UM(JL,JK) = ZDIAMETER_UM * YDERAD%RRE2DE + ELSE + PRE_UM(JL,JK) = ZDEFAULT_RE_UM + ENDIF + ENDDO + ENDDO + +CASE DEFAULT + WRITE(NULERR,'(A,I0,A)') 'ICE EFFECTIVE RADIUS OPTION NRADLP=',YDERAD%NRADIP,' NOT AVAILABLE' + CALL ABOR1('ERROR IN ICE_EFFECTIVE_RADIUS') + +END SELECT + +! ------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('ICE_EFFECTIVE_RADIUS',1,ZHOOK_HANDLE) + +END SUBROUTINE ICE_EFFECTIVE_RADIUS Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/liquid_effective_radius.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/liquid_effective_radius.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/liquid_effective_radius.F90 (revision 6016) @@ -0,0 +1,208 @@ +SUBROUTINE LIQUID_EFFECTIVE_RADIUS & + & (YDERAD,KIDIA, KFDIA, KLON, KLEV, & + & PPRESSURE, PTEMPERATURE, PCLOUD_FRAC, PQ_LIQ, PQ_RAIN, & + & PLAND_FRAC, PCCN_LAND, PCCN_SEA, & + & PRE_UM) !, PPERT) + +! LIQUID_EFFECTIVE_RADIUS +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! PURPOSE +! ------- +! Calculate effective radius of liquid clouds +! +! AUTHOR +! ------ +! Robin Hogan, ECMWF (using code extracted from radlswr.F90) +! Original: 2015-09-24 +! +! MODIFICATIONS +! ------------- +! +! +! ------------------------------------------------------------------- + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOERAD , ONLY : TERAD +USE YOERDU , ONLY : REPLOG, REPSCW +USE YOMLUN , ONLY : NULERR +USE YOMCST , ONLY : RD, RPI + +! ------------------------------------------------------------------- + +IMPLICIT NONE + +! INPUT ARGUMENTS + +! *** Array dimensions and ranges +TYPE(TERAD) ,INTENT(IN) :: YDERAD +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA ! Start column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA ! End column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KLON ! Number of columns +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV ! Number of levels + +! *** Variables on model levels +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE(KLON,KLEV) ! (Pa) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE(KLON,KLEV) ! (K) +REAL(KIND=JPRB), INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_LIQ(KLON,KLEV) ! (kg/kg) +REAL(KIND=JPRB), INTENT(IN) :: PQ_RAIN(KLON,KLEV) ! (kg/kg) + +! *** Single-level variables +REAL(KIND=JPRB), INTENT(IN) :: PLAND_FRAC(KLON) ! 1=land, 0=sea +REAL(KIND=JPRB), INTENT(IN) :: PCCN_LAND(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PCCN_SEA(KLON) + +! OUTPUT ARGUMENT +! Effective radius +REAL(KIND=JPRB), INTENT(OUT) :: PRE_UM(KLON,KLEV) ! (microns) + +! PARAMETERS + +! Minimum and maximum effective radius, in microns +REAL(KIND=JPRB), PARAMETER :: PP_MIN_RE_UM = 4.0_JPRB +REAL(KIND=JPRB), PARAMETER :: PP_MAX_RE_UM = 30.0_JPRB + +! LOCAL VARIABLES +INTEGER(KIND=JPIM) :: IRADLP ! ID of effective radius scheme to use +REAL(KIND=JPRB) :: ZCCN ! CCN concentration (units?) + +REAL(KIND=JPRB) :: ZSPECTRAL_DISPERSION +REAL(KIND=JPRB) :: ZNTOT_CM3 ! Number conc in cm-3 +REAL(KIND=JPRB) :: ZRE_CUBED +REAL(KIND=JPRB) :: ZLWC_GM3, ZRWC_GM3 ! In-cloud liquid, rain content in g m-3 +REAL(KIND=JPRB) :: ZAIR_DENSITY_GM3 ! Air density in g m-3 +REAL(KIND=JPRB) :: ZRAIN_RATIO ! Ratio of rain to liquid water content +REAL(KIND=JPRB) :: ZWOOD_FACTOR, ZRATIO + +INTEGER(KIND=JPIM) :: JL, JK + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------- + +#include "abor1.intfb.h" + +! ------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('LIQUID_EFFECTIVE_RADIUS',0,ZHOOK_HANDLE) + +! ------------------------------------------------------------------- + +IRADLP=YDERAD%NRADLP + +SELECT CASE(IRADLP) +CASE(0) + ! Very old parameterization as a function of pressure, used in ERA-15 + PRE_UM(KIDIA:KFDIA,:) = 10.0_JPRB& + & + (100000.0_JPRB-PPRESSURE(KIDIA:KFDIA,:))*3.5_JPRB + +CASE(1) + ! Simple distinction between land (10um) and ocean (13um) by Zhang + ! and Rossow + DO JL = KIDIA,KFDIA + IF (PLAND_FRAC(JL) < 0.5_JPRB) THEN + PRE_UM(JL,:) = 13.0_JPRB + ELSE + PRE_UM(JL,:) = 10.0_JPRB + ENDIF + ENDDO + +CASE(2) + ! Martin et al. (JAS 1994) + DO JL = KIDIA,KFDIA + ! First compute the cloud droplet concentration + IF (PLAND_FRAC(JL) < 0.5_JPRB) THEN + ! Sea case + IF (YDERAD%LCCNO) THEN + ZCCN = PCCN_SEA(JL) + ELSE + ZCCN = YDERAD%RCCNSEA + ENDIF + ZSPECTRAL_DISPERSION = 0.77_JPRB + ! Cloud droplet concentration in cm-3 (activated CCN) over + ! ocean + ZNTOT_CM3 = -1.15E-03_JPRB*ZCCN*ZCCN + 0.963_JPRB*ZCCN + 5.30_JPRB + ELSE + ! Land case + IF (YDERAD%LCCNL) THEN + ZCCN=PCCN_LAND(JL) + ELSE + ZCCN=YDERAD%RCCNLND + ENDIF + ZSPECTRAL_DISPERSION = 0.69_JPRB + ! Cloud droplet concentration in cm-3 (activated CCN) over + ! land + ZNTOT_CM3 = -2.10E-04_JPRB*ZCCN*ZCCN + 0.568_JPRB*ZCCN - 27.9_JPRB + ENDIF + + ZRATIO = (0.222_JPRB/ZSPECTRAL_DISPERSION)**0.333_JPRB + + DO JK = 1,KLEV + + ! Only consider cloudy regions + IF (PCLOUD_FRAC(JL,JK) >= 0.001_JPRB& + & .AND. (PQ_LIQ(JL,JK)+PQ_RAIN(JL,JK)) > 0.0_JPRB) THEN + + ! Compute liquid and rain water contents + ZAIR_DENSITY_GM3 = 1000.0_JPRB * PPRESSURE(JL,JK)& + & / (RD*PTEMPERATURE(JL,JK)) + ! In-cloud mean water contents found by dividing by cloud + ! fraction + ZLWC_GM3 = ZAIR_DENSITY_GM3 * PQ_LIQ(JL,JK) / PCLOUD_FRAC(JL,JK) + ZRWC_GM3 = ZAIR_DENSITY_GM3 * PQ_RAIN(JL,JK) / PCLOUD_FRAC(JL,JK) + + ! Wood's (2000, eq. 19) adjustment to Martin et al's + ! parameterization + IF (ZLWC_GM3 > REPSCW) THEN + ZRAIN_RATIO = ZRWC_GM3 / ZLWC_GM3 + ZWOOD_FACTOR = ((1.0_JPRB + ZRAIN_RATIO)**0.666_JPRB)& + & / (1.0_JPRB + 0.2_JPRB * ZRATIO*ZRAIN_RATIO) + ELSE + ZWOOD_FACTOR = 1.0_JPRB + ENDIF + + ! g m-3 and cm-3 units cancel out with density of water + ! 10^6/(1000*1000); need a factor of 10^6 to convert to + ! microns and cubed root is factor of 100 which appears in + ! equation below + ZRE_CUBED = (3.0_JPRB * (ZLWC_GM3 + ZRWC_GM3))& + & / (4.0_JPRB*RPI*ZNTOT_CM3*ZSPECTRAL_DISPERSION) + IF (ZRE_CUBED > REPLOG) THEN + PRE_UM(JL,JK) = ZWOOD_FACTOR*100.0_JPRB*EXP(0.333_JPRB*LOG(ZRE_CUBED)) + ! Make sure effective radius is bounded in range 4-30 microns + PRE_UM(JL,JK) = MAX(PP_MIN_RE_UM, MIN(PRE_UM(JL,JK), PP_MAX_RE_UM)) + ELSE + PRE_UM(JL,JK) = PP_MIN_RE_UM + ENDIF + + ELSE + ! Cloud fraction or liquid+rain water content too low to + ! consider this a cloud + PRE_UM(JL,JK) = PP_MIN_RE_UM + + ENDIF + + ENDDO + + ENDDO + +CASE DEFAULT + WRITE(NULERR,'(A,I0,A)') 'LIQUID EFFECTIVE RADIUS OPTION IRADLP=',IRADLP,' NOT AVAILABLE' + CALL ABOR1('ERROR IN LIQUID_EFFECTIVE_RADIUS') +END SELECT + +! ------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('LIQUID_EFFECTIVE_RADIUS',1,ZHOOK_HANDLE) + +END SUBROUTINE LIQUID_EFFECTIVE_RADIUS Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/radiation_scheme.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/radiation_scheme.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/radiation_scheme.F90 (revision 6016) @@ -0,0 +1,626 @@ +SUBROUTINE RADIATION_SCHEME & + & (YRADIATION,KIDIA, KFDIA, KLON, KLEV, KAEROSOL, & + & PSOLAR_IRRADIANCE, & + & PMU0, PTEMPERATURE_SKIN, PALBEDO_DIF, PALBEDO_DIR, & + & PSPECTRALEMISS, & + & PCCN_LAND, PCCN_SEA, & + & PGELAM, PGEMU, PLAND_SEA_MASK, & + & PPRESSURE, PTEMPERATURE, & + & PPRESSURE_H, PTEMPERATURE_H, & + & PQ, PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, PCCL4, PO3, & + & PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_RAIN, PQ_SNOW, & + & PAEROSOL_OLD, PAEROSOL, & + & PFLUX_SW, PFLUX_LW, PFLUX_SW_CLEAR, PFLUX_LW_CLEAR, & + & PFLUX_SW_DN, PFLUX_LW_DN, PFLUX_SW_DN_CLEAR, PFLUX_LW_DN_CLEAR, & + & PFLUX_DIR, PFLUX_DIR_CLEAR, PFLUX_DIR_INTO_SUN, & + & PFLUX_UV, PFLUX_PAR, PFLUX_PAR_CLEAR, & + & PFLUX_SW_DN_TOA, PEMIS_OUT, PLWDERIVATIVE, & + & PSWDIFFUSEBAND, PSWDIRECTBAND) + +! RADIATION_SCHEME - Interface to modular radiation scheme +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! PURPOSE +! ------- +! The modular radiation scheme is contained in a separate +! library. This routine puts the the IFS arrays into appropriate +! objects, computing the additional data that is required, and sends +! it to the radiation scheme. It returns net fluxes and surface +! flux components needed by the rest of the model. +! +! Lower case is used for variables and types taken from the +! radiation library +! +! INTERFACE +! --------- +! RADIATION_SCHEME is called from RADLSWR. The +! SETUP_RADIATION_SCHEME routine (in the RADIATION_SETUP module) +! populates the YRADIATION object, and should have been run first. +! +! AUTHOR +! ------ +! Robin Hogan, ECMWF +! Original: 2015-09-16 +! +! MODIFICATIONS +! ------------- +! 2017-03-03 R. Hogan Read configuration data from YRADIATION object +! 2017-05-11 R. Hogan Pass KIDIA,KFDIA to get_layer_mass +! 2018-01-11 R. Hogan Capability to scale solar spectrum in each band +! 2017-11-11 M. Ahlgrimm add variable FSD for cloud heterogeneity +! 2017-11-29 R. Hogan Check fluxes in physical bounds +! 2019-01-22 R. Hogan Use fluxes in albedo bands from ecRad +! 2019-01-23 R. Hogan Spectral longwave emissivity in NLWEMISS bands +! 2019-02-04 R. Hogan Pass out surface longwave downwelling in each emissivity interval +! 2019-02-07 R. Hogan SPARTACUS cloud size from PARAM_CLOUD_EFFECTIVE_SEPARATION_ETA +! +!----------------------------------------------------------------------- + +! Modules from ifs or ifsaux libraries +USE PARKIND1 , ONLY : JPIM, JPRB, JPRD +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMCST , ONLY : RPI, RSIGMA ! Stefan-Boltzmann constant +USE YOMLUN , ONLY : NULERR +USE RADIATION_SETUP, ONLY : ITYPE_TROP_BG_AER, ITYPE_STRAT_BG_AER, TRADIATION + +! Modules from ecRad radiation library +USE RADIATION_CONFIG, ONLY : ISOLVERSPARTACUS +USE RADIATION_SINGLE_LEVEL, ONLY : SINGLE_LEVEL_TYPE +USE RADIATION_THERMODYNAMICS, ONLY : THERMODYNAMICS_TYPE +USE RADIATION_GAS, ONLY : GAS_TYPE,& + & IMASSMIXINGRATIO, IVOLUMEMIXINGRATIO,& + & IH2O, ICO2, ICH4, IN2O, ICFC11, ICFC12, IHCFC22, ICCL4, IO3, IO2 +USE RADIATION_CLOUD, ONLY : CLOUD_TYPE +USE RADIATION_AEROSOL, ONLY : AEROSOL_TYPE +USE RADIATION_FLUX, ONLY : FLUX_TYPE +USE RADIATION_INTERFACE, ONLY : RADIATION, SET_GAS_UNITS +USE RADIATION_SAVE, ONLY : SAVE_INPUTS, SAVE_FLUXES + +IMPLICIT NONE + +! INPUT ARGUMENTS + +TYPE(TRADIATION), INTENT(IN) :: YRADIATION + +! *** Array dimensions and ranges +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA ! Start column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA ! End column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KLON ! Number of columns +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV ! Number of levels +INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL ! Number of aerosol types + +! *** Single-level fields +REAL(KIND=JPRB), INTENT(IN) :: PSOLAR_IRRADIANCE ! (W m-2) +REAL(KIND=JPRB), INTENT(IN) :: PMU0(KLON) ! Cosine of solar zenith ang +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE_SKIN(KLON) ! (K) +! Diffuse and direct components of surface shortwave albedo +REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIF(KLON,YRADIATION%YRERAD%NSW) +REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIR(KLON,YRADIATION%YRERAD%NSW) +! Longwave spectral emissivity +REAL(KIND=JPRB), INTENT(IN) :: PSPECTRALEMISS(KLON,YRADIATION%YRERAD%NLWEMISS) +! Longitude (radians), sine of latitude +REAL(KIND=JPRB), INTENT(IN) :: PGELAM(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) +! Land-sea mask +REAL(KIND=JPRB), INTENT(IN) :: PLAND_SEA_MASK(KLON) + +! *** Variables on full levels +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE(KLON,KLEV) ! (Pa) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE(KLON,KLEV) ! (K) +! *** Variables on half levels +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1) ! (Pa) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE_H(KLON,KLEV+1) ! (K) + +! *** Gas mass mixing ratios on full levels +REAL(KIND=JPRB), INTENT(IN) :: PQ(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCO2(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCH4(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PN2O(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PNO2(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCFC11(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCFC12(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PHCFC22(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCCL4(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PO3(KLON,KLEV) + +! *** Cloud fraction and hydrometeor mass mixing ratios +REAL(KIND=JPRB), INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_LIQUID(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_ICE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_RAIN(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_SNOW(KLON,KLEV) + +! *** Aerosol mass mixing ratios +REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL_OLD(KLON,6,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL) + +REAL(KIND=JPRB), INTENT(IN) :: PCCN_LAND(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PCCN_SEA(KLON) + +! OUTPUT ARGUMENTS + +! *** Net fluxes on half-levels (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_CLEAR(KLON,KLEV+1) + +! *** Surface flux components (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_DN(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN_CLEAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_DN_CLEAR(KLON) +! Direct component of surface flux into horizontal plane +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON) +! As PFLUX_DIR but into a plane perpendicular to the sun +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON) + +! *** Ultraviolet and photosynthetically active radiation (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_UV(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_PAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_PAR_CLEAR(KLON) + +! *** Other single-level diagnostics +! Top-of-atmosphere incident solar flux (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN_TOA(KLON) +! Diagnosed longwave surface emissivity across the whole spectrum +REAL(KIND=JPRB), INTENT(OUT) :: PEMIS_OUT(KLON) + +! Partial derivative of total-sky longwave upward flux at each level +! with respect to upward flux at surface, used to correct heating +! rates at gridpoints/timesteps between calls to the full radiation +! scheme. Note that this version uses the convention of level index +! increasing downwards, unlike the local variable ZLwDerivative that +! is returned from the LW radiation scheme. +REAL(KIND=JPRB), INTENT(OUT) :: PLWDERIVATIVE(KLON,KLEV+1) + +! Surface diffuse and direct downwelling shortwave flux in each +! shortwave albedo band, used in RADINTG to update the surface fluxes +! accounting for high-resolution albedo information +REAL(KIND=JPRB), INTENT(OUT) :: PSWDIFFUSEBAND(KLON,YRADIATION%YRERAD%NSW) +REAL(KIND=JPRB), INTENT(OUT) :: PSWDIRECTBAND (KLON,YRADIATION%YRERAD%NSW) + +! LOCAL VARIABLES +TYPE(SINGLE_LEVEL_TYPE) :: SINGLE_LEVEL +TYPE(THERMODYNAMICS_TYPE) :: THERMODYNAMICS +TYPE(GAS_TYPE) :: GAS +TYPE(CLOUD_TYPE) :: YLCLOUD +TYPE(AEROSOL_TYPE) :: AEROSOL +TYPE(FLUX_TYPE) :: FLUX + +! Cloud effective radii in microns +REAL(KIND=JPRB) :: ZRE_LIQUID_UM(KLON,KLEV) +REAL(KIND=JPRB) :: ZRE_ICE_UM(KLON,KLEV) + +! Cloud overlap decorrelation length for cloud boundaries in km +REAL(KIND=JPRB) :: ZDECORR_LEN_KM(KLON) + +! Ratio of cloud overlap decorrelation length for cloud water +! inhomogeneities to that for cloud boundaries (typically 0.5) +REAL(KIND=JPRB) :: ZDECORR_LEN_RATIO + +! The surface net longwave flux if the surface was a black body, used +! to compute the effective broadband surface emissivity +REAL(KIND=JPRB) :: ZBLACK_BODY_NET_LW(KIDIA:KFDIA) + +! Layer mass in kg m-2 +REAL(KIND=JPRB) :: ZLAYER_MASS(KIDIA:KFDIA,KLEV) + +! Time integers +! INTEGER(KIND=JPIM) :: ITIM, IDAY + +! Loop indices +INTEGER(KIND=JPIM) :: JLON, JLEV, JBAND, JAER + +! Have any fluxes been returned that are out of a physically +! reasonable range? This integer stores the number of blocks of fluxes +! that have contained a bad value so far, for this task. NetCDF files +! will be written up to the value of NAERAD:NDUMPBADINPUTS. +INTEGER(KIND=JPIM), SAVE :: N_BAD_FLUXES = 0 + +! For debugging it can be useful to save input profiles and output +! fluxes without the condition that the fluxes are out of a reasonable +! range. NetCDF files will be written up to the value of +! NAERAD:NDUMPINPUTS. +INTEGER(KIND=JPIM), SAVE :: N_OUTPUT_FLUXES = 0 + +! NetCDF file name in case of bad fluxes +CHARACTER(LEN=512) :: CL_FILE_NAME + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! Dummy from YOMCT3 +! INTEGER(KIND=JPIM) :: NSTEP = 0 + +! Dummy from MPL_MYRANK_MOD +INTEGER(KIND=JPIM) :: MPL_MYRANK +MPL_MYRANK() = 1 + +! Import time functions for iseed calculation +#include "fcttim.func.h" + +#include "liquid_effective_radius.intfb.h" +#include "ice_effective_radius.intfb.h" +#include "cloud_overlap_decorr_len.intfb.h" +!#include "satur.intfb.h" +!#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',0,ZHOOK_HANDLE) + +ASSOCIATE(YRERAD =>YRADIATION%YRERAD, & + & RAD_CONFIG=>YRADIATION%RAD_CONFIG, & + & NWEIGHT_UV=>YRADIATION%NWEIGHT_UV, & + & IBAND_UV =>YRADIATION%IBAND_UV(:), & + & WEIGHT_UV =>YRADIATION%WEIGHT_UV(:), & + & NWEIGHT_PAR=>YRADIATION%NWEIGHT_PAR, & + & IBAND_PAR =>YRADIATION%IBAND_PAR(:), & + & WEIGHT_PAR=>YRADIATION%WEIGHT_PAR(:), & + & TROP_BG_AER_MASS_EXT=>YRADIATION%TROP_BG_AER_MASS_EXT, & + & STRAT_BG_AER_MASS_EXT=>YRADIATION%STRAT_BG_AER_MASS_EXT) +! Allocate memory in radiation objects +CALL SINGLE_LEVEL%ALLOCATE(KLON, YRERAD%NSW, YRERAD%NLWEMISS, & + & USE_SW_ALBEDO_DIRECT=.TRUE.) +CALL THERMODYNAMICS%ALLOCATE(KLON, KLEV, USE_H2O_SAT=.TRUE.) +CALL GAS%ALLOCATE(KLON, KLEV) +CALL YLCLOUD%ALLOCATE(KLON, KLEV) +IF (YRERAD%NAERMACC == 1) THEN + CALL AEROSOL%ALLOCATE(KLON, 1, KLEV, KAEROSOL) ! MACC aerosols +ELSE + CALL AEROSOL%ALLOCATE(KLON, 1, KLEV, 6) ! Tegen climatology +ENDIF +CALL FLUX%ALLOCATE(RAD_CONFIG, 1, KLON, KLEV) + +! Set thermodynamic profiles: simply copy over the half-level +! pressure and temperature +THERMODYNAMICS%PRESSURE_HL (KIDIA:KFDIA,:) = PPRESSURE_H (KIDIA:KFDIA,:) +THERMODYNAMICS%TEMPERATURE_HL(KIDIA:KFDIA,:) = PTEMPERATURE_H(KIDIA:KFDIA,:) + +! IFS currently sets the half-level temperature at the surface to be +! equal to the skin temperature. The radiation scheme takes as input +! only the half-level temperatures and assumes the Planck function to +! vary linearly in optical depth between half levels. In the lowest +! atmospheric layer, where the atmospheric temperature can be much +! cooler than the skin temperature, this can lead to significant +! differences between the effective temperature of this lowest layer +! and the true value in the model. +! +! We may approximate the temperature profile in the lowest model level +! as piecewise linear between the top of the layer T[k-1/2], the +! centre of the layer T[k] and the base of the layer Tskin. The mean +! temperature of the layer is then 0.25*T[k-1/2] + 0.5*T[k] + +! 0.25*Tskin, which can be achieved by setting the atmospheric +! temperature at the half-level corresponding to the surface as +! follows: +THERMODYNAMICS%TEMPERATURE_HL(KIDIA:KFDIA,KLEV+1)& + & = PTEMPERATURE(KIDIA:KFDIA,KLEV)& + & + 0.5_JPRB * (PTEMPERATURE_H(KIDIA:KFDIA,KLEV+1)& + & -PTEMPERATURE_H(KIDIA:KFDIA,KLEV)) + +! Alternatively we respect the model's atmospheric temperature in the +! lowest model level by setting the temperature at the lowest +! half-level such that the mean temperature of the layer is correct: +!thermodynamics%temperature_hl(KIDIA:KFDIA,KLEV+1) & +! & = 2.0_JPRB * PTEMPERATURE(KIDIA:KFDIA,KLEV) & +! & - PTEMPERATURE_H(KIDIA:KFDIA,KLEV) + +! Compute saturation specific humidity, used to hydrate aerosols. The +! "2" for the last argument indicates that the routine is not being +! called from within the convection scheme. +!CALL SATUR(KIDIA, KFDIA, KLON, 1, KLEV, .false., & +! & PPRESSURE, PTEMPERATURE, THERMODYNAMICS%H2O_SAT_LIQ, 2) +! Alternative approximate version using temperature and pressure from +! the thermodynamics structure +CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA) + +! Set single-level fileds +SINGLE_LEVEL%SOLAR_IRRADIANCE = PSOLAR_IRRADIANCE +SINGLE_LEVEL%COS_SZA(KIDIA:KFDIA) = PMU0(KIDIA:KFDIA) +SINGLE_LEVEL%SKIN_TEMPERATURE(KIDIA:KFDIA) = PTEMPERATURE_SKIN(KIDIA:KFDIA) +SINGLE_LEVEL%SW_ALBEDO(KIDIA:KFDIA,:) = PALBEDO_DIF(KIDIA:KFDIA,:) +SINGLE_LEVEL%SW_ALBEDO_DIRECT(KIDIA:KFDIA,:)=PALBEDO_DIR(KIDIA:KFDIA,:) +! Spectral longwave emissivity +SINGLE_LEVEL%LW_EMISSIVITY(KIDIA:KFDIA,:) = PSPECTRALEMISS(KIDIA:KFDIA,:) + +! Create the relevant seed from date and time get the starting day +! and number of minutes since start +! IDAY = NDD(NINDAT) +! ITIM = NINT(NSTEP * YDMODEL%YRML_GCONF%YRRIP%TSTEP / 60.0_JPRB) +! DO JLON = KIDIA, KFDIA +! ! This method gives a unique value for roughly every 1-km square +! ! on the globe and every minute. ASIN(PGEMU)*60 gives rough +! ! latitude in degrees, which we multiply by 100 to give a unique +! ! value for roughly every km. PGELAM*60*100 gives a unique number +! ! for roughly every km of longitude around the equator, which we +! ! multiply by 180*100 so there is no overlap with the latitude +! ! values. The result can be contained in a 32-byte integer (but +! ! since random numbers are generated with the help of integer +! ! overflow, it should not matter if the number did overflow). +! SINGLE_LEVEL%ISEED(JLON) = ITIM + IDAY & +! & + NINT(PGELAM(JLON)*108000000.0_JPRD & +! & + ASIN(PGEMU(JLON))*6000.0_JPRD) +! ENDDO + +! Simple initialization of the seeds for the Monte Carlo scheme +call single_level%init_seed_simple(kidia, kfdia) + +! Set the solar spectrum scaling, if required +IF (YRERAD%NSOLARSPECTRUM == 1) THEN + ALLOCATE(SINGLE_LEVEL%SPECTRAL_SOLAR_SCALING(RAD_CONFIG%N_BANDS_SW)) + ! Ratio of SORCE (Coddington et al. 2016) and Kurucz solar spectra + SINGLE_LEVEL%SPECTRAL_SOLAR_SCALING & + & = (/ 1.0, 1.0, 1.0, 1.0478, 1.0404, 1.0317, 1.0231, & + & 1.0054, 0.98413, 0.99863, 0.99907, 0.90589, 0.92213, 1.0 /) +ENDIF + +! Set cloud fields +YLCLOUD%Q_LIQ(KIDIA:KFDIA,:) = PQ_LIQUID(KIDIA:KFDIA,:) +YLCLOUD%Q_ICE(KIDIA:KFDIA,:) = PQ_ICE(KIDIA:KFDIA,:) + PQ_SNOW(KIDIA:KFDIA,:) +YLCLOUD%FRACTION(KIDIA:KFDIA,:) = PCLOUD_FRAC(KIDIA:KFDIA,:) + +! Compute effective radii and convert to metres +CALL LIQUID_EFFECTIVE_RADIUS(YRERAD, & + & KIDIA, KFDIA, KLON, KLEV, & + & PPRESSURE, PTEMPERATURE, PCLOUD_FRAC, PQ_LIQUID, PQ_RAIN, & + & PLAND_SEA_MASK, PCCN_LAND, PCCN_SEA, & + & ZRE_LIQUID_UM) !, PPERT=PPERT) +YLCLOUD%RE_LIQ(KIDIA:KFDIA,:) = ZRE_LIQUID_UM(KIDIA:KFDIA,:) * 1.0E-6_JPRB + +CALL ICE_EFFECTIVE_RADIUS(YRERAD, KIDIA, KFDIA, KLON, KLEV, & + & PPRESSURE, PTEMPERATURE, PCLOUD_FRAC, PQ_ICE, PQ_SNOW, PGEMU, & + & ZRE_ICE_UM) !, PPERT=PPERT) +YLCLOUD%RE_ICE(KIDIA:KFDIA,:) = ZRE_ICE_UM(KIDIA:KFDIA,:) * 1.0E-6_JPRB + +! Get the cloud overlap decorrelation length (for cloud boundaries), +! in km, according to the parameterization specified by NDECOLAT, +! and insert into the "cloud" object. Also get the ratio of +! decorrelation lengths for cloud water content inhomogeneities and +! cloud boundaries, and set it in the "rad_config" object. +CALL CLOUD_OVERLAP_DECORR_LEN(KIDIA,KFDIA,KLON, & + & PGEMU,YRERAD%NDECOLAT, & + & PDECORR_LEN_EDGES_KM=ZDECORR_LEN_KM, PDECORR_LEN_RATIO=ZDECORR_LEN_RATIO) + +! Compute cloud overlap parameter from decorrelation length +!RAD_CONFIG%CLOUD_INHOM_DECORR_SCALING = ZDECORR_LEN_RATIO +DO JLON = KIDIA,KFDIA + CALL YLCLOUD%SET_OVERLAP_PARAM(THERMODYNAMICS,& + & ZDECORR_LEN_KM(JLON)*1000.0_JPRB,& + & ISTARTCOL=JLON, IENDCOL=JLON) +ENDDO +! Or we can call the routine on all columns at once +!CALL YLCLOUD%SET_OVERLAP_PARAM(THERMODYNAMICS,& +! & ZDECORR_LEN_KM(KIDIA:KFDIA)*1000.0_JPRB,& +! & ISTARTCOL=KIDIA, IENDCOL=KFDIA) + +! Cloud water content fractional standard deviation is configurable +! from namelist NAERAD but must be globally constant. Before it was +! hard coded at 1.0. +CALL YLCLOUD%CREATE_FRACTIONAL_STD(KLON, KLEV, YRERAD%RCLOUD_FRAC_STD) + + +IF ( RAD_CONFIG%I_SOLVER_LW == ISOLVERSPARTACUS & + & .OR. RAD_CONFIG%I_SOLVER_SW == ISOLVERSPARTACUS) THEN + ! We are using the SPARTACUS solver so need to specify cloud scale, + ! and use Mark Fielding's parameterization based on ARM data + CALL YLCLOUD%PARAM_CLOUD_EFFECTIVE_SEPARATION_ETA(KLON, KLEV, & + & PPRESSURE_H, YRERAD%RCLOUD_SEPARATION_SCALE_SURF, & + & YRERAD%RCLOUD_SEPARATION_SCALE_TOA, 3.5_JPRB, 0.75_JPRB, & + & KIDIA, KFDIA) +ENDIF + +! Compute the dry mass of each layer neglecting humidity effects, in +! kg m-2, needed to scale some of the aerosol inputs +CALL THERMODYNAMICS%GET_LAYER_MASS(KIDIA,KFDIA,ZLAYER_MASS) + +! Copy over aerosol mass mixing ratio +IF (YRERAD%NAERMACC == 1) THEN + + + ! MACC aerosol from climatology or prognostic aerosol variables - + ! this is already in mass mixing ratio units with the required array + ! orientation so we can copy it over directly + ! AB need to cap the minimum mass mixing ratio/AOD to avoid instability + ! in case of negative values in input + DO JAER = 1,KAEROSOL + DO JLEV = 1,KLEV + DO JLON = KIDIA,KFDIA + AEROSOL%MIXING_RATIO(JLON,JLEV,JAER) = MAX(PAEROSOL(JLON,JLEV,JAER),0.0_JPRB) + ENDDO + ENDDO + ENDDO + + IF (YRERAD%NAERMACC == 1) THEN + ! Add the tropospheric and stratospheric backgrounds contained in the + ! old Tegen arrays - this is very ugly! + IF (TROP_BG_AER_MASS_EXT > 0.0_JPRB) THEN + AEROSOL%MIXING_RATIO(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER)& + & = AEROSOL%MIXING_RATIO(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER)& + & + PAEROSOL_OLD(KIDIA:KFDIA,1,:)& + & / (ZLAYER_MASS * TROP_BG_AER_MASS_EXT) + ENDIF + IF (STRAT_BG_AER_MASS_EXT > 0.0_JPRB) THEN + AEROSOL%MIXING_RATIO(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER)& + & = AEROSOL%MIXING_RATIO(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER)& + & + PAEROSOL_OLD(KIDIA:KFDIA,6,:)& + & / (ZLAYER_MASS * STRAT_BG_AER_MASS_EXT) + ENDIF + ENDIF +ELSE + + ! Tegen aerosol climatology - the array PAEROSOL_OLD contains the + ! 550-nm optical depth in each layer. The optics data file + ! aerosol_ifs_rrtm_tegen.nc does not contain mass extinction + ! coefficient, but a scaling factor that the 550-nm optical depth + ! should be multiplied by to obtain the optical depth in each + ! spectral band. Therefore, in order for the units to work out, we + ! need to divide by the layer mass (in kg m-2) to obtain the 550-nm + ! cross-section per unit mass of dry air (so in m2 kg-1). We also + ! need to permute the array. + DO JLEV = 1,KLEV + DO JAER = 1,6 + AEROSOL%MIXING_RATIO(KIDIA:KFDIA,JLEV,JAER)& + & = PAEROSOL_OLD(KIDIA:KFDIA,JAER,JLEV)& + & / ZLAYER_MASS(KIDIA:KFDIA,JLEV) + ENDDO + ENDDO + +ENDIF + +! Insert gas mixing ratios +CALL GAS%PUT(IH2O, IMASSMIXINGRATIO, PQ) +CALL GAS%PUT(ICO2, IMASSMIXINGRATIO, PCO2) +CALL GAS%PUT(ICH4, IMASSMIXINGRATIO, PCH4) +CALL GAS%PUT(IN2O, IMASSMIXINGRATIO, PN2O) +CALL GAS%PUT(ICFC11, IMASSMIXINGRATIO, PCFC11) +CALL GAS%PUT(ICFC12, IMASSMIXINGRATIO, PCFC12) +CALL GAS%PUT(IHCFC22, IMASSMIXINGRATIO, PHCFC22) +CALL GAS%PUT(ICCL4, IMASSMIXINGRATIO, PCCL4) +CALL GAS%PUT(IO3, IMASSMIXINGRATIO, PO3) +CALL GAS%PUT_WELL_MIXED(IO2, IVOLUMEMIXINGRATIO, 0.20944_JPRB) + +! Ensure the units of the gas mixing ratios are what is required by +! the gas absorption model +CALL SET_GAS_UNITS(RAD_CONFIG, GAS) + +!call save_inputs('inputs_ifs.nc', rad_config, single_level, thermodynamics, & +! & gas, ylcloud, aerosol, & +! & lat=spread(0.0_jprb,1,klon), & +! & lon=spread(0.0_jprb,1,klon), & +! & iverbose=2) + +! Call radiation scheme +CALL RADIATION(KLON, KLEV, KIDIA, KFDIA, RAD_CONFIG,& + & SINGLE_LEVEL, THERMODYNAMICS, GAS, YLCLOUD, AEROSOL, FLUX) + +! Check fluxes are within physical bounds +IF (YRERAD%NDUMPBADINPUTS /= 0 & + & .AND. (N_BAD_FLUXES == 0 .OR. N_BAD_FLUXES < YRERAD%NDUMPBADINPUTS)) THEN + IF (FLUX%OUT_OF_PHYSICAL_BOUNDS(KIDIA,KFDIA)) THEN +!$OMP CRITICAL + N_BAD_FLUXES = N_BAD_FLUXES+1 + WRITE(CL_FILE_NAME, '(A,I0,A,I0,A)') '/home/parr/ifs_dump/bad_inputs_', & + & MPL_MYRANK(), '_', N_BAD_FLUXES, '.nc' + WRITE(NULERR,*) ' Writing ', TRIM(CL_FILE_NAME) + ! Implicit assumption that KFDIA==KLON + CALL SAVE_INPUTS(TRIM(CL_FILE_NAME), RAD_CONFIG, SINGLE_LEVEL, & + & THERMODYNAMICS, GAS, YLCLOUD, AEROSOL, & + & LAT=ASIN(PGEMU)*180.0/RPI, LON=PGELAM*180.0/RPI, IVERBOSE=3) + WRITE(CL_FILE_NAME, '(A,I0,A,I0,A)') '/home/parr/ifs_dump/bad_outputs_', & + & MPL_MYRANK(), '_', N_BAD_FLUXES, '.nc' + WRITE(NULERR,*) ' Writing ', TRIM(CL_FILE_NAME) + CALL SAVE_FLUXES(TRIM(CL_FILE_NAME), RAD_CONFIG, THERMODYNAMICS, FLUX, IVERBOSE=3) + IF (YRERAD%NDUMPBADINPUTS < 0) THEN + ! Abort on the first set of bad fluxes + CALL ABOR1("RADIATION_SCHEME: ABORT DUE TO FLUXES OUT OF PHYSICAL BOUNDS") + ENDIF +!$OMP END CRITICAL + ENDIF +ENDIF + +! For debugging, do we store a certain number of inputs and outputs +! regardless of whether bad fluxes have been detected? +IF (N_OUTPUT_FLUXES < YRERAD%NDUMPINPUTS) THEN +!$OMP CRITICAL + N_OUTPUT_FLUXES = N_OUTPUT_FLUXES+1 + WRITE(CL_FILE_NAME, '(A,I0,A,I0,A)') '/home/parr/ifs_dump/inputs_', & + & MPL_MYRANK(), '_', N_OUTPUT_FLUXES, '.nc' + WRITE(NULERR,*) ' Writing ', TRIM(CL_FILE_NAME) + ! Implicit assumption that KFDIA==KLON + CALL SAVE_INPUTS(TRIM(CL_FILE_NAME), RAD_CONFIG, SINGLE_LEVEL, & + & THERMODYNAMICS, GAS, YLCLOUD, AEROSOL, & + & LAT=ASIN(PGEMU)*180.0/RPI, LON=PGELAM*180.0/RPI, IVERBOSE=3) + WRITE(CL_FILE_NAME, '(A,I0,A,I0,A)') '/home/parr/ifs_dump/outputs_', & + & MPL_MYRANK(), '_', N_OUTPUT_FLUXES, '.nc' + WRITE(NULERR,*) ' Writing ', TRIM(CL_FILE_NAME) + CALL SAVE_FLUXES(TRIM(CL_FILE_NAME), RAD_CONFIG, THERMODYNAMICS, FLUX, IVERBOSE=3) +!$OMP END CRITICAL +ENDIF + +! Compute required output fluxes +! First the net fluxes +PFLUX_SW(KIDIA:KFDIA,:) = FLUX%SW_DN(KIDIA:KFDIA,:) - FLUX%SW_UP(KIDIA:KFDIA,:) +PFLUX_LW(KIDIA:KFDIA,:) = FLUX%LW_DN(KIDIA:KFDIA,:) - FLUX%LW_UP(KIDIA:KFDIA,:) +PFLUX_SW_CLEAR(KIDIA:KFDIA,:)& + & = FLUX%SW_DN_CLEAR(KIDIA:KFDIA,:) - FLUX%SW_UP_CLEAR(KIDIA:KFDIA,:) +PFLUX_LW_CLEAR(KIDIA:KFDIA,:)& + & = FLUX%LW_DN_CLEAR(KIDIA:KFDIA,:) - FLUX%LW_UP_CLEAR(KIDIA:KFDIA,:) +! Now the surface fluxes +PFLUX_SW_DN (KIDIA:KFDIA) = FLUX%SW_DN (KIDIA:KFDIA,KLEV+1) +PFLUX_LW_DN (KIDIA:KFDIA) = FLUX%LW_DN (KIDIA:KFDIA,KLEV+1) +PFLUX_SW_DN_CLEAR(KIDIA:KFDIA) = FLUX%SW_DN_CLEAR (KIDIA:KFDIA,KLEV+1) +PFLUX_LW_DN_CLEAR(KIDIA:KFDIA) = FLUX%LW_DN_CLEAR (KIDIA:KFDIA,KLEV+1) +PFLUX_DIR (KIDIA:KFDIA) = FLUX%SW_DN_DIRECT (KIDIA:KFDIA,KLEV+1) +PFLUX_DIR_CLEAR (KIDIA:KFDIA) = FLUX%SW_DN_DIRECT_CLEAR(KIDIA:KFDIA,KLEV+1) +PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB +WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB)) + PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA) / PMU0(KIDIA:KFDIA) +ENDWHERE +! Top-of-atmosphere downwelling flux +PFLUX_SW_DN_TOA(KIDIA:KFDIA) = FLUX%SW_DN(KIDIA:KFDIA,1) + +! Compute UV fluxes as weighted sum of appropriate shortwave bands +PFLUX_UV (KIDIA:KFDIA) = 0.0_JPRB +DO JBAND = 1,NWEIGHT_UV +!DEC$ IVDEP + PFLUX_UV(KIDIA:KFDIA) = PFLUX_UV(KIDIA:KFDIA) + WEIGHT_UV(JBAND)& + & * FLUX%SW_DN_SURF_BAND(IBAND_UV(JBAND),KIDIA:KFDIA) +ENDDO + +! Compute photosynthetically active radiation similarly +PFLUX_PAR (KIDIA:KFDIA) = 0.0_JPRB +PFLUX_PAR_CLEAR(KIDIA:KFDIA) = 0.0_JPRB +DO JBAND = 1,NWEIGHT_PAR +!DEC$ IVDEP + PFLUX_PAR(KIDIA:KFDIA) = PFLUX_PAR(KIDIA:KFDIA) + WEIGHT_PAR(JBAND)& + & * FLUX%SW_DN_SURF_BAND(IBAND_PAR(JBAND),KIDIA:KFDIA) +!DEC$ IVDEP + PFLUX_PAR_CLEAR(KIDIA:KFDIA) = PFLUX_PAR_CLEAR(KIDIA:KFDIA)& + & + WEIGHT_PAR(JBAND)& + & * FLUX%SW_DN_SURF_CLEAR_BAND(IBAND_PAR(JBAND),KIDIA:KFDIA) +ENDDO + +! Compute effective broadband emissivity. This is only approximate - +! due to spectral variations in emissivity, it is not in general +! possible to provide a broadband emissivity that can reproduce the +! upwelling surface flux given the downwelling flux and the skin +! temperature. +ZBLACK_BODY_NET_LW = PFLUX_LW_DN(KIDIA:KFDIA) & + & - RSIGMA*PTEMPERATURE_SKIN(KIDIA:KFDIA)**4 +PEMIS_OUT(KIDIA:KFDIA) = PSPECTRALEMISS(KIDIA:KFDIA,1) ! Default value +WHERE (ABS(ZBLACK_BODY_NET_LW) > 1.0E-5) + ! This calculation can go outside the range of any individual + ! spectral emissivity value, so needs to be capped + PEMIS_OUT(KIDIA:KFDIA) = MAX(0.8_JPRB, MIN(0.99_JPRB, PFLUX_LW(KIDIA:KFDIA,KLEV+1) / ZBLACK_BODY_NET_LW)) +ENDWHERE + +! Copy longwave derivatives +IF (YRERAD%LAPPROXLWUPDATE) THEN + PLWDERIVATIVE(KIDIA:KFDIA,:) = FLUX%LW_DERIVATIVES(KIDIA:KFDIA,:) +ENDIF + +! Store the shortwave downwelling fluxes in each albedo band +IF (YRERAD%LAPPROXSWUPDATE) THEN + PSWDIFFUSEBAND(KIDIA:KFDIA,:) = TRANSPOSE(FLUX%SW_DN_DIFFUSE_SURF_CANOPY(:,KIDIA:KFDIA)) + PSWDIRECTBAND (KIDIA:KFDIA,:) = TRANSPOSE(FLUX%SW_DN_DIRECT_SURF_CANOPY (:,KIDIA:KFDIA)) +ENDIF + +CALL SINGLE_LEVEL%DEALLOCATE +CALL THERMODYNAMICS%DEALLOCATE +CALL GAS%DEALLOCATE +CALL YLCLOUD%DEALLOCATE +CALL AEROSOL%DEALLOCATE +CALL FLUX%DEALLOCATE + +END ASSOCIATE + +IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',1,ZHOOK_HANDLE) + +END SUBROUTINE RADIATION_SCHEME Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/radiation_setup.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/radiation_setup.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/radiation_setup.F90 (revision 6016) @@ -0,0 +1,553 @@ +MODULE RADIATION_SETUP + +! RADIATION_SETUP - Setting up modular radiation scheme +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! PURPOSE +! ------- +! The modular radiation scheme is contained in a separate +! library. SETUP_RADIATION_SCHEME in this module sets up a small +! derived type that contains the configuration object for the +! radiation scheme, plus a small number of additional variables +! needed for its implemenation in the IFS. +! +! INTERFACE +! --------- +! SETUP_RADIATION_SCHEME is called from SUECRAD. The radiation +! scheme is actually run using the RADIATION_SCHEME routine (not in +! this module). +! +! AUTHOR +! ------ +! Robin Hogan, ECMWF +! Original: 2015-09-16 +! +! MODIFICATIONS +! ------------- +! 2017-03-03 R. Hogan Put global variables in TRADIATION derived type +! 2017-11-17 S. Remy Add Nitrates and SOA if NAERMACC=0 +! 2017-11-28 R. Hogan Delta scaling applied to particles only +! 2018-01-11 R. Hogan Capability to scale solar spectrum in each band +! 2018-04-20 A. Bozzo Added capability to read in aerosol optical properties +! at selected wavelengths +! 2019-01-21 R. Hogan Explicit albedo and emissivity spectral definitions +! leading to smarter weighting in ecRad +! + +!----------------------------------------------------------------------- + +USE PARKIND1, ONLY : JPRB,JPIM +USE radiation_config, ONLY : config_type, & + & ISolverMcICA, ISolverSpartacus, & + & ISolverTripleclouds, ISolverCloudless, & + & ILiquidModelSlingo, ILiquidModelSOCRATES, & + & IIceModelFu, IIceModelBaran, & + & IOverlapExponential, IOverlapMaximumRandom, & + & IOverlapExponentialRandom +USE YOERAD, ONLY : TERAD + +IMPLICIT NONE + +SAVE + +! Background aerosol is specified in an ugly way: using the old Tegen +! fields that are in terms of optical depth, and converted to mass +! mixing ratio via the relevant mass-extinction coefficient. The +! following are the indices to the aerosol types used to describe +! tropospheric and stratospheric background aerosol. +INTEGER(KIND=JPIM), PARAMETER :: ITYPE_TROP_BG_AER = 8 ! hydrophobic organic +INTEGER(KIND=JPIM), PARAMETER :: ITYPE_STRAT_BG_AER=12 ! non-absorbing sulphate + +! This derived type contains configuration information for the +! radiation scheme plus a few additional variables and parameters +! needed for the IFS interface to it +TYPE :: TRADIATION + + ! Configuration for wider aspects of the radiation scheme + TYPE(TERAD) :: YRERAD + + ! Configuration information for the ecRad radiation scheme + type(config_type) :: rad_config + + ! Ultraviolet weightings + INTEGER(KIND=JPIM) :: NWEIGHT_UV + INTEGER(KIND=JPIM) :: IBAND_UV(100) + REAL(KIND=JPRB) :: WEIGHT_UV(100) + ! Photosynthetically active radiation weightings + INTEGER(KIND=JPIM) :: NWEIGHT_PAR + INTEGER(KIND=JPIM) :: IBAND_PAR(100) + REAL(KIND=JPRB) :: WEIGHT_PAR(100) + ! Mass-extinction coefficient (m2 kg-1) of tropospheric and + ! stratospheric background aerosol at 550 nm + REAL(KIND=JPRB) :: TROP_BG_AER_MASS_EXT + REAL(KIND=JPRB) :: STRAT_BG_AER_MASS_EXT + +END TYPE TRADIATION + +! Dummy type +TYPE :: TCOMPO + LOGICAL :: LAERNITRATE = .false. + LOGICAL :: LAERSOA = .false. +END TYPE TCOMPO + +CONTAINS + + ! This routine copies information between the IFS radiation + ! configuration (stored mostly in YDERAD) and the radiation + ! configuration of the modular radiation scheme (stored in + ! PRADIATION%rad_config). The optional input logical LDOUTPUT + ! controls whether to print lots of information during the setup + ! stage (default is no). + SUBROUTINE SETUP_RADIATION_SCHEME(PRADIATION,LDOUTPUT,FILE_NAME) + + USE YOMHOOK, ONLY : LHOOK, DR_HOOK, JPHOOK + USE YOMLUN, ONLY : NULOUT, NULERR + !USE YOESRTWN, ONLY : NMPSRTM + USE YOERAD, ONLY : TERAD + USE YOEPHY, ONLY : TEPHY + !USE YOMCOMPO, ONLY : TCOMPO + + USE RADIATION_INTERFACE, ONLY : SETUP_RADIATION + USE RADIATION_AEROSOL_OPTICS, ONLY : DRY_AEROSOL_MASS_EXTINCTION + + ! Radiation configuration information + TYPE(TCOMPO) :: YDCOMPO + TYPE(TRADIATION) ,INTENT(INOUT), TARGET :: PRADIATION + CHARACTER(LEN=512),INTENT(IN), OPTIONAL :: FILE_NAME + + ! Whether or not to print out information on the radiation scheme + ! configuration + LOGICAL, INTENT(IN), OPTIONAL :: LDOUTPUT + + ! Verbosity of configuration information 0=none, 1=warning, + ! 2=info, 3=progress, 4=detailed, 5=debug + INTEGER(KIND=JPIM) :: IVERBOSESETUP + !INTEGER(KIND=JPIM) :: ISTAT + + ! Data directory name + CHARACTER(LEN=256) :: CL_DATA_DIR + + ! Arrays to avoid temporaries + REAL(KIND=JPRB) :: ZWAVBOUND(15) + INTEGER(KIND=JPIM) :: IBAND(16) + + ! Do we use the nearest ecRad band to the albedo/emissivity + ! intervals, or a more intelligent weighting? + LOGICAL :: LL_DO_NEAREST_SW_ALBEDO, LL_DO_NEAREST_LW_EMISS + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +!#include "posname.intfb.h" +#include "abor1.intfb.h" + + IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',0,ZHOOK_HANDLE) + + ! *** GENERAL SETUP *** + ASSOCIATE(YDERAD=>PRADIATION%YRERAD) + ASSOCIATE(RAD_CONFIG=>PRADIATION%RAD_CONFIG,& + & LAERNITRATE=>YDCOMPO%LAERNITRATE, & + & LAERSOA=>YDCOMPO%LAERSOA, & + & YSPECTPLANCK=>YDERAD%YSPECTPLANCK) + + ! Configure verbosity of setup of radiation scheme + IVERBOSESETUP = 4 ! Provide plenty of information + IF (PRESENT(LDOUTPUT)) THEN + IF (.NOT. LDOUTPUT) THEN + IVERBOSESETUP = 1 ! Warnings and errors only + ENDIF + ENDIF + RAD_CONFIG%IVERBOSESETUP = IVERBOSESETUP + + IF (IVERBOSESETUP > 1) THEN + WRITE(NULOUT,'(a)') '-------------------------------------------------------------------------------' + WRITE(NULOUT,'(a)') 'RADIATION_SETUP: ecRad 1.5' + ENDIF + + ! Normal operation of the radiation scheme displays only errors + ! and warnings + RAD_CONFIG%IVERBOSE = 1 + + ! Read data directory name from the DATA environment variable + CALL GETENV("DATA", CL_DATA_DIR) + IF (CL_DATA_DIR /= " ") THEN + RAD_CONFIG%DIRECTORY_NAME = TRIM(CL_DATA_DIR) // "/ifsdata" + ELSE + ! If DATA not present, use the current directory + RAD_CONFIG%DIRECTORY_NAME = "." + ENDIF + + ! Do we do Hogan and Bozzo (2015) approximate longwave updates? + RAD_CONFIG%DO_LW_DERIVATIVES = YDERAD%LAPPROXLWUPDATE + + ! If we are to perform Hogan and Bozzo (2015) approximate + ! shortwave updates then we need the downwelling direct and + ! diffuse shortwave fluxes at the surface in each albedo spectral + ! interval + RAD_CONFIG%DO_CANOPY_FLUXES_SW = YDERAD%LAPPROXSWUPDATE + + ! If we are to perform approximate longwave updates and we are + ! using the new 6-interval longwave emissivity scheme then we need + ! ecRad to compute the downwelling surface longwave fluxes in each + ! emissivity spectral interval + IF (YDERAD%NLWOUT > 1) THEN + RAD_CONFIG%DO_CANOPY_FLUXES_LW = .TRUE. + ENDIF + + ! Surface spectral fluxes are needed for UV and PAR calculations + RAD_CONFIG%DO_SURFACE_SW_SPECTRAL_FLUX = .TRUE. + + + ! *** SETUP GAS OPTICS *** + + ! Assume IFS has already set-up RRTM, so the setup_radiation + ! routine below does not have to + !RAD_CONFIG%DO_SETUP_IFSRRTM = .FALSE. + + + ! *** SETUP CLOUD OPTICS *** + + ! Setup liquid optics + IF (YDERAD%NLIQOPT == 2) THEN + RAD_CONFIG%I_LIQ_MODEL = ILIQUIDMODELSLINGO + ELSEIF (YDERAD%NLIQOPT == 4) THEN + RAD_CONFIG%I_LIQ_MODEL = ILIQUIDMODELSOCRATES + ELSE + WRITE(NULERR,'(a,i0)') '*** Error: Unavailable liquid optics model in modular radiation scheme: NLIQOPT=', & + & YDERAD%NLIQOPT + CALL ABOR1('RADIATION_SETUP: error interpreting NLIQOPT') + ENDIF + + ! Setup ice optics + IF (YDERAD%NICEOPT == 3) THEN + RAD_CONFIG%I_ICE_MODEL = IICEMODELFU + IF (YDERAD%LFU_LW_ICE_OPTICS_BUG) THEN + RAD_CONFIG%DO_FU_LW_ICE_OPTICS_BUG = .TRUE. + ENDIF + ELSEIF (YDERAD%NICEOPT == 4) THEN + RAD_CONFIG%I_ICE_MODEL = IICEMODELBARAN + ELSE + WRITE(NULERR,'(a,i0)') '*** Error: Unavailable ice optics model in modular radiation scheme: NICEOPT=', & + & YDERAD%NICEOPT +!! CALL ABOR1('RADIATION_SETUP: error interpreting NICEOPT') !db fix + ENDIF + + ! For consistency with earlier versions of the IFS radiation + ! scheme, until 45R1 we performed shortwave delta-Eddington + ! scaling after the merge of the cloud, aerosol and gas optical + ! properties. Setting this to "false" does the scaling on the + ! cloud and aerosol properties separately before merging with + ! gases, which is more physically appropriate. The impact is very + ! small (see item 6 of table 2 of Technical Memo 787). + RAD_CONFIG%DO_SW_DELTA_SCALING_WITH_GASES = .FALSE. + + + ! *** SETUP AEROSOLS *** + + RAD_CONFIG%USE_AEROSOLS = .TRUE. + + ! If monochromatic aerosol properties are available they will be + ! read in automatically so the following is not needed + !IF (YDEAERATM%LAERRAD) RAD_CONFIG%AEROSOL_OPTICS%READ_MONOCHROMATIC_OPTICS=.TRUE. + + IF (YDERAD%NAERMACC == 1) THEN + ! Using MACC climatology or prognostic aerosol variables - in + ! this case the aerosol optics file will be chosen automatically + + ! 12 IFS aerosol classes: 1-3 Sea salt, 4-6 Boucher desert dust, + ! 7 hydrophilic organics, 8 hydrophobic organics, 9&10 + ! hydrophobic black carbon, 11 ammonium sulphate, 12 inactive + ! SO2 + RAD_CONFIG%N_AEROSOL_TYPES = 12 + + ! Indices to the aerosol optical properties in + ! aerosol_ifs_rrtm_*.nc, for each class, where negative numbers + ! index hydrophilic aerosol types and positive numbers index + ! hydrophobic aerosol types + RAD_CONFIG%I_AEROSOL_TYPE_MAP = 0 ! There can be up to 256 types + RAD_CONFIG%I_AEROSOL_TYPE_MAP(1:12) = (/& + & -1,&! Sea salt, size bin 1 (OPAC) + & -2,&! Sea salt, size bin 2 (OPAC) + & -3,&! Sea salt, size bin 3 (OPAC) + & 7,&! Desert dust, size bin 1 (Woodward 2001) + & 8,&! Desert dust, size bin 2 (Woodward 2001) + & 9,&! Desert dust, size bin 3 (Woodward 2001) + & -4,&! Hydrophilic organic matter (Hess, OPAC) + & 10,&! Hydrophobic organic matter (Hess, OPAC) + & 11,&! Black carbon (Hess, OPAC) + & 11,&! Black carbon (Hess, OPAC) + & -5,&! Ammonium sulphate (GACP) + & 14 /) ! Stratospheric sulphate (GACP) [ climatology only ] + + ! Background aerosol mass-extinction coefficients are obtained + ! after the configuration files have been read - see later in + ! this routine. + + ! The default aerosol optics file is the following - please + ! update here, not in radiation/module/radiation_config.F90 + RAD_CONFIG%AEROSOL_OPTICS_OVERRIDE_FILE_NAME = 'aerosol_ifs_rrtm_46R1_with_NI_AM.nc' + + ELSE + ! Using Tegen climatology + RAD_CONFIG%N_AEROSOL_TYPES = 6 + RAD_CONFIG%I_AEROSOL_TYPE_MAP = 0 ! There can be up to 256 types + RAD_CONFIG%I_AEROSOL_TYPE_MAP(1:6) = (/& + & 1,&! Continental background + & 2,&! Maritime + & 3,&! Desert + & 4,&! Urban + & 5,&! Volcanic active + & 6 /) ! Stratospheric background + + ! Manually set the aerosol optics file name (the directory will + ! be added automatically) + RAD_CONFIG%AEROSOL_OPTICS_OVERRIDE_FILE_NAME = 'aerosol_ifs_rrtm_tegen.nc' + ENDIF + + ! *** SETUP SOLVER *** + + ! 3D effects are off by default + RAD_CONFIG%DO_3D_EFFECTS = .FALSE. + + ! Select longwave solver + SELECT CASE (YDERAD%NLWSOLVER) + CASE(0) + RAD_CONFIG%I_SOLVER_LW = ISOLVERMCICA + CASE(1) + RAD_CONFIG%I_SOLVER_LW = ISOLVERSPARTACUS + CASE(2) + RAD_CONFIG%I_SOLVER_LW = ISOLVERSPARTACUS + RAD_CONFIG%DO_3D_EFFECTS = .TRUE. + CASE(3) + RAD_CONFIG%I_SOLVER_LW = ISOLVERTRIPLECLOUDS + CASE(4) + RAD_CONFIG%I_SOLVER_LW = ISOLVERCLOUDLESS + CASE DEFAULT + WRITE(NULERR,'(a,i0)') '*** Error: Unknown value for NLWSOLVER: ', YDERAD%NLWSOLVER + CALL ABOR1('RADIATION_SETUP: error interpreting NLWSOLVER') + END SELECT + + ! Select shortwave solver + SELECT CASE (YDERAD%NSWSOLVER) + CASE(0) + RAD_CONFIG%I_SOLVER_SW = ISOLVERMCICA + CASE(1) + RAD_CONFIG%I_SOLVER_SW = ISOLVERSPARTACUS + RAD_CONFIG%DO_3D_EFFECTS = .FALSE. + IF (YDERAD%NLWSOLVER == 2) THEN + CALL ABOR1('RADIATION_SETUP: cannot represent 3D effects in LW but not SW') + ENDIF + CASE(2) + RAD_CONFIG%I_SOLVER_SW = ISOLVERSPARTACUS + RAD_CONFIG%DO_3D_EFFECTS = .TRUE. + IF (YDERAD%NLWSOLVER == 1) THEN + CALL ABOR1('RADIATION_SETUP: cannot represent 3D effects in SW but not LW') + ENDIF + CASE(3) + RAD_CONFIG%I_SOLVER_SW = ISOLVERTRIPLECLOUDS + CASE(4) + RAD_CONFIG%I_SOLVER_SW = ISOLVERCLOUDLESS + CASE DEFAULT + WRITE(NULERR,'(a,i0)') '*** Error: Unknown value for NSWSOLVER: ', YDERAD%NSWSOLVER + CALL ABOR1('RADIATION_SETUP: error interpreting NSWSOLVER') + END SELECT + + ! For stability the cloud effective size can't be too small in + ! SPARTACUS + RAD_CONFIG%MIN_CLOUD_EFFECTIVE_SIZE = 500.0_JPRB + + ! SPARTACUS solver requires delta scaling to be done separately + ! for clouds & aerosols + IF (RAD_CONFIG%I_SOLVER_SW == ISOLVERSPARTACUS) THEN + RAD_CONFIG%DO_SW_DELTA_SCALING_WITH_GASES = .FALSE. + ENDIF + + ! Do we represent longwave scattering? + RAD_CONFIG%DO_LW_CLOUD_SCATTERING = .FALSE. + RAD_CONFIG%DO_LW_AEROSOL_SCATTERING = .FALSE. + SELECT CASE (YDERAD%NLWSCATTERING) + CASE(1) + RAD_CONFIG%DO_LW_CLOUD_SCATTERING = .TRUE. + CASE(2) + RAD_CONFIG%DO_LW_CLOUD_SCATTERING = .TRUE. + IF (YDERAD%NAERMACC > 0) THEN + ! Tegen climatology omits data required to do longwave + ! scattering by aerosols, so only turn this on with a more + ! recent scattering database + RAD_CONFIG%DO_LW_AEROSOL_SCATTERING = .TRUE. + ENDIF + END SELECT + + SELECT CASE (YDERAD%NCLOUDOVERLAP) + CASE (1) + RAD_CONFIG%I_OVERLAP_SCHEME = IOVERLAPMAXIMUMRANDOM + CASE (2) + ! Use Exponential-Exponential cloud overlap to match original IFS + ! implementation of Raisanen cloud generator + RAD_CONFIG%I_OVERLAP_SCHEME = IOVERLAPEXPONENTIAL + CASE (3) + RAD_CONFIG%I_OVERLAP_SCHEME = IOVERLAPEXPONENTIALRANDOM + CASE DEFAULT + WRITE(NULERR,'(a,i0)') '*** Error: Unknown value for NCLOUDOVERLAP: ', YDERAD%NCLOUDOVERLAP + CALL ABOR1('RADIATION_SETUP: error interpreting NCLOUDOVERLAP') + END SELECT + + ! Change cloud overlap to exponential-random if Tripleclouds or + ! SPARTACUS selected as both the shortwave and longwave solvers + IF (RAD_CONFIG%I_OVERLAP_SCHEME /= IOVERLAPEXPONENTIALRANDOM & + & .AND. ( RAD_CONFIG%I_SOLVER_SW == ISOLVERTRIPLECLOUDS & + & .OR. RAD_CONFIG%I_SOLVER_LW == ISOLVERTRIPLECLOUDS & + & .OR. RAD_CONFIG%I_SOLVER_SW == ISOLVERSPARTACUS & + & .OR. RAD_CONFIG%I_SOLVER_LW == ISOLVERSPARTACUS)) THEN + IF (RAD_CONFIG%I_SOLVER_SW == RAD_CONFIG%I_SOLVER_LW) THEN + WRITE(NULOUT,'(a)') 'Warning: Tripleclouds/SPARTACUS solver selected so changing cloud overlap to Exp-Ran' + RAD_CONFIG%I_OVERLAP_SCHEME = IOVERLAPEXPONENTIALRANDOM + ELSE + ! If the solvers are not the same and exponential-random has + ! not been selected then abort + WRITE(NULERR,'(a)') '*** Error: Tripleclouds and SPARTACUS solvers can only simulate exponential-random overlap' + CALL ABOR1('RADIATION_SETUP: Cloud overlap incompatible with solver') + ENDIF + + ! For additional stability in SPARTACUS solver it helps if the + ! cloud fraction threshold is higher than the default of 1.0e-6 + ! used for McICA; this is done for Tripleclouds too so that it + ! is a good control for SPARTACUS. + RAD_CONFIG%CLOUD_FRACTION_THRESHOLD = 2.5E-5_JPRB + ENDIF + + + ! Number of longwave surface emissivity intervals to use: + ! Traditional approach: one value of emissivty for parts of the + ! spectrum on either side of the infrared atmospheric window + ! (PEMIR), and one value for the window itself (PEMIW) + YDERAD%NLWEMISS = 2 + ! ...and the longwave approximate update scheme uses a single + ! broadband emissivity + YDERAD%NLWOUT = 1 + ! Create a spectral Planck look-up table, used by RADHEATN. Note + ! that this routine makes use of the length of its third argument. + ! The wavelength bounds (metres) allow for the first emissivity to + ! represent values outside the infrared atmospheric window, and the + ! second emissivity to represent values within it. + CALL YDERAD%YSPECTPLANCK%INIT(2, [ 8.0E-6_JPRB, 13.0E-6_JPRB ], & + & [ 1,2,1 ]) + + ! Populate the mapping between the 14 RRTM shortwave bands and the + ! 6 albedo inputs. + YDERAD%NSW = 6 + ZWAVBOUND(1:5) = [ 0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, & + & 1.19e-6_jprb, 2.38e-6_jprb ] + IBAND(1:6) = [ 1,2,3,4,5,6 ] + ! If NALBEDOSCHEME==2 then we are using the 6-component MODIS + ! albedo climatology, and a weighted average is used to compute + ! the albedos in each ecRad spectral band. If NALBEDOSCHEME==3 + ! then we use the diffuse part of the 4 components but still with + ! a weighted average. Otherwise the older behaviour is followed: + ! the nearest albedo interval to each band is selected, resulting + ! in a discrete mapping that matches the one in YOESRTWN:NMPSRTM. + ! Note that this tends to bias albedo high because there is a lot + ! of energy around the interface between the UV-Vis and Near-IR + ! channels, so this should be close to the 0.7 microns intended by + ! the MODIS dataset, not shifted to the nearest RRTM band boundary + ! at 0.625 microns. + LL_DO_NEAREST_SW_ALBEDO = .FALSE. + CALL RAD_CONFIG%DEFINE_SW_ALBEDO_INTERVALS(YDERAD%NSW, ZWAVBOUND, IBAND, & + & DO_NEAREST=LL_DO_NEAREST_SW_ALBEDO) + + ! Likewise between the 16 RRTM longwave bands and the NLWEMISS + ! emissivity inputs - these are defined in suecrad.F90. + LL_DO_NEAREST_LW_EMISS = .TRUE. + CALL RAD_CONFIG%DEFINE_LW_EMISS_INTERVALS(UBOUND(YSPECTPLANCK%INTERVAL_MAP,1), & + & YSPECTPLANCK%WAVLEN_BOUND, YSPECTPLANCK%INTERVAL_MAP, & + & DO_NEAREST=LL_DO_NEAREST_LW_EMISS) + + ! Do we scale the incoming solar radiation in each band? + IF (YDERAD%NSOLARSPECTRUM == 1) THEN + IF (RAD_CONFIG%N_BANDS_SW /= 14) THEN + WRITE(NULERR,'(a)') '*** Error: Shortwave must have 14 bands to apply spectral scaling' + CALL ABOR1('RADIATION_SETUP: Shortwave must have 14 bands to apply spectral scaling') + ELSE + RAD_CONFIG%USE_SPECTRAL_SOLAR_SCALING = .TRUE. + ENDIF + ENDIF + + ! *** IMPLEMENT SETTINGS *** + + ! For advanced configuration, the configuration data for the + ! "radiation" project can specified directly in the namelist. + ! However, the variable naming convention is not consistent with + ! the rest of the IFS. For basic configuration there are specific + ! variables in the NAERAD namelist available in the YDERAD + ! structure. + !CALL POSNAME(NULNAM, 'RADIATION', ISTAT) + !SELECT CASE (ISTAT) + ! CASE(0) + ! CALL RAD_CONFIG%READ(UNIT=NULNAM) + ! CASE(1) + ! WRITE(NULOUT,'(a)') 'Namelist RADIATION not found, using settings from NAERAD only' + ! CASE DEFAULT + ! CALL ABOR1('RADIATION_SETUP: error reading RADIATION section of namelist file') + !END SELECT + IF (PRESENT(FILE_NAME)) THEN + CALL RAD_CONFIG%READ(FILE_NAME=FILE_NAME) + ENDIF + + ! Print configuration + IF (IVERBOSESETUP > 1) THEN + WRITE(NULOUT,'(a)') 'Radiation scheme settings:' + CALL RAD_CONFIG%PRINT(IVERBOSE=IVERBOSESETUP) + ENDIF + + ! Use configuration data to set-up radiation scheme, including + ! reading scattering datafiles + CALL SETUP_RADIATION(RAD_CONFIG) + + ! Get spectral weightings for UV and PAR + CALL RAD_CONFIG%GET_SW_WEIGHTS(0.2E-6_JPRB, 0.4415E-6_JPRB,& + & PRADIATION%NWEIGHT_UV, PRADIATION%IBAND_UV, PRADIATION%WEIGHT_UV,& + & 'ultraviolet') + CALL RAD_CONFIG%GET_SW_WEIGHTS(0.4E-6_JPRB, 0.7E-6_JPRB,& + & PRADIATION%NWEIGHT_PAR, PRADIATION%IBAND_PAR, PRADIATION%WEIGHT_PAR,& + & 'photosynthetically active radiation, PAR') + + IF (YDERAD%NAERMACC > 0) THEN + ! With the MACC aerosol climatology we need to add in the + ! background aerosol afterwards using the Tegen arrays. In this + ! case we first configure the background aerosol mass-extinction + ! coefficient at 550 nm, which corresponds to the 10th RRTMG + ! shortwave band. + PRADIATION%TROP_BG_AER_MASS_EXT = DRY_AEROSOL_MASS_EXTINCTION(RAD_CONFIG,& + & ITYPE_TROP_BG_AER, 550.0E-9_JPRB) + PRADIATION%STRAT_BG_AER_MASS_EXT = DRY_AEROSOL_MASS_EXTINCTION(RAD_CONFIG,& + & ITYPE_STRAT_BG_AER, 550.0E-9_JPRB) + + WRITE(NULOUT,'(a,i0)') 'Tropospheric background uses aerosol type ',& + & ITYPE_TROP_BG_AER + WRITE(NULOUT,'(a,i0)') 'Stratospheric background uses aerosol type ',& + & ITYPE_STRAT_BG_AER + ELSE + PRADIATION%TROP_BG_AER_MASS_EXT = 0.0_JPRB + PRADIATION%STRAT_BG_AER_MASS_EXT = 0.0_JPRB + ENDIF + + IF (IVERBOSESETUP > 1) THEN + WRITE(NULOUT,'(a)') '-------------------------------------------------------------------------------' + ENDIF + + END ASSOCIATE + END ASSOCIATE + + IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',1,ZHOOK_HANDLE) + + END SUBROUTINE SETUP_RADIATION_SCHEME + + +END MODULE RADIATION_SETUP Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/satur.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/satur.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/satur.F90 (revision 6016) @@ -0,0 +1,143 @@ +! (C) Copyright 1996- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +SUBROUTINE SATUR ( KIDIA , KFDIA , KLON , KTDIA , KLEV, LDPHYLIN, & + & PAPRSF, PT , PQSAT , KFLAG) + +!*** + +! ** *SATUR* - COMPUTES SPECIFIC HUMIDITY AT SATURATION + +! J.F. MAHFOUF E.C.M.W.F. 15/05/96 + +! Modified J. HAGUE 13/01/03 MASS Vector Functions + +! PURPOSE. +! -------- + +! SPECIFIC HUMIDITY AT SATURATION IS USED BY THE +! DIAGNOSTIC CLOUD SCHEME TO COMPUTE RELATIVE HUMIDITY +! AND LIQUID WATER CONTENT + +! INTERFACE +! --------- + +! THIS ROUTINE IS CALLED FROM *CALLPAR*. + +! PARAMETER DESCRIPTION UNITS +! --------- ----------- ----- +! INPUT PARAMETERS (INTEGER): + +! *KIDIA* START POINT +! *KFDIA* END POINT +! *KLON* NUMBER OF GRID POINTS PER PACKET +! *KTDIA* START OF THE VERTICAL LOOP +! *KLEV* NUMBER OF LEVELS + +! INPUT PARAMETERS (REAL): + +! *PAPRSF* PRESSURE ON FULL LEVELS PA +! *PT* TEMPERATURE AT T-DT K + +! INPUT PARAMETERS (INTEGER): + +! *KFLAG* FLAG TO DETECT CALL FROM + +! CONVECTION KFLAG=1 +! OTHER KFLAG=2 + +! OUTPUT PARAMETER (REAL): + +! *PQSAT* SATURATION SPECIFIC HUMIDITY KG/KG + +!------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOMCST , ONLY : RETV ,RLVTT ,RLSTT ,RTT +USE YOETHF , ONLY : R2ES ,R3LES ,R3IES ,R4LES ,& + & R4IES ,R5LES ,R5IES ,R5ALVCP ,R5ALSCP ,& + & RALVDCP ,RALSDCP ,RTWAT ,RTICE ,RTICECU ,& + & RTWAT_RTICE_R ,RTWAT_RTICECU_R + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KLON +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KTDIA +LOGICAL ,INTENT(IN) :: LDPHYLIN +REAL(KIND=JPRB) ,INTENT(IN) :: PAPRSF(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PT(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PQSAT(KLON,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KFLAG +INTEGER(KIND=JPIM) :: JK, JL + +REAL(KIND=JPRB) :: ZCOR, ZEW, ZFOEEW, ZQMAX, ZQS, ZTARG +REAL(KIND=JPRB) :: ZALFA, ZFOEEWL, ZFOEEWI +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +!DIR$ VFUNCTION EXPHF + +#include "fcttre.func.h" + +!---------------------------------------------------------------------- + +!* 1. DEFINE CONSTANTS +! ---------------- + +IF (LHOOK) CALL DR_HOOK('SATUR',0,ZHOOK_HANDLE) +ZQMAX=0.5_JPRB + +! * +!---------------------------------------------------------------------- + +! * 2. CALCULATE SATURATION SPECIFIC HUMIDITY +! -------------------------------------- + +IF (LDPHYLIN) THEN + DO JK=KTDIA,KLEV + DO JL=KIDIA, KFDIA + ZTARG = PT(JL,JK) + ZALFA = FOEALFA(ZTARG) + + ZFOEEWL = R2ES*EXP(R3LES*(ZTARG-RTT)/(ZTARG-R4LES)) + ZFOEEWI = R2ES*EXP(R3IES*(ZTARG-RTT)/(ZTARG-R4IES)) + ZFOEEW = ZALFA*ZFOEEWL+(1.0_JPRB-ZALFA)*ZFOEEWI + + ZQS = ZFOEEW/PAPRSF(JL,JK) + IF (ZQS > ZQMAX) THEN + ZQS=ZQMAX + ENDIF + ZCOR = 1.0_JPRB/(1.0_JPRB-RETV*ZQS) + PQSAT(JL,JK)=ZQS*ZCOR + ENDDO + ENDDO +ELSE + + DO JK=KTDIA,KLEV + DO JL=KIDIA, KFDIA + IF(KFLAG == 1) THEN + ZEW = FOEEWMCU(PT(JL,JK)) + ELSE + ZEW = FOEEWM(PT(JL,JK)) + ENDIF + ZQS = ZEW/PAPRSF(JL,JK) + ZQS = MIN(ZQMAX,ZQS) + ZCOR = 1.0_JPRB/(1.0_JPRB-RETV*ZQS) + PQSAT(JL,JK)=ZQS*ZCOR + ENDDO + ENDDO + +ENDIF + +IF (LHOOK) CALL DR_HOOK('SATUR',1,ZHOOK_HANDLE) +END SUBROUTINE SATUR Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoe_spectral_planck.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoe_spectral_planck.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoe_spectral_planck.F90 (revision 6016) @@ -0,0 +1,353 @@ +! (C) Copyright 2019- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOE_SPECTRAL_PLANCK + +! YOE_SPECTRAL_PLANCK +! +! PURPOSE +! ------- +! Calculate Planck function integrated across user-specified +! spectral intervals, used in RADHEATN by approximate longwave +! update scheme to modify longwave fluxes to account for the +! spectral emissivity on the high-resolution model grid (rather than +! the lower resolution grid seen by the radiation scheme). +! +! INTERFACE +! --------- +! Call the INIT member routine to configure the look-up table of the +! TSPECRALPLANCK type, followed by any number of CALC calls with the +! temperatures at which the Planck function is required. FREE then +! deallocates memory. +! +! AUTHOR +! ------ +! Robin Hogan, ECMWF +! Original: 2019-02-04 +! +! MODIFICATIONS +! ------------- +! A Dawson 2019-08-05 avoid single precision overflow in INIT + +!----------------------------------------------------------------------- + +USE PARKIND1, ONLY : JPRB,JPRD,JPIM +IMPLICIT NONE +SAVE + +!----------------------------------------------------------------------- +! Type for storing Planck function look-up table +TYPE TSPECTRALPLANCK + ! Number of intervals over which the integrated Planck function is + ! required. Note that an interval need not be contiguous in + ! wavelength. + INTEGER(KIND=JPIM) :: NINTERVALS + + ! Number of temperatures in look-up table + INTEGER(KIND=JPIM) :: NTEMPS + + ! Start temperature and temperature spacing of look-up table + REAL(KIND=JPRB) :: TEMP1, DTEMP + + ! Integrated Planck functions in look-up table, dimensioned + ! (NINTERVALS,NTEMPS) + REAL(KIND=JPRB), ALLOCATABLE :: PLANCK_LUT(:,:) + + ! Store interval data + REAL(KIND=JPRB), ALLOCATABLE :: WAVLEN_BOUND(:) + INTEGER(KIND=JPIM), ALLOCATABLE :: INTERVAL_MAP(:) + +CONTAINS + PROCEDURE :: INIT + PROCEDURE :: CALC + PROCEDURE :: PRINT=> PRINT_SPECTRAL_PLANCK + PROCEDURE :: FREE => FREE_SPECTRAL_PLANCK + +END TYPE TSPECTRALPLANCK + +CONTAINS + +!----------------------------------------------------------------------- +! Generate a Planck function look-up table consisting of KINTERVALS +! spectral intervals (which need not be contiguous in wavelength), +! whose wavelength bounds are defined by PWAVLEN_BOUND and mapping +! on to KINTERVALS described by KINTERVAL_MAP. +SUBROUTINE INIT(SELF, KINTERVALS, PWAVLEN_BOUND, KINTERVAL_MAP) + + USE YOMCST, ONLY : RPI, RKBOL, RHPLA, RCLUM + USE YOMHOOK, ONLY : LHOOK, DR_HOOK, JPHOOK + USE YOMLUN, ONLY : NULOUT + + CLASS(TSPECTRALPLANCK), INTENT(INOUT) :: SELF + INTEGER(KIND=JPIM) , INTENT(IN) :: KINTERVALS + REAL(KIND=JPRB) , INTENT(IN) :: PWAVLEN_BOUND(:) + INTEGER(KIND=JPIM) , INTENT(IN) :: KINTERVAL_MAP(:) + + ! Current temperature (K) + REAL(KIND=JPRB) :: ZTEMP + + ! Combinations of constants in the Planck function + REAL(KIND=JPRB) :: ZCOEFF1, ZCOEFF2 + + ! Wavelengths at start and end of range + REAL(KIND=JPRB) :: ZWAVLEN1, ZWAVLEN2, DWAVLEN + + ! Wavelength, wavelength squared + REAL(KIND=JPRB) :: ZWAVLEN, ZWAVLEN_SQR + + ! Sum of Planck values, integration weight + REAL(KIND=JPRB) :: ZSUM, ZWEIGHT + + ! A double-precision temporary to hold the exponential term in Planck's law. + ! A single precision float can overflow during this calculation. + REAL(KIND=JPRD) :: ZPLANCKEXP + + ! Number of wavelength ranges represented by PWAVLEN_BOUND and + ! KINTERVAL_MAP + INTEGER(KIND=JPIM) :: NRANGES, NWAVLEN + + INTEGER(KIND=JPIM) :: JT, JI, JW, JR + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + + IF (LHOOK) CALL DR_HOOK('YOE_SPECTRAL_PLANCK:INIT',0,ZHOOK_HANDLE) + + IF (KINTERVALS == 1) THEN + ! We can use Stefan-Boltzmann law without a look-up table + WRITE(NULOUT,'(a)') 'YOE_SPECTRAL_PLANCK: Single-band look-up table requested: use Stefan-Boltzmann law' + SELF%NINTERVALS = KINTERVALS + CALL SELF%FREE + ELSE + ! Full look-up table required + ZCOEFF1 = 2.0_JPRB * RPI * RHPLA * RCLUM * RCLUM + ZCOEFF2 = RHPLA * RCLUM / RKBOL + + NRANGES = SIZE(KINTERVAL_MAP,1) + IF (SIZE(PWAVLEN_BOUND,1) /= NRANGES-1) THEN + CALL ABOR1('YOS_SPECTRAL_PLANCK:INIT: PWAVLEN_BOUND must have one fewer elements than KINTERVAL_MAP') + ENDIF + + CALL SELF%FREE + + ALLOCATE(SELF%WAVLEN_BOUND(NRANGES-1)) + ALLOCATE(SELF%INTERVAL_MAP(NRANGES)) + SELF%WAVLEN_BOUND(1:NRANGES-1) = PWAVLEN_BOUND(1:NRANGES-1) + SELF%INTERVAL_MAP(1:NRANGES) = KINTERVAL_MAP(1:NRANGES) + + SELF%NINTERVALS = KINTERVALS + ! Temperature in 1-K intervals from 150 K to 350 K + SELF%TEMP1 = 150.0_JPRB + SELF%DTEMP = 1.0_JPRB + SELF%NTEMPS = 1 + NINT((350.0_JPRB - SELF%TEMP1) / SELF%DTEMP) + + ALLOCATE(SELF%PLANCK_LUT(SELF%NINTERVALS,SELF%NTEMPS)) + SELF%PLANCK_LUT(:,:) = 0.0_JPRB + + ! Print the properties of the look-up table + WRITE(NULOUT,'(a,i0,a,f5.1,a,f5.1,a)') & + & 'YOE_SPECTRAL_PLANCK: Generating Planck look-up table with ', & + & SELF%NTEMPS, ' temperatures from ', & + & SELF%TEMP1, ' to ', SELF%TEMP1+SELF%DTEMP*(SELF%NTEMPS-1), ' K:' + DO JI = 1,SELF%NINTERVALS + WRITE(NULOUT,'(a,i0,a)',advance='no') ' Band ', JI, ':' + DO JR = 1,NRANGES + IF (KINTERVAL_MAP(JR) == JI) THEN + IF (JR == 1) THEN + WRITE(NULOUT,'(a,f0.2)',advance='no') ' 0.00-', & + & PWAVLEN_BOUND(1)*1.0e6_JPRB + ELSEIF (JR == NRANGES) THEN + WRITE(NULOUT,'(a,f0.2,a)',advance='no') ' ', & + & PWAVLEN_BOUND(JR-1)*1.0e6_JPRB, '-Inf' + ELSE + WRITE(NULOUT,'(a,f0.2,a,f0.2)',advance='no') ' ', & + & PWAVLEN_BOUND(JR-1)*1.0e6_JPRB, '-', & + & PWAVLEN_BOUND(JR)*1.0e6_JPRB + ENDIF + ENDIF + ENDDO + WRITE(NULOUT,'(a)') ' microns' + ENDDO + + ! Create the look-up table + DO JT = 1,SELF%NTEMPS + + ZTEMP = SELF%TEMP1 + (JT-1) * SELF%DTEMP + + DO JI = 1,NRANGES + + IF (JI == 1) THEN + ZWAVLEN1 = MIN(1.0E-6_JPRB, 0.8_JPRB * PWAVLEN_BOUND(1)) + ZWAVLEN2 = PWAVLEN_BOUND(1) + ELSEIF (JI == NRANGES) THEN + ZWAVLEN1 = PWAVLEN_BOUND(NRANGES-1) + ! Simulate up to at least 200 microns wavelength + ZWAVLEN2 = MAX(200.0E-6_JPRB, PWAVLEN_BOUND(NRANGES-1)+20.0E-6_JPRB) + ELSE + ZWAVLEN1 = PWAVLEN_BOUND(JI-1) + ZWAVLEN2 = PWAVLEN_BOUND(JI) + ENDIF + + NWAVLEN = 100 + DWAVLEN = (ZWAVLEN2 - ZWAVLEN1) / NWAVLEN + ZSUM = 0.0_JPRB + DO JW = 0,NWAVLEN + ZWAVLEN = ZWAVLEN1 + DWAVLEN*JW + ! Weights for trapezoidal rule + !IF (JW > 0 .AND. JW < NWAVLEN) THEN + ! ZWEIGHT = 2.0_JPRB + !ELSE + ! ZWEIGHT = 1.0_JPRB + !ENDIF + ! Weights for Simpson's rule + IF (JW > 0 .AND. JW < NWAVLEN) THEN + ZWEIGHT = 2.0_JPRB + 2.0_JPRB * MOD(JW,2) + ELSE + ZWEIGHT = 1.0_JPRB + ENDIF + ! Planck's law + ! + ! The exponential term is computed in double precision to avoid + ! overflow. The final result should still be in the range of a single + ! precision float. + ZWAVLEN_SQR = ZWAVLEN*ZWAVLEN + ZPLANCKEXP = EXP(REAL(ZCOEFF2, JPRD) & + & / (REAL(ZWAVLEN, JPRD) * REAL(ZTEMP, JPRD))) + ZSUM = ZSUM + ZWEIGHT / (ZWAVLEN_SQR*ZWAVLEN_SQR*ZWAVLEN & + & * (ZPLANCKEXP - 1.0_JPRB)) + ENDDO + SELF%PLANCK_LUT(KINTERVAL_MAP(JI),JT) = SELF%PLANCK_LUT(KINTERVAL_MAP(JI),JT) & + & + ZCOEFF1 * ZSUM * DWAVLEN / 3.0_JPRB + ENDDO + + ENDDO + + ENDIF + + IF (LHOOK) CALL DR_HOOK('YOE_SPECTRAL_PLANCK:INIT',1,ZHOOK_HANDLE) + +END SUBROUTINE INIT + + +!----------------------------------------------------------------------- +! Calculate Planck function in spectral intervals from temperature +SUBROUTINE CALC(SELF, KIDIA, KFDIA, KLON, PTEMPERATURE, PPLANCK) + + USE YOMCST, ONLY : RSIGMA + USE YOMHOOK, ONLY : LHOOK, DR_HOOK, JPHOOK + + CLASS(TSPECTRALPLANCK), INTENT(IN) :: SELF + ! Process columns KIDIA-KFDIA from total of KLON columns + INTEGER(KIND=JPIM) , INTENT(IN) :: KIDIA, KFDIA, KLON + ! Temperature in Kelvin + REAL(KIND=JPRB) , INTENT(IN) :: PTEMPERATURE(KLON) + ! Integrated Planck function as an irradiance, in W m-2 + REAL(KIND=JPRB) , INTENT(OUT) :: PPLANCK(KLON,SELF%NINTERVALS) + + ! Column loop counter, index to temperature interval + INTEGER(KIND=JPRB) :: JL, ITEMP + + ! Interpolation weight, highest temperature in look-up table + REAL(KIND=JPRB) :: ZWEIGHT, ZTEMP2 + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + IF (LHOOK) CALL DR_HOOK('YOE_SPECTRAL_PLANCK:INIT',0,ZHOOK_HANDLE) + + IF (SELF%NINTERVALS == 1) THEN + ! Stefan-Boltzmann law + PPLANCK(KIDIA:KFDIA,1) = RSIGMA * PTEMPERATURE(KIDIA:KFDIA)**4 + + ELSE + ! Look-up table + ZTEMP2 = SELF%TEMP1 + SELF%DTEMP * (SELF%NTEMPS - 1) + + DO JL = KIDIA,KFDIA + + IF (PTEMPERATURE(JL) <= SELF%TEMP1) THEN + ! Cap the Planck function at the low end + ITEMP = 1 + ZWEIGHT = 0.0_JPRB + ELSEIF (PTEMPERATURE(JL) < ZTEMP2) THEN + ! Linear interpolation + ZWEIGHT = 1.0_JPRB + (PTEMPERATURE(JL) - SELF%TEMP1) / SELF%DTEMP + ITEMP = NINT(ZWEIGHT) + ZWEIGHT = ZWEIGHT - ITEMP + ELSE + ! Linear extrapolation at high temperatures off the scale + ITEMP = SELF%NTEMPS-1 + ZWEIGHT = 1.0_JPRB + (PTEMPERATURE(JL) - SELF%TEMP1) / SELF%DTEMP - ITEMP + ENDIF + + PPLANCK(JL,:) = SELF%PLANCK_LUT(:,ITEMP) & + & + ZWEIGHT * (SELF%PLANCK_LUT(:,ITEMP+1) - SELF%PLANCK_LUT(:,ITEMP)) + + ! Force sum to equal Stefan-Boltzmann law + PPLANCK(JL,:) = PPLANCK(JL,:) * RSIGMA * PTEMPERATURE(JL)**4 / SUM(PPLANCK(JL,:),1) + + ENDDO + + ENDIF + + IF (LHOOK) CALL DR_HOOK('YOE_SPECTRAL_PLANCK:INIT',1,ZHOOK_HANDLE) + +END SUBROUTINE CALC + + +!----------------------------------------------------------------------- +! Print look-up table to a unit +SUBROUTINE PRINT_SPECTRAL_PLANCK(SELF, IUNIT) + + CLASS(TSPECTRALPLANCK), INTENT(IN) :: SELF + INTEGER(KIND=JPIM), INTENT(IN) :: IUNIT + + INTEGER(KIND=JPIM) :: JT + + CHARACTER(len=24) :: MY_FORMAT + + IF (SELF%NINTERVALS == 1) THEN + + WRITE(IUNIT,'(A)') 'Spectral Planck in only one interval: using Stefan-Boltzmann law' + + ELSE + + WRITE(IUNIT,'(A,I0,A)') 'Spectral Planck look-up table defined in ', & + & SELF%NINTERVALS, ' intervals:' + WRITE(MY_FORMAT,'(A,I0,A)') '(f7.2,', SELF%NINTERVALS, 'e15.5)' + DO JT = 1,SELF%NTEMPS + WRITE(IUNIT,TRIM(MY_FORMAT)) SELF%TEMP1 + (JT-1) * SELF%DTEMP, & + & SELF%PLANCK_LUT(:,JT) + ENDDO + + ENDIF + +END SUBROUTINE PRINT_SPECTRAL_PLANCK + + +!----------------------------------------------------------------------- +! Free allocated memory +SUBROUTINE FREE_SPECTRAL_PLANCK(SELF) + + CLASS(TSPECTRALPLANCK), INTENT(INOUT) :: SELF + + IF (ALLOCATED(SELF%PLANCK_LUT)) THEN + DEALLOCATE(SELF%PLANCK_LUT) + ENDIF + IF (ALLOCATED(SELF%WAVLEN_BOUND)) THEN + DEALLOCATE(SELF%WAVLEN_BOUND) + ENDIF + IF (ALLOCATED(SELF%INTERVAL_MAP)) THEN + DEALLOCATE(SELF%INTERVAL_MAP) + ENDIF + +END SUBROUTINE FREE_SPECTRAL_PLANCK + + +END MODULE YOE_SPECTRAL_PLANCK Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoecld.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoecld.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoecld.F90 (revision 6016) @@ -0,0 +1,25 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOECLD + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOECLD* - CONTROL PARAMETERS FOR DIAGNOSTIC CLOUDS +! ----------------------------------------------------------------- + +REAL(KIND=JPRB) :: RDECORR_CF = 2.0_JPRB +REAL(KIND=JPRB) :: RDECORR_CW = 1.0_JPRB + +END MODULE YOECLD Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoephy.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoephy.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoephy.F90 (revision 6016) @@ -0,0 +1,383 @@ +! (C) Copyright 1991- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOEPHY + +USE PARKIND1, ONLY : JPRB, JPIM +!USE ISO_C_BINDING + +IMPLICIT NONE + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOEPHY* - SWITCHES RELATED TO DIABATIC PROCESSES +! ----------------------------------------------------------------- + +! * E.C.M.W.F. PHYSICS PACKAGE * + +TYPE :: TEPHY +!!! LOGICAL :: LEPHYS +!!! LOGICAL :: LECOND +!!! LOGICAL :: LECUMF +!!! LOGICAL :: LEDCLD +!!! LOGICAL :: LEEVAP +!!! LOGICAL :: LEGWDG +!!! LOGICAL :: LEGWWMS +!!! LOGICAL :: LEOZOC +!!! LOGICAL :: LEQNGT +!!! LOGICAL :: LERADI +!!! LOGICAL :: LERADS +!!! LOGICAL :: LESICE +!!! LOGICAL :: LESURF +!!! LOGICAL :: LEVDIF +!!! LOGICAL :: LAGPHY +!!! LOGICAL :: LEPCLD +!!! LOGICAL :: LEO3CH +!!! LOGICAL :: LO3CH_SAFE +!!! LOGICAL :: LO3CH_OLDVER +!!! LOGICAL :: LO3CH_BMS +!!! LOGICAL :: LO3CH_HLO +!!! CHARACTER(LEN=4) :: CO3CHEM +!!! LOGICAL :: LECO2DIU +!!! LOGICAL :: LNEEONLINE +!!! LOGICAL :: LBUD23 +!!! LOGICAL :: LPPTILES +!!! LOGICAL :: LBUDCYCLE +!!! LOGICAL :: LEMETHOX +!!! LOGICAL :: LECURR +!!! LOGICAL :: LESURFTRAJ +!!! LOGICAL :: LVDFTRAC +!!! LOGICAL :: LMFTRAC +!!! LOGICAL :: LMFSCAV +!!! LOGICAL :: LERAIN +!!! LOGICAL :: LEMWAVE +!!! LOGICAL :: LEGBRAD +!!! LOGICAL :: LERAINGG +!!! LOGICAL :: LESMOS +!!! LOGICAL :: LESMAP +!!! LOGICAL :: LEOCWA +!!! LOGICAL :: LEOCCO +!!! LOGICAL :: LEOCSA +!!! LOGICAL :: LEOCLA +!!! LOGICAL :: LEVGEN +!!! LOGICAL :: LESSRO +!!! LOGICAL :: LEFLAKE +!!! LOGICAL :: LEOCML +!!! LOGICAL :: LEOBC +!!! LOGICAL :: LEOBCMAX +!!! REAL(KIND=JPRB) :: REOBCMAX +!!! LOGICAL :: LEOBCICE +!!! LOGICAL :: LEOCLAKE +!!! LOGICAL :: LEOLAKESST +!!! LOGICAL :: LOCMLTKE +!!! LOGICAL :: LECLIPQT0 +!!! LOGICAL :: LECLIPCLDT0 +!!! LOGICAL :: LDUCTDIA +!!! LOGICAL :: LDIAGTURB_EC +!!! LOGICAL :: LDIAGTURBGRAD_EC +! ----- split ECMWF physics:for split physics (one part at t-Dt, one part at t+Dt) +!!! LOGICAL :: LSLPHY ! Moved from YOMCT0 /MH +!!! LOGICAL :: LESN09 +!!! LOGICAL :: LELAIV +!!! LOGICAL :: LECTESSEL +!!! LOGICAL :: LEAGS +!!! LOGICAL :: LSPCRM +!!! LOGICAL :: LELIGHT +!!! REAL(KIND=JPRB) :: RTHRFRTI +!!! REAL(KIND=JPRB) :: RCIMIN +!!! REAL(KIND=JPRB) :: RLAIINT +!!! INTEGER (KIND=JPIM) :: NPRACCL +!!! INTEGER (KIND=JPIM) :: NLIMODE +!!! LOGICAL :: LECLIM10D ! 10-day clim interpolation +!!! LOGICAL :: LESNML +!!! INTEGER (KIND=JPIM) :: NSNMLWS + +!VARIABLES FOR THE FLUX ADJUSTMENT OF GPP/RECO +!!! LOGICAL :: LBFASCO2 + +! SOME VARIABLES RELATED TO THE DIFFERENT NBF CO2 CLIMATOLOGIES + +! NCO2CLIMYY1 ===> First year in the NBF CO2 climatology +! NCO2CLIMYY2 ===> Last year in the NBF CO2 climatology +! NCO2CLIMN1 ===> starting time for the diurnally variable fluxes (in minutes) +! NCO2CLIMN2 ===> end time for the diurnally variable fluxes (in minutes) +! NCO2CLIMFRQ ===> time frequency at which the diurnal cycle is provided (in minutes) + +!!! INTEGER(KIND=JPIM) :: NCO2CLIMYY1 +!!! INTEGER(KIND=JPIM) :: NCO2CLIMYY2 +!!! INTEGER(KIND=JPIM) :: NCO2CLIMN1 +!!! INTEGER(KIND=JPIM) :: NCO2CLIMN2 +!!! INTEGER(KIND=JPIM) :: NCO2CLIMFRQ + +! Surface albedo and emissivity scheme for radiation (needs to be +! defined here rather than in yoerad because NALBEDOSCHEME controls +! what albedo climatology fields are read in, which is done before +! yoerad is initialized). +INTEGER(KIND=JPIM) :: NALBEDOSCHEME +INTEGER(KIND=JPIM) :: NEMISSSCHEME + +! Albedo of permanent snow, used in Antarctica and on glaciers +!!! REAL(KIND=JPRB) :: RALFMINPSN + +! REFERENCE. +! ---------- + +! F Vitart E.C.M.W.F. 06/08/10 + +! RNORTHML : northern limit domain +! RSOUTHML : southern limit +! RWESTML : western limit +! REASTML : eastern limit +! INVML: =true: ML is applied inside the domain, =false: ML is applied outside the domain + +!!! REAL(KIND=JPRB) :: RNORTHML +!!! REAL(KIND=JPRB) :: RSOUTHML +!!! REAL(KIND=JPRB) :: RWESTML +!!! REAL(KIND=JPRB) :: REASTML + +!!! LOGICAL :: INVML +!!! LOGICAL :: LFPOS_EC_PHYS = .FALSE. +!!! LOGICAL :: LFPOS_ACC_RESET + +! LRAD_CLOUD_INHOMOG: Logical:Use regime-dependent value of fractional +! standard deviation (FSD) of condensate in radiation scheme. +! Required to set up GFL variable to carry FSD from cloudsc to radiation +!!! LOGICAL :: LRAD_CLOUD_INHOMOG + +! YSURF : Pointer to surface package configuration + +!!! TYPE(C_PTR) :: YSURF +!---------------------------------------------------------------------------- + +CONTAINS + + PROCEDURE, PASS :: PRINT => PRINT_CONFIGURATION + +END TYPE TEPHY + +TYPE(TEPHY), POINTER :: YREPHY => NULL() + +! REFERENCE. +! ---------- + +! J.-J. MORCRETTE E.C.M.W.F. 91/07/14 + +! MODIFICATIONS +! ------------- + +! P. Viterbo ECMWF 03-12-2004 Include user-defined RTHRFRTI +! G. Balsamo ECMWF 14-03-2007 Include LEVGEN, LESSRO switches +! G. Balsamo ECMWF 07-04-2008 Include LEFLAKE switch +! G. Balsamo ECMWF 13-10-2008 Include LEOCML switch +! F. Vitart ECMWF 21-01-2013 Include LEOBC switch +! G. Balsamo ECMWF 13-10-2008 Include LESNWD switch +! P. Lopez ECMWF 24-01-2009 Include LDUCTDIA switch +! G. Balsamo ECMWF 24-02-2009 Include full set of SNOW switches +! Y. Takaya ECMWF 21-08-2009 Include LEOCLA switch +! S. Boussetta/G.Balsamo May 2009 Include variable LAI switch LELAIV +! E. Dutra 18-11-2009 snow 2009 cleaning of logicals - LESN09 to activate all +! Y. Takaya/P. de Rosnay May 2020 SSS for SMOS +! P. Lopez ECMWF 14-08-2009 Include LEGBRAD switch and NPRACCL +! S.Boussetta/G.Balsamo Nov 2010 Include land carbon switch LECTESSEL +! G.Balsamo ECMWF 21-06-2011 Include LEAGS switch (CO2&Evap modularity) +! P. Lopez ECMWF 22-08-2012 Include LERAINGG switch for rain gauge assim. +! S.Boussetta Nov 2013 Include 10-day clim interpolation switch LECLIM10D +! F. Vana & M. Kharoutdinov 06-Feb-2015 Super-parametrization scheme. +! A. Agusti-Panareda 09-08-2013 Add flag for GPP/REC flux adjustment (LBFASCO2) +! P. Lopez ECMWF 24-07-2015 Added LELIGHT and NLIMODE for lightning parameterization. +! E.Dutra/G.Arduini Jan 2018: Include LESNML switch turn on/off snow multi-layer +! R. Hogan ECMWF 14-01-2019 Replace LE4ALB with NALBEDOSCHEME, add NEMISSSCHEME +! P. Bechtold ECMWF 21-02-2019 Add LDIAGTURB_EC switch for 3D Turb EDRP diagnostics +! R. Hogan ECMWF 07-03-2019 Add RALFMINPSN: albedo of permanent snow +! ------------------------------------------------------------------ + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! LEPHYS : LOGICAL : SWITCH THE FULL E.C.M.W.F. PHYSICS PACKAGE ON +! LAGPHY : LOGICAL : IF TRUE, PHYSICS PACKAGE CALLED IN LAGGED MODE +! LECOND : LOGICAL : TURN THE LARGE-SCALE CONDENSATION ON +! LECUMF : LOGICAL : TURN THE MASS-FLUX CUMULUS CONVECTION SCHEME ON +! LEDCLD : LOGICAL : TURN THE DIAGNOSTIC CLOUD SCHEME ON +! LEPCLD : LOGICAL : TURN THE PROGNOSTIC CLOUD SCHEME ON +! LEEVAP : LOGICAL : TURN THE EVAPORATION OF PRECIPITATION ON +! LEGWDG : LOGICAL : TURN THE GRAVITY WAVE DRAG ON +! LEGWWMS: LOGICAL : TURN THE WARNER-MCINTYRE-SCINOCCA NON-OROGRAPHIC GRAVITY WAVE SCHEME ON +! LEOZOC : LOGICAL : TURN THE CLIMATOLOGICAL OZONE ON +! LEQNGT : LOGICAL : TURN THE NEGATIVE HUMIDITY FIXER ON +! LERADI : LOGICAL : TURN THE RADIATION SCHEME ON +! LERADS : LOGICAL : TURN THE INTERACTIVE SURFACE RADIATIVE PROPERTIESON +! LESICE : LOGICAL : TURN THE INTERACTIVE SEA ICE PROCESSES ON +! LESURF : LOGICAL : TURN THE INTERACTIVE SURFACE PROCESSES ON +! LEVDIF : LOGICAL : TURN THE VERTICAL DIFFUSION ON +! LEO3CH : LOGICAL : TURN THE O3 CHEMISTRY ON (for EC prog. ozone) +! LO3CH_SAFE : LOGICAL : TURN INCREASED RELAXATION TO O3 TERM +! LO3CH_HLO : LOGICAL : USE HYBRID LINEAR OZONE SCHEME +! CO3CHEM : CHARACTER(LEN=4) : OZONE CHEMISTRY VERSION +! LO3CH_OLDVER : LOGICAL : USE OLD VERSION (v2.3) OF OZONE CHEMISTRY +! LECO2DIU: LOGICAL: UPDATE THE NBF CO2 FLUXES CLIMATOLOGY DURING THE RUN OF THE MODEL (introduce a diurnal cycle) +! LNEEONLINE: LOGICAL: USE ON-LINE CTESSEL IF TRUE +! LBFASCO2 : LOGICAL : APPLY THE FLUX ADJUSTMENT TO GPP AND REC IN CTESSEL +! LBUD23 : LOGICAL : SWITCH FOR 3 AND 2 DIMENSIONAL BUDGETS +! LPPTILES : LOGICAL : SWITCH FOR TILE POST-PROCESSING +! LBUDCYCLE: LOGICL: SWITCH FOR DIURNAL CYCLE DIAGNOSTICS +! LEMETHOX: LOGICAL: TURN THE METHANE OXIDATION ON +! LECURR : LOGICAL : IF TRUE, OCEAN CURRENT BOUNDARY CONDITION IS USED +! LVDFTRAC: LOGICAL: TURN TRACER TRANSPORT BY VERTICAL DIFFUSION ON +! LMFTRAC: LOGICAL : TURN TRACER TRANSPORT BY MASS FLUX CONVECTION ON +! LMFSCAV:LOGICAL : TURN TRACER WET SCAAVENGING IN CUMULUS CONVECTION SCHEME ON +! LERAIN : LOGICAL : RAIN ASSIMILATION +! LEMWAVE : LOGICAL : ALL-SKY RADIANCE ASSIMILATION +! LEOCWA : LOGICAL : WARM OCEAN LAYER PARAMETRIZATION +! LEOBC : LOGICAL : SST CORRECTION +! LEOBCMAX : LOGICAL : REMOVE ANY SST CORRECTIONS LARGER THAN REOBCMAX +! REOBCMAX : REAL : SST CORRECTIONS ABS(VALUES) LARGER THAN THIS VALUE IS IGNORED IF LEOBCCHK +! LEOBCICE : LOGICAL : ICE CORRECTION (IMPLIED IF LEOBC) +! LEOCCO : LOGICAL : COOL OCEAN SKIN PARAMETRIZATION +! LEOCSA : LOGICAL : SALINTY EFFECT ON SATURATION AT OCEAN SURFACE +! LEOCLA : LOGICAL : LANGMUIR CIRCULATION EFFECT IN SKIN LAYER SCHEME +! RTHRFRTI : INTEGER : MINIMUM FRACTION FOR ALL SURFACE TILES +! PRCIMIN : REAL : MINIMUM ICE FRACTION +! LEVGEN : LOGICAL : VAN GENUCHTEN HYDROLOGY (with SOIL TYPE field) +! LESSRO : LOGICAL : OROGRAPHIC (VIC-TYPE) RUNOFF +! LEFLAKE : LOGICAL : LAKE MODEL FLAKE +! LEOCML : LOGICAL : OCEAN MIX LAYER MODEL +! LEOCLAKE : LOGICAL : PERSISTED LAKE SST and ICE +! LEOLAKESST : LOGICAL : USE LAKES TEMPERATURE AND ICE AS SST AND ICE ON LAKE POINTS +! LOCMLTKE : LOGICAL : IF TRUE JANSSEN'S VERSION OF THE MELLOR-YAMADA SCHEME IS RUN. +! LECLIPQT0: LOGICAL: REMOVE NEGATIVE Q AND SUPERSATURATION AT INITIAL TIME +! LECLIPCLDT0: LOGICAL: REMOVE NEGATIVE CLOUD WATER/ICE AND BOUND CLOUD COVER AT INITIAL TIME +! LDUCTDIA : LOGICAL : COMPUTATIONS AND ARCHIVING OF DUCTING DIAGNOSTICS +! LDIAGTURB_EC : LOGICAL : ACTIVATE 3D TURBULENCE EDR PARAMETERS FOR CAT AND MWT +! LDIAGTURBGRAD_EC : LOGICAL : ACTIVATE HORIZONTAL GRADIENTS FOR 3D TURBULENCE EDR PARAMETERS +! LESN09 : LOGICAL : IF true use the snow 2009 scheme (liquid water, density, snow cover fraction, exposed and forest albedo) +! LELAIV : LOGICAL : IF FALSE OVERWRITE CLIMATE LAI FIELDS WITH LUT VALUES +! LECTESSEL : LOGICAL : LAND CARBON (CTESSEL) USED FOR CO2 FLUXES +! LEAGS : LOGICAL : LAND CARBON (CTESSEL) USED FOR CO2 AND EVAP FLUXES +! RLAIINT : REAL : INTERACTIVE LAI CLIM RELAXATION (1=interactive ; 0=clim) +! LEGBRAD : LOGICAL : ACTIVATE RADAR PRECIPITATION OBSERVATION OPERATOR +! NPRACCL : INTEGER : ACCUMULATION LENGTH FOR RADAR PRECIPITATION OBSERVATION ASSIMILATION +! LERAINGG : LOGICAL : ACTIVATE RAIN GAUGE OBSERVATION OPERATOR +! LECLIM10D: Logical: IF TRUE interpolate between 10-day climate values (for albedo and LAI) +! LSPCRM : LOGICAL : ACTIVATES SUPER-PARAMETRIZATION SCHEME REPLACING MOIST PROCESSES. +! LELIGHT : LOGICAL : ACTIVATES LIGHTNING PARAMETRIZATION. +! NLIMODE : LOGICAL : SELECTION OF LIGHTNING PARAMETRIZATION (see CULIGHT routine). +! RALFMINPSN : REAL : Albedo of permanent snow, used in Antarctica and on glaciers +! NALBEDOSCHEME : INTEGER : Surface shortwave albedo: +! 0: ERBE +! 1: MODIS 4 comp. (UV-Vis+NIR)x(direct+diffuse), nearest neigh to SW bands +! 2: MODIS 6 component, weighting to SW bands +! 3: MODIS 2 compoent (diffuse albedo for everything, weighting to SW bands +! NEMISSSCHEME : INTEGER : Surface longwave emissivity scheme: +! 0: 2-interval (infrared window and everything else) +! 1: 6-interval scheme + +! ----------------------------------------------------------------- + +CONTAINS + +SUBROUTINE PRINT_CONFIGURATION(SELF, KDEPTH, KOUTNO) + IMPLICIT NONE + CLASS(TEPHY), INTENT(IN) :: SELF + INTEGER , INTENT(IN) :: KDEPTH + INTEGER , INTENT(IN) :: KOUTNO + + INTEGER :: IDEPTHLOC + + IDEPTHLOC = KDEPTH+2 + + WRITE(KOUTNO,*) REPEAT(' ',KDEPTH ) // 'model%yrml_phy_ec%yrephy : ' + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEPHYS = ', SELF%LEPHYS + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LECOND = ', SELF%LECOND + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LECUMF = ', SELF%LECUMF + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEDCLD = ', SELF%LEDCLD + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEEVAP = ', SELF%LEEVAP + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEGWDG = ', SELF%LEGWDG + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEGWWMS = ', SELF%LEGWWMS + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOZOC = ', SELF%LEOZOC + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEQNGT = ', SELF%LEQNGT + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LERADI = ', SELF%LERADI + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LERADS = ', SELF%LERADS + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LESICE = ', SELF%LESICE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LESURF = ', SELF%LESURF + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEVDIF = ', SELF%LEVDIF + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LAGPHY = ', SELF%LAGPHY + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEPCLD = ', SELF%LEPCLD + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEO3CH = ', SELF%LEO3CH + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LO3CH_OLDVER = ', SELF%LO3CH_OLDVER + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LO3CH_BMS = ', SELF%LO3CH_BMS + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LO3CH_HLO = ', SELF%LO3CH_HLO + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'CO3CHEM = ', SELF%CO3CHEM + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LECO2DIU = ', SELF%LECO2DIU + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LNEEONLINE = ', SELF%LNEEONLINE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LBUD23 = ', SELF%LBUD23 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LPPTILES = ', SELF%LPPTILES + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LBUDCYCLE = ', SELF%LBUDCYCLE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEMETHOX = ', SELF%LEMETHOX + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LECURR = ', SELF%LECURR + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LVDFTRAC = ', SELF%LVDFTRAC + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LMFTRAC = ', SELF%LMFTRAC + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LMFSCAV = ', SELF%LMFSCAV + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LERAIN = ', SELF%LERAIN + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEMWAVE = ', SELF%LEMWAVE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEGBRAD = ', SELF%LEGBRAD + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LERAINGG = ', SELF%LERAINGG + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LESMOS = ', SELF%LESMOS + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LESMAP = ', SELF%LESMAP + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOCWA = ', SELF%LEOCWA + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOCCO = ', SELF%LEOCCO + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOCSA = ', SELF%LEOCSA + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOCLA = ', SELF%LEOCLA + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEVGEN = ', SELF%LEVGEN + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LESSRO = ', SELF%LESSRO + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEFLAKE = ', SELF%LEFLAKE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOCML = ', SELF%LEOCML + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOBC = ', SELF%LEOBC + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOBCICE = ', SELF%LEOBCICE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOCLAKE = ', SELF%LEOCLAKE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEOLAKESST = ', SELF%LEOLAKESST + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LOCMLTKE = ', SELF%LOCMLTKE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LECLIPQT0 = ', SELF%LECLIPQT0 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LECLIPCLDT0 = ', SELF%LECLIPCLDT0 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LDUCTDIA = ', SELF%LDUCTDIA + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LDIAGTURB_EC = ', SELF%LDIAGTURB_EC + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LDIAGTURBGRAD_EC = ', SELF%LDIAGTURBGRAD_EC + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LESN09 = ', SELF%LESN09 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LELAIV = ', SELF%LELAIV + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LECTESSEL = ', SELF%LECTESSEL + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LEAGS = ', SELF%LEAGS + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LSPCRM = ', SELF%LSPCRM + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LELIGHT = ', SELF%LELIGHT + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RTHRFRTI = ', SELF%RTHRFRTI + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCIMIN = ', SELF%RCIMIN + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RLAIINT = ', SELF%RLAIINT + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NPRACCL = ', SELF%NPRACCL + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NLIMODE = ', SELF%NLIMODE + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LECLIM10D = ', SELF%LECLIM10D + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LESNML = ', SELF%LESNML + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NSNMLWS = ', SELF%NSNMLWS + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LBFASCO2 = ', SELF%LBFASCO2 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NCO2CLIMYY1 = ', SELF%NCO2CLIMYY1 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NCO2CLIMYY2 = ', SELF%NCO2CLIMYY2 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NCO2CLIMN1 = ', SELF%NCO2CLIMN1 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NCO2CLIMN2 = ', SELF%NCO2CLIMN2 + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NCO2CLIMFRQ = ', SELF%NCO2CLIMFRQ + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RNORTHML = ', SELF%RNORTHML + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSOUTHML = ', SELF%RSOUTHML + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RWESTML = ', SELF%RWESTML + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'REASTML = ', SELF%REASTML + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'INVML = ', SELF%INVML + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LFPOS_EC_PHYS = ', SELF%LFPOS_EC_PHYS + ! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'LFPOS_ACC_RESET = ', SELF%LFPOS_ACC_RESET + WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NALBEDOSCHEME = ', SELF%NALBEDOSCHEME + WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NEMISSSCHEME = ', SELF%NEMISSSCHEME + +END SUBROUTINE PRINT_CONFIGURATION + +END MODULE YOEPHY Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoerad.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoerad.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoerad.F90 (revision 6016) @@ -0,0 +1,325 @@ +MODULE YOERAD + +USE PARKIND1, ONLY : JPIM, JPRB +USE YOE_SPECTRAL_PLANCK, ONLY : TSPECTRALPLANCK + +IMPLICIT NONE + +SAVE + +! ------------------------------------------------------------------ +!* ** *YOERAD* - CONTROL OPTIONS FOR RADIATION CONFIGURATION +! ------------------------------------------------------------------ + +! Here we have hard-coded the options that configure the radiation +! scheme; in the IFS they are set in suecrad.F90 with the option to +! override them using the NAERAD namelist +TYPE :: TERAD + INTEGER(KIND=JPIM) :: NSW = 6 + INTEGER(KIND=JPIM) :: NLWEMISS = 2 + INTEGER(KIND=JPIM) :: NICEOPT = 3 + INTEGER(KIND=JPIM) :: NLIQOPT = 4 + INTEGER(KIND=JPIM) :: NRADIP = 3 + INTEGER(KIND=JPIM) :: NRADLP = 2 + INTEGER(KIND=JPIM) :: NLWOUT = 1 + INTEGER(KIND=JPIM) :: NDECOLAT = 2 + INTEGER(KIND=JPIM) :: NMINICE = 1 + INTEGER(KIND=JPIM) :: NAERMACC = 1 + INTEGER(KIND=JPIM) :: NMCVAR = 12 + INTEGER(KIND=JPIM) :: NLWSCATTERING = 1 + INTEGER(KIND=JPIM) :: NSWSOLVER = 3 ! Tripleclouds + INTEGER(KIND=JPIM) :: NLWSOLVER = 3 ! Tripleclouds + INTEGER(KIND=JPIM) :: NSOLARSPECTRUM = 0 + INTEGER(KIND=JPIM) :: NDUMPBADINPUTS = 0 + INTEGER(KIND=JPIM) :: NDUMPINPUTS = 0 + INTEGER(KIND=JPIM) :: NCLOUDOVERLAP = 3 + REAL(KIND=JPRB) :: RCLOUD_FRAC_STD = 1.0_JPRB + REAL(KIND=JPRB) :: RCLOUD_SEPARATION_SCALE_TOA = 14000.0_JPRB + REAL(KIND=JPRB) :: RCLOUD_SEPARATION_SCALE_SURF = 2500.0_JPRB + LOGICAL :: LFU_LW_ICE_OPTICS_BUG = .FALSE. + LOGICAL :: LDIAGFORCING = .FALSE. + LOGICAL :: LAPPROXLWUPDATE = .TRUE. + LOGICAL :: LAPPROXSWUPDATE = .FALSE. + LOGICAL :: LCCNL = .TRUE. + LOGICAL :: LCCNO = .TRUE. + REAL(KIND=JPRB) :: RCCNLND = 900.0_JPRB + REAL(KIND=JPRB) :: RCCNSEA = 50.0_JPRB + REAL(KIND=JPRB) :: RRE2DE = 0.64952_JPRB + REAL(KIND=JPRB) :: RMINICE = 60.0_JPRB + + ! Look-up table for Planck function in emissivity intervals + TYPE(TSPECTRALPLANCK) :: YSPECTPLANCK + +END TYPE TERAD +!============================================================================ + +TYPE(TERAD), POINTER :: YRERAD => NULL() + + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 +! Modifications +! R J Hogan 20 May 2014: Added LApproxLwUpdate +! R J Hogan 19 June 2014: Added LApproxSwUpdate +! R J Hogan 19 Nov 2014: Added LCentredTimeSZA +! R J Hogan 15 Apr 2015: Added LMannersSwUpdate +! R J Hogan 24 Apr 2015: Added LAverageSZA +! R J Hogan 18 Sept 2015: Added LUsePre2017Rad (was LUsePre2015Rad) +! R J Hogan 1 Mar 2016: Added NLwSolver, NSwSolver, NLwScattering +! A Bozzo Feb 2017: Added logical to enable 3D aerosol climatology +! R J Hogan 9 Mar 2018: Added NDUMPBADINPUTS +! R J Hogan 22 Jan 2019: Added NLWEMISS, NCLOUDOVERLAP, NDUMPINPUTS +! R J Hogan 4 Feb 2019: Added NLWOUT +! R J Hogan 5 Feb 2019: Added YSPECTPLANCK +! R J Hogan 11 Mar 2019: Added CGHG*FILE, CSOLARIRRADIANCEFILE + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! LERAD1H: LOGICAL : .T. TO ALLOW MORE FREQUENT RADIATION CALCULATIONS +! : DURING FIRST N HOURS OF FORECAST +! NLNGR1H: INTEGER : NUMBER FORECAST HOURS DURING WHICH MORE FREQUENT +! RADIATION CALCULATIONS ARE REQUIRED +! LEPO3RA: LOGICAL : .T. IF PROGNOSTIC OZONE (EC) IS PASSED TO RADIATION +! NAER : INTEGER : CONFIGURATION INDEX FOR AEROSOLS +! NMODE : INTEGER : CONFIGURATION FOR RADIATION CODE: FLUX VS. RADIANCE +! NOZOCL : INTEGER : CHOICE OF OZONE CLIMATOLOGY (0 old, 1 new) +! NRADFR : INTEGER : FREQUENCY OF FULL RADIATION COMPUTATIONS +! IF(NRADFR.GT.0): RAD EVERY 'NRADFR' TIME-STEPS +! IF(NRADFR.LT.0): RAD EVERY '-NRADFR' HOURS +! NRADPFR: INTEGER : PRINT FREQUENCY FOR RAD.STATISTICS (in RAD.T.STEPS) +! NRADPLA: INTEGER : PRINT RAD.STATISTICS EVERY 'NRADPLA' ROWS +! NRADINT: INTEGER : RADIATION INTERPOLATION METHOD +! : 1 = SPECTRAL TRANSFORM INTERPOLATION +! : 2 = 4 POINT HORIZONTAL INTERPOLATION +! : 3 = 12 POINT HORIZONTAL INTERPOLATION +! NRADRES: INTEGER : RADIATION GRID SPECTRAL RESOLUTION +! NRADNFR: INTEGER : NORMAL FREQUENCY OF RADIATION STEPS +! NRADSFR: INTEGER : START-UP FREQUENCY OF RADIATION STEPS +! NRADE1H: INTEGER : START-UP FREQUENCY OF RADIATION STEPS FOR EPS +! NRADE3H: INTEGER : SUBSEQUENT FREQUENCY OF RADIATION STEPS FOR EPS +! NRADELG: INTEGER : LENGTH IN HOURS DURING WHICH THE FREQUENCY OF RADIATION IS INCREASED FOR EPS +! NOVLP : INTEGER : CLOUD OVERLAP CONFIGURATION IN PRE-MCRAD/ECRAD SCHEME +! : 1 = Max-rand (Geleyn & Hollingsworth) +! : 2 = Maximum +! : 3 = Random +! NRPROMA: INTEGER : VECTOR LENGTH FOR RADIATION CALCULATIONS +! NSW : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS +! NSWNL : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS IN NL MODEL +! NSWTL : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS IN TL MODEL +! NTSW : INTEGER : MAXIMUM POSSIBLE NUMBER OF SW SPECTRAL INTERVALS +! NUV : INTEGER : NUMBER OF UV SPECTRAL INTERVALS FOR THE UV PROCESSOR +! LOPTRPROMA:LOGICAL: .T. NRPROMA will be optimised +! : .F. NRPROMA will not be optimised (forced +! : by negative NRPROMA in namelist) + +! NRADIP : INTEGER : INDEX FOR DIAGNOSIS OF ICE CLOUD EFFECTIVE RADIUS +! 0 = fixed at 40 microns +! 1 = Liou & Ou (1994) capped between 40-130 microns +! 2 = Liou & Ou but capped between 30 and 60 microns +! 3 = Sun & Rikus (1999) revised by Sun (2001) +! NRADLP : INTEGER : INDEX FOR DIAGNOSIS OF LIQ. CLOUD EFFECTIVE RADIUS +! 0 = ERA-15 function of pressure +! 1 = 10 microns over land, 13 microns over sea +! 2 = Martin_et_al (1994) in terms of land-sea number conc +! 3 = Linked to prognostic aerosols +! NICEOPT: INTEGER : INDEX FOR ICE CLOUD OPTICAL PROPERTIES +! 0 = SW Ebert-Curry, LW Smith & Shi (1992) +! 1 = SW Ebert-Curry, LW Ebert-Curry (1992) +! 2 = SW & LW Fu-Liou (1993) +! 3 = SW Fu (1996) LW Fu et al. (1998) + Chou et al. (1999) LW scatt approx +! the following only available in newer modular radiation scheme: +! 4 = SW/LW Baran data fitted versus ice mixing ratio +! NLIQOPT: INTEGER : INDEX FOR LIQUID WATER CLOUD OPTICAL PROPERTIES +! 0 = SW Fouquart (1991) LW Smith-Shi (1992) YF/SmSh +! 1 = SW Slingo (1989) LW Savijarvi (1997) +! 2 = SW Slingo (1989) LW Lindner-Li (2000) +! the following only available in RADLSW, not RADLSWR: +! 3 = SW Nielsen LW Smith-Shi +! the following only available in newer modular radiation scheme: +! 4 = SW/LW SOCRATES scheme +! +! LONEWSW: LOGICAL : .T. IF NEW SW CODE IS ACTIVE +! LECSRAD: LOGICAL : .T. IF CLEAR-SKY RADIATION IS ARCHIVED AS PEXTR2 +! NCSRADF: INTEGER : 1 IF ACCUMULATED, 2 IF INSTANTANEOUS +! LRRTM : LOGICAL : .T. IF RRTM140MR IS USED FOR LW RADIATION TRANSFER + +! LHVOLCA: LOGICAL : .T. IF USING HISTORICAL VOLCANIC AEROSOLS +! LNEWAER: LOGICAL : .T. IF AEROSOL MONTHLY DISTRIBUTIONS ARE USED +! LNOTROAER:LOGICAL: .T. IF NO TROPOSPHERIC AEROSOLS +! CRTABLEDIR: CHAR : IF NRADINT > 0 SPECIFIES DIRECTORY PATH FOR RADIATION +! : GRID RTABLE NAMELIST +! CRTABLEFIL: CHAR : IF NRADINT > 0 SPECIFIES FILE NAME OF RADIATION +! : GRID RTABLE NAMELIST +! LRAYL : LOGICAL : .T. NEW RAYLEIGH FOR SW-6 VERSION + +! RAOVLP : REAL : COEFFICIENTS FOR ALPHA1 FACTOR IN HOGAN & +! RBOVLP : REAL : ILLINGWORTH's PARAMETRIZATION + +! LCCNL : LOGICAL : .T. IF CCN CONCENTRATION OVER LAND IS DIAGNOSED +! LCCNO : LOGICAL : .T. IF CCN CONCENTRATION OVER OCEAN IS DIAGNOSED +! RCCNLND: REAL : NUMBER CONCENTRATION (CM-3) OF CCNs OVER LAND +! RCCNSEA: REAL : NUMBER CONCENTRATION (CM-3) OF CCNs OVER SEA + +! LDIFFC : LOGICAL : .T. IF SAVIJARVI'S DIFFUSIVITY CORRECTION IS ON + +! NINHOM : INTEGER : 0 IF NO INHOMOGENEITY SCALING EFFECT +! 1 IF SIMPLE 0.7 SCALING +! 2 IF BARKER, 3 IF CAIRNS ET AL. +! RLWINHF: REAL : INHOMOG. SCALING FACTOR FOR CLOUD LW OPTICAL THICKNESS +! RSWINHF: REAL : INHOMOG. SCALING FACTOR FOR CLOUD SW OPTICAL THICKNESS + +! NPERTAER : INTERGER : PERCENTAGE OF PERTURBATION FOR AEROSOL +! NPERTOZONE : INTEGER : PERCENTAGE OF PERTURBATION FOR OZONE +! NHINCSOL : INTEGER : 0: Total Solar Irradiance (TSI) fixed at 1366.0 W m-2 +! 1: Deprecated - use default +! 2: Deprecated - use default +! 3: Deprecated (was CMIP5) - use default +! 4: TSI from CMIP6 NetCDF (default), or override with CSOLARIRRADIANCEFILE +! NSWWVCONTINUUM : INTEGER : 0 MT_CKD2.5 (SRTM default WV continuum) +! 1 CAVIAR continuum (Shine et al. 2016) +! LECO2VAR: LOGICAL: .T. IF ERA-40/AMIP2 VARIABILITY OF GHG IS ON (ignored) +! LHGHG : LOGICAL : .T. IF VARIABILITY OF GREENHOUSE GASES (INCLUDING CO2) IS ON +! N.B.: LHGHG supersedes LECO2VAR and allows using better specification of trace gases +! NSCEN : INTEGER : 21st CENTURY SCENARIO FOR GHG (1=A1B, 2=A2, 3=B1) +! RRe2De : REAL : CONVERSION FACTOR BETWWEN EFFECTIVE RADIUS AND PARTICLE SIZE +! RMINICE: REAL : MINIMUM SIZE FOR ICE PARTICLES (um) +! FOR ICE +! NMINICE: INTEGER : 1-6 MINIMUM ICE PARTICLE SIZE DEPENDS ON LATITUDE, 0=INDEPENDENT OF LATITUDE +! NDECOLAT:INTEGER : DECORRELATION LENGTH FOR CF AND CW +! 0: SPECIFIED INDEPENDENT OF LATITUDE, 1: SHONK-HOGAN, 2: IMPROVED +! NMCICA : INTEGER : 0: NO McICA +! 1: McICA w maximum-random in cloud generator +! 2: McICA w generalized overlap in cloud generator +! LESO4HIS: LOGICAL:.T.: Use historical/projected SO4 data per decade and month +! NGHGRAD: INTEGER : configuration of 3D GHG climatologies accounted for in radiation +! 0: global values +! 1: CO2 2: CH4 3: N2O 4: NO2 5:CFC11 6:CFC12 +! 12: CO2+CH4 13: CO2+CH4+N2O +! 16: CO2+CH4+N2O+CFC11+CFC12 +! LETRACGMS: LOGICAL : F=Cariolle climatol. T=GEMS-derived clim for CO2, CH4, O3 +! LAERCLIM : LOGICAL : .T. for output of the climatological aerosol optical depth at 550 nm +! LAERVISI : LOGICAL : .T. for output of the visibility (from diagnsotic or prognostic aerosols) +! NVOLCVERT: INTEGER : Vertical distribution of volcanic aerosol +! 0: original profile, diagnosed from T +! 1: original profile, but upper boundary at 10hPa +! 2: lower boundary diagnosed from ozone, upper boundary at 10hPa +! LVOLCSPEC: LOGICAL : T for specified volcanic aerosol +! LVOLCDAMP: LOGICAL : T for damping of specified volcanic aerosol from initial value +! RVOLCSPEC: REAL : Specified volcanic aerosol (total optical depth) in NH/Tropics/SH +! RNs : derived from Avogadro +! RSIGAIR: invariant terms in expression of Rayleigh scattering cross-section +! NREDGSW : INTEGER : 0 full resolution for RRTM_SW (224) +! 1 ECMWF High resolution model configuration (_SW: 112) +! 2 ECMWF EPS configuration (_SW: 56) +! NREDGLW : INTEGER : 0 full resolution for RRTM_LW (256) +! 1 ECMWF High resolution model configuration (_LW: 140) +! 2 ECMWF EPS configuration (_LW: 70) +! LDIAGFORCING : LOGICAL : T Write input ozone, ghg and aerosol forcing to 3D fields +! To be used for diagnostics only; do not use in production runs +! NAERMACC : INTEGER : MACC-derived aerosol climatology on a NMCLAT x NMCLON grid +! RAESHxx : REAL : parameters related to scale height of MACC-derived aerosol climatology +! CVDAExx : REAL : scale heights of MACC-derived aerosol climatology +! LAERADJDU: LOGICAL : T adjust MACC-derived DU climatology +! LAERADCLI: LOGICAL : T if radiation uses the MACC-derived aerosol climatology +! LApproxLwUpdate : LOGICAL : Update the longwave upwelling flux every +! timestep/gridpoint using the stored rate +! of change of the fluxes with respect to +! the surface upwelling longwave flux +! LApproxSwUpdate : LOGICAL : Update the shortwave upwelling flux +! every gridpoint to account for the local +! value of surface albedo +! LMannersSwUpdate: LOGICAL : Update the shortwave flux every timestep +! using Manners et al. (2009) correction +! for solar zenith angle change +! LCentredTimeSZA : LOGICAL : Compute solar zenith angle in radiation +! scheme half way between calls to +! radiation scheme (rather than previous +! behaviour, which is half way between +! calls plus half a model timestep) +! LAverageSZA : LOGICAL : Compute an averaged solar zenith angle +! across the time interval required +! (either a model timestep or a radiation +! timestep). Should be used with +! LCentredTimeSZA=TRUE. +! LUsePre2017Rad : LOGICAL : Use the pre-2017 radiation scheme, rather +! than the modular scheme contained in the +! separate "radiation" library. Note that +! the radiation library may make use of the +! pre-2017 RRTM-G gas optics. +! RCloud_Frac_Std : REAL : Cloud water content horizontal fractional +! standard deviation in a gridbox +! LInterpInCloudMean : LOGICAL : When interpolating model fields to +! radiation grid, interpolate in-cloud +! mean water contents? Better +! conservation achieved by interpolating +! gridbox-means. +! CGHGCLIMFILE : STRING : Location of greenhouse gas climatology file, +! or empty if the default is to be used. If it +! starts with "." or "/" then a relative path +! is assumed, otherwise the default directory. +! CGHGTIMESERIESFILE:STRING : Location of greenhouse gas timeseries +! file, or empty if it is to be worked out +! from the NSCEN, YOECMIP%NGHGCMIP and +! YOECMIP%NRCP variables. If it starts +! with "." or "/" then a relative path is +! assumed, otherwise the default +! directory. +! CSOLARIRRADIANCEFILE:STRING:Location of Total Solar Irradiance file, +! or empty if the default is to be +! used. If it starts with "." or "/" then +! a relative path is assumed, otherwise +! the default directory. +! NLWEMISS : INTEGER : Number of emissivity spectral intervals, set +! according to the value of NEMISSSCHEME; traditionally +! this has always been 2: outside the IR window and within +! NLWOUT : INTEGER : Number of spectral intervals to pass LW downwelling flux +! to RADHEATN; traditionally this was 1, but this led +! to errors with LAPPROXLWUPDATE=TRUE, which updated +! fluxes using a single broadband emissivity. Now we can +! do approximate updates using full spectral emissivity. +! ------------------------------------------------------------------ +! THE FOLLOWING ARE ONLY USED FOR THE ECRAD SCHEME (LUsePre2017Rad = .FALSE.) +! NLwScattering : INTEGER : 0: No longwave scattering +! 1: Longwave scattering by clouds only +! 2: Longwave scattering by clouds and aerosols +! NSwSolver : INTEGER : +! NLwSolver : INTEGER : 0: McICA +! 1: SPARTACUS 1D +! 2: SPARTACUS 3D +! 3: TripleClouds +! LFU_LW_ICE_OPTICS_BUG : LOGICAL : Continue to use bug in Fu LW ice +! optics whereby single scattering albedo is +! one minus what it should be +! NSOLARSPECTRUM : INTEGER : 0: Kurucz +! 1: Coddington et al. (BAMS 2016) +! NDUMPBADINPUTS : INTEGER : 0: Warn only if fluxes out of physical bounds +! n: Write netcdf file of bad inputs up to n times per task +! -n: Abort if fluxes ever out of physical bounds +! NDUMPINPUTS : INTEGER : 0: Do nothing +! n: Write netcdf file of all inputs up to n times per task +! NCLOUDOVERLAP : INTEGER : Cloud overlap scheme +! 1: Maximum-random +! 2: Exponential-exponential (the actual behaviour of McRad) +! 3: Exponential-random (only option for Tripleclouds and SPARTACUS) +! RCLOUD_SEPARATION_SCALE_TOA, RCLOUD_SEPARATION_SCALE_SURF : REAL +! Cloud horizontal length scale, in metres, used to +! compute rate of horizontal exchange of radiation +! between clouds and clear skies in SPARTACUS solver +! ------------------------------------------------------------------ +! KMODTS : INTEGER : (A Bozzo) switch for different radiative transfer schemes for UV +! = 0 Fouquart&Bonnel adapted by Morcrette and Arola +! = 1 eddington (joseph et al., 1976) +! = 2 pifm (zdunkowski et al., 1980) +! = 3 discrete ordinates (liou, 1973) +! ------------------------------------------------------------------ +! TRBKG : REAL tropospheric background OD@550nm for aerosol climatology. +! default for Tegen climatology was 0.03 +! STBKG : REAL stratospheric background OD@550nm for aerosol climatology. +! ------------------------------------------------------------------ +! LDUSEASON : LOGICAL enables a monthly-varying scale height for the +! dust aerosol climatology +! LAER3D : LOGICAL : to enable aerosol climatology in 3D + + +END MODULE YOERAD Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoerdu.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoerdu.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoerdu.F90 (revision 6016) @@ -0,0 +1,62 @@ +! (C) Copyright 1989- ECMWF. +! (C) Copyright 1989- Meteo-France. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOERDU + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +! ------------------------------------------------------------------ +!* ** *YOERDU* - CONTROL, PARAMETERS AND SECURITY IN RADIATION +! ------------------------------------------------------------------ + +INTEGER(KIND=JPIM) :: NUAER +INTEGER(KIND=JPIM) :: NTRAER +INTEGER(KIND=JPIM) :: NIMP +INTEGER(KIND=JPIM) :: NOUT + +REAL(KIND=JPRB) :: R10E +REAL(KIND=JPRB) :: REPLOG = 1.0E-12_JPRB +REAL(KIND=JPRB) :: REPSC +REAL(KIND=JPRB) :: REPSCA +REAL(KIND=JPRB) :: REPSCO +REAL(KIND=JPRB) :: REPSCQ +REAL(KIND=JPRB) :: REPSCT +REAL(KIND=JPRB) :: REPSCW = 1.0E-12_JPRB +REAL(KIND=JPRB) :: DIFF + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! NUAER : INTEGER NUMBER OF ABSORBER AMOUNTS W OR W/O AEROSOLS +! NTRAER : INTEGER NUMBER OF TRANSMISSION FUNCTIONS W OR W/O AEROSOLS +! NIMP : INTEGER INDEX FOR EXTRA PRINTS WITHIN RADIATION CODE +! NOUT : INTEGER UNIT NUMBER FOR THE EXTRA PRINTS +! RCDAY : REAL +! CCO2 : REAL CONVERSION COEFFICIENT FOR CO2 IN S.W. CODE +! CH2O : REAL CONVERSION COEFFICIENT FOR H2O IN S.W. CODE +! R10E : REAL DECIMAL/NATURAL LOG.FACTOR +! DIFF : REAL DIFFUSIVITY FACTOR +!-SECURITY THRESHOLDS +! REPLOG : REAL SEC. EPSILON FOR ABS.AMOUNT IN LAPLACE TRANSFORM +! REPSC : REAL SEC. EPSILON FOR CLOUD COVER +! REPSCO : REAL SEC. EPSILON FOR OZONE AMOUNT +! REPSCQ : REAL SEC. EPSILON FOR WATER VAPOR +! REPSCT : REAL SEC. EPSILON FOR SHORTWAVE OPTICAL THICKNESS +! REPSCW : REAL SEC. EPSILON FOR CLOUD LIQUID WATER PATH + +! ----------------------------------------------------------------- +END MODULE YOERDU Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoethf.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoethf.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yoethf.F90 (revision 6016) @@ -0,0 +1,72 @@ +! (C) Copyright 1988- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOETHF + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMCST , ONLY : RD, RV, RCPD, RLVTT, RLSTT, RLMLT, RTT + +IMPLICIT NONE + +SAVE + +! ------------------------------------------------------------------ +!* *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS +! ------------------------------------------------------------------ + +REAL(KIND=JPRB), PARAMETER :: R2ES = 611.21_JPRB*RD/RV +REAL(KIND=JPRB), PARAMETER :: R3LES = 17.502_JPRB +REAL(KIND=JPRB), PARAMETER :: R3IES = 22.587_JPRB +REAL(KIND=JPRB), PARAMETER :: R4LES = 32.19_JPRB +REAL(KIND=JPRB), PARAMETER :: R4IES = -0.7_JPRB +REAL(KIND=JPRB), PARAMETER :: R5LES = R3LES*(RTT-R4LES) +REAL(KIND=JPRB), PARAMETER :: R5IES = R3IES*(RTT-R4IES) +REAL(KIND=JPRB), PARAMETER :: RVTMP2 = 0.0_JPRB +REAL(KIND=JPRB), PARAMETER :: RHOH2O = 1000.0_JPRB +REAL(KIND=JPRB), PARAMETER :: R5ALVCP = R5LES*RLVTT/RCPD +REAL(KIND=JPRB), PARAMETER :: R5ALSCP = R5IES*RLSTT/RCPD +REAL(KIND=JPRB), PARAMETER :: RALVDCP = RLVTT/RCPD +REAL(KIND=JPRB), PARAMETER :: RALSDCP = RLSTT/RCPD +REAL(KIND=JPRB), PARAMETER :: RALFDCP = RLMLT/RCPD +REAL(KIND=JPRB), PARAMETER :: RTWAT = RTT +REAL(KIND=JPRB), PARAMETER :: RTBER = RTT-5._JPRB +REAL(KIND=JPRB), PARAMETER :: RTBERCU = RTT-5.0_JPRB +REAL(KIND=JPRB), PARAMETER :: RTICE = RTT-23._JPRB +REAL(KIND=JPRB), PARAMETER :: RTICECU = RTT-23._JPRB +REAL(KIND=JPRB), PARAMETER :: RTWAT_RTICE_R = 1.0_JPRB/(RTWAT-RTICE) +REAL(KIND=JPRB), PARAMETER :: RTWAT_RTICECU_R = 1.0_JPRB/(RTWAT-RTICECU) +REAL(KIND=JPRB), PARAMETER :: RKOOP1 = 2.583_JPRB +REAL(KIND=JPRB), PARAMETER :: RKOOP2 = 0.48116E-2_JPRB + +! J.-J. MORCRETTE 91/07/14 ADAPTED TO I.F.S. + +! NAME TYPE PURPOSE +! ---- ---- ------- + +! *R__ES* REAL *CONSTANTS USED FOR COMPUTATION OF SATURATION +! MIXING RATIO OVER LIQUID WATER(*R_LES*) OR +! ICE(*R_IES*). +! *RVTMP2* REAL *RVTMP2=RCPV/RCPD-1. +! *RHOH2O* REAL *DENSITY OF LIQUID WATER. (RATM/100.) +! *R5ALVCP* REAL *R5LES*RLVTT/RCPD +! *R5ALSCP* REAL *R5IES*RLSTT/RCPD +! *RALVDCP* REAL *RLVTT/RCPD +! *RALSDCP* REAL *RLSTT/RCPD +! *RALFDCP* REAL *RLMLT/RCPD +! *RTWAT* REAL *RTWAT=RTT +! *RTBER* REAL *RTBER=RTT-0.05 +! *RTBERCU REAL *RTBERCU=RTT-5.0 +! *RTICE* REAL *RTICE=RTT-0.1 +! *RTICECU* REAL *RTICECU=RTT-23.0 +! *RKOOP? REAL *CONSTANTS TO DESCRIBE KOOP FORM FOR NUCLEATION +! *RTWAT_RTICE_R* REAL *RTWAT_RTICE_R=1./(RTWAT-RTICE) +! *RTWAT_RTICECU_R* REAL *RTWAT_RTICECU_R=1./(RTWAT-RTICECU) + +! ---------------------------------------------------------------- +END MODULE YOETHF Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yomrip.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yomrip.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifs/yomrip.F90 (revision 6016) @@ -0,0 +1,241 @@ +! (C) Copyright 1989- ECMWF. +! (C) Copyright 1989- Meteo-France. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOMRIP + +USE PARKIND1 , ONLY : JPIM ,JPRB +!USE YOEOZOC , ONLY : TEOZOC +!USE YOECMIP , ONLY : TECMIP +!USE YOERADGHG, ONLY : TRADGHG +!USE YOEAERC , ONLY : TEAERC_TEGEN, TEAERC_MACC +!USE REGLATLON_FIELD_MIX, ONLY : REGLATLON_FIELD + +IMPLICIT NONE + +SAVE + +! -------------------------------------------------------------------------------- +! Date and timestep related variables. +! Values may be different for the different models run under the OOPS layer. +! In particuliar, we find there all date and timestep variables updated in UPDTIM. +! -------------------------------------------------------------------------------- + +TYPE :: TRIP + +!* Numbering of timesteps + +! NSTART : first timestep of model +! NSTOP : last timestep of model +! CSTOP : character string defining stopping criteria for run + +! NFOST : NUMBER OF FIRST-ORDER TIME STEPS AT THE START OF THE RUN +! IN ORDER TO AVOID TRAJECTORIES GOING OUT OF THE ATMOSPHERE. + +! ------------------------------------------------------------------ + +!* Real time related variables (updated in UPDTIM) + +! NSTADD : NUMBER OF DAYS SINCE START OF THE MODEL +! NSTASS : NUMBER OF SECONDS since start of model modulo(86400) +! RSTATI : NUMBER OF SECONDS SINCE START OF THE MODEL +! RTIMTR : ABSOLUTE TIME OF THE MODEL + +! RHGMT : GMT TIME OF THE MODEL (BETWEEN 0 AND 86400) +! REQTIM : EQUATION OF TIME + +! ------------------------------------------------------------------ + +!* Sun related variables (updated in UPDTIM) +! RSOVR : TRUE SOLAR TIME (GMT+EQUATION OF TIME) + +! RDEASO : DISTANCE EARTH-SUN +! RDECLI : DECLINATION +! RWSOVR : IN RADIANS, TRUE SOLAR TIME (GMT+EQUATION OF TIME) +! THIS ANGLE IS ALSO PI - (LONGITUDE OF THE POINT +! WHERE THE SUN IS AT ZENITH) +! RIP0 : I0 WEIGHTED BY THE DISTANCE EARTH-SUN + +! RCODEC : COSINE OF THE DECLINATION +! RSIDEC : SINE OF THE DECLINATION + +! RCOVSR : COSINE OF TRUE SOLAR TIME +! RSIVSR : SINE OF TRUE SOLAR TIME + +! NEW VARIABLES FOR LMSE +! RCODECN : COSINE OF THE DECLINATION FOR NEXT TIME STEP +! RSIDECN : SINE OF THE DECLINATION FOR NEXT TIME STEP + +! RCOVSRN : COSINE OF TRUE SOLAR TIME FOR NEXT TIME STEP +! RSIVSRN : SINE OF TRUE SOLAR TIME FOR NEXT TIME STEP + +! RCODECF : COSINE OF THE DECLINATION at the end of radiation step +! RSIDECF : SINE OF THE DECLINATION at the end of radiation step +! RCOVSRF : COSINE OF TRUE SOLAR TIME at the end of radiation step +! RSIVSRF : SINE OF TRUE SOLAR TIME at the end of radiation step + +! ------------------------------------------------------------------ + +!* Moon related variables (updated in UPDTIM) + +! RDECLU : LUNAR DECLINATION +! RTMOLT : IN RADIANS, TRUE LUNAR TIME (GMT+EQUATION OF TIME) +! THIS ANGLE IS ALSO PI - (LONGITUDE OF THE POINT +! WHERE THE MOON IS AT ZENITH) +! RIP0LU : LUNAR I0 (DOWNWARD TOA LUNAR FLUX) + +! RCODECLU : COSINE OF THE LUNAR DECLINATION +! RSIDECLU : SINE OF THE LUNAR DECLINATION + +! RCOVSRLU : COSINE OF TRUE LUNAR TIME +! RSIVSRLU : SINE OF TRUE LUNAR TIME + +! ------------------------------------------------------------------ + +!* Time step related variables + +! TSTEP : length of the timestep in seconds +! TDT : For leap-frog scheme: 2*TSTEP except at the first time step where it is TSTEP +! For a two-time level scheme (semi-Lagrangian), TDT is always TSTEP. + +! RDTSA : TDT /RA +! RDTSA2 : RDTSA**2 +! RDTS62 : RDTSA**2/6 +! RDTS22 : RDTSA**2/2 + +! RTDT : TDT + +! ------------------------------------------------------------------ + +!* Time-variable climatological distributions of gases / aerosols +! YREOZOC : spectral distribution of ozone + +! INTEGER(KIND=JPIM) :: NSTART +! INTEGER(KIND=JPIM) :: NSTOP +! CHARACTER(LEN=8) :: CSTOP !! added olivier +! INTEGER(KIND=JPIM) :: NSTADD +! INTEGER(KIND=JPIM) :: NSTASS +! INTEGER(KIND=JPIM) :: NFOST +! REAL(KIND=JPRB) :: RSTATI +! REAL(KIND=JPRB) :: RTIMTR +! REAL(KIND=JPRB) :: RHGMT +! REAL(KIND=JPRB) :: REQTIM +! REAL(KIND=JPRB) :: RSOVR +! REAL(KIND=JPRB) :: RDEASO +! REAL(KIND=JPRB) :: RDECLI +! REAL(KIND=JPRB) :: RWSOVR +! REAL(KIND=JPRB) :: RIP0 +! REAL(KIND=JPRB) :: RCODEC +! REAL(KIND=JPRB) :: RSIDEC +! REAL(KIND=JPRB) :: RCOVSR +! REAL(KIND=JPRB) :: RSIVSR +! REAL(KIND=JPRB) :: RCODECN +! REAL(KIND=JPRB) :: RSIDECN +! REAL(KIND=JPRB) :: RCOVSRN +! REAL(KIND=JPRB) :: RSIVSRN +! REAL(KIND=JPRB) :: RCODECF +! REAL(KIND=JPRB) :: RSIDECF +! REAL(KIND=JPRB) :: RCOVSRF +! REAL(KIND=JPRB) :: RSIVSRF +REAL(KIND=JPRB) :: TSTEP +! REAL(KIND=JPRB) :: TDT +! REAL(KIND=JPRB) :: RDTSA +! REAL(KIND=JPRB) :: RDTSA2 +! REAL(KIND=JPRB) :: RDTS62 +! REAL(KIND=JPRB) :: RDTS22 +! REAL(KIND=JPRB) :: RTDT +! REAL(KIND=JPRB) :: RDECLU +! REAL(KIND=JPRB) :: RTMOLT +! REAL(KIND=JPRB) :: RIP0LU +! REAL(KIND=JPRB) :: RCODECLU +! REAL(KIND=JPRB) :: RSIDECLU +! REAL(KIND=JPRB) :: RCOVSRLU +! REAL(KIND=JPRB) :: RSIVSRLU +! +! !! things put here because their values are time-interpolated, i.e. non-constant +! ! defined in YOEOZOC +! TYPE(TEOZOC) :: YREOZOC +! ! defined in YOECMIP +! TYPE(TECMIP) :: YRECMIP +! ! defined in YOERADGHG +! TYPE(TRADGHG) :: YRERADGHG +! ! defined in YOEAERC +! TYPE(TEAERC_TEGEN) :: YREAERC_TEGEN +! TYPE(TEAERC_MACC) :: YREAERC_MACC +! TYPE(REGLATLON_FIELD) :: RAERSO4 + +CONTAINS + + PROCEDURE, PASS :: PRINT => PRINT_CONFIGURATION + +END TYPE TRIP + +! -------------------------------------------------------------------------------- +CONTAINS + +SUBROUTINE PRINT_CONFIGURATION(SELF, KDEPTH, KOUTNO) + IMPLICIT NONE + CLASS(TRIP), INTENT(IN) :: SELF + INTEGER , INTENT(IN) :: KDEPTH + INTEGER , INTENT(IN) :: KOUTNO + + INTEGER :: IDEPTHLOC + + IDEPTHLOC = KDEPTH+2 + + WRITE(KOUTNO,*) REPEAT(' ',KDEPTH ) // 'model%yrml_gconf%yrrip : ' +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NSTART = ', SELF%NSTART +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NSTOP = ', SELF%NSTOP +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NSTADD = ', SELF%NSTADD +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NSTASS = ', SELF%NSTASS +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'NFOST = ', SELF%NFOST +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSTATI = ', SELF%RSTATI +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RTIMTR = ', SELF%RTIMTR +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RHGMT = ', SELF%RHGMT +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'REQTIM = ', SELF%REQTIM +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSOVR = ', SELF%RSOVR +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RDEASO = ', SELF%RDEASO +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RDECLI = ', SELF%RDECLI +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RWSOVR = ', SELF%RWSOVR +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RIP0 = ', SELF%RIP0 +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCODEC = ', SELF%RCODEC +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSIDEC = ', SELF%RSIDEC +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCOVSR = ', SELF%RCOVSR +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSIVSR = ', SELF%RSIVSR +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCODECN = ', SELF%RCODECN +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSIDECN = ', SELF%RSIDECN +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCOVSRN = ', SELF%RCOVSRN +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSIVSRN = ', SELF%RSIVSRN +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCODECF = ', SELF%RCODECF +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSIDECF = ', SELF%RSIDECF +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCOVSRF = ', SELF%RCOVSRF +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSIVSRF = ', SELF%RSIVSRF + WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'TSTEP = ', SELF%TSTEP +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'TDT = ', SELF%TDT +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RDTSA = ', SELF%RDTSA +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RDTSA2 = ', SELF%RDTSA2 +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RDTS62 = ', SELF%RDTS62 +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RDTS22 = ', SELF%RDTS22 +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RTDT = ', SELF%RTDT +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RDECLU = ', SELF%RDECLU +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RTMOLT = ', SELF%RTMOLT +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RIP0LU = ', SELF%RIP0LU +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCODECLU = ', SELF%RCODECLU +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSIDECLU = ', SELF%RSIDECLU +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RCOVSRLU = ', SELF%RCOVSRLU +! WRITE(KOUTNO,*) REPEAT(' ',IDEPTHLOC) // 'RSIVSRLU = ', SELF%RSIVSRLU +! WRITE(KOUTNO,*) '' + +END SUBROUTINE PRINT_CONFIGURATION + +!!TYPE(TRIP), POINTER :: YRRIP => NULL() + +! -------------------------------------------------------------------------------- + +END MODULE YOMRIP Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/Makefile (revision 6016) @@ -0,0 +1,28 @@ +SOURCES = parkind1.F90 yomlun_ifsaux.F90 yomcst.F90 abor1.F90 \ + yomtag.F90 mpl_module.F90 yommp0.F90 yomdyncore.F90 yomlun.F90 +MAKE_INCLUDES = ../bin/make_intfbl.1.pl +INCLUDE_DIR = ../include + +OBJECTS := $(SOURCES:.F90=.o) +LIBIFSAUX = ../lib/libifsaux.a + +all: $(LIBIFSAUX) + +deps: includes + +$(LIBIFSAUX): $(OBJECTS) + ar r $(LIBIFSAUX) $(OBJECTS) + +%.o: %.F90 + $(FC) $(FCFLAGS) -c $< + +includes: + LOC_INTFBDIR=$(INCLUDE_DIR) INTFBDIR=$(INCLUDE_DIR) $(MAKE_INCLUDES) $(SOURCES) + +clean: + rm -f *.o $(LIBIFSAUX) + +yomlun_ifsaux.o yomhook.o random_numbers_mix.o yomcst.o yomtag.o mpl_module.o yomdyncore.o: parkind1.o +abor1.o yomlun.o : yomlun_ifsaux.o + +.PHONY: deps includes Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/abor1.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/abor1.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/abor1.F90 (revision 6016) @@ -0,0 +1,34 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +SUBROUTINE ABOR1(CDTEXT) + +USE PARKIND1, ONLY : JPIM, JPRB +USE YOMLUN_IFSAUX, ONLY : NULOUT, NULERR + +IMPLICIT NONE + +CHARACTER(LEN=*), INTENT(IN) :: CDTEXT + +IF (NULOUT >= 0) WRITE(NULOUT,'(1X,A)') CDTEXT +IF (NULERR >= 0) WRITE(NULERR,'(1X,A,A)') 'ABORT! ', CDTEXT + +IF (NULOUT >= 0) THEN + ! FLUSH not understood by NAG compiler + !CALL FLUSH(NULOUT) + IF (NULOUT /= 0 .and. NULOUT /= 6) CLOSE(NULOUT) +ENDIF + +#ifdef __PGI + stop 1 +#else + error stop 1 +#endif + +END SUBROUTINE ABOR1 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/ecradhook.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/ecradhook.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/ecradhook.F90 (revision 6016) @@ -0,0 +1,34 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! DR_HOOK is a profiling and debugging system for the IFS, and should +! be called at the beginning and end of each subroutine. This is a +! dummy implementation for offline packages. + +module ecradhook + + public + + save + + integer, parameter :: jphook = selected_real_kind(13,300) + logical :: lhook = .false. + +contains + + subroutine dr_hook(proc_name, iswitch, proc_key) + + character(len=*), intent(in) :: proc_name + integer, intent(in) :: iswitch + real(jphook), intent(inout) :: proc_key + ! Do nothing! + + end subroutine dr_hook + +end module ecradhook Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/mpl_module.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/mpl_module.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/mpl_module.F90 (revision 6016) @@ -0,0 +1,57 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE MPL_MODULE + +USE PARKIND1, ONLY : JPRB + +IMPLICIT NONE + +PRIVATE + +INTERFACE MPL_BROADCAST + + MODULE PROCEDURE MPL_BROADCAST_REAL81, MPL_BROADCAST_REAL82, & + & MPL_BROADCAST_REAL83, MPL_BROADCAST_REAL84 + +END INTERFACE MPL_BROADCAST + +PUBLIC MPL_BROADCAST + +CONTAINS + +SUBROUTINE MPL_BROADCAST_REAL81(KBUF,KTAG,KROOT,CDSTRING) +REAL(JPRB) :: KBUF(:) +INTEGER,INTENT(IN) :: KTAG +INTEGER,INTENT(IN),OPTIONAL :: KROOT +CHARACTER*(*),INTENT(IN) :: CDSTRING +END SUBROUTINE MPL_BROADCAST_REAL81 + +SUBROUTINE MPL_BROADCAST_REAL82(KBUF,KTAG,KROOT,CDSTRING) +REAL(JPRB) :: KBUF(:,:) +INTEGER,INTENT(IN) :: KTAG +INTEGER,INTENT(IN),OPTIONAL :: KROOT +CHARACTER*(*),INTENT(IN) :: CDSTRING +END SUBROUTINE MPL_BROADCAST_REAL82 + +SUBROUTINE MPL_BROADCAST_REAL83(KBUF,KTAG,KROOT,CDSTRING) +REAL(JPRB) :: KBUF(:,:,:) +INTEGER,INTENT(IN) :: KTAG +INTEGER,INTENT(IN),OPTIONAL :: KROOT +CHARACTER*(*),INTENT(IN) :: CDSTRING +END SUBROUTINE MPL_BROADCAST_REAL83 + +SUBROUTINE MPL_BROADCAST_REAL84(KBUF,KTAG,KROOT,CDSTRING) +REAL(JPRB) :: KBUF(:,:,:,:) +INTEGER,INTENT(IN) :: KTAG +INTEGER,INTENT(IN),OPTIONAL :: KROOT +CHARACTER*(*),INTENT(IN) :: CDSTRING +END SUBROUTINE MPL_BROADCAST_REAL84 + +END MODULE MPL_MODULE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/parkind1.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/parkind1.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/parkind1.F90 (revision 6016) @@ -0,0 +1,57 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE PARKIND1 +! +! *** Define usual kinds for strong typing *** +! +IMPLICIT NONE +PUBLIC +SAVE +! +! Integer Kinds +! ------------- +! +INTEGER, PARAMETER :: JPIT = SELECTED_INT_KIND(2) +INTEGER, PARAMETER :: JPIS = SELECTED_INT_KIND(4) +INTEGER, PARAMETER :: JPIM = SELECTED_INT_KIND(9) +INTEGER, PARAMETER :: JPIB = SELECTED_INT_KIND(12) + +!Special integer type to be used for sensative adress calculations +!should be *8 for a machine with 8byte adressing for optimum performance +#ifdef ADDRESS64 +INTEGER, PARAMETER :: JPIA = JPIB +#else +INTEGER, PARAMETER :: JPIA = JPIM +#endif + +! +! Real Kinds +! ---------- +! +INTEGER, PARAMETER :: JPRT = SELECTED_REAL_KIND(2,1) +INTEGER, PARAMETER :: JPRS = SELECTED_REAL_KIND(4,2) +INTEGER, PARAMETER :: JPRM = SELECTED_REAL_KIND(6,37) +! This parameter should always be double precision as a few parts of +! the radiation code require it +INTEGER, PARAMETER :: JPRD = SELECTED_REAL_KIND(13,300) + +! This parameter governs the precision of most of the code +#ifdef PARKIND1_SINGLE +INTEGER, PARAMETER :: JPRB = JPRM +#else +INTEGER, PARAMETER :: JPRB = JPRD +#endif +! + +! Logical Kinds for RTTOV.... + +INTEGER, PARAMETER :: JPLM = JPIM !Standard logical type + +END MODULE PARKIND1 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomcst.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomcst.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomcst.F90 (revision 6016) @@ -0,0 +1,76 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOMCST + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! * RPI : number Pi +REAL(KIND=JPRB), PARAMETER :: RPI = 3.14159265358979323846_JPRB +! * RCLUM : light velocity +REAL(KIND=JPRB), PARAMETER :: RCLUM = 299792458._JPRB +! * RHPLA : Planck constant +REAL(KIND=JPRB), PARAMETER :: RHPLA = 6.6260755E-34_JPRB +! * RKBOL : Bolzmann constant +REAL(KIND=JPRB), PARAMETER :: RKBOL = 1.380658E-23_JPRB +! * RNAVO : Avogadro number +REAL(KIND=JPRB), PARAMETER :: RNAVO = 6.0221367E+23_JPRB +! * RSIGMA : Stefan-Bolzman constant +REAL(KIND=JPRB), PARAMETER :: RSIGMA = 5.67037321e-8_JPRB ! W m-2 K-4 +! * RG : gravity constant +REAL(KIND=JPRB), PARAMETER :: RG = 9.80665_JPRB ! m s-2 +! * RMD : dry air molar mass +REAL(KIND=JPRB), PARAMETER :: RMD = 28.9644_JPRB +! * RMV : vapour water molar mass +REAL(KIND=JPRB), PARAMETER :: RMV = 18.0153_JPRB +! * R : perfect gas constant +REAL(KIND=JPRB), PARAMETER :: R = RNAVO*RKBOL +! * RD : R_dry (dry air constant) +REAL(KIND=JPRB), PARAMETER :: RD = 287.058_JPRB! J kg-1 K-1 +! * RV : R_vap (vapour water constant) +REAL(KIND=JPRB), PARAMETER :: RV = 1000._JPRB*R/RMV +! * RMO3 : ozone molar mass +REAL(KIND=JPRB), PARAMETER :: RMO3 = 47.9942_JPRB +! * RTT : Tt = temperature of water fusion at "pre_n" +REAL(KIND=JPRB), PARAMETER :: RTT = 273.16_JPRB +! * RLVTT : RLvTt = vaporisation latent heat at T=Tt +REAL(KIND=JPRB), PARAMETER :: RLVTT = 2.5008E+6_JPRB +! * RLSTT : RLsTt = sublimation latent heat at T=Tt +REAL(KIND=JPRB), PARAMETER :: RLSTT = 2.8345E+6_JPRB +! * RI0 : solar constant +REAL(KIND=JPRB), PARAMETER :: RI0 = 1366.0_JPRB +! * RETV : R_vap/R_dry - 1 +REAL(KIND=JPRB), PARAMETER :: RETV = RV/RD-1.0_JPRB +! * RMCO2 : CO2 (carbon dioxide) molar mass +REAL(KIND=JPRB), PARAMETER :: RMCO2 = 44.0095_JPRB +! * RMCH4 : CH4 (methane) molar mass +REAL(KIND=JPRB), PARAMETER :: RMCH4 = 16.04_JPRB +! * RMN2O : N2O molar mass +REAL(KIND=JPRB), PARAMETER :: RMN2O = 44.013_JPRB +! * RMNO2 : NO2 (nitrogen dioxide) molar mass +REAL(KIND=JPRB), PARAMETER :: RMNO2 = 46.01_JPRB +! * RMCFC11 : CFC11 molar mass +REAL(KIND=JPRB), PARAMETER :: RMCFC11 = 137.3686_JPRB +! * RMCFC12 : CFC12 molar mass +REAL(KIND=JPRB), PARAMETER :: RMCFC12 = 120.914_JPRB +! * RMHCFC12 : HCFC22 molar mass +REAL(KIND=JPRB), PARAMETER :: RMHCFC22 = 86.469_JPRB +! * RMCCL4 : CCl4 molar mass +REAL(KIND=JPRB), PARAMETER :: RMCCL4 = 153.823_JPRB + +REAL(KIND=JPRB), PARAMETER :: RCPD = 3.5_JPRB*RD +REAL(KIND=JPRB), PARAMETER :: RLMLT = RLSTT-RLVTT + +END MODULE YOMCST Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomdyncore.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomdyncore.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomdyncore.F90 (revision 6016) @@ -0,0 +1,26 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOMDYNCORE + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! Aqua planet? +LOGICAL, PARAMETER :: LAQUA = .false. +! Small-planet factor +REAL(KIND=JPRB) :: RPLRG = 1.0 + + +END MODULE YOMDYNCORE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomlun.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomlun.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomlun.F90 (revision 6016) @@ -0,0 +1,24 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOMLUN + +USE PARKIND1, ONLY : JPIM +USE YOMLUN_IFSAUX, ONLY : NULOUT, NULERR + +IMPLICIT NONE + +PUBLIC + +SAVE + +INTEGER(KIND=JPIM) :: NULRAD = 25 + +! ------------------------------------------------------------------ +END MODULE YOMLUN Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomlun_ifsaux.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomlun_ifsaux.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomlun_ifsaux.F90 (revision 6016) @@ -0,0 +1,33 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +! This is taken from yomlun_ifsaux in the IFS + +MODULE YOMLUN_IFSAUX + +USE PARKIND1 ,ONLY : JPIM + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------ + +!* Logical units used by code + +! NULOUT : output unit +! NULERR : unit number for comparison with reference run + +INTEGER(KIND=JPIM) :: NULOUT = 6 +INTEGER(KIND=JPIM) :: NULERR = 0 + +! ------------------------------------------------------------------ +END MODULE YOMLUN_IFSAUX Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yommp0.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yommp0.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yommp0.F90 (revision 6016) @@ -0,0 +1,19 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOMMP0 + +IMPLICIT NONE + +PUBLIC + +INTEGER, PARAMETER :: NPROC = 1 +INTEGER, PARAMETER :: MYPROC = 1 + +END MODULE YOMMP0 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomtag.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomtag.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsaux/yomtag.F90 (revision 6016) @@ -0,0 +1,23 @@ +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +MODULE YOMTAG + +USE PARKIND1 ,ONLY : JPIM + +IMPLICIT NONE + +PUBLIC + +SAVE + +! MTAGRAD : tag for communications done in SUECRAD (ECMWF physics) +INTEGER(KIND=JPIM), PARAMETER :: MTAGRAD = 2800 + +END MODULE YOMTAG Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/AER-BSD3-LICENSE =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/AER-BSD3-LICENSE (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/AER-BSD3-LICENSE (revision 6016) @@ -0,0 +1,28 @@ +THE BSD 3-CLAUSE LICENSE + +Copyright (c) 2002-2016, Atmospheric & Environmental Research, Inc. (AER) +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Atmospheric & Environmental Research, Inc., nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ATMOSPHERIC & +ENVIRONMENTAL RESEARCH, INC., 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. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/DEPENDENCIES.txt =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/DEPENDENCIES.txt (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/DEPENDENCIES.txt (revision 6016) @@ -0,0 +1,50 @@ +PARKIND1 +PARRRTM +PARSRTM +YOERAD +YOERDI +YOERRTA1 +YOERRTA10 +YOERRTA11 +YOERRTA12 +YOERRTA13 +YOERRTA14 +YOERRTA15 +YOERRTA16 +YOERRTA2 +YOERRTA3 +YOERRTA4 +YOERRTA5 +YOERRTA6 +YOERRTA7 +YOERRTA8 +YOERRTA9 +YOERRTAB +YOERRTM +YOERRTRF +YOERRTWN +YOESRTA16 +YOESRTA17 +YOESRTA18 +YOESRTA19 +YOESRTA20 +YOESRTA21 +YOESRTA22 +YOESRTA23 +YOESRTA24 +YOESRTA25 +YOESRTA26 +YOESRTA27 +YOESRTA28 +YOESRTA29 +YOESRTAB +YOESRTAER +YOESRTM +YOESRTWN +YOESW +YOMCST +YOMDIMV +YOMDYNCORE +YOMHOOK +YOMPHY3 +YOM_YGFL Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/MODIFICATIONS =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/MODIFICATIONS (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/MODIFICATIONS (revision 6016) @@ -0,0 +1,16 @@ +srtm_gas_optical_depth.F90 + New file - adapted from srtm_spcrt(_mcica).F90 + MODIFIED 28 Sept 2015 +rrtm_prepare_gases.F90 + New file - adapted from rrtm_ecrt_140gp_mcica.F90 + MODIFIED 28 Sept 2015 +rrtm_rrtm_140gp_mcica.F90 + Remove ZHEATFAC +srtm_srtm_224gp_mcica.F90 - NOT USED? + RII0 is an argument +rrtm_setcoeff_140gp.F90 + Fix argument order +yoesrta21.F90 + Fix equivalence +rrtm_init_140gp.F90, rrtm_kgb1.F90, srtm_init.F90, srtm_kgb16.F90 + Pass through directory containing RADRRTM and RADSRTM Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/Makefile (revision 6016) @@ -0,0 +1,84 @@ +OBJECTS = parrrtm.o parsrtm.o rrtm_prepare_gases.o \ +rrtm_gas_optical_depth.o rrtm_setcoef_140gp.o \ +rrtm_taumol1.o rrtm_taumol10.o rrtm_taumol11.o rrtm_taumol12.o \ +rrtm_taumol13.o rrtm_taumol14.o rrtm_taumol15.o rrtm_taumol16.o \ +rrtm_taumol2.o rrtm_taumol3.o rrtm_taumol4.o rrtm_taumol5.o \ +rrtm_taumol6.o rrtm_taumol7.o rrtm_taumol8.o rrtm_taumol9.o \ +srtm_setcoef.o surrtrf.o srtm_gas_optical_depth.o \ +srtm_taumol16.o srtm_taumol17.o srtm_taumol18.o srtm_taumol19.o \ +srtm_taumol20.o srtm_taumol21.o srtm_taumol22.o srtm_taumol23.o \ +srtm_taumol24.o srtm_taumol25.o srtm_taumol26.o srtm_taumol27.o \ +srtm_taumol28.o srtm_taumol29.o yoerrta1.o yoerrta10.o yoerrta11.o \ +yoerrta12.o yoerrta13.o yoerrta14.o yoerrta15.o yoerrta16.o \ +yoerrta2.o yoerrta3.o yoerrta4.o yoerrta5.o yoerrta6.o yoerrta7.o \ +yoerrta8.o yoerrta9.o yoerrtab.o yoesrta16.o yoesrta17.o yoesrta18.o \ +yoesrta19.o yoesrta20.o yoesrta21.o yoesrta22.o yoesrta23.o \ +yoesrta24.o yoesrta25.o yoesrta26.o yoesrta27.o yoesrta28.o \ +yoesrta29.o yoesrtab.o yoesrtaer.o yoesw.o \ +yom_ygfl.o yomdimv.o yoerrtm.o yoerrtftr.o yoerrtrf.o \ +yoerrtwn.o yoesrtwn.o yoesrtm.o yoerdi.o rrtm_init_140gp.o \ +yoerrtbg2.o yoerrtrwt.o surdi.o surrtab.o surrtpk.o surrtftr.o \ +srtm_init.o rrtm_cmbgb1.o rrtm_cmbgb10.o rrtm_cmbgb11.o \ +rrtm_cmbgb12.o rrtm_cmbgb13.o rrtm_cmbgb14.o rrtm_cmbgb15.o \ +rrtm_cmbgb16.o rrtm_cmbgb2.o rrtm_cmbgb3.o rrtm_cmbgb4.o \ +rrtm_cmbgb5.o rrtm_cmbgb6.o rrtm_cmbgb7.o rrtm_cmbgb8.o rrtm_cmbgb9.o \ +rrtm_kgb1.o rrtm_kgb10.o rrtm_kgb11.o rrtm_kgb12.o rrtm_kgb13.o \ +rrtm_kgb14.o rrtm_kgb15.o rrtm_kgb16.o rrtm_kgb2.o rrtm_kgb3.o \ +rrtm_kgb4.o rrtm_kgb5.o rrtm_kgb6.o rrtm_kgb7.o rrtm_kgb8.o \ +rrtm_kgb9.o srtm_cmbgb16.o srtm_cmbgb17.o srtm_cmbgb18.o \ +srtm_cmbgb19.o srtm_cmbgb20.o srtm_cmbgb21.o srtm_cmbgb22.o \ +srtm_cmbgb23.o srtm_cmbgb24.o srtm_cmbgb25.o srtm_cmbgb26.o \ +srtm_cmbgb27.o srtm_cmbgb28.o srtm_cmbgb29.o srtm_kgb16.o \ +srtm_kgb17.o srtm_kgb18.o srtm_kgb19.o srtm_kgb20.o srtm_kgb21.o \ +srtm_kgb22.o srtm_kgb23.o srtm_kgb24.o srtm_kgb25.o srtm_kgb26.o \ +srtm_kgb27.o srtm_kgb28.o srtm_kgb29.o yoerrto1.o yoerrto10.o \ +yoerrto11.o yoerrto12.o yoerrto13.o yoerrto14.o yoerrto15.o \ +yoerrto16.o yoerrto2.o yoerrto3.o yoerrto4.o yoerrto5.o yoerrto6.o \ +yoerrto7.o yoerrto8.o yoerrto9.o susrtm.o modify_wv_continuum.o + +SOURCES := $(OBJECTS:.o=.F90) + +MAKE_DEPS = ../bin/make_deps.sh +MAKE_DUMMY_INCLUDES = ../bin/make_dummy_includes.sh +MAKE_INCLUDES = ../bin/make_intfbl.1.pl +INCLUDE_DIR = ../include + +DEPS_FILE = Makefile_deps + +LIBIFSRRTM = ../lib/libifsrrtm.a + +all: $(LIBIFSRRTM) + +#deps: clean-deps $(DEPS_FILE) dummy_includes +deps: clean-deps $(DEPS_FILE) includes + +$(LIBIFSRRTM): $(OBJECTS) + ar r $(LIBIFSRRTM) $(OBJECTS) + +%.o: %.F90 + $(FC) $(FCFLAGS) -c $< + +$(DEPS_FILE): $(SOURCES) + $(MAKE_DEPS) $(SOURCES) > $(DEPS_FILE) + +dummy_includes: + $(MAKE_DUMMY_INCLUDES) $(SOURCES) + +includes: + LOC_INTFBDIR=$(INCLUDE_DIR) INTFBDIR=$(INCLUDE_DIR) $(MAKE_INCLUDES) $(SOURCES) + +count: + echo $(OBJECTS) | wc + +clean: + rm -f *.o $(LIBIFSRRTM) + +dist-clean: clean-deps + +clean-deps: + rm -f Makefile_deps + +.PHONY: deps dummy_includes includes clean-deps + +include $(DEPS_FILE) + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/Makefile_deps =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/Makefile_deps (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/Makefile_deps (revision 6016) @@ -0,0 +1,107 @@ +rrtm_prepare_gases.o: parrrtm.o +rrtm_gas_optical_depth.o: parrrtm.o yoerrtm.o +rrtm_setcoef_140gp.o: parrrtm.o yoerrtrf.o +rrtm_taumol1.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta1.o +rrtm_taumol10.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta10.o +rrtm_taumol11.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta11.o +rrtm_taumol12.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta12.o yoerrtrf.o +rrtm_taumol13.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta13.o yoerrtrf.o +rrtm_taumol14.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta14.o +rrtm_taumol15.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta15.o yoerrtrf.o +rrtm_taumol16.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta16.o yoerrtrf.o +rrtm_taumol2.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta2.o +rrtm_taumol3.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta3.o yoerrtrf.o +rrtm_taumol4.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta4.o yoerrtrf.o +rrtm_taumol5.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta5.o yoerrtrf.o +rrtm_taumol6.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta6.o yoerrtrf.o +rrtm_taumol7.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta7.o yoerrtrf.o +rrtm_taumol8.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta8.o yoerrtrf.o +rrtm_taumol9.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrta9.o yoerrtrf.o +srtm_setcoef.o: yoesrtwn.o +surrtrf.o: yoerrtrf.o +srtm_gas_optical_depth.o: parsrtm.o yoesrtm.o yoesrtwn.o +srtm_taumol16.o: parsrtm.o yoesrtm.o yoesrta16.o yoesrtwn.o +srtm_taumol17.o: parsrtm.o yoesrtm.o yoesrta17.o yoesrtwn.o +srtm_taumol18.o: parsrtm.o yoesrtm.o yoesrta18.o yoesrtwn.o +srtm_taumol19.o: parsrtm.o yoesrtm.o yoesrta19.o yoesrtwn.o +srtm_taumol20.o: parsrtm.o yoesrtm.o yoesrta20.o yoesrtwn.o +srtm_taumol21.o: parsrtm.o yoesrtm.o yoesrta21.o yoesrtwn.o +srtm_taumol22.o: parsrtm.o yoesrtm.o yoesrta22.o yoesrtwn.o +srtm_taumol23.o: parsrtm.o yoesrtm.o yoesrta23.o yoesrtwn.o +srtm_taumol24.o: parsrtm.o yoesrtm.o yoesrta24.o yoesrtwn.o +srtm_taumol25.o: parsrtm.o yoesrtm.o yoesrta25.o yoesrtwn.o +srtm_taumol26.o: parsrtm.o yoesrtm.o yoesrta26.o +srtm_taumol27.o: parsrtm.o yoesrtm.o yoesrta27.o yoesrtwn.o +srtm_taumol28.o: parsrtm.o yoesrtm.o yoesrta28.o yoesrtwn.o +srtm_taumol29.o: parsrtm.o yoesrtm.o yoesrta29.o yoesrtwn.o +yoerrtm.o: parrrtm.o +yoesrtm.o: parsrtm.o +rrtm_init_140gp.o: parrrtm.o yoerrtm.o yoerrtwn.o yoerrtftr.o yoerrtbg2.o yoerrtrwt.o +yoerrtrwt.o: parrrtm.o +surdi.o: yoerdi.o +surrtab.o: yoerrtab.o +surrtpk.o: yoerrtwn.o +surrtftr.o: yoerrtftr.o yoerrtm.o +srtm_init.o: parsrtm.o yoesrtm.o yoesrtwn.o +rrtm_cmbgb1.o: yoerrto1.o yoerrta1.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb10.o: yoerrto10.o yoerrta10.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb11.o: yoerrto11.o yoerrta11.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb12.o: yoerrto12.o yoerrta12.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb13.o: yoerrto13.o yoerrta13.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb14.o: yoerrto14.o yoerrta14.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb15.o: yoerrto15.o yoerrta15.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb16.o: yoerrto16.o yoerrta16.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb2.o: yoerrto2.o yoerrta2.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb3.o: yoerrto3.o yoerrta3.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb4.o: yoerrto4.o yoerrta4.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb5.o: yoerrto5.o yoerrta5.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb6.o: yoerrto6.o yoerrta6.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb7.o: yoerrto7.o yoerrta7.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb8.o: yoerrto8.o yoerrta8.o yoerrtrwt.o yoerrtftr.o +rrtm_cmbgb9.o: yoerrto9.o yoerrta9.o yoerrtrwt.o yoerrtftr.o +rrtm_kgb1.o: yoerrto1.o +rrtm_kgb10.o: yoerrto10.o +rrtm_kgb11.o: yoerrto11.o +rrtm_kgb12.o: yoerrto12.o +rrtm_kgb13.o: yoerrto13.o +rrtm_kgb14.o: yoerrto14.o +rrtm_kgb15.o: yoerrto15.o +rrtm_kgb16.o: yoerrto16.o +rrtm_kgb2.o: yoerrto2.o +rrtm_kgb3.o: yoerrto3.o +rrtm_kgb4.o: yoerrto4.o +rrtm_kgb5.o: yoerrto5.o +rrtm_kgb6.o: yoerrto6.o +rrtm_kgb7.o: yoerrto7.o +rrtm_kgb8.o: yoerrto8.o +rrtm_kgb9.o: yoerrto9.o +srtm_cmbgb16.o: yoesrtm.o yoesrtwn.o yoesrta16.o +srtm_cmbgb17.o: yoesrtm.o yoesrtwn.o yoesrta17.o +srtm_cmbgb18.o: yoesrtm.o yoesrtwn.o yoesrta18.o +srtm_cmbgb19.o: yoesrtm.o yoesrtwn.o yoesrta19.o +srtm_cmbgb20.o: yoesrtm.o yoesrtwn.o yoesrta20.o +srtm_cmbgb21.o: yoesrtm.o yoesrtwn.o yoesrta21.o +srtm_cmbgb22.o: yoesrtm.o yoesrtwn.o yoesrta22.o +srtm_cmbgb23.o: yoesrtm.o yoesrtwn.o yoesrta23.o +srtm_cmbgb24.o: yoesrtm.o yoesrtwn.o yoesrta24.o +srtm_cmbgb25.o: yoesrtm.o yoesrtwn.o yoesrta25.o +srtm_cmbgb26.o: yoesrtm.o yoesrtwn.o yoesrta26.o +srtm_cmbgb27.o: yoesrtm.o yoesrtwn.o yoesrta27.o +srtm_cmbgb28.o: yoesrtm.o yoesrtwn.o yoesrta28.o +srtm_cmbgb29.o: yoesrtm.o yoesrtwn.o yoesrta29.o +srtm_kgb16.o: yoesrta16.o +srtm_kgb17.o: yoesrta17.o +srtm_kgb18.o: yoesrta18.o +srtm_kgb19.o: yoesrta19.o +srtm_kgb20.o: yoesrta20.o +srtm_kgb21.o: yoesrta21.o +srtm_kgb22.o: yoesrta22.o +srtm_kgb23.o: yoesrta23.o +srtm_kgb24.o: yoesrta24.o +srtm_kgb25.o: yoesrta25.o +srtm_kgb26.o: yoesrta26.o +srtm_kgb27.o: yoesrta27.o +srtm_kgb28.o: yoesrta28.o +srtm_kgb29.o: yoesrta29.o +susrtm.o: yoesrtm.o yoesrtwn.o +modify_wv_continuum.o: yoesrta16.o yoesrta17.o yoesrta18.o yoesrta19.o yoesrta20.o yoesrta21.o yoesrta22.o yoesrta23.o yoesrta29.o Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/modify_wv_continuum.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/modify_wv_continuum.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/modify_wv_continuum.F90 (revision 6016) @@ -0,0 +1,138 @@ +SUBROUTINE MODIFY_WV_CONTINUUM(NWVCONTINUUM) + +! MODIFY_WV_CONTINUUM - Adjust the shortwave continuum coefficients +! +! PURPOSE +! ------- +! The default water vapour continuum model in SRTM is MT_CKD 2.5, +! but some measurement programmes, notably from the CAVIAR project +! (Shine et al., J. Mol. Spectrosc., 2016) suggest a much stronger +! absorption in the near infrared. This routine provides the option +! to implement an approximate scaling of the shortwave continuum +! coefficients to match the CAVIAR continuum. Further details on the +! impact were provided by Hogan et al. (2017, ECMWF Tech. Memo. 816). +! +! INTERFACE +! --------- +! This routine is called from SUECRAD. If its argument is 0, it does +! nothing so that the default SRTM continuum is used. If its +! argument is 1 then it implements the CAVIAR continuum by scaling +! coefficients within the relevant SRTM modules. +! +! AUTHOR +! ------ +! Robin Hogan, ECMWF +! Original: 2018-02-21 +! +! MODIFICATIONS +! ------------- +! +! ----------------------------------------------------------------------- + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +! Load the coefficients for each relevant shortwave band +USE YOESRTA16, ONLY : SELFREF16 => SELFREF, FORREF16 => FORREF +USE YOESRTA17, ONLY : SELFREF17 => SELFREF, FORREF17 => FORREF +USE YOESRTA18, ONLY : SELFREF18 => SELFREF, FORREF18 => FORREF +USE YOESRTA19, ONLY : SELFREF19 => SELFREF, FORREF19 => FORREF +USE YOESRTA20, ONLY : SELFREF20 => SELFREF, FORREF20 => FORREF +USE YOESRTA21, ONLY : SELFREF21 => SELFREF, FORREF21 => FORREF +USE YOESRTA22, ONLY : SELFREF22 => SELFREF, FORREF22 => FORREF +USE YOESRTA23, ONLY : SELFREF23 => SELFREF, FORREF23 => FORREF +USE YOESRTA29, ONLY : SELFREF29 => SELFREF, FORREF29 => FORREF + +IMPLICIT NONE + +! CAVIAR continuum enhancements +REAL(KIND=JPRB), PARAMETER :: SELF_ENH16(16) = (/ 2.42, 2.42, 2.91, 2.91, 2.52, & + & 2.52, 2.53, 2.53, 2.51, 2.51, 2.51, 2.51, 2.58, 2.58, 2.58, 2.58 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH16(16) = (/ 3.38, 3.38, 3.19, 3.19, 1.21, & + & 1.21, 1.09, 1.09, 1.07, 1.07, 1.07, 1.07, 1.12, 1.12, 1.12, 1.12 /) +REAL(KIND=JPRB), PARAMETER :: SELF_ENH17(16) = (/ 2.18, 1.40, 1.09, 1.19, 1.02, 1.00, & + & 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH17(16) = (/ 3.17, 3.40, 1.66, 1.00, 1.00, 1.00, & + & 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) +REAL(KIND=JPRB), PARAMETER :: SELF_ENH18(16) = (/ 9.67, 12.36, 9.22, 3.71, 1.12, 1.12, & + & 0.53, 0.53, 0.49, 0.49, 0.49, 0.49, 0.35, 0.35, 0.35, 0.35 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH18(16) = (/ 38.90, 15.37, 16.55, 14.81, 4.91, 4.91, & + & 2.59, 2.59, 2.21, 2.21, 2.21, 2.21, 1.77, 1.77, 1.77, 1.77 /) +REAL(KIND=JPRB), PARAMETER :: SELF_ENH19(16) = (/ 28.53, 26.12, 19.14, 10.12, 3.69, & + & 3.69, 1.63, 1.63, 2.52, 2.52, 2.52, 2.52, 2.40, 2.40, 2.40, 2.40 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH19(16) = (/ 11.66, 9.78, 9.57, 9.55, 4.96, & + & 4.96, 2.68, 2.68, 2.61, 2.61, 2.61, 2.61, 2.37, 2.37, 2.37, 2.37 /) +REAL(KIND=JPRB), PARAMETER :: SELF_ENH20(16) = (/ 4.93, 2.76, 1.23, 0.66, 1.41, & + & 1.11, 1.07, 1.03, 1.03, 1.03, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH20(16) = (/ 24.16, 9.04, 2.73, 2.17, 1.05, & + & 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) +REAL(KIND=JPRB), PARAMETER :: SELF_ENH21(16) = (/ 9.70, 4.56, 0.99, 1.21, 1.37, & + & 1.25, 0.94, 0.99, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH21(16) = (/ 50.84, 19.27, 1.49, 1.16, 0.97, & + & 1.64, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) +REAL(KIND=JPRB), PARAMETER :: SELF_ENH22(16) = (/ 3.37, 3.37, 3.37, 3.37, 3.37, & + & 3.37, 3.37, 3.37, 1.42, 1.42, 1.42, 1.42, 1.42, 1.42, 1.42, 1.42 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH22(16) = (/ 12.31, 12.31, 12.31, 12.31, 12.31, & + & 12.31, 12.31, 12.31, 3.20, 3.20, 3.20, 3.20, 3.20, 3.20, 3.20, 3.20 /) +REAL(KIND=JPRB), PARAMETER :: SELF_ENH23(16) = (/ 1.00, 1.00, 1.19, 1.19, 1.65, & + & 1.46, 1.32, 1.07, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH23(16) = (/ 1.04, 1.04, 1.08, 1.08, 1.12, & + & 1.10, 1.18, 1.06, 1.01, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) +REAL(KIND=JPRB), PARAMETER :: SELF_ENH29(16) = (/ 1.70, 1.00, 1.00, 1.03, 1.19, & + & 1.19, 1.43, 1.43, 1.30, 1.30, 1.33, 1.33, 1.28, 1.28, 1.08, 1.23 /) +REAL(KIND=JPRB), PARAMETER :: FORE_ENH29(16) = (/ 107.42, 5.87, 3.26, 2.42, 1.39, & + & 1.39, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /) + +INTEGER(KIND=JPIM), INTENT(IN) :: NWVCONTINUUM + +INTEGER(KIND=JPIM) :: JG + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('MODIFY_WV_CONTINUUM',0,ZHOOK_HANDLE) +! ----------------------------------------------------------------------- + +IF (NWVCONTINUUM == 1) THEN + ! Apply CAVIAR continuum enhancements + DO JG = 1,16 + FORREF16(:,JG) = FORREF16(:,JG) * FORE_ENH16(JG) + SELFREF16(:,JG) = SELFREF16(:,JG) * SELF_ENH16(JG) + ENDDO + DO JG = 1,16 + FORREF17(:,JG) = FORREF17(:,JG) * FORE_ENH17(JG) + SELFREF17(:,JG) = SELFREF17(:,JG) * SELF_ENH17(JG) + ENDDO + DO JG = 1,16 + FORREF18(:,JG) = FORREF18(:,JG) * FORE_ENH18(JG) + SELFREF18(:,JG) = SELFREF18(:,JG) * SELF_ENH18(JG) + ENDDO + DO JG = 1,16 + FORREF19(:,JG) = FORREF19(:,JG) * FORE_ENH19(JG) + SELFREF19(:,JG) = SELFREF19(:,JG) * SELF_ENH19(JG) + ENDDO + DO JG = 1,16 + FORREF20(:,JG) = FORREF20(:,JG) * FORE_ENH20(JG) + SELFREF20(:,JG) = SELFREF20(:,JG) * SELF_ENH20(JG) + ENDDO + DO JG = 1,16 + FORREF21(:,JG) = FORREF21(:,JG) * FORE_ENH21(JG) + SELFREF21(:,JG) = SELFREF21(:,JG) * SELF_ENH21(JG) + ENDDO + DO JG = 1,16 + FORREF22(:,JG) = FORREF22(:,JG) * FORE_ENH22(JG) + SELFREF22(:,JG) = SELFREF22(:,JG) * SELF_ENH22(JG) + ENDDO + DO JG = 1,16 + FORREF23(:,JG) = FORREF23(:,JG) * FORE_ENH23(JG) + SELFREF23(:,JG) = SELFREF23(:,JG) * SELF_ENH23(JG) + ENDDO + DO JG = 1,16 + FORREF29(:,JG) = FORREF29(:,JG) * FORE_ENH29(JG) + SELFREF29(:,JG) = SELFREF29(:,JG) * SELF_ENH29(JG) + ENDDO +ENDIF + +! ----------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('MODIFY_WV_CONTINUUM',1,ZHOOK_HANDLE) + +END SUBROUTINE MODIFY_WV_CONTINUUM Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/parrrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/parrrtm.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/parrrtm.F90 (revision 6016) @@ -0,0 +1,110 @@ +MODULE PARRRTM + +USE PARKIND1 ,ONLY : JPIM + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------ +! Parameters relevant to AER's RRTM-LW radiation scheme + +! 19980714 JJMorcrette +! 20110322 JJMorcrette : additional comments +! 20110603 JJMorcrette reduced number of g-points +! ------------------------------------------------------------------ + +!-- basic spectral information unrelated to number of g-points +! JPG : maximum possible number of g-points in each band of RRTM_LW +! JPBAND : number of longwave spectral bands +! JPXSEC : number of cross-sections for active trace gases +! JPINPX : maximum dimension of the array of active trace gases +! JPGPT : total number of g-points in the (operational) spectrally-reduced RRTM_LW + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16 +INTEGER(KIND=JPIM), PARAMETER :: JPBAND = 16 +INTEGER(KIND=JPIM), PARAMETER :: JPXSEC = 4 +INTEGER(KIND=JPIM), PARAMETER :: JPINPX = 35 +INTEGER(KIND=JPIM), PARAMETER :: JPGMAX = 256 + +!-- configuration for EPS with 70 g-points + +!INTEGER(KIND=JPIM), PARAMETER :: JPGPT = 70 + +!INTEGER(KIND=JPIM), PARAMETER :: NG1 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG2 = 7 +!INTEGER(KIND=JPIM), PARAMETER :: NG3 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG4 = 7 +!INTEGER(KIND=JPIM), PARAMETER :: NG5 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG6 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG7 = 6 +!INTEGER(KIND=JPIM), PARAMETER :: NG8 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG9 = 6 +!INTEGER(KIND=JPIM), PARAMETER :: NG10 = 3 +!INTEGER(KIND=JPIM), PARAMETER :: NG11 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG12 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG13 = 2 +!INTEGER(KIND=JPIM), PARAMETER :: NG14 = 1 +!INTEGER(KIND=JPIM), PARAMETER :: NG15 = 1 +!INTEGER(KIND=JPIM), PARAMETER :: NG16 = 1 + +!INTEGER(KIND=JPIM), PARAMETER :: NGS1 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NGS2 = 11 +!INTEGER(KIND=JPIM), PARAMETER :: NGS3 = 19 +!INTEGER(KIND=JPIM), PARAMETER :: NGS4 = 26 +!INTEGER(KIND=JPIM), PARAMETER :: NGS5 = 34 +!INTEGER(KIND=JPIM), PARAMETER :: NGS6 = 38 +!INTEGER(KIND=JPIM), PARAMETER :: NGS7 = 44 +!INTEGER(KIND=JPIM), PARAMETER :: NGS8 = 48 +!INTEGER(KIND=JPIM), PARAMETER :: NGS9 = 54 +!INTEGER(KIND=JPIM), PARAMETER :: NGS10 = 57 +!INTEGER(KIND=JPIM), PARAMETER :: NGS11 = 61 +!INTEGER(KIND=JPIM), PARAMETER :: NGS12 = 65 +!INTEGER(KIND=JPIM), PARAMETER :: NGS13 = 67 +!INTEGER(KIND=JPIM), PARAMETER :: NGS14 = 68 +!INTEGER(KIND=JPIM), PARAMETER :: NGS15 = 69 + + +!-- configuration with 140 g-points + +!INTEGER(KIND=JPIM), PARAMETER :: JPGPTF = 140 +!INTEGER(KIND=JPIM), PARAMETER :: JPGPTR = 140 +!INTEGER(KIND=JPIM), PARAMETER :: JPGPT = 140 + +!INTEGER(KIND=JPIM), PARAMETER :: NG1 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG2 = 14 +!INTEGER(KIND=JPIM), PARAMETER :: NG3 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG4 = 14 +!INTEGER(KIND=JPIM), PARAMETER :: NG5 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG6 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG7 = 12 +!INTEGER(KIND=JPIM), PARAMETER :: NG8 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG9 = 12 +!INTEGER(KIND=JPIM), PARAMETER :: NG10 = 6 +!INTEGER(KIND=JPIM), PARAMETER :: NG11 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG12 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG13 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG14 = 2 +!INTEGER(KIND=JPIM), PARAMETER :: NG15 = 2 +!INTEGER(KIND=JPIM), PARAMETER :: NG16 = 2 + +!INTEGER(KIND=JPIM), PARAMETER :: NGS1 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NGS2 = 22 +!INTEGER(KIND=JPIM), PARAMETER :: NGS3 = 38 +!INTEGER(KIND=JPIM), PARAMETER :: NGS4 = 52 +!INTEGER(KIND=JPIM), PARAMETER :: NGS5 = 68 +!INTEGER(KIND=JPIM), PARAMETER :: NGS6 = 76 +!INTEGER(KIND=JPIM), PARAMETER :: NGS7 = 88 +!INTEGER(KIND=JPIM), PARAMETER :: NGS8 = 96 +!INTEGER(KIND=JPIM), PARAMETER :: NGS9 = 108 +!INTEGER(KIND=JPIM), PARAMETER :: NGS10 = 114 +!INTEGER(KIND=JPIM), PARAMETER :: NGS11 = 122 +!INTEGER(KIND=JPIM), PARAMETER :: NGS12 = 130 +!INTEGER(KIND=JPIM), PARAMETER :: NGS13 = 134 +!INTEGER(KIND=JPIM), PARAMETER :: NGS14 = 136 +!INTEGER(KIND=JPIM), PARAMETER :: NGS15 = 138 + +! ------------------------------------------------------------------ +END MODULE PARRRTM Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/parsrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/parsrtm.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/parsrtm.F90 (revision 6016) @@ -0,0 +1,131 @@ +MODULE PARSRTM + +USE PARKIND1 ,ONLY : JPIM + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------ +! Parameters relevant to AER's RRTM-SW radiation scheme + +! 030224 JJMorcrette + +! Modified for g-point reduction from 224 to 112. +! Swap code below to restore 224 g-point set. +! Mar2004 MJIacono, AER +! 20110322 JJMorcrette : additional comments +! 20110603 JJMorcrette reduced number of g-points +! ------------------------------------------------------------------ + +!-- basic spectral information unrelated to number of g-points +! JPG : INTEGER : maximum number of g-points in a given spectral band +! JPBAND : INTEGER : total number of spectral bands +! JPSW : INTEGER : total number of shortwave spectral bands +! JPB1 : INTEGER : starting index of shortwave spectrum +! JPB2 : INTEGER : end index of shortwave spectrum + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16 +INTEGER(KIND=JPIM), PARAMETER :: JPBAND = 29 +INTEGER(KIND=JPIM), PARAMETER :: JPSW = 14 +INTEGER(KIND=JPIM), PARAMETER :: JPB1 = 16 +INTEGER(KIND=JPIM), PARAMETER :: JPB2 = 29 +INTEGER(KIND=JPIM), PARAMETER :: JPGMAX = 224 + +!-- other information that could be relevant for RRTM_SW +!-- NB: The following parameters are unused within the ECMWF IFS. +! They relate to the description of the optical properties +! in the original cloud model embedded in RRTM_SW +!INTEGER(KIND=JPIM), PARAMETER :: JMCMU = 32 +!INTEGER(KIND=JPIM), PARAMETER :: JMUMU = 32 +!INTEGER(KIND=JPIM), PARAMETER :: JMPHI = 3 +!INTEGER(KIND=JPIM), PARAMETER :: JMXANG = 4 +!INTEGER(KIND=JPIM), PARAMETER :: JMXSTR = 16 + +!-- original spectral grid before spectral averaging +!-- original from AER, Inc with 224 g-points +INTEGER(KIND=JPIM), PARAMETER :: NGS16 = 0 +INTEGER(KIND=JPIM), PARAMETER :: NGS17 = 16 +INTEGER(KIND=JPIM), PARAMETER :: NGS18 = 32 +INTEGER(KIND=JPIM), PARAMETER :: NGS19 = 48 +INTEGER(KIND=JPIM), PARAMETER :: NGS20 = 64 +INTEGER(KIND=JPIM), PARAMETER :: NGS21 = 80 +INTEGER(KIND=JPIM), PARAMETER :: NGS22 = 96 +INTEGER(KIND=JPIM), PARAMETER :: NGS23 = 112 +INTEGER(KIND=JPIM), PARAMETER :: NGS24 = 128 +INTEGER(KIND=JPIM), PARAMETER :: NGS25 = 144 +INTEGER(KIND=JPIM), PARAMETER :: NGS26 = 160 +INTEGER(KIND=JPIM), PARAMETER :: NGS27 = 176 +INTEGER(KIND=JPIM), PARAMETER :: NGS28 = 192 +INTEGER(KIND=JPIM), PARAMETER :: NGS29 = 208 + +!------------------------------------------------------------------------------- +!-- NGnn : number of g-points in bands nn=16 to 29 +!- as used in the Ng g-points version of RRTM_SW +!------------------------------------------------------------------------------- +!-- configuration with 14 spectral intervals +! and a total of 56 g-points (14xvariable number) + +!INTEGER(KIND=JPIM), PARAMETER :: JPGPT = 56 +! +!INTEGER(KIND=JPIM), PARAMETER :: NG16 = 3 +!INTEGER(KIND=JPIM), PARAMETER :: NG17 = 6 +!INTEGER(KIND=JPIM), PARAMETER :: NG18 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG19 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG20 = 5 +!INTEGER(KIND=JPIM), PARAMETER :: NG21 = 5 +!INTEGER(KIND=JPIM), PARAMETER :: NG22 = 1 +!INTEGER(KIND=JPIM), PARAMETER :: NG23 = 5 +!INTEGER(KIND=JPIM), PARAMETER :: NG24 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG25 = 3 +!INTEGER(KIND=JPIM), PARAMETER :: NG26 = 3 +!INTEGER(KIND=JPIM), PARAMETER :: NG27 = 4 +!INTEGER(KIND=JPIM), PARAMETER :: NG28 = 3 +!INTEGER(KIND=JPIM), PARAMETER :: NG29 = 6 +!------------------------------------------------------------------------------- +!-- configuration with 14 spectral intervals +! and a total of 112 g-points (14xvariable number) +! +!INTEGER(KIND=JPIM), PARAMETER :: JPGPT = 112 +! +!INTEGER(KIND=JPIM), PARAMETER :: NG16 = 6 +!INTEGER(KIND=JPIM), PARAMETER :: NG17 = 12 +!INTEGER(KIND=JPIM), PARAMETER :: NG18 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG19 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG20 = 10 +!INTEGER(KIND=JPIM), PARAMETER :: NG21 = 10 +!INTEGER(KIND=JPIM), PARAMETER :: NG22 = 2 +!INTEGER(KIND=JPIM), PARAMETER :: NG23 = 10 +!INTEGER(KIND=JPIM), PARAMETER :: NG24 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG25 = 6 +!INTEGER(KIND=JPIM), PARAMETER :: NG26 = 6 +!INTEGER(KIND=JPIM), PARAMETER :: NG27 = 8 +!INTEGER(KIND=JPIM), PARAMETER :: NG28 = 6 +!INTEGER(KIND=JPIM), PARAMETER :: NG29 = 12 + +!------------------------------------------------------------------------------- +!-- configuration with 14 spectral intervals +! and a total of 224 g-points (14x16) +! +!INTEGER(KIND=JPIM), PARAMETER :: JPGPT = 224 + +!INTEGER(KIND=JPIM), PARAMETER :: NG16 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG17 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG18 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG19 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG20 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG21 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG22 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG23 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG24 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG25 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG26 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG27 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG28 = 16 +!INTEGER(KIND=JPIM), PARAMETER :: NG29 = 16 + +! ------------------------------------------------------------------ +END MODULE PARSRTM + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb1.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb1.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb1.F90 (revision 6016) @@ -0,0 +1,128 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB1 +!*************************************************************************** + +! The subroutines CMBGB1->CMBGB16 input the absorption coefficient +! data for each band, which are defined for 16 g-points and 16 spectral +! bands. The data are combined with appropriate weighting following the +! g-point mapping arrays specified in RRTMINIT. Plank fraction data +! in arrays FRACREFA and FRACREFB are combined without weighting. All +! g-point reduced data are put into new arrays for use in RRTM. + +! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) + +! ABozzo may 2013 update to the last version of rrtmg + +!band 1: 10-350 cm-1 (low key - h2o; low minor - n2) +! (high key - h2o; high minor - n2) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO1 , ONLY : KAO, KBO, SELFREFO, FORREFO, FRACREFAO,FRACREFBO,KAO_MN2, KBO_MN2 +USE YOERRTA1 , ONLY : KA , KB , SELFREF , FORREF , FRACREFA ,FRACREFB, KA_MN2, KB_MN2 +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF1, Z_SUMF2, Z_SUMK, Z_SUMK1, Z_SUMK2 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB1',0,ZHOOK_HANDLE) +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(1) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM) + ENDDO + + KA(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(1) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM) + ENDDO + + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(1) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(1) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO + ENDDO + + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(1) + Z_SUMK1 = 0.0_JPRB + Z_SUMK2 = 0.0_JPRB + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + Z_SUMK1 = Z_SUMK1 + KAO_MN2(JT,IPRSM)*RWGT(IPRSM) + Z_SUMK2 = Z_SUMK2 + KBO_MN2(JT,IPRSM)*RWGT(IPRSM) + ENDDO + KA_MN2(JT,IGC) = Z_SUMK1 + KB_MN2(JT,IGC) = Z_SUMK2 + ENDDO + ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(1) + Z_SUMF1 = 0.0_JPRB + Z_SUMF2 = 0.0_JPRB + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + + Z_SUMF1= Z_SUMF1+ FRACREFAO(IPRSM) + Z_SUMF2= Z_SUMF2+ FRACREFBO(IPRSM) + ENDDO + + FRACREFA(IGC) = Z_SUMF1 + FRACREFB(IGC) = Z_SUMF2 +ENDDO + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, KA_MN2, KB_MN2, & +!$ACC SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB1',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB1 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb10.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb10.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb10.F90 (revision 6016) @@ -0,0 +1,100 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB10 +!*************************************************************************** + +! BAND 10: 1390-1480 cm-1 (low - H2O; high - H2O) +! ABozzo updated to rrtmg v4.85 +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO10, ONLY : KAO ,KBO ,FRACREFAO ,FRACREFBO, SELFREFO,FORREFO +USE YOERRTA10, ONLY : KA ,KB ,FRACREFA ,FRACREFB, SELFREF,FORREF +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF1, Z_SUMF2, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB10',0,ZHOOK_HANDLE) +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(10) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+144) + ENDDO + + KA(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(10) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+144) + ENDDO + + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + + DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(10) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+144) + ENDDO + SELFREF(JT,IGC) = Z_SUMK + ENDDO + ENDDO + + DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(10) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+144) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO + ENDDO + + IPRSM = 0 + DO IGC = 1,NGC(10) + Z_SUMF1= 0.0_JPRB + Z_SUMF2= 0.0_JPRB + DO IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + Z_SUMF1= Z_SUMF1+ FRACREFAO(IPRSM) + Z_SUMF2= Z_SUMF2+ FRACREFBO(IPRSM) + ENDDO + FRACREFA(IGC) = Z_SUMF1 + FRACREFB(IGC) = Z_SUMF2 + ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB10',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB10 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb11.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb11.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb11.F90 (revision 6016) @@ -0,0 +1,122 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB11 +!*************************************************************************** + +! BAND 11: 1480-1800 cm-1 (low - H2O; high - H2O) +! ABozzo updated to rrtmg v4.85 +! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +! (high key - h2o; high minor - o2) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO11, ONLY : KAO ,KBO ,SELFREFO,FORREFO ,FRACREFAO ,FRACREFBO, & + & KAO_MO2, KBO_MO2 +USE YOERRTA11, ONLY : KA ,KB ,SELFREF,FORREF ,FRACREFA ,FRACREFB, & + & KA_MO2, KB_MO2 +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF1, Z_SUMF2, Z_SUMK,Z_SUMK1,Z_SUMK2 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB11',0,ZHOOK_HANDLE) +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(11) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+160) + ENDDO + + KA(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(11) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+160) + ENDDO + + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(11) + Z_SUMK1 = 0.0_JPRB + Z_SUMK2 = 0.0_JPRB + DO IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK1 = Z_SUMK1 + KAO_MO2(JT,IPRSM)*RWGT(IPRSM+160) + Z_SUMK2 = Z_SUMK2 + KBO_MO2(JT,IPRSM)*RWGT(IPRSM+160) + ENDDO + KA_MO2(JT,IGC) = Z_SUMK1 + KB_MO2(JT,IGC) = Z_SUMK2 + ENDDO + ENDDO + + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(11) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+160) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(11) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+160) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(11) + Z_SUMF1= 0.0_JPRB + Z_SUMF2= 0.0_JPRB + DO IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + Z_SUMF1= Z_SUMF1+ FRACREFAO(IPRSM) + Z_SUMF2= Z_SUMF2+ FRACREFBO(IPRSM) + ENDDO + FRACREFA(IGC) = Z_SUMF1 + FRACREFB(IGC) = Z_SUMF2 + ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, KA_MO2, KB_MO2, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB11',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB11 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb12.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb12.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb12.F90 (revision 6016) @@ -0,0 +1,91 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB12 +!*************************************************************************** + +! BAND 12: 1800-2080 cm-1 (low - H2O,CO2; high - nothing) +! ABozzo updated to rrtmg v4.85 +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO12, ONLY : KAO ,SELFREFO, FORREFO ,FRACREFAO +USE YOERRTA12, ONLY : KA ,SELFREF, FORREF ,FRACREFA +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB12',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(12) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+176) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(12) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+176) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(12) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+176) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(12) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + + FRACREFA(IGC,JP) = Z_SUMF + ENDDO +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, KA, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB12',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB12 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb13.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb13.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb13.F90 (revision 6016) @@ -0,0 +1,135 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB13 +!*************************************************************************** + +! BAND 13: 2080-2250 cm-1 (low - H2O,N2O; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO13, ONLY : KAO ,SELFREFO, FORREFO ,FRACREFAO, FRACREFBO, & + & KAO_MCO2, KAO_MCO, KBO_MO3 +USE YOERRTA13, ONLY : KA ,SELFREF, FORREF ,FRACREFA, FRACREFB, & + & KA_MCO2, KA_MCO, KB_MO3 +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK, Z_SUMK1, Z_SUMK2 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB13',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(13) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+192) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JN = 1,9 + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(13) + Z_SUMK1 = 0.0_JPRB + Z_SUMK2 = 0.0_JPRB + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK1 = Z_SUMK1 + KAO_MCO2(JN,JT,IPRSM)*RWGT(IPRSM+192) + Z_SUMK2 = Z_SUMK2 + KAO_MCO(JN,JT,IPRSM)*RWGT(IPRSM+192) + ENDDO + KA_MCO2(JN,JT,IGC) = Z_SUMK1 + KA_MCO(JN,JT,IGC) = Z_SUMK2 + ENDDO + ENDDO +ENDDO + +DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(13) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KBO_MO3(JT,IPRSM)*RWGT(IPRSM+192) + ENDDO + KB_MO3(JT,IGC) = Z_SUMK + ENDDO +ENDDO + + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(13) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+192) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(13) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+192) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(13) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + Z_SUMF = Z_SUMF + FRACREFBO(IPRSM) + ENDDO + FRACREFB(IGC) = Z_SUMF +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(13) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + + FRACREFA(IGC,JP) = Z_SUMF + ENDDO +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, SELFREF, FORREF, KA_MCO2, KA_MCO, & +!$ACC KB_MO3) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB13',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB13 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb14.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb14.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb14.F90 (revision 6016) @@ -0,0 +1,105 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB14 +!*************************************************************************** + +! BAND 14: 2250-2380 cm-1 (low - CO2; high - CO2) +! ABozzo 201306 updated to rrtmg v4.85 +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO14, ONLY : KAO ,KBO ,SELFREFO, FORREFO ,FRACREFAO ,FRACREFBO +USE YOERRTA14, ONLY : KA ,KB ,SELFREF, FORREF ,FRACREFA ,FRACREFB +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF1, Z_SUMF2, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB14',0,ZHOOK_HANDLE) +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(14) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+208) + ENDDO + + KA(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(14) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+208) + ENDDO + + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(14) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+208) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(14) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+208) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(14) + Z_SUMF1= 0.0_JPRB + Z_SUMF2= 0.0_JPRB + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF1= Z_SUMF1+ FRACREFAO(IPRSM) + Z_SUMF2= Z_SUMF2+ FRACREFBO(IPRSM) + ENDDO + + FRACREFA(IGC) = Z_SUMF1 + FRACREFB(IGC) = Z_SUMF2 +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB14',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB14 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb15.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb15.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb15.F90 (revision 6016) @@ -0,0 +1,106 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB15 +!*************************************************************************** + +! BAND 15: 2380-2600 cm-1 (low - N2O,CO2; high - nothing) +! ABozzo 2001306 updated to rrtmg v4.85 +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO15, ONLY : KAO ,KAO_MN2,SELFREFO,FORREFO ,FRACREFAO +USE YOERRTA15, ONLY : KA ,KA_MN2,SELFREF,FORREF ,FRACREFA +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB15',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(15) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(14)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+224) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JN = 1,9 + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(15) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(14)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KAO_MN2(JN,JT,IPRSM)*RWGT(IPRSM+224) + ENDDO + KA_MN2(JN,JT,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(15) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(14)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+224) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(15) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(14)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+224) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(15) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(14)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + + FRACREFA(IGC,JP) = Z_SUMF + ENDDO +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, KA, KA_MN2, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB15',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB15 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb16.F90 (revision 6016) @@ -0,0 +1,116 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB16 +!*************************************************************************** + +! BAND 16: 2600-3000 cm-1 (low - H2O,CH4; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO16, ONLY : KAO,KBO ,SELFREFO,FORREFO ,FRACREFAO,FRACREFBO +USE YOERRTA16, ONLY : KA,KB ,SELFREF,FORREF ,FRACREFA,FRACREFB +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB16',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(16) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+240) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(16) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+240) + ENDDO + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(16) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+240) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(16) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+240) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(16) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + Z_SUMF = Z_SUMF + FRACREFBO(IPRSM) + ENDDO + FRACREFB(IGC) = Z_SUMF +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(16) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + + FRACREFA(IGC,JP) = Z_SUMF + ENDDO +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB16',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB16 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb2.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb2.F90 (revision 6016) @@ -0,0 +1,125 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB2 +!*************************************************************************** + +! BAND 2: 250-500 cm-1 (low - H2O; high - H2O) +! ABozzo May 2013 updated to last version of rrtmg +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO2 , ONLY : KAO ,KBO ,SELFREFO ,FRACREFAO ,& + & FRACREFBO ,FORREFO +USE YOERRTA2 , ONLY : KA ,KB ,SELFREF ,FRACREFA ,& + & FRACREFB ,FORREF +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB2',0,ZHOOK_HANDLE) +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(2) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+16) + ENDDO + + KA(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(2) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+16) + ENDDO +! KBC(JT,JP,IGC) = SUMK + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(2) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+16) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(2) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+16) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + + +IPRSM = 0 +DO IGC = 1,NGC(2) + Z_SUMK = 0.0_JPRB + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + FRACREFAO(IPRSM) + Z_SUMF = Z_SUMF + FRACREFBO(IPRSM) + ENDDO + + FRACREFA(IGC) = Z_SUMK + FRACREFB(IGC) = Z_SUMF +ENDDO + +!DO JP = 1,13 +! DO IGC = 1,NGC(2) + +! FREFA(NGS(1)+IGC,JP) = FRACREFA(IGC,JP) +! ENDDO +!ENDDO +!DO JP = 2,13 +! DO IGC = 1,NGC(2) + +! FREFADF(NGS(1)+IGC,JP) = FRACREFA(IGC,JP-1) -FRACREFA(IGC,JP) +! ENDDO +!ENDDO +!DO IGC = 1,NGC(2) + +! FREFB(NGS(1)+IGC,1) = FRACREFB(IGC) +!ENDDO + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, & +!$ACC SELFREF, FORREF) +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, SELFREF, FORREF) + + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB2',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB2 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb3.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb3.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb3.F90 (revision 6016) @@ -0,0 +1,154 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB3 +!*************************************************************************** + +! BAND 3: 500-630 cm-1 (low - H2O,CO2; high - H2O,CO2) +! ABozzo 200130517 updated to rrtmg_lw_v4.85: +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) +! (high key - h2o,co2; high minor - n2o) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO3 , ONLY : KAO ,KBO ,SELFREFO ,FRACREFAO ,& + & FRACREFBO ,FORREFO ,KAO_MN2O ,KBO_MN2O +USE YOERRTA3 , ONLY : KA ,KB ,SELFREF ,FRACREFA ,& + & FRACREFB ,FORREF ,KA_MN2O ,KB_MN2O +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB3',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(3) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+32) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO +DO JN = 1,5 + DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(3) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JN,JT,JP,IPRSM)*RWGT(IPRSM+32) + ENDDO + + KB(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO + + DO JN = 1,9 + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(3) + Z_SUMK = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KAO_MN2O(JN,JT,IPRSM)*RWGT(IPRSM+32) + ENDDO + KA_MN2O(JN,JT,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO + + DO JN = 1,5 + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(3) + Z_SUMK = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KBO_MN2O(JN,JT,IPRSM)*RWGT(IPRSM+32) + ENDDO + KB_MN2O(JN,JT,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO + + + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(3) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+32) + ENDDO + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + + DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(3) + Z_SUMK = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+32) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO + ENDDO + + DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(3) + Z_SUMF = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + FRACREFA(IGC,JP) = Z_SUMF + ENDDO + ENDDO + + + +DO JP = 1,5 + IPRSM = 0 + DO IGC = 1,NGC(3) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFBO(IPRSM,JP) + ENDDO + + FRACREFB(IGC,JP) = Z_SUMF + ENDDO +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA_MN2O, KB_MN2O, KA, KB, SELFREF, & +!$ACC FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB3',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB3 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb4.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb4.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb4.F90 (revision 6016) @@ -0,0 +1,121 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB4 +!*************************************************************************** + +! BAND 4: 630-700 cm-1 (low - H2O,CO2; high - O3,CO2) +! ABozzo 201306 updated to rrtmg v4.85 +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO4 , ONLY : KAO ,KBO ,SELFREFO , FORREFO, FRACREFAO ,FRACREFBO +USE YOERRTA4 , ONLY : KA ,KB ,SELFREF , FORREF, FRACREFA ,FRACREFB +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB4',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(4) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+48) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO +DO JN = 1,5 + DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(4) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JN,JT,JP,IPRSM)*RWGT(IPRSM+48) + ENDDO + + KB(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(4) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+48) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(4) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+48) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(4) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + + FRACREFA(IGC,JP) = Z_SUMF + ENDDO +ENDDO + +DO JP = 1,5 + IPRSM = 0 + DO IGC = 1,NGC(4) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFBO(IPRSM,JP) + ENDDO + + FRACREFB(IGC,JP) = Z_SUMF + ENDDO +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB4',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB4 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb5.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb5.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb5.F90 (revision 6016) @@ -0,0 +1,155 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB5 +!*************************************************************************** + +! BAND 5: 700-820 cm-1 (low - H2O,CO2; high - O3,CO2) +! ABozzo 201306 updated to rrtmg v4.85 +! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) +! (high key - o3,co2) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO5 , ONLY : KAO ,KBO ,SELFREFO ,FORREFO, FRACREFAO ,& + & FRACREFBO, CCL4O, KAO_MO3 +USE YOERRTA5 , ONLY : KA ,KB ,SELFREF ,FORREF, FRACREFA ,& + & FRACREFB , CCL4, KA_MO3 +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB5',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(5) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+64) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO +DO JN = 1,5 + DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(5) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JN,JT,JP,IPRSM)*RWGT(IPRSM+64) + ENDDO + + KB(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO + + DO JN = 1,9 + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(5) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KAO_MO3(JN,JT,IPRSM)*RWGT(IPRSM+64) + ENDDO + KA_MO3(JN,JT,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + + + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(5) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+64) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(5) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+64) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + + + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(5) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + + FRACREFA(IGC,JP) = Z_SUMF + ENDDO +ENDDO + +DO JP = 1,5 + IPRSM = 0 + DO IGC = 1,NGC(5) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFBO(IPRSM,JP) + ENDDO + + FRACREFB(IGC,JP) = Z_SUMF + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(5) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + CCL4O(IPRSM)*RWGT(IPRSM+64) + ENDDO + + CCL4(IGC) = Z_SUMK +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, CCL4, KA, KB, KA_MO3, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB5',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB5 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb6.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb6.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb6.F90 (revision 6016) @@ -0,0 +1,108 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB6 +!*************************************************************************** + +! BAND 6: 820-980 cm-1 (low - H2O; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) +! (high key - nothing; high minor - cfc11, cfc12) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO6 , ONLY : KAO ,SELFREFO , FORREFO, FRACREFAO ,& + & KAO_MCO2 ,CFC11ADJO,CFC12O +USE YOERRTA6 , ONLY : KA ,SELFREF , FORREF, FRACREFA ,& + & KA_MCO2 ,CFC11ADJ ,CFC12 +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK, Z_SUMK2, Z_SUMK3 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB6',0,ZHOOK_HANDLE) +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(6) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+80) + ENDDO + + KA(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(6) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KAO_MCO2(JT,IPRSM)*RWGT(IPRSM+80) + ENDDO + KA_MCO2(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(6) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+80) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(6) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+80) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(6) + Z_SUMF = 0.0_JPRB + Z_SUMK2= 0.0_JPRB + Z_SUMK3= 0.0_JPRB + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM) + Z_SUMK2= Z_SUMK2+ CFC11ADJO(IPRSM)*RWGT(IPRSM+80) + Z_SUMK3= Z_SUMK3+ CFC12O(IPRSM)*RWGT(IPRSM+80) + ENDDO + + FRACREFA(IGC) = Z_SUMF + CFC11ADJ(IGC) = Z_SUMK2 + CFC12(IGC) = Z_SUMK3 +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, CFC11ADJ, CFC12, KA, SELFREF, KA_MCO2, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB6',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB6 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb7.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb7.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb7.F90 (revision 6016) @@ -0,0 +1,149 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB7 +!*************************************************************************** + +! BAND 7: 980-1080 cm-1 (low - H2O,O3; high - O3) +! ABozzo 201306 updated to rrtmg v4.85 +! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) +! (high key - o3; high minor - co2) +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO7 , ONLY : KAO ,KBO ,SELFREFO ,FORREFO, FRACREFAO ,& + & FRACREFBO, KAO_MCO2 ,KBO_MCO2 +USE YOERRTA7 , ONLY : KA ,KB ,SELFREF ,FORREF, FRACREFA ,& + & FRACREFB, KA_MCO2 ,KB_MCO2 +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB7',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(7) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+96) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(7) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+96) + ENDDO + + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JN = 1,9 + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(7) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KAO_MCO2(JN,JT,IPRSM)*RWGT(IPRSM+96) + ENDDO + KA_MCO2(JN,JT,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(7) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KBO_MCO2(JT,IPRSM)*RWGT(IPRSM+96) + ENDDO + KB_MCO2(JT,IGC) = Z_SUMK + ENDDO +ENDDO + + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(7) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+96) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(7) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+96) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(7) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + + FRACREFA(IGC,JP) = Z_SUMF + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(7) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFBO(IPRSM) + ENDDO + + FRACREFB(IGC) = Z_SUMF +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, SELFREF, KA_MCO2, KB_MCO2, & +!$ACC FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB7',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB7 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb8.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb8.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb8.F90 (revision 6016) @@ -0,0 +1,132 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB8 +!*************************************************************************** + +! BAND 8: 1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3) +! ABozzo 201306 updated to rrtmg v4.85 +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO8 , ONLY : KAO ,KBO ,SELFREFO ,FORREFO, FRACREFAO ,& + & FRACREFBO, KAO_MCO2, KAO_MN2O ,KAO_MO3, KBO_MCO2, KBO_MN2O, & + & CFC12O , CFC22ADJO +USE YOERRTA8 , ONLY : KA ,KB ,SELFREF ,FORREF, FRACREFA ,& + & FRACREFB , KA_MCO2, KA_MN2O ,KA_MO3, KB_MCO2, KB_MN2O,& + & CFC12 , CFC22ADJ +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JP, JT + +REAL(KIND=JPRB) :: Z_SUMF1, Z_SUMF2, Z_SUMK, Z_SUMK1, Z_SUMK2, Z_SUMK3, Z_SUMK4, Z_SUMK5 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB8',0,ZHOOK_HANDLE) +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(8) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+112) + ENDDO + KA(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(8) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+112) + ENDDO + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(8) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+112) + ENDDO + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(8) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+112) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + +DO JT = 1,19 +IPRSM = 0 +DO IGC = 1,NGC(8) + Z_SUMK1= 0.0_JPRB + Z_SUMK2= 0.0_JPRB + Z_SUMK3= 0.0_JPRB + Z_SUMK4= 0.0_JPRB + Z_SUMK5= 0.0_JPRB + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK1= Z_SUMK1+ KAO_MCO2(JT,IPRSM)*RWGT(IPRSM+112) + Z_SUMK2= Z_SUMK2+ KBO_MCO2(JT,IPRSM)*RWGT(IPRSM+112) + Z_SUMK3= Z_SUMK3+ KAO_MO3(JT,IPRSM)*RWGT(IPRSM+112) + Z_SUMK4= Z_SUMK4+ KAO_MN2O(JT,IPRSM)*RWGT(IPRSM+112) + Z_SUMK5= Z_SUMK5+ KBO_MN2O(JT,IPRSM)*RWGT(IPRSM+112) + ENDDO + KA_MCO2(JT,IGC) = Z_SUMK1 + KB_MCO2(JT,IGC) = Z_SUMK2 + KA_MO3(JT,IGC) = Z_SUMK3 + KA_MN2O(JT,IGC) = Z_SUMK4 + KB_MN2O(JT,IGC) = Z_SUMK5 +ENDDO +ENDDO + + + +IPRSM = 0 +DO IGC = 1,NGC(8) + Z_SUMF1= 0.0_JPRB + Z_SUMF2= 0.0_JPRB + Z_SUMK1= 0.0_JPRB + Z_SUMK2= 0.0_JPRB + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + Z_SUMF1= Z_SUMF1+ FRACREFAO(IPRSM) + Z_SUMF2= Z_SUMF2+ FRACREFBO(IPRSM) + Z_SUMK1= Z_SUMK1+ CFC12O(IPRSM)*RWGT(IPRSM+112) + Z_SUMK2= Z_SUMK2+ CFC22ADJO(IPRSM)*RWGT(IPRSM+112) + ENDDO + FRACREFA(IGC) = Z_SUMF1 + FRACREFB(IGC) = Z_SUMF2 + CFC12(IGC) = Z_SUMK1 + CFC22ADJ(IGC) = Z_SUMK2 +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, CFC12, CFC22ADJ, KA, KB, KA_MCO2, & +!$ACC KA_MN2O, KA_MO3, KB_MCO2, KB_MN2O, SELFREF, FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB8',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB8 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb9.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb9.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_cmbgb9.F90 (revision 6016) @@ -0,0 +1,153 @@ +! This file has been modified for the use in ICON + +!*************************************************************************** +SUBROUTINE RRTM_CMBGB9 +!*************************************************************************** + +! BAND 9: 1180-1390 cm-1 (low - H2O,CH4; high - CH4) +! ABozzo 201306 updated to rrtmg v4.85 +! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) +! (high key - ch4; high minor - n2o)! +!*************************************************************************** + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERRTO9 , ONLY : KAO ,KBO ,SELFREFO, FORREFO ,FRACREFAO ,& + & FRACREFBO, KAO_MN2O, KBO_MN2O +USE YOERRTA9 , ONLY : KA ,KB ,SELFREF, FORREF ,FRACREFA ,& + & FRACREFB , KA_MN2O, KB_MN2O +USE YOERRTRWT, ONLY : RWGT +USE YOERRTFTR, ONLY : NGC ,NGS ,NGN + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM, JN, JP, JT + + +REAL(KIND=JPRB) :: Z_SUMF, Z_SUMK +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB9',0,ZHOOK_HANDLE) +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(9) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+128) + ENDDO + + KA(JN,JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(9) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+128) + ENDDO + + KB(JT,JP,IGC) = Z_SUMK + ENDDO + ENDDO +ENDDO + + DO JN = 1,9 + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(9) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KAO_MN2O(JN,JT,IPRSM)*RWGT(IPRSM+128) + ENDDO + KA_MN2O(JN,JT,IGC) = Z_SUMK + ENDDO + ENDDO + ENDDO + + DO JT = 1,19 + IPRSM = 0 + DO IGC = 1,NGC(9) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + KBO_MN2O(JT,IPRSM)*RWGT(IPRSM+128) + ENDDO + KB_MN2O(JT,IGC) = Z_SUMK + ENDDO + ENDDO + + + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(9) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMK = Z_SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+128) + ENDDO + + SELFREF(JT,IGC) = Z_SUMK + ENDDO +ENDDO + + DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(9) + Z_SUMK = 0.0_JPRB + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + Z_SUMK = Z_SUMK + FORREFO(JT,IPRSM)*RWGT(IPRSM+128) + ENDDO + FORREF(JT,IGC) = Z_SUMK + ENDDO + ENDDO + + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(9) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFAO(IPRSM,JP) + ENDDO + + FRACREFA(IGC,JP) = Z_SUMF + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(9) + Z_SUMF = 0.0_JPRB + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + + Z_SUMF = Z_SUMF + FRACREFBO(IPRSM) + ENDDO + + FRACREFB(IGC) = Z_SUMF +ENDDO + + +!$ACC UPDATE DEVICE(FRACREFA, FRACREFB, KA, KB, KA_MN2O, KB_MN2O, SELFREF, & +!$ACC FORREF) + +IF (LHOOK) CALL DR_HOOK('RRTM_CMBGB9',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_CMBGB9 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_ecrt_140gp_mcica.F90.erase =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_ecrt_140gp_mcica.F90.erase (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_ecrt_140gp_mcica.F90.erase (revision 6016) @@ -0,0 +1,370 @@ +SUBROUTINE RRTM_ECRT_140GP_MCICA & + &( KIDIA, KFDIA, KLON, KLEV, KCOLS ,& + & PAER , PAPH , PAP , PAERTAUL, PAERASYL, PAEROMGL, & + & PTS , PTH , PT , & + & PEMIS, PEMIW, & + & PQ , PCO2 , PCH4, PN2O , PNO2, PC11, PC12, PC22, PCL4, POZN, PCLDF , PTAUCLDI, & + & PCLDFRAC, PTAUCLD, PCOLDRY, PWBRODL, PWKL, PWX , & + & PTAUAERL, PAVEL , PTAVEL , PZ , PTZ , PTBOUND, PSEMISS , KREFLECT) + +!----compiled for Cray with -h nopattern---- + +! Reformatted for F90 by JJMorcrette, ECMWF, 980714 + +! Read in atmospheric profile from ECMWF radiation code, and prepare it +! for use in RRTM. Set other RRTM input parameters. Values are passed +! back through existing RRTM arrays and commons. + +!- Modifications + +! 2000-05-15 Deborah Salmond Speed-up +! JJMorcrette 20050110 McICA version +! NEC 25-Oct-2007 Optimisations +! PBechtold+NSemane 09-Jul-2012 Gravity +! 201305 ABozzo PWBRODL,O2 + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE YOMCST , ONLY : RG +USE PARRRTM , ONLY : JPBAND, JPXSEC, JPINPX +USE YOERAD , ONLY : NSPMAPL +USE YOESW , ONLY : RAER +USE YOEAERATM, ONLY : LAERRRTM, LAERCSTR, LAERVOL +USE YOM_YGFL , ONLY : YGFL +USE YOMDYNCORE,ONLY : RPLRG + +!------------------------------Arguments-------------------------------- + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KLON! Number of atmospheres (longitudes) +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV! Number of atmospheric layers +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KCOLS + +REAL(KIND=JPRB) ,INTENT(IN) :: PAER(KLON,6,KLEV) ! Aerosol optical thickness +REAL(KIND=JPRB) ,INTENT(IN) :: PAERTAUL(KLON,KLEV,16), PAERASYL(KLON,KLEV,16), PAEROMGL(KLON,KLEV,16) +REAL(KIND=JPRB) ,INTENT(IN) :: PAPH(KLON,KLEV+1) ! Interface pressures (Pa) +REAL(KIND=JPRB) ,INTENT(IN) :: PAP(KLON,KLEV) ! Layer pressures (Pa) +REAL(KIND=JPRB) ,INTENT(IN) :: PTS(KLON) ! Surface temperature (K) +REAL(KIND=JPRB) ,INTENT(IN) :: PTH(KLON,KLEV+1) ! Interface temperatures (K) +REAL(KIND=JPRB) ,INTENT(IN) :: PT(KLON,KLEV) ! Layer temperature (K) +REAL(KIND=JPRB) ,INTENT(IN) :: PEMIS(KLON) ! Non-window surface emissivity +REAL(KIND=JPRB) ,INTENT(IN) :: PEMIW(KLON) ! Window surface emissivity +REAL(KIND=JPRB) ,INTENT(IN) :: PQ(KLON,KLEV) ! H2O specific humidity (mmr) +REAL(KIND=JPRB) ,INTENT(IN) :: PCO2(KLON,KLEV) ! CO2 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PCH4(KLON,KLEV) ! CH4 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PN2O(KLON,KLEV) ! N2O mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PNO2(KLON,KLEV) ! NO2 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC11(KLON,KLEV) ! CFC11 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC12(KLON,KLEV) ! CFC12 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC22(KLON,KLEV) ! CFC22 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PCL4(KLON,KLEV) ! CCL4 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: POZN(KLON,KLEV) ! O3 mass mixing ratio + +REAL(KIND=JPRB) ,INTENT(IN) :: PCLDF(KLON,KCOLS,KLEV) ! Cloud fraction +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUCLDI(KLON,KLEV,KCOLS) ! Cloud optical depth + +REAL(KIND=JPRB) ,INTENT(OUT) :: PCLDFRAC(KIDIA:KFDIA,KCOLS,KLEV) ! Cloud fraction +REAL(KIND=JPRB) ,INTENT(OUT) :: PTAUCLD(KIDIA:KFDIA,KLEV,KCOLS) ! Spectral optical thickness + +REAL(KIND=JPRB) ,INTENT(OUT) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWBRODL(KIDIA:KFDIA,KLEV) ! broadening gas column density (mol/cm2) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWKL(KIDIA:KFDIA,JPINPX,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWX(KIDIA:KFDIA,JPXSEC,KLEV) ! Amount of trace gases +REAL(KIND=JPRB) ,INTENT(OUT) :: PTAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(OUT) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PZ(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTZ(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTBOUND(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(OUT) :: PSEMISS(KIDIA:KFDIA,JPBAND) +INTEGER(KIND=JPIM),INTENT(OUT) :: KREFLECT(KIDIA:KFDIA) + +! real rch4 ! CH4 mass mixing ratio +! real rn2o ! N2O mass mixing ratio +! real rcfc11 ! CFC11 mass mixing ratio +! real rcfc12 ! CFC12 mass mixing ratio +! real rcfc22 ! CFC22 mass mixing ratio +! real rccl4 ! CCl4 mass mixing ratio +!- from AER +!- from PROFILE +!- from SURFACE +REAL(KIND=JPRB) :: ztauaer(5) +REAL(KIND=JPRB) :: ZAMD ! Effective molecular weight of dry air (g/mol) +REAL(KIND=JPRB) :: ZAMW ! Molecular weight of water vapor (g/mol) +REAL(KIND=JPRB) :: ZAMCO2 ! Molecular weight of carbon dioxide (g/mol) +REAL(KIND=JPRB) :: ZAMO ! Molecular weight of ozone (g/mol) +REAL(KIND=JPRB) :: ZAMCH4 ! Molecular weight of methane (g/mol) +REAL(KIND=JPRB) :: ZAMN2O ! Molecular weight of nitrous oxide (g/mol) +REAL(KIND=JPRB) :: ZAMC11 ! Molecular weight of CFC11 (g/mol) - CFCL3 +REAL(KIND=JPRB) :: ZAMC12 ! Molecular weight of CFC12 (g/mol) - CF2CL2 +REAL(KIND=JPRB) :: ZAMC22 ! Molecular weight of CFC22 (g/mol) - CHF2CL +REAL(KIND=JPRB) :: ZAMCL4 ! Molecular weight of CCl4 (g/mol) - CCL4 +REAL(KIND=JPRB) :: ZAVGDRO ! Avogadro's number (molecules/mole) +REAL(KIND=JPRB) :: ZGRAVIT ! Gravitational acceleration (cm/s**2) + +REAL(KIND=JPRB) :: ZSUMMOL + +! Atomic weights for conversion from mass to volume mixing ratios; these +! are the same values used in ECRT to assure accurate conversion to vmr +data ZAMD / 28.970_JPRB / +data ZAMW / 18.0154_JPRB / +data ZAMCO2 / 44.011_JPRB / +data ZAMO / 47.9982_JPRB / +data ZAMCH4 / 16.043_JPRB / +data ZAMN2O / 44.013_JPRB / +data ZAMC11 / 137.3686_JPRB / +data ZAMC12 / 120.9140_JPRB / +data ZAMC22 / 86.4690_JPRB / +data ZAMCL4 / 153.8230_JPRB / +data ZAVGDRO/ 6.02214E23_JPRB / + +INTEGER(KIND=JPIM) :: IATM, JMOL, IXMAX, J1, J2, IAE, IKL, JK, JCOLS, JL, JLW +INTEGER(KIND=JPIM) :: ITMOL, INXMOL + +REAL(KIND=JPRB) :: ZAMM + +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +! *** + +! *** mji +! Initialize all molecular amounts and aerosol optical depths to zero here, +! then pass ECRT amounts into RRTM arrays below. + +! DATA ZWKL /MAXPRDW*0.0/ +! DATA ZWX /MAXPROD*0.0/ +! DATA KREFLECT /0/ + +! Activate cross section molecules: +! NXMOL - number of cross-sections input by user +! IXINDX(I) - index of cross-section molecule corresponding to Ith +! cross-section specified by user +! = 0 -- not allowed in RRTM +! = 1 -- CCL4 +! = 2 -- CFC11 +! = 3 -- CFC12 +! = 4 -- CFC22 +! DATA KXMOL /2/ +! DATA KXINDX /0,2,3,0,31*0/ + +! IREFLECT=KREFLECT +! NXMOL=KXMOL + +ASSOCIATE(NFLEVG=>KLEV, & + & NACTAERO=>YGFL%NACTAERO) +IF (LHOOK) CALL DR_HOOK('RRTM_ECRT_140GP_MCICA',0,ZHOOK_HANDLE) + +ZGRAVIT=(RG/RPLRG)*1.E2_JPRB + +DO JL = KIDIA, KFDIA + KREFLECT(JL)=0 + INXMOL=2 +ENDDO + +!DO J1=1,35 +! IXINDX(J1)=0 +DO J2=1,KLEV + DO J1=1,35 + DO JL = KIDIA, KFDIA + PWKL(JL,J1,J2)=0.0_JPRB + ENDDO + ENDDO +ENDDO +!IXINDX(2)=2 +!IXINDX(3)=3 + +! Set parameters needed for RRTM execution: +IATM = 0 +! IXSECT = 1 +! NUMANGS = 0 +! IOUT = -1 +IXMAX = 4 + +! Bands 6,7,8 are considered the 'window' and allowed to have a +! different surface emissivity (as in ECMWF). Eli wrote this part.... +DO JL = KIDIA, KFDIA + PSEMISS(JL,1) = PEMIS(JL) + PSEMISS(JL,2) = PEMIS(JL) + PSEMISS(JL,3) = PEMIS(JL) + PSEMISS(JL,4) = PEMIS(JL) + PSEMISS(JL,5) = PEMIS(JL) + PSEMISS(JL,6) = PEMIW(JL) + PSEMISS(JL,7) = PEMIW(JL) + PSEMISS(JL,8) = PEMIW(JL) + PSEMISS(JL,9) = PEMIS(JL) + PSEMISS(JL,10) = PEMIS(JL) + PSEMISS(JL,11) = PEMIS(JL) + PSEMISS(JL,12) = PEMIS(JL) + PSEMISS(JL,13) = PEMIS(JL) + PSEMISS(JL,14) = PEMIS(JL) + PSEMISS(JL,15) = PEMIS(JL) + PSEMISS(JL,16) = PEMIS(JL) + +! Set surface temperature. + + PTBOUND(JL) = PTS(JL) + +! Install ECRT arrays into RRTM arrays for pressure, temperature, +! and molecular amounts. Pressures are converted from Pascals +! (ECRT) to mb (RRTM). H2O, CO2, O3 and trace gas amounts are +! converted from mass mixing ratio to volume mixing ratio. CO2 +! converted with same dry air and CO2 molecular weights used in +! ECRT to assure correct conversion back to the proper CO2 vmr. +! 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: RRTM levels count from bottom to top, while the ECRT input +! variables count from the top down and must be reversed + ITMOL = 7 + PZ(JL,0) = PAPH(JL,KLEV+1)/100._JPRB + PTZ(JL,0) = PTH(JL,KLEV+1) +ENDDO + + DO JK = 1, KLEV +DO JL = KIDIA, KFDIA + PAVEL(JL,JK) = PAP(JL,KLEV-JK+1)/100._JPRB + PTAVEL(JL,JK) = PT(JL,KLEV-JK+1) + PZ(JL,JK) = PAPH(JL,KLEV-JK+1)/100._JPRB + PTZ(JL,JK) = PTH(JL,KLEV-JK+1) + PWKL(JL,1,JK) = PQ(JL,KLEV-JK+1)*ZAMD/ZAMW + PWKL(JL,2,JK) = PCO2(JL,KLEV-JK+1)*ZAMD/ZAMCO2 + PWKL(JL,3,JK) = POZN(JL,KLEV-JK+1)*ZAMD/ZAMO + PWKL(JL,4,JK) = PN2O(JL,KLEV-JK+1)*ZAMD/ZAMN2O + PWKL(JL,6,JK) = PCH4(JL,KLEV-JK+1)*ZAMD/ZAMCH4 + PWKL(JL,7,JK) = 0.209488_JPRB + ZAMM = (1.0_JPRB-PWKL(JL,1,JK))*ZAMD + PWKL(JL,1,JK)*ZAMW + PCOLDRY(JL,JK) = (PZ(JL,JK-1)-PZ(JL,JK))*1.E3_JPRB*ZAVGDRO/(ZGRAVIT*ZAMM*(1.0_JPRB+PWKL(JL,1,JK))) +ENDDO + ENDDO + +!- If prognostic aerosols with proper RRTM optical properties, fill the RRTM aerosol arrays + +IF (LAERRRTM) THEN + IF (LAERCSTR .OR. (LAERVOL .AND. NACTAERO == 15)) THEN + DO JLW=1,16 + DO JK=1,KLEV + IKL=KLEV-JK+1 + DO JL=KIDIA,KFDIA + PTAUAERL(JL,JK,JLW)=PAERTAUL(JL,IKL,JLW) + ENDDO + ENDDO + ENDDO + + ELSEIF (.NOT.LAERCSTR) THEN + DO JLW=1,16 + DO JK=1,KLEV + IKL=KLEV-JK+1 + DO JL=KIDIA,KFDIA + PTAUAERL(JL,JK,JLW)=PAERTAUL(JL,IKL,JLW)+RAER(NSPMAPL(JLW),6)*PAER(JL,6,IKL) + ENDDO + ENDDO + ENDDO + ENDIF + +ELSE + +!- Fill RRTM aerosol arrays with operational ECMWF aerosols, +! do the mixing and distribute over the 16 spectral intervals + + DO JK=1,KLEV + IKL=KLEV-JK+1 + DO JL = KIDIA, KFDIA + IAE=1 + ZTAUAER(IAE) =& + & RAER(IAE,1)*PAER(JL,1,IKL)+RAER(IAE,2)*PAER(JL,2,IKL)& + & +RAER(IAE,3)*PAER(JL,3,IKL)+RAER(IAE,4)*PAER(JL,4,IKL)& + & +RAER(IAE,5)*PAER(JL,5,IKL)+RAER(IAE,6)*PAER(JL,6,IKL) + PTAUAERL(JL,JK, 1)=ZTAUAER(1) + PTAUAERL(JL,JK, 2)=ZTAUAER(1) + IAE=2 + ZTAUAER(IAE) =& + & RAER(IAE,1)*PAER(JL,1,IKL)+RAER(IAE,2)*PAER(JL,2,IKL)& + & +RAER(IAE,3)*PAER(JL,3,IKL)+RAER(IAE,4)*PAER(JL,4,IKL)& + & +RAER(IAE,5)*PAER(JL,5,IKL)+RAER(IAE,6)*PAER(JL,6,IKL) + PTAUAERL(JL,JK, 3)=ZTAUAER(2) + PTAUAERL(JL,JK, 4)=ZTAUAER(2) + PTAUAERL(JL,JK, 5)=ZTAUAER(2) + IAE=3 + ZTAUAER(IAE) =& + & RAER(IAE,1)*PAER(JL,1,IKL)+RAER(IAE,2)*PAER(JL,2,IKL)& + & +RAER(IAE,3)*PAER(JL,3,IKL)+RAER(IAE,4)*PAER(JL,4,IKL)& + & +RAER(IAE,5)*PAER(JL,5,IKL)+RAER(IAE,6)*PAER(JL,6,IKL) + PTAUAERL(JL,JK, 6)=ZTAUAER(3) + PTAUAERL(JL,JK, 8)=ZTAUAER(3) + PTAUAERL(JL,JK, 9)=ZTAUAER(3) + IAE=4 + ZTAUAER(IAE) =& + & RAER(IAE,1)*PAER(JL,1,IKL)+RAER(IAE,2)*PAER(JL,2,IKL)& + & +RAER(IAE,3)*PAER(JL,3,IKL)+RAER(IAE,4)*PAER(JL,4,IKL)& + & +RAER(IAE,5)*PAER(JL,5,IKL)+RAER(IAE,6)*PAER(JL,6,IKL) + PTAUAERL(JL,JK, 7)=ZTAUAER(4) + IAE=5 + ZTAUAER(IAE) =& + & RAER(IAE,1)*PAER(JL,1,IKL)+RAER(IAE,2)*PAER(JL,2,IKL)& + & +RAER(IAE,3)*PAER(JL,3,IKL)+RAER(IAE,4)*PAER(JL,4,IKL)& + & +RAER(IAE,5)*PAER(JL,5,IKL)+RAER(IAE,6)*PAER(JL,6,IKL) + PTAUAERL(JL,JK,10)=ZTAUAER(5) + PTAUAERL(JL,JK,11)=ZTAUAER(5) + PTAUAERL(JL,JK,12)=ZTAUAER(5) + PTAUAERL(JL,JK,13)=ZTAUAER(5) + PTAUAERL(JL,JK,14)=ZTAUAER(5) + PTAUAERL(JL,JK,15)=ZTAUAER(5) + PTAUAERL(JL,JK,16)=ZTAUAER(5) + ENDDO + ENDDO +ENDIF + + DO J2=1,KLEV + DO J1=1,JPXSEC +DO JL = KIDIA, KFDIA + PWX(JL,J1,J2)=0.0_JPRB +ENDDO + ENDDO + ENDDO + + DO JK = 1, KLEV +DO JL = KIDIA, KFDIA +!- Set cross section molecule amounts from ECRT; convert to vmr + PWX(JL,1,JK) = PCL4(JL,KLEV-JK+1) * ZAMD/ZAMCL4 + PWX(JL,2,JK) = PC11(JL,KLEV-JK+1) * ZAMD/ZAMC11 + PWX(JL,3,JK) = PC12(JL,KLEV-JK+1) * ZAMD/ZAMC12 + PWX(JL,4,JK) = PC22(JL,KLEV-JK+1) * ZAMD/ZAMC22 + PWX(JL,1,JK) = PCOLDRY(JL,JK) * PWX(JL,1,JK) * 1.E-20_JPRB + PWX(JL,2,JK) = PCOLDRY(JL,JK) * PWX(JL,2,JK) * 1.E-20_JPRB + PWX(JL,3,JK) = PCOLDRY(JL,JK) * PWX(JL,3,JK) * 1.E-20_JPRB + PWX(JL,4,JK) = PCOLDRY(JL,JK) * PWX(JL,4,JK) * 1.E-20_JPRB + +!- Here, all molecules in WKL and WX are in volume mixing ratio; convert to +! molec/cm2 based on COLDRY for use in RRTM + +!CDIR UNROLL=6 +ZSUMMOL = 0.0_JPRB +!AB broadening gases + DO JMOL = 2, ITMOL + ZSUMMOL = ZSUMMOL + PWKL(JL,JMOL,JK) + ENDDO + PWBRODL(JL,JK) = PCOLDRY(JL,JK) * (1._JPRB - ZSUMMOL) + DO JMOL = 1, ITMOL + PWKL(JL,JMOL,JK) = PCOLDRY(JL,JK) * PWKL(JL,JMOL,JK) + ENDDO +ENDDO + ENDDO + +!- McICA: No overlap; simple copy of optical thickness; layer cloud cover is 0. or 1. + + DO JK=1,KLEV + DO JCOLS=1,KCOLS +DO JL = KIDIA, KFDIA + PCLDFRAC(JL,JCOLS,JK)=PCLDF(JL,JCOLS,JK) + PTAUCLD(JL,JK,JCOLS) =PTAUCLDI(JL,JK,JCOLS) +ENDDO + ENDDO + ENDDO + +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('RRTM_ECRT_140GP_MCICA',1,ZHOOK_HANDLE) +END ASSOCIATE +END SUBROUTINE RRTM_ECRT_140GP_MCICA Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_gas_optical_depth.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_gas_optical_depth.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_gas_optical_depth.F90 (revision 6016) @@ -0,0 +1,204 @@ +! This file has been modified for the use in ICON + +!option! -pvctl no_on_adb +!option! -pvctl nocollapse +SUBROUTINE RRTM_GAS_OPTICAL_DEPTH(KIDIA,KFDIA,KLEV,POD,PAVEL, PCOLDRY,PCOLBRD,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLO3,PCOLN2O,PCOLCH4,PCOLO2,P_CO2MULT,& + & KLAYTROP,KLAYSWTCH,KLAYLOW,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & KINDMINOR,PSCALEMINOR,PSCALEMINORN2,PMINORFRAC,& + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_H2OO3, PRAT_H2OO3_1, & + & PRAT_H2ON2O, PRAT_H2ON2O_1, PRAT_H2OCH4, PRAT_H2OCH4_1, & + & PRAT_N2OCO2, PRAT_N2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) + +! R. J. Hogan 20160831 Adapted from rrtm_gasabs1a_140gp.F90 + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(OUT) :: POD(JPGPT,KLEV,KIDIA:KFDIA) ! Optical depth: note different orientation +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) ! Layer pressures (Pa) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PWX(KIDIA:KFDIA,JPXSEC,KLEV) ! Amount of trace gases +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS + +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_CO2MULT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYLOW(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINORN2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLBRD(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) , INTENT(IN) :: & ! + & PRAT_H2OCO2(KIDIA:KFDIA,KLEV),PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV), & + & PRAT_H2OO3(KIDIA:KFDIA,KLEV),PRAT_H2OO3_1(KIDIA:KFDIA,KLEV), & ! DIMENSIONS: (NLAYERS) + & PRAT_H2ON2O(KIDIA:KFDIA,KLEV),PRAT_H2ON2O_1(KIDIA:KFDIA,KLEV), & + & PRAT_H2OCH4(KIDIA:KFDIA,KLEV),PRAT_H2OCH4_1(KIDIA:KFDIA,KLEV), & + & PRAT_N2OCO2(KIDIA:KFDIA,KLEV),PRAT_N2OCO2_1(KIDIA:KFDIA,KLEV), & + & PRAT_O3CO2(KIDIA:KFDIA,KLEV),PRAT_O3CO2_1(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) :: ZTAU (KIDIA:KFDIA,JPGPT,KLEV) + +INTEGER(KIND=JPIM) :: JI, JLEV +INTEGER(KIND=JPIM) :: JLON + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "rrtm_taumol1.intfb.h" +#include "rrtm_taumol10.intfb.h" +#include "rrtm_taumol11.intfb.h" +#include "rrtm_taumol12.intfb.h" +#include "rrtm_taumol13.intfb.h" +#include "rrtm_taumol14.intfb.h" +#include "rrtm_taumol15.intfb.h" +#include "rrtm_taumol16.intfb.h" +#include "rrtm_taumol2.intfb.h" +#include "rrtm_taumol3.intfb.h" +#include "rrtm_taumol4.intfb.h" +#include "rrtm_taumol5.intfb.h" +#include "rrtm_taumol6.intfb.h" +#include "rrtm_taumol7.intfb.h" +#include "rrtm_taumol8.intfb.h" +#include "rrtm_taumol9.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_GAS_OPTICAL_DEPTH',0,ZHOOK_HANDLE) + +!$ACC KERNELS DEFAULT(NONE) PRESENT(PFRAC) ASYNC(1) +PFRAC(:,:,:) = 0.0_jprb +!$ACC END KERNELS + +ASSOCIATE(NFLEVG=>KLEV) + +!$ACC DATA CREATE(ZTAU) PRESENT(POD) + +CALL RRTM_TAUMOL1 (KIDIA,KFDIA,KLEV,ZTAU,PAVEL,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, PMINORFRAC, & + & KINDMINOR,PSCALEMINORN2,PCOLBRD) +CALL RRTM_TAUMOL2 (KIDIA,KFDIA,KLEV,ZTAU,PAVEL,PCOLDRY,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC) +CALL RRTM_TAUMOL3 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLN2O,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCO2, PRAT_H2OCO2_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL4 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLO3,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) +CALL RRTM_TAUMOL5 (KIDIA,KFDIA,KLEV,ZTAU,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLO3,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL6 (KIDIA,KFDIA,KLEV,ZTAU,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,PCOLCO2,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL7 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLO3,PCOLCO2,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OO3, PRAT_H2OO3_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL8 (KIDIA,KFDIA,KLEV,ZTAU,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,PCOLO3,PCOLN2O,PCOLCO2,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL9 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLN2O,PCOLCH4,PCOLDRY,KLAYTROP,KLAYSWTCH,KLAYLOW,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCH4,PRAT_H2OCH4_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL10 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC) +CALL RRTM_TAUMOL11 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,PCOLO2,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC,PMINORFRAC,KINDMINOR,PSCALEMINOR) +CALL RRTM_TAUMOL12 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCO2, PRAT_H2OCO2_1) +CALL RRTM_TAUMOL13 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLN2O,PCOLCO2,PCOLO3,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2ON2O, PRAT_H2ON2O_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL14 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLCO2,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC) +CALL RRTM_TAUMOL15 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLN2O,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_N2OCO2, PRAT_N2OCO2_1,PMINORFRAC,KINDMINOR,PSCALEMINOR,PCOLBRD) +CALL RRTM_TAUMOL16 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCH4,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCH4,PRAT_H2OCH4_1) + +!TO CHECK TOTAL OD FOR EACH BAND + ! print*,'ZTAU2= ',sum(ZTAU(:,11:22,:),2) + ! print*,'ZTAU3= ',sum(ZTAU(:,23:38,:),2) + ! print*,'ZTAU4= ',sum(ZTAU(:,39:52,:),2) + ! print*,'ZTAU5= ',sum(ZTAU(:,53:68,:),2) + ! print*,'ZTAU6= ',sum(ZTAU(:,69:76,:),2) + ! print*,'ZTAU7= ',sum(ZTAU(:,77:88,:),2) + ! print*,'ZTAU8= ',sum(ZTAU(:,89:96,:),2) + ! print*,'ZTAU9= ',sum(ZTAU(:,97:108,:),2) + ! print*,'ZTAU10= ',sum(ZTAU(:,109:114,:),2) + ! print*,'ZTAU11= ',sum(ZTAU(:,115:122,:),2) + ! print*,'ZTAU12= ',sum(ZTAU(:,123:130,:),2) + ! print*,'ZTAU13= ',sum(ZTAU(:,131:134,:),2) + ! print*,'ZTAU14= ',sum(ZTAU(:,135:136,:),2) + ! print*,'ZTAU15= ',sum(ZTAU(:,137:138,:),2) + ! print*,'ZTAU16= ',sum(ZTAU(:,139:140,:),2) + + +!- Loop over g-channels. +!$ACC PARALLEL DEFAULT(NONE) ASYNC(1) +!$ACC LOOP GANG VECTOR COLLAPSE(3) +DO JLEV = 1, KLEV +!cdir unroll=4 + DO JI = 1, JPGPT + DO JLON = KIDIA, KFDIA + POD(JI,JLEV,JLON) = ZTAU(JLON,JI,JLEV) + ENDDO + ENDDO +ENDDO +!$ACC END PARALLEL +! ----------------------------------------------------------------- + +!$ACC WAIT +!$ACC END DATA + +END ASSOCIATE + +IF (LHOOK) CALL DR_HOOK('RRTM_GAS_OPTICAL_DEPTH',1,ZHOOK_HANDLE) + +END SUBROUTINE RRTM_GAS_OPTICAL_DEPTH Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_gasabs1a_140gp.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_gasabs1a_140gp.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_gasabs1a_140gp.F90 (revision 6016) @@ -0,0 +1,235 @@ +!option! -pvctl no_on_adb +!option! -pvctl nocollapse +SUBROUTINE RRTM_GASABS1A_140GP (KIDIA,KFDIA,KLEV,PATR1,POD,PTF1,PAVEL, PCOLDRY,PCOLBRD,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLO3,PCOLN2O,PCOLCH4,PCOLO2,P_CO2MULT,& + & KLAYTROP,KLAYSWTCH,KLAYLOW,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & KINDMINOR,PSCALEMINOR,PSCALEMINORN2,PMINORFRAC,& + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_H2OO3, PRAT_H2OO3_1, & + & PRAT_H2ON2O, PRAT_H2ON2O_1, PRAT_H2OCH4, PRAT_H2OCH4_1, & + & PRAT_N2OCO2, PRAT_N2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) + +! NEC/FC 05-Oct-2009 Optimisation +! Reformatted for F90 by JJMorcrette, ECMWF, 980714 +! NEC 25-Oct-2007 Optimisations +! D. Salmond 11-Dec-2007 Optimizations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 update to rrtmg-lw v4.85 + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT +USE YOERRTAB , ONLY : TRANS ,BPADE + + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(OUT) :: PATR1(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: POD(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) ! Layer pressures (Pa) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTF1(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PWX(KIDIA:KFDIA,JPXSEC,KLEV) ! Amount of trace gases +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS + +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_CO2MULT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYLOW(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINORN2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLBRD(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) , INTENT(IN) :: & ! + & PRAT_H2OCO2(KIDIA:KFDIA,KLEV),PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV), & + & PRAT_H2OO3(KIDIA:KFDIA,KLEV),PRAT_H2OO3_1(KIDIA:KFDIA,KLEV), & ! DIMENSIONS: (NLAYERS) + & PRAT_H2ON2O(KIDIA:KFDIA,KLEV),PRAT_H2ON2O_1(KIDIA:KFDIA,KLEV), & + & PRAT_H2OCH4(KIDIA:KFDIA,KLEV),PRAT_H2OCH4_1(KIDIA:KFDIA,KLEV), & + & PRAT_N2OCO2(KIDIA:KFDIA,KLEV),PRAT_N2OCO2_1(KIDIA:KFDIA,KLEV), & + & PRAT_O3CO2(KIDIA:KFDIA,KLEV),PRAT_O3CO2_1(KIDIA:KFDIA,KLEV) +!- from AER +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +!- from SP +REAL(KIND=JPRB) :: ZTAU (KIDIA:KFDIA,JPGPT,KLEV) + +INTEGER(KIND=JPIM) :: JI, ITR, JLEV +INTEGER(KIND=JPIM) :: JLON + +REAL(KIND=JPRB) :: ZODEPTH, ZSECANG, ZTF +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +#include "rrtm_taumol1.intfb.h" +#include "rrtm_taumol10.intfb.h" +#include "rrtm_taumol11.intfb.h" +#include "rrtm_taumol12.intfb.h" +#include "rrtm_taumol13.intfb.h" +#include "rrtm_taumol14.intfb.h" +#include "rrtm_taumol15.intfb.h" +#include "rrtm_taumol16.intfb.h" +#include "rrtm_taumol2.intfb.h" +#include "rrtm_taumol3.intfb.h" +#include "rrtm_taumol4.intfb.h" +#include "rrtm_taumol5.intfb.h" +#include "rrtm_taumol6.intfb.h" +#include "rrtm_taumol7.intfb.h" +#include "rrtm_taumol8.intfb.h" +#include "rrtm_taumol9.intfb.h" + +!CDIR DUPLICATE(TRANS,256) + +!- SECANG is equal to the secant of the diffusivity angle. +ASSOCIATE(NFLEVG=>KLEV) +IF (LHOOK) CALL DR_HOOK('RRTM_GASABS1A_140GP',0,ZHOOK_HANDLE) +ZSECANG = 1.66_JPRB + +CALL RRTM_TAUMOL1 (KIDIA,KFDIA,KLEV,ZTAU,PAVEL,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, PMINORFRAC, & + & KINDMINOR,PSCALEMINORN2,PCOLBRD) +CALL RRTM_TAUMOL2 (KIDIA,KFDIA,KLEV,ZTAU,PAVEL,PCOLDRY,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC) +CALL RRTM_TAUMOL3 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLN2O,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCO2, PRAT_H2OCO2_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL4 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLO3,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) +CALL RRTM_TAUMOL5 (KIDIA,KFDIA,KLEV,ZTAU,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLO3,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL6 (KIDIA,KFDIA,KLEV,ZTAU,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,PCOLCO2,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL7 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLO3,PCOLCO2,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OO3, PRAT_H2OO3_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL8 (KIDIA,KFDIA,KLEV,ZTAU,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,PCOLO3,PCOLN2O,PCOLCO2,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL9 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLN2O,PCOLCH4,PCOLDRY,KLAYTROP,KLAYSWTCH,KLAYLOW,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCH4,PRAT_H2OCH4_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL10 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC) +CALL RRTM_TAUMOL11 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLH2O,PCOLO2,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC,PMINORFRAC,KINDMINOR,PSCALEMINOR) +CALL RRTM_TAUMOL12 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCO2, PRAT_H2OCO2_1) +CALL RRTM_TAUMOL13 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLN2O,PCOLCO2,PCOLO3,PCOLDRY,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2ON2O, PRAT_H2ON2O_1,PMINORFRAC,KINDMINOR) +CALL RRTM_TAUMOL14 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,& + & PCOLCO2,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC) +CALL RRTM_TAUMOL15 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLN2O,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_N2OCO2, PRAT_N2OCO2_1,PMINORFRAC,KINDMINOR,PSCALEMINOR,PCOLBRD) +CALL RRTM_TAUMOL16 (KIDIA,KFDIA,KLEV,ZTAU,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCH4,KLAYTROP,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC, & + & PRAT_H2OCH4,PRAT_H2OCH4_1) + +!TO CHECK TOTAL OD FOR EACH BAND + ! print*,'ZTAU2= ',sum(ZTAU(:,11:22,:),2) + ! print*,'ZTAU3= ',sum(ZTAU(:,23:38,:),2) + ! print*,'ZTAU4= ',sum(ZTAU(:,39:52,:),2) + ! print*,'ZTAU5= ',sum(ZTAU(:,53:68,:),2) + ! print*,'ZTAU6= ',sum(ZTAU(:,69:76,:),2) + ! print*,'ZTAU7= ',sum(ZTAU(:,77:88,:),2) + ! print*,'ZTAU8= ',sum(ZTAU(:,89:96,:),2) + ! print*,'ZTAU9= ',sum(ZTAU(:,97:108,:),2) + ! print*,'ZTAU10= ',sum(ZTAU(:,109:114,:),2) + ! print*,'ZTAU11= ',sum(ZTAU(:,115:122,:),2) + ! print*,'ZTAU12= ',sum(ZTAU(:,123:130,:),2) + ! print*,'ZTAU13= ',sum(ZTAU(:,131:134,:),2) + ! print*,'ZTAU14= ',sum(ZTAU(:,135:136,:),2) + ! print*,'ZTAU15= ',sum(ZTAU(:,137:138,:),2) + ! print*,'ZTAU16= ',sum(ZTAU(:,139:140,:),2) + + +DO JLEV = 1, KLEV +!cdir unroll=4 + DO JI = 1, JPGPT + DO JLON = KIDIA, KFDIA + IF (ZTAU(JLON,JI,JLEV) < 0._JPRB) THEN +9101 FORMAT(1X,'GASABS JLEV,JI,JLON=',I3,I5,I9,' SECANG=',F9.6,' ZTAU=',E12.6) + ENDIF + ENDDO + ENDDO +ENDDO + + +!- Loop over g-channels. +DO JLEV = 1, KLEV +!cdir unroll=4 + DO JI = 1, JPGPT + DO JLON = KIDIA, KFDIA + ZODEPTH = ZSECANG * ZTAU(JLON,JI,JLEV) + POD(JLON,JI,JLEV) = ZODEPTH + ZODEPTH=0.5D0*(ABS(ZODEPTH)+ZODEPTH) + +!-- revised code to get the pre-computed transmission +! IF (ODEPTH.LE.0.) PRINT*, 'ODEPTH = ',ODEPTH +!! IF (ODEPTH <= _ZERO_)THEN +!! ATR1(JI,LAY) = _ONE_ - TRANS(0) +!! TF1(JI,LAY) = _ZERO_ +!! ELSE + + ZTF = ZODEPTH/(BPADE+ZODEPTH) + + ITR=INT(5.E+03_JPRB*ZTF+0.5_JPRB) + PATR1(JLON,JI,JLEV) = 1.0_JPRB - TRANS(ITR) + PTF1(JLON,JI,JLEV) = ZTF +!! ENDIF + ENDDO + ENDDO +ENDDO +! ----------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('RRTM_GASABS1A_140GP',1,ZHOOK_HANDLE) +END ASSOCIATE +END SUBROUTINE RRTM_GASABS1A_140GP Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_init_140gp.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_init_140gp.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_init_140gp.F90 (revision 6016) @@ -0,0 +1,173 @@ +!*************************************************************************** +SUBROUTINE RRTM_INIT_140GP(CDIRECTORY) +!*************************************************************************** +! Reformatted for F90 by JJMorcrette, ECMWF, 980714 + +! JJMorcrette 20110613 flexible number of g-points + +! Parameters +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE PARRRTM , ONLY : JPBAND ,JPG +USE YOERRTM , ONLY : JPGPT +USE YOERRTWN , ONLY : NG +USE YOERRTFTR, ONLY : NGC ,NGN ,NGM , WT +! Output +USE YOERRTBG2, ONLY : CORR1 ,CORR2 +USE YOERRTRWT, ONLY : FREFA ,FREFB ,FREFADF ,FREFBDF ,RWGT +!USE YOMLUN , ONLY : NULOUT + +IMPLICIT NONE + +CHARACTER(LEN=*), INTENT(IN) :: CDIRECTORY + +REAL(KIND=JPRB) :: ZWTSM(JPG) + +INTEGER(KIND=JPIM) :: I, IBND, IG, IGC, IGCSM, IND, IPR, IPRSM, IPT + +REAL(KIND=JPRB) :: ZFP, ZRTFP, ZWTSUM +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +!#include "surrtmcf.intfb.h" +#include "surrtftr.intfb.h" + +#include "rrtm_kgb1.intfb.h" +#include "rrtm_kgb10.intfb.h" +#include "rrtm_kgb11.intfb.h" +#include "rrtm_kgb12.intfb.h" +#include "rrtm_kgb13.intfb.h" +#include "rrtm_kgb14.intfb.h" +#include "rrtm_kgb15.intfb.h" +#include "rrtm_kgb16.intfb.h" +#include "rrtm_kgb2.intfb.h" +#include "rrtm_kgb3.intfb.h" +#include "rrtm_kgb4.intfb.h" +#include "rrtm_kgb5.intfb.h" +#include "rrtm_kgb6.intfb.h" +#include "rrtm_kgb7.intfb.h" +#include "rrtm_kgb8.intfb.h" +#include "rrtm_kgb9.intfb.h" + +#include "rrtm_cmbgb1.intfb.h" +#include "rrtm_cmbgb10.intfb.h" +#include "rrtm_cmbgb11.intfb.h" +#include "rrtm_cmbgb12.intfb.h" +#include "rrtm_cmbgb13.intfb.h" +#include "rrtm_cmbgb14.intfb.h" +#include "rrtm_cmbgb15.intfb.h" +#include "rrtm_cmbgb16.intfb.h" +#include "rrtm_cmbgb2.intfb.h" +#include "rrtm_cmbgb3.intfb.h" +#include "rrtm_cmbgb4.intfb.h" +#include "rrtm_cmbgb5.intfb.h" +#include "rrtm_cmbgb6.intfb.h" +#include "rrtm_cmbgb7.intfb.h" +#include "rrtm_cmbgb8.intfb.h" +#include "rrtm_cmbgb9.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_INIT_140GP',0,ZHOOK_HANDLE) + +!CALL SURRTMCF +CALL SURRTFTR + +! Read the absorption-related coefficients over the 16 x 16 g-points + +CALL RRTM_KGB1(CDIRECTORY) +CALL RRTM_KGB2 +CALL RRTM_KGB3 +CALL RRTM_KGB4 +CALL RRTM_KGB5 +CALL RRTM_KGB6 +CALL RRTM_KGB7 +CALL RRTM_KGB8 +CALL RRTM_KGB9 +CALL RRTM_KGB10 +CALL RRTM_KGB11 +CALL RRTM_KGB12 +CALL RRTM_KGB13 +CALL RRTM_KGB14 +CALL RRTM_KGB15 +CALL RRTM_KGB16 + +! Calculate lookup tables for functions needed in routine TAUMOL (TAUGB2) + +CORR1(0) = 1.0_JPRB +CORR1(200) = 1.0_JPRB +CORR2(0) = 1.0_JPRB +CORR2(200) = 1.0_JPRB +DO I = 1,199 + ZFP = 0.005_JPRB*REAL(I) + ZRTFP = SQRT(ZFP) + CORR1(I) = ZRTFP/ZFP + CORR2(I) = (1.0_JPRB-ZRTFP)/(1.0_JPRB-ZFP) +ENDDO + +! Perform g-point reduction from 16 per band (256 total points) to +! a band dependant number (140 total points) for all absorption +! coefficient input data and Planck fraction input data. +! Compute relative weighting for new g-point combinations. + +IGCSM = 0 +DO IBND = 1,JPBAND + IPRSM = 0 + IF (NGC(IBND) < 16) THEN + DO IGC = 1,NGC(IBND) + IGCSM = IGCSM + 1 + ZWTSUM = 0.0_JPRB + DO IPR = 1, NGN(IGCSM) + IPRSM = IPRSM + 1 + ZWTSUM = ZWTSUM + WT(IPRSM) + ENDDO + ZWTSM(IGC) = ZWTSUM + ENDDO + + DO IG = 1,NG(IBND) + IND = (IBND-1)*16 + IG + RWGT(IND) = WT(IG)/ZWTSM(NGM(IND)) + ENDDO + ELSE + DO IG = 1,NG(IBND) + IGCSM = IGCSM + 1 + IND = (IBND-1)*16 + IG + RWGT(IND) = 1.0_JPRB + ENDDO + ENDIF +ENDDO + +! Initialize arrays for combined Planck fraction data. + +DO IPT = 1,13 + DO IPR = 1, JPGPT + FREFA(IPR,IPT) = 0.0_JPRB + FREFADF(IPR,IPT) = 0.0_JPRB + ENDDO +ENDDO +DO IPT = 1,6 + DO IPR = 1, JPGPT + FREFB(IPR,IPT) = 0.0_JPRB + FREFBDF(IPR,IPT) = 0.0_JPRB + ENDDO +ENDDO + +! Reduce g-points for relevant data in each LW spectral band. + +CALL RRTM_CMBGB1 +CALL RRTM_CMBGB2 +CALL RRTM_CMBGB3 +CALL RRTM_CMBGB4 +CALL RRTM_CMBGB5 +CALL RRTM_CMBGB6 +CALL RRTM_CMBGB7 +CALL RRTM_CMBGB8 +CALL RRTM_CMBGB9 +CALL RRTM_CMBGB10 +CALL RRTM_CMBGB11 +CALL RRTM_CMBGB12 +CALL RRTM_CMBGB13 +CALL RRTM_CMBGB14 +CALL RRTM_CMBGB15 +CALL RRTM_CMBGB16 + +IF (LHOOK) CALL DR_HOOK('RRTM_INIT_140GP',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_INIT_140GP Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb1.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb1.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb1.F90 (revision 6016) @@ -0,0 +1,361 @@ +! This file has been modified for the use in ICON + +SUBROUTINE RRTM_KGB1(DIRECTORY) + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo May 2013 update to RRTMG v4.85 +! band 1: 10-350 cm-1 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD +USE YOMMP0 , ONLY : NPROC, MYPROC + +USE YOERRTO1 , ONLY : KAO ,KBO ,KAO_D,KBO_D,SELFREFO ,FRACREFAO ,& + & FRACREFBO ,FORREFO, KAO_MN2, KBO_MN2 + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +CHARACTER(LEN=*), INTENT(IN) :: DIRECTORY + +!CHARACTER(LEN = 80) :: CLZZZ +CHARACTER(LEN = 255) :: CLF1 +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB1',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + !CALL GETENV("DATA",CLZZZ) + !IF(CLZZZ /= " ") THEN + ! CLF1=TRIM(CLZZZ) // "/RADRRTM" + CLF1 = DIRECTORY // "/RADRRTM" +#ifdef __ECRAD_LITTLE_ENDIAN + OPEN(NULRAD,FILE=TRIM(CLF1),CONVERT="BIG_ENDIAN",FORM="UNFORMATTED",ACTION="READ",ERR=1000) +#else + WRITE(0,'(A,A)') 'Reading ',TRIM(CLF1) + OPEN(NULRAD,FILE=TRIM(CLF1),FORM="UNFORMATTED",ACTION="READ",ERR=1000) +#endif + !ELSE + ! OPEN(NULRAD,FILE='RADRRTM',FORM="UNFORMATTED",ACTION="READ",ERR=1000) + !ENDIF + READ(NULRAD,ERR=1001) KAO_D,KBO_D + ! Convert the data into model actual precision. + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB1:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB1:') +ENDIF + +! Planck fraction mapping level: P = 212.7250 mbar, T = 223.06 K +FRACREFAO(:) = (/ & + & 2.1227E-01_JPRB,1.8897E-01_JPRB,1.3934E-01_JPRB,1.1557E-01_JPRB,9.5282E-02_JPRB,8.3359E-02_JPRB, & + & 6.5333E-02_JPRB,5.2016E-02_JPRB,3.4272E-02_JPRB,4.0257E-03_JPRB,3.1857E-03_JPRB,2.6014E-03_JPRB, & + & 1.9141E-03_JPRB,1.2612E-03_JPRB,5.3169E-04_JPRB,7.6476E-05_JPRB/) + +! Planck fraction mapping level: P = 212.7250 mbar, T = 223.06 K +! These Planck fractions were calculated using lower atmosphere +! parameters. +FRACREFBO(:) = (/ & + & 2.1227E-01_JPRB,1.8897E-01_JPRB,1.3934E-01_JPRB,1.1557E-01_JPRB,9.5282E-02_JPRB,8.3359E-02_JPRB, & + & 6.5333E-02_JPRB,5.2016E-02_JPRB,3.4272E-02_JPRB,4.0257E-03_JPRB,3.1857E-03_JPRB,2.6014E-03_JPRB, & + & 1.9141E-03_JPRB,1.2612E-03_JPRB,5.3169E-04_JPRB,7.6476E-05_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + & 3.6742e-02_JPRB,1.0664e-01_JPRB,2.6132e-01_JPRB,2.7906e-01_JPRB,2.8151e-01_JPRB,2.7465e-01_JPRB, & + & 2.8530e-01_JPRB,2.9123e-01_JPRB,3.0697e-01_JPRB,3.1801e-01_JPRB,3.2444e-01_JPRB,2.7746e-01_JPRB, & + & 3.1994e-01_JPRB,2.9750e-01_JPRB,2.1226e-01_JPRB,1.2847e-01_JPRB/) + FORREFO(2,:) = (/ & + & 4.0450e-02_JPRB,1.1085e-01_JPRB,2.9205e-01_JPRB,3.1934e-01_JPRB,3.1739e-01_JPRB,3.1450e-01_JPRB, & + & 3.2797e-01_JPRB,3.2223e-01_JPRB,3.3099e-01_JPRB,3.4800e-01_JPRB,3.4046e-01_JPRB,3.5700e-01_JPRB, & + & 3.8264e-01_JPRB,3.6679e-01_JPRB,3.3481e-01_JPRB,3.2113e-01_JPRB/) + FORREFO(3,:) = (/ & + & 4.6952e-02_JPRB,1.1999e-01_JPRB,3.1473e-01_JPRB,3.7015e-01_JPRB,3.6913e-01_JPRB,3.6352e-01_JPRB, & + & 3.7754e-01_JPRB,3.7402e-01_JPRB,3.7113e-01_JPRB,3.7720e-01_JPRB,3.8365e-01_JPRB,4.0876e-01_JPRB, & + & 4.2968e-01_JPRB,4.4186e-01_JPRB,4.3468e-01_JPRB,4.7083e-01_JPRB/) + FORREFO(4,:) = (/ & + & 7.0645e-02_JPRB,1.6618e-01_JPRB,2.8516e-01_JPRB,3.1819e-01_JPRB,3.0131e-01_JPRB,2.9552e-01_JPRB, & + & 2.8972e-01_JPRB,2.9348e-01_JPRB,2.8668e-01_JPRB,2.8483e-01_JPRB,2.8130e-01_JPRB,2.7757e-01_JPRB, & + & 2.9735e-01_JPRB,3.1684e-01_JPRB,3.0681e-01_JPRB,3.6778e-01_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + + + KAO_MN2(:, 1) = (/ & + & 5.12042E-08_JPRB, 5.51239E-08_JPRB, 5.93436E-08_JPRB, 6.38863E-08_JPRB, 6.87767E-08_JPRB, & + & 7.40415E-08_JPRB, 7.97093E-08_JPRB, 8.58110E-08_JPRB, 9.23797E-08_JPRB, 9.94513E-08_JPRB, & + & 1.07064E-07_JPRB, 1.15260E-07_JPRB, 1.24083E-07_JPRB, 1.33581E-07_JPRB, 1.43807E-07_JPRB, & + & 1.54815E-07_JPRB, 1.66666E-07_JPRB, 1.79424E-07_JPRB, 1.93159E-07_JPRB/) + KAO_MN2(:, 2) = (/ & + & 2.30938E-07_JPRB, 2.41696E-07_JPRB, 2.52955E-07_JPRB, 2.64738E-07_JPRB, 2.77071E-07_JPRB, & + & 2.89978E-07_JPRB, 3.03486E-07_JPRB, 3.17623E-07_JPRB, 3.32419E-07_JPRB, 3.47904E-07_JPRB, & + & 3.64111E-07_JPRB, 3.81072E-07_JPRB, 3.98824E-07_JPRB, 4.17402E-07_JPRB, 4.36846E-07_JPRB, & + & 4.57196E-07_JPRB, 4.78494E-07_JPRB, 5.00784E-07_JPRB, 5.24112E-07_JPRB/) + KAO_MN2(:, 3) = (/ & + & 6.70458E-07_JPRB, 7.04274E-07_JPRB, 7.39795E-07_JPRB, 7.77109E-07_JPRB, 8.16304E-07_JPRB, & + & 8.57476E-07_JPRB, 9.00724E-07_JPRB, 9.46154E-07_JPRB, 9.93876E-07_JPRB, 1.04400E-06_JPRB, & + & 1.09666E-06_JPRB, 1.15197E-06_JPRB, 1.21008E-06_JPRB, 1.27111E-06_JPRB, 1.33522E-06_JPRB, & + & 1.40256E-06_JPRB, 1.47331E-06_JPRB, 1.54761E-06_JPRB, 1.62567E-06_JPRB/) + KAO_MN2(:, 4) = (/ & + & 1.84182E-06_JPRB, 1.89203E-06_JPRB, 1.94360E-06_JPRB, 1.99658E-06_JPRB, 2.05101E-06_JPRB, & + & 2.10692E-06_JPRB, 2.16435E-06_JPRB, 2.22335E-06_JPRB, 2.28396E-06_JPRB, 2.34622E-06_JPRB, & + & 2.41017E-06_JPRB, 2.47587E-06_JPRB, 2.54337E-06_JPRB, 2.61270E-06_JPRB, 2.68392E-06_JPRB, & + & 2.75708E-06_JPRB, 2.83224E-06_JPRB, 2.90944E-06_JPRB, 2.98875E-06_JPRB/) + KAO_MN2(:, 5) = (/ & + & 3.41996E-06_JPRB, 3.32758E-06_JPRB, 3.23770E-06_JPRB, 3.15024E-06_JPRB, 3.06515E-06_JPRB, & + & 2.98235E-06_JPRB, 2.90180E-06_JPRB, 2.82341E-06_JPRB, 2.74715E-06_JPRB, 2.67294E-06_JPRB, & + & 2.60074E-06_JPRB, 2.53049E-06_JPRB, 2.46214E-06_JPRB, 2.39563E-06_JPRB, 2.33092E-06_JPRB, & + & 2.26796E-06_JPRB, 2.20670E-06_JPRB, 2.14709E-06_JPRB, 2.08910E-06_JPRB/) + KAO_MN2(:, 6) = (/ & + & 3.38746E-06_JPRB, 3.25966E-06_JPRB, 3.13669E-06_JPRB, 3.01836E-06_JPRB, 2.90449E-06_JPRB, & + & 2.79491E-06_JPRB, 2.68947E-06_JPRB, 2.58801E-06_JPRB, 2.49037E-06_JPRB, 2.39642E-06_JPRB, & + & 2.30601E-06_JPRB, 2.21902E-06_JPRB, 2.13530E-06_JPRB, 2.05475E-06_JPRB, 1.97723E-06_JPRB, & + & 1.90264E-06_JPRB, 1.83086E-06_JPRB, 1.76179E-06_JPRB, 1.69532E-06_JPRB/) + KAO_MN2(:, 7) = (/ & + & 3.17530E-06_JPRB, 3.07196E-06_JPRB, 2.97199E-06_JPRB, 2.87527E-06_JPRB, 2.78170E-06_JPRB, & + & 2.69118E-06_JPRB, 2.60360E-06_JPRB, 2.51887E-06_JPRB, 2.43690E-06_JPRB, 2.35759E-06_JPRB, & + & 2.28087E-06_JPRB, 2.20664E-06_JPRB, 2.13483E-06_JPRB, 2.06536E-06_JPRB, 1.99814E-06_JPRB, & + & 1.93312E-06_JPRB, 1.87021E-06_JPRB, 1.80934E-06_JPRB, 1.75046E-06_JPRB/) + KAO_MN2(:, 8) = (/ & + & 2.84701E-06_JPRB, 2.77007E-06_JPRB, 2.69521E-06_JPRB, 2.62237E-06_JPRB, 2.55150E-06_JPRB, & + & 2.48254E-06_JPRB, 2.41545E-06_JPRB, 2.35017E-06_JPRB, 2.28666E-06_JPRB, 2.22486E-06_JPRB, & + & 2.16473E-06_JPRB, 2.10623E-06_JPRB, 2.04930E-06_JPRB, 1.99392E-06_JPRB, 1.94003E-06_JPRB, & + & 1.88760E-06_JPRB, 1.83659E-06_JPRB, 1.78695E-06_JPRB, 1.73866E-06_JPRB/) + KAO_MN2(:, 9) = (/ & + & 2.79917E-06_JPRB, 2.73207E-06_JPRB, 2.66658E-06_JPRB, 2.60266E-06_JPRB, 2.54027E-06_JPRB, & + & 2.47937E-06_JPRB, 2.41994E-06_JPRB, 2.36192E-06_JPRB, 2.30530E-06_JPRB, 2.25004E-06_JPRB, & + & 2.19610E-06_JPRB, 2.14346E-06_JPRB, 2.09208E-06_JPRB, 2.04193E-06_JPRB, 1.99298E-06_JPRB, & + & 1.94520E-06_JPRB, 1.89857E-06_JPRB, 1.85306E-06_JPRB, 1.80864E-06_JPRB/) + KAO_MN2(:,10) = (/ & + & 2.74910E-06_JPRB, 2.64462E-06_JPRB, 2.54412E-06_JPRB, 2.44743E-06_JPRB, 2.35442E-06_JPRB, & + & 2.26495E-06_JPRB, 2.17887E-06_JPRB, 2.09606E-06_JPRB, 2.01641E-06_JPRB, 1.93978E-06_JPRB, & + & 1.86606E-06_JPRB, 1.79514E-06_JPRB, 1.72692E-06_JPRB, 1.66129E-06_JPRB, 1.59815E-06_JPRB, & + & 1.53742E-06_JPRB, 1.47899E-06_JPRB, 1.42278E-06_JPRB, 1.36871E-06_JPRB/) + KAO_MN2(:,11) = (/ & + & 2.63952E-06_JPRB, 2.60263E-06_JPRB, 2.56626E-06_JPRB, 2.53039E-06_JPRB, 2.49503E-06_JPRB, & + & 2.46016E-06_JPRB, 2.42578E-06_JPRB, 2.39188E-06_JPRB, 2.35845E-06_JPRB, 2.32549E-06_JPRB, & + & 2.29299E-06_JPRB, 2.26094E-06_JPRB, 2.22934E-06_JPRB, 2.19819E-06_JPRB, 2.16747E-06_JPRB, & + & 2.13717E-06_JPRB, 2.10731E-06_JPRB, 2.07786E-06_JPRB, 2.04882E-06_JPRB/) + KAO_MN2(:,12) = (/ & + & 2.94106E-06_JPRB, 2.82819E-06_JPRB, 2.71966E-06_JPRB, 2.61528E-06_JPRB, 2.51492E-06_JPRB, & + & 2.41841E-06_JPRB, 2.32560E-06_JPRB, 2.23635E-06_JPRB, 2.15053E-06_JPRB, 2.06800E-06_JPRB, & + & 1.98863E-06_JPRB, 1.91232E-06_JPRB, 1.83893E-06_JPRB, 1.76836E-06_JPRB, 1.70049E-06_JPRB, & + & 1.63524E-06_JPRB, 1.57248E-06_JPRB, 1.51214E-06_JPRB, 1.45411E-06_JPRB/) + KAO_MN2(:,13) = (/ & + & 2.94607E-06_JPRB, 2.87369E-06_JPRB, 2.80309E-06_JPRB, 2.73422E-06_JPRB, 2.66705E-06_JPRB, & + & 2.60152E-06_JPRB, 2.53760E-06_JPRB, 2.47526E-06_JPRB, 2.41445E-06_JPRB, 2.35513E-06_JPRB, & + & 2.29726E-06_JPRB, 2.24082E-06_JPRB, 2.18577E-06_JPRB, 2.13207E-06_JPRB, 2.07969E-06_JPRB, & + & 2.02859E-06_JPRB, 1.97875E-06_JPRB, 1.93014E-06_JPRB, 1.88272E-06_JPRB/) + KAO_MN2(:,14) = (/ & + & 2.58051E-06_JPRB, 2.48749E-06_JPRB, 2.39782E-06_JPRB, 2.31139E-06_JPRB, 2.22807E-06_JPRB, & + & 2.14775E-06_JPRB, 2.07033E-06_JPRB, 1.99570E-06_JPRB, 1.92376E-06_JPRB, 1.85441E-06_JPRB, & + & 1.78756E-06_JPRB, 1.72313E-06_JPRB, 1.66101E-06_JPRB, 1.60114E-06_JPRB, 1.54342E-06_JPRB, & + & 1.48778E-06_JPRB, 1.43415E-06_JPRB, 1.38245E-06_JPRB, 1.33262E-06_JPRB/) + KAO_MN2(:,15) = (/ & + & 3.03447E-06_JPRB, 2.88559E-06_JPRB, 2.74401E-06_JPRB, 2.60938E-06_JPRB, 2.48135E-06_JPRB, & + & 2.35961E-06_JPRB, 2.24384E-06_JPRB, 2.13375E-06_JPRB, 2.02906E-06_JPRB, 1.92951E-06_JPRB, & + & 1.83484E-06_JPRB, 1.74481E-06_JPRB, 1.65921E-06_JPRB, 1.57780E-06_JPRB, 1.50039E-06_JPRB, & + & 1.42677E-06_JPRB, 1.35677E-06_JPRB, 1.29020E-06_JPRB, 1.22690E-06_JPRB/) + KAO_MN2(:,16) = (/ & + & 1.48655E-06_JPRB, 1.48283E-06_JPRB, 1.47913E-06_JPRB, 1.47543E-06_JPRB, 1.47174E-06_JPRB, & + & 1.46806E-06_JPRB, 1.46439E-06_JPRB, 1.46072E-06_JPRB, 1.45707E-06_JPRB, 1.45343E-06_JPRB, & + & 1.44979E-06_JPRB, 1.44617E-06_JPRB, 1.44255E-06_JPRB, 1.43894E-06_JPRB, 1.43534E-06_JPRB, & + & 1.43176E-06_JPRB, 1.42817E-06_JPRB, 1.42460E-06_JPRB, 1.42104E-06_JPRB/) + KBO_MN2(:, 1) = (/ & + & 5.12042E-08_JPRB, 5.51239E-08_JPRB, 5.93436E-08_JPRB, 6.38863E-08_JPRB, 6.87767E-08_JPRB, & + & 7.40415E-08_JPRB, 7.97093E-08_JPRB, 8.58110E-08_JPRB, 9.23797E-08_JPRB, 9.94513E-08_JPRB, & + & 1.07064E-07_JPRB, 1.15260E-07_JPRB, 1.24083E-07_JPRB, 1.33581E-07_JPRB, 1.43807E-07_JPRB, & + & 1.54815E-07_JPRB, 1.66666E-07_JPRB, 1.79424E-07_JPRB, 1.93159E-07_JPRB/) + KBO_MN2(:, 2) = (/ & + & 2.30938E-07_JPRB, 2.41696E-07_JPRB, 2.52955E-07_JPRB, 2.64738E-07_JPRB, 2.77071E-07_JPRB, & + & 2.89978E-07_JPRB, 3.03486E-07_JPRB, 3.17623E-07_JPRB, 3.32419E-07_JPRB, 3.47904E-07_JPRB, & + & 3.64111E-07_JPRB, 3.81072E-07_JPRB, 3.98824E-07_JPRB, 4.17402E-07_JPRB, 4.36846E-07_JPRB, & + & 4.57196E-07_JPRB, 4.78494E-07_JPRB, 5.00784E-07_JPRB, 5.24112E-07_JPRB/) + KBO_MN2(:, 3) = (/ & + & 6.70458E-07_JPRB, 7.04274E-07_JPRB, 7.39795E-07_JPRB, 7.77109E-07_JPRB, 8.16304E-07_JPRB, & + & 8.57476E-07_JPRB, 9.00724E-07_JPRB, 9.46154E-07_JPRB, 9.93876E-07_JPRB, 1.04400E-06_JPRB, & + & 1.09666E-06_JPRB, 1.15197E-06_JPRB, 1.21008E-06_JPRB, 1.27111E-06_JPRB, 1.33522E-06_JPRB, & + & 1.40256E-06_JPRB, 1.47331E-06_JPRB, 1.54761E-06_JPRB, 1.62567E-06_JPRB/) + KBO_MN2(:, 4) = (/ & + & 1.84182E-06_JPRB, 1.89203E-06_JPRB, 1.94360E-06_JPRB, 1.99658E-06_JPRB, 2.05101E-06_JPRB, & + & 2.10692E-06_JPRB, 2.16435E-06_JPRB, 2.22335E-06_JPRB, 2.28396E-06_JPRB, 2.34622E-06_JPRB, & + & 2.41017E-06_JPRB, 2.47587E-06_JPRB, 2.54337E-06_JPRB, 2.61270E-06_JPRB, 2.68392E-06_JPRB, & + & 2.75708E-06_JPRB, 2.83224E-06_JPRB, 2.90944E-06_JPRB, 2.98875E-06_JPRB/) + KBO_MN2(:, 5) = (/ & + & 3.41996E-06_JPRB, 3.32758E-06_JPRB, 3.23770E-06_JPRB, 3.15024E-06_JPRB, 3.06515E-06_JPRB, & + & 2.98235E-06_JPRB, 2.90180E-06_JPRB, 2.82341E-06_JPRB, 2.74715E-06_JPRB, 2.67294E-06_JPRB, & + & 2.60074E-06_JPRB, 2.53049E-06_JPRB, 2.46214E-06_JPRB, 2.39563E-06_JPRB, 2.33092E-06_JPRB, & + & 2.26796E-06_JPRB, 2.20670E-06_JPRB, 2.14709E-06_JPRB, 2.08910E-06_JPRB/) + KBO_MN2(:, 6) = (/ & + & 3.38746E-06_JPRB, 3.25966E-06_JPRB, 3.13669E-06_JPRB, 3.01836E-06_JPRB, 2.90449E-06_JPRB, & + & 2.79491E-06_JPRB, 2.68947E-06_JPRB, 2.58801E-06_JPRB, 2.49037E-06_JPRB, 2.39642E-06_JPRB, & + & 2.30601E-06_JPRB, 2.21902E-06_JPRB, 2.13530E-06_JPRB, 2.05475E-06_JPRB, 1.97723E-06_JPRB, & + & 1.90264E-06_JPRB, 1.83086E-06_JPRB, 1.76179E-06_JPRB, 1.69532E-06_JPRB/) + KBO_MN2(:, 7) = (/ & + & 3.17530E-06_JPRB, 3.07196E-06_JPRB, 2.97199E-06_JPRB, 2.87527E-06_JPRB, 2.78170E-06_JPRB, & + & 2.69118E-06_JPRB, 2.60360E-06_JPRB, 2.51887E-06_JPRB, 2.43690E-06_JPRB, 2.35759E-06_JPRB, & + & 2.28087E-06_JPRB, 2.20664E-06_JPRB, 2.13483E-06_JPRB, 2.06536E-06_JPRB, 1.99814E-06_JPRB, & + & 1.93312E-06_JPRB, 1.87021E-06_JPRB, 1.80934E-06_JPRB, 1.75046E-06_JPRB/) + KBO_MN2(:, 8) = (/ & + & 2.84701E-06_JPRB, 2.77007E-06_JPRB, 2.69521E-06_JPRB, 2.62237E-06_JPRB, 2.55150E-06_JPRB, & + & 2.48254E-06_JPRB, 2.41545E-06_JPRB, 2.35017E-06_JPRB, 2.28666E-06_JPRB, 2.22486E-06_JPRB, & + & 2.16473E-06_JPRB, 2.10623E-06_JPRB, 2.04930E-06_JPRB, 1.99392E-06_JPRB, 1.94003E-06_JPRB, & + & 1.88760E-06_JPRB, 1.83659E-06_JPRB, 1.78695E-06_JPRB, 1.73866E-06_JPRB/) + KBO_MN2(:, 9) = (/ & + & 2.79917E-06_JPRB, 2.73207E-06_JPRB, 2.66658E-06_JPRB, 2.60266E-06_JPRB, 2.54027E-06_JPRB, & + & 2.47937E-06_JPRB, 2.41994E-06_JPRB, 2.36192E-06_JPRB, 2.30530E-06_JPRB, 2.25004E-06_JPRB, & + & 2.19610E-06_JPRB, 2.14346E-06_JPRB, 2.09208E-06_JPRB, 2.04193E-06_JPRB, 1.99298E-06_JPRB, & + & 1.94520E-06_JPRB, 1.89857E-06_JPRB, 1.85306E-06_JPRB, 1.80864E-06_JPRB/) + KBO_MN2(:,10) = (/ & + & 2.74910E-06_JPRB, 2.64462E-06_JPRB, 2.54412E-06_JPRB, 2.44743E-06_JPRB, 2.35442E-06_JPRB, & + & 2.26495E-06_JPRB, 2.17887E-06_JPRB, 2.09606E-06_JPRB, 2.01641E-06_JPRB, 1.93978E-06_JPRB, & + & 1.86606E-06_JPRB, 1.79514E-06_JPRB, 1.72692E-06_JPRB, 1.66129E-06_JPRB, 1.59815E-06_JPRB, & + & 1.53742E-06_JPRB, 1.47899E-06_JPRB, 1.42278E-06_JPRB, 1.36871E-06_JPRB/) + KBO_MN2(:,11) = (/ & + & 2.63952E-06_JPRB, 2.60263E-06_JPRB, 2.56626E-06_JPRB, 2.53039E-06_JPRB, 2.49503E-06_JPRB, & + & 2.46016E-06_JPRB, 2.42578E-06_JPRB, 2.39188E-06_JPRB, 2.35845E-06_JPRB, 2.32549E-06_JPRB, & + & 2.29299E-06_JPRB, 2.26094E-06_JPRB, 2.22934E-06_JPRB, 2.19819E-06_JPRB, 2.16747E-06_JPRB, & + & 2.13717E-06_JPRB, 2.10731E-06_JPRB, 2.07786E-06_JPRB, 2.04882E-06_JPRB/) + KBO_MN2(:,12) = (/ & + & 2.94106E-06_JPRB, 2.82819E-06_JPRB, 2.71966E-06_JPRB, 2.61528E-06_JPRB, 2.51492E-06_JPRB, & + & 2.41841E-06_JPRB, 2.32560E-06_JPRB, 2.23635E-06_JPRB, 2.15053E-06_JPRB, 2.06800E-06_JPRB, & + & 1.98863E-06_JPRB, 1.91232E-06_JPRB, 1.83893E-06_JPRB, 1.76836E-06_JPRB, 1.70049E-06_JPRB, & + & 1.63524E-06_JPRB, 1.57248E-06_JPRB, 1.51214E-06_JPRB, 1.45411E-06_JPRB/) + KBO_MN2(:,13) = (/ & + & 2.94607E-06_JPRB, 2.87369E-06_JPRB, 2.80309E-06_JPRB, 2.73422E-06_JPRB, 2.66705E-06_JPRB, & + & 2.60152E-06_JPRB, 2.53760E-06_JPRB, 2.47526E-06_JPRB, 2.41445E-06_JPRB, 2.35513E-06_JPRB, & + & 2.29726E-06_JPRB, 2.24082E-06_JPRB, 2.18577E-06_JPRB, 2.13207E-06_JPRB, 2.07969E-06_JPRB, & + & 2.02859E-06_JPRB, 1.97875E-06_JPRB, 1.93014E-06_JPRB, 1.88272E-06_JPRB/) + KBO_MN2(:,14) = (/ & + & 2.58051E-06_JPRB, 2.48749E-06_JPRB, 2.39782E-06_JPRB, 2.31139E-06_JPRB, 2.22807E-06_JPRB, & + & 2.14775E-06_JPRB, 2.07033E-06_JPRB, 1.99570E-06_JPRB, 1.92376E-06_JPRB, 1.85441E-06_JPRB, & + & 1.78756E-06_JPRB, 1.72313E-06_JPRB, 1.66101E-06_JPRB, 1.60114E-06_JPRB, 1.54342E-06_JPRB, & + & 1.48778E-06_JPRB, 1.43415E-06_JPRB, 1.38245E-06_JPRB, 1.33262E-06_JPRB/) + KBO_MN2(:,15) = (/ & + & 3.03447E-06_JPRB, 2.88559E-06_JPRB, 2.74401E-06_JPRB, 2.60938E-06_JPRB, 2.48135E-06_JPRB, & + & 2.35961E-06_JPRB, 2.24384E-06_JPRB, 2.13375E-06_JPRB, 2.02906E-06_JPRB, 1.92951E-06_JPRB, & + & 1.83484E-06_JPRB, 1.74481E-06_JPRB, 1.65921E-06_JPRB, 1.57780E-06_JPRB, 1.50039E-06_JPRB, & + & 1.42677E-06_JPRB, 1.35677E-06_JPRB, 1.29020E-06_JPRB, 1.22690E-06_JPRB/) + KBO_MN2(:,16) = (/ & + & 1.48655E-06_JPRB, 1.48283E-06_JPRB, 1.47913E-06_JPRB, 1.47543E-06_JPRB, 1.47174E-06_JPRB, & + & 1.46806E-06_JPRB, 1.46439E-06_JPRB, 1.46072E-06_JPRB, 1.45707E-06_JPRB, 1.45343E-06_JPRB, & + & 1.44979E-06_JPRB, 1.44617E-06_JPRB, 1.44255E-06_JPRB, 1.43894E-06_JPRB, 1.43534E-06_JPRB, & + & 1.43176E-06_JPRB, 1.42817E-06_JPRB, 1.42460E-06_JPRB, 1.42104E-06_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 2.16803e+00_JPRB, 1.98236e+00_JPRB, 1.81260e+00_JPRB, 1.65737e+00_JPRB, 1.51544e+00_JPRB, & + & 1.38567e+00_JPRB, 1.26700e+00_JPRB, 1.15850e+00_JPRB, 1.05929e+00_JPRB, 9.68576e-01_JPRB/) + SELFREFO(:, 2) = (/ & + & 3.70149e+00_JPRB, 3.43145e+00_JPRB, 3.18110e+00_JPRB, 2.94902e+00_JPRB, 2.73387e+00_JPRB, & + & 2.53441e+00_JPRB, 2.34951e+00_JPRB, 2.17810e+00_JPRB, 2.01919e+00_JPRB, 1.87188e+00_JPRB/) + SELFREFO(:, 3) = (/ & + & 6.17433e+00_JPRB, 5.62207e+00_JPRB, 5.11920e+00_JPRB, 4.66131e+00_JPRB, 4.24438e+00_JPRB, & + & 3.86474e+00_JPRB, 3.51906e+00_JPRB, 3.20430e+00_JPRB, 2.91769e+00_JPRB, 2.65672e+00_JPRB/) + SELFREFO(:, 4) = (/ & + & 6.56459e+00_JPRB, 5.94787e+00_JPRB, 5.38910e+00_JPRB, 4.88282e+00_JPRB, 4.42410e+00_JPRB, & + & 4.00848e+00_JPRB, 3.63190e+00_JPRB, 3.29070e+00_JPRB, 2.98155e+00_JPRB, 2.70145e+00_JPRB/) + SELFREFO(:, 5) = (/ & + & 6.49581e+00_JPRB, 5.91114e+00_JPRB, 5.37910e+00_JPRB, 4.89494e+00_JPRB, 4.45436e+00_JPRB, & + & 4.05344e+00_JPRB, 3.68860e+00_JPRB, 3.35660e+00_JPRB, 3.05448e+00_JPRB, 2.77956e+00_JPRB/) + SELFREFO(:, 6) = (/ & + & 6.50189e+00_JPRB, 5.89381e+00_JPRB, 5.34260e+00_JPRB, 4.84294e+00_JPRB, 4.39001e+00_JPRB, & + & 3.97944e+00_JPRB, 3.60727e+00_JPRB, 3.26990e+00_JPRB, 2.96409e+00_JPRB, 2.68687e+00_JPRB/) + SELFREFO(:, 7) = (/ & + & 6.64768e+00_JPRB, 6.01719e+00_JPRB, 5.44650e+00_JPRB, 4.92993e+00_JPRB, 4.46236e+00_JPRB, & + & 4.03914e+00_JPRB, 3.65605e+00_JPRB, 3.30930e+00_JPRB, 2.99543e+00_JPRB, 2.71134e+00_JPRB/) + SELFREFO(:, 8) = (/ & + & 6.43744e+00_JPRB, 5.87166e+00_JPRB, 5.35560e+00_JPRB, 4.88490e+00_JPRB, 4.45557e+00_JPRB, & + & 4.06397e+00_JPRB, 3.70679e+00_JPRB, 3.38100e+00_JPRB, 3.08384e+00_JPRB, 2.81281e+00_JPRB/) + SELFREFO(:, 9) = (/ & + & 6.55466e+00_JPRB, 5.99777e+00_JPRB, 5.48820e+00_JPRB, 5.02192e+00_JPRB, 4.59525e+00_JPRB, & + & 4.20484e+00_JPRB, 3.84759e+00_JPRB, 3.52070e+00_JPRB, 3.22158e+00_JPRB, 2.94787e+00_JPRB/) + SELFREFO(:,10) = (/ & + & 6.84510e+00_JPRB, 6.26933e+00_JPRB, 5.74200e+00_JPRB, 5.25902e+00_JPRB, 4.81667e+00_JPRB, & + & 4.41152e+00_JPRB, 4.04046e+00_JPRB, 3.70060e+00_JPRB, 3.38933e+00_JPRB, 3.10424e+00_JPRB/) + SELFREFO(:,11) = (/ & + & 6.83128e+00_JPRB, 6.25536e+00_JPRB, 5.72800e+00_JPRB, 5.24510e+00_JPRB, 4.80291e+00_JPRB, & + & 4.39799e+00_JPRB, 4.02722e+00_JPRB, 3.68770e+00_JPRB, 3.37681e+00_JPRB, 3.09212e+00_JPRB/) + SELFREFO(:,12) = (/ & + & 7.35969e+00_JPRB, 6.61719e+00_JPRB, 5.94960e+00_JPRB, 5.34936e+00_JPRB, 4.80968e+00_JPRB, & + & 4.32445e+00_JPRB, 3.88817e+00_JPRB, 3.49590e+00_JPRB, 3.14321e+00_JPRB, 2.82610e+00_JPRB/) + SELFREFO(:,13) = (/ & + & 7.50064e+00_JPRB, 6.80749e+00_JPRB, 6.17840e+00_JPRB, 5.60744e+00_JPRB, 5.08925e+00_JPRB, & + & 4.61894e+00_JPRB, 4.19210e+00_JPRB, 3.80470e+00_JPRB, 3.45310e+00_JPRB, 3.13399e+00_JPRB/) + SELFREFO(:,14) = (/ & + & 7.40801e+00_JPRB, 6.71328e+00_JPRB, 6.08370e+00_JPRB, 5.51316e+00_JPRB, 4.99613e+00_JPRB, & + & 4.52759e+00_JPRB, 4.10298e+00_JPRB, 3.71820e+00_JPRB, 3.36950e+00_JPRB, 3.05351e+00_JPRB/) + SELFREFO(:,15) = (/ & + & 7.51895e+00_JPRB, 6.68846e+00_JPRB, 5.94970e+00_JPRB, 5.29254e+00_JPRB, 4.70796e+00_JPRB, & + & 4.18795e+00_JPRB, 3.72538e+00_JPRB, 3.31390e+00_JPRB, 2.94787e+00_JPRB, 2.62227e+00_JPRB/) + SELFREFO(:,16) = (/ & + & 7.84774e+00_JPRB, 6.80673e+00_JPRB, 5.90380e+00_JPRB, 5.12065e+00_JPRB, 4.44138e+00_JPRB, & + & 3.85223e+00_JPRB, 3.34122e+00_JPRB, 2.89800e+00_JPRB, 2.51357e+00_JPRB, 2.18014e+00_JPRB/) + + + + + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB1',1,ZHOOK_HANDLE) +RETURN + +1000 CONTINUE +CALL ABOR1("RRTM_KGB1:ERROR OPENING FILE RADRRTM") +1001 CONTINUE +CALL ABOR1("RRTM_KGB1:ERROR READING FILE RADRRTM") + +! ----------------------------------------------------------------- +END SUBROUTINE RRTM_KGB1 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb10.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb10.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb10.F90 (revision 6016) @@ -0,0 +1,170 @@ +SUBROUTINE RRTM_KGB10 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 10: 1390-1480 cm-1 (low - H2O; high - H2O) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 101306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO10, ONLY : KAO, KBO, KAO_D, KBO_D, FRACREFAO, FRACREFBO, SELFREFO, FORREFO + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB10',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB10:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB10:') +ENDIF + +! Planck fraction mapping level : P = 212.7250, T = 223.06 K + FRACREFAO(:) = (/ & + & 1.6909E-01_JPRB, 1.5419E-01_JPRB, 1.3999E-01_JPRB, 1.2637E-01_JPRB, & + & 1.1429E-01_JPRB, 9.9676E-02_JPRB, 8.0093E-02_JPRB, 6.0283E-02_JPRB, & + & 4.1077E-02_JPRB, 4.4857E-03_JPRB, 3.6545E-03_JPRB, 2.9243E-03_JPRB, & + & 2.0407E-03_JPRB, 1.2891E-03_JPRB, 4.8767E-04_JPRB, 6.7748E-05_JPRB/) + +! Planck fraction mapping level : P = 95.58350 mb, T = 215.70 K + FRACREFBO(:) = (/ & + & 1.7391E-01_JPRB, 1.5680E-01_JPRB, 1.4419E-01_JPRB, 1.2672E-01_JPRB, & + & 1.0708E-01_JPRB, 9.7034E-02_JPRB, 7.8545E-02_JPRB, 5.9784E-02_JPRB, & + & 4.0879E-02_JPRB, 4.4704E-03_JPRB, 3.7150E-03_JPRB, 2.9038E-03_JPRB, & + & 2.1454E-03_JPRB, 1.2802E-03_JPRB, 4.8328E-04_JPRB, 6.7378E-05_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &1.0515E-02_JPRB,1.4860E-02_JPRB,1.7181E-02_JPRB,1.6642E-02_JPRB,1.6644E-02_JPRB,1.5649E-02_JPRB, & + &1.7734E-02_JPRB,1.7521E-02_JPRB,1.7868E-02_JPRB,1.8400E-02_JPRB,1.9361E-02_JPRB,2.1487E-02_JPRB, & + &2.0192E-02_JPRB,1.6545E-02_JPRB,2.0922E-02_JPRB,2.0922E-02_JPRB/) + FORREFO(2,:) = (/ & + &1.0423E-02_JPRB,1.4593E-02_JPRB,1.6329E-02_JPRB,1.7071E-02_JPRB,1.7252E-02_JPRB,1.6188E-02_JPRB, & + &1.7752E-02_JPRB,1.7913E-02_JPRB,1.7551E-02_JPRB,1.8203E-02_JPRB,1.7946E-02_JPRB,1.9828E-02_JPRB, & + &2.1566E-02_JPRB,1.9707E-02_JPRB,2.0944E-02_JPRB,2.0944E-02_JPRB/) + FORREFO(3,:) = (/ & + &9.2770E-03_JPRB,1.2818E-02_JPRB,1.7181E-02_JPRB,1.7858E-02_JPRB,1.7888E-02_JPRB,1.7121E-02_JPRB, & + &1.8116E-02_JPRB,1.8230E-02_JPRB,1.7719E-02_JPRB,1.7833E-02_JPRB,1.8438E-02_JPRB,1.7995E-02_JPRB, & + &2.0895E-02_JPRB,2.1525E-02_JPRB,2.0517E-02_JPRB,2.0954E-02_JPRB/) + FORREFO(4,:) = (/ & + &8.3290E-03_JPRB,1.3483E-02_JPRB,1.5432E-02_JPRB,2.0793E-02_JPRB,1.8404E-02_JPRB,1.7470E-02_JPRB, & + &1.7253E-02_JPRB,1.7132E-02_JPRB,1.7119E-02_JPRB,1.7376E-02_JPRB,1.7030E-02_JPRB,1.6847E-02_JPRB, & + &1.5562E-02_JPRB,1.6836E-02_JPRB,1.8746E-02_JPRB,2.1233E-02_JPRB/) + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 2.41120E-01_JPRB, 2.27071E-01_JPRB, 2.13840E-01_JPRB, 2.01380E-01_JPRB, 1.89646E-01_JPRB, & + & 1.78596E-01_JPRB, 1.68190E-01_JPRB, 1.58390E-01_JPRB, 1.49161E-01_JPRB, 1.40470E-01_JPRB/) + SELFREFO(:, 2) = (/ & + & 3.11156E-01_JPRB, 2.92249E-01_JPRB, 2.74490E-01_JPRB, 2.57810E-01_JPRB, 2.42144E-01_JPRB, & + & 2.27430E-01_JPRB, 2.13610E-01_JPRB, 2.00630E-01_JPRB, 1.88439E-01_JPRB, 1.76988E-01_JPRB/) + SELFREFO(:, 3) = (/ & + & 3.37148E-01_JPRB, 3.17767E-01_JPRB, 2.99500E-01_JPRB, 2.82283E-01_JPRB, 2.66056E-01_JPRB, & + & 2.50762E-01_JPRB, 2.36347E-01_JPRB, 2.22760E-01_JPRB, 2.09955E-01_JPRB, 1.97885E-01_JPRB/) + SELFREFO(:, 4) = (/ & + & 3.57139E-01_JPRB, 3.32763E-01_JPRB, 3.10050E-01_JPRB, 2.88888E-01_JPRB, 2.69170E-01_JPRB, & + & 2.50798E-01_JPRB, 2.33680E-01_JPRB, 2.17730E-01_JPRB, 2.02869E-01_JPRB, 1.89022E-01_JPRB/) + SELFREFO(:, 5) = (/ & + & 3.60626E-01_JPRB, 3.35433E-01_JPRB, 3.12000E-01_JPRB, 2.90204E-01_JPRB, 2.69931E-01_JPRB, & + & 2.51074E-01_JPRB, 2.33534E-01_JPRB, 2.17220E-01_JPRB, 2.02045E-01_JPRB, 1.87931E-01_JPRB/) + SELFREFO(:, 6) = (/ & + & 3.42420E-01_JPRB, 3.18795E-01_JPRB, 2.96800E-01_JPRB, 2.76323E-01_JPRB, 2.57258E-01_JPRB, & + & 2.39509E-01_JPRB, 2.22985E-01_JPRB, 2.07600E-01_JPRB, 1.93277E-01_JPRB, 1.79942E-01_JPRB/) + SELFREFO(:, 7) = (/ & + & 3.65491E-01_JPRB, 3.41599E-01_JPRB, 3.19270E-01_JPRB, 2.98400E-01_JPRB, 2.78895E-01_JPRB, & + & 2.60664E-01_JPRB, 2.43625E-01_JPRB, 2.27700E-01_JPRB, 2.12816E-01_JPRB, 1.98905E-01_JPRB/) + SELFREFO(:, 8) = (/ & + & 3.70354E-01_JPRB, 3.45005E-01_JPRB, 3.21390E-01_JPRB, 2.99392E-01_JPRB, 2.78899E-01_JPRB, & + & 2.59809E-01_JPRB, 2.42026E-01_JPRB, 2.25460E-01_JPRB, 2.10028E-01_JPRB, 1.95652E-01_JPRB/) + SELFREFO(:, 9) = (/ & + & 3.60483E-01_JPRB, 3.37846E-01_JPRB, 3.16630E-01_JPRB, 2.96747E-01_JPRB, 2.78112E-01_JPRB, & + & 2.60648E-01_JPRB, 2.44280E-01_JPRB, 2.28940E-01_JPRB, 2.14563E-01_JPRB, 2.01090E-01_JPRB/) + SELFREFO(:,10) = (/ & + & 3.71845E-01_JPRB, 3.48164E-01_JPRB, 3.25990E-01_JPRB, 3.05229E-01_JPRB, 2.85790E-01_JPRB, & + & 2.67588E-01_JPRB, 2.50547E-01_JPRB, 2.34590E-01_JPRB, 2.19650E-01_JPRB, 2.05661E-01_JPRB/) + SELFREFO(:,11) = (/ & + & 3.60606E-01_JPRB, 3.40789E-01_JPRB, 3.22060E-01_JPRB, 3.04361E-01_JPRB, 2.87634E-01_JPRB, & + & 2.71826E-01_JPRB, 2.56888E-01_JPRB, 2.42770E-01_JPRB, 2.29428E-01_JPRB, 2.16819E-01_JPRB/) + SELFREFO(:,12) = (/ & + & 3.90046E-01_JPRB, 3.68879E-01_JPRB, 3.48860E-01_JPRB, 3.29928E-01_JPRB, 3.12023E-01_JPRB, & + & 2.95089E-01_JPRB, 2.79075E-01_JPRB, 2.63930E-01_JPRB, 2.49607E-01_JPRB, 2.36061E-01_JPRB/) + SELFREFO(:,13) = (/ & + & 4.38542E-01_JPRB, 4.05139E-01_JPRB, 3.74280E-01_JPRB, 3.45771E-01_JPRB, 3.19434E-01_JPRB, & + & 2.95103E-01_JPRB, 2.72626E-01_JPRB, 2.51860E-01_JPRB, 2.32676E-01_JPRB, 2.14953E-01_JPRB/) + SELFREFO(:,14) = (/ & + & 4.19448E-01_JPRB, 3.81920E-01_JPRB, 3.47750E-01_JPRB, 3.16637E-01_JPRB, 2.88307E-01_JPRB, & + & 2.62513E-01_JPRB, 2.39026E-01_JPRB, 2.17640E-01_JPRB, 1.98168E-01_JPRB, 1.80438E-01_JPRB/) + SELFREFO(:,15) = (/ & + & 4.20276E-01_JPRB, 3.92281E-01_JPRB, 3.66150E-01_JPRB, 3.41760E-01_JPRB, 3.18995E-01_JPRB, & + & 2.97746E-01_JPRB, 2.77912E-01_JPRB, 2.59400E-01_JPRB, 2.42121E-01_JPRB, 2.25993E-01_JPRB/) + SELFREFO(:,16) = (/ & + & 4.20276E-01_JPRB, 3.92281E-01_JPRB, 3.66150E-01_JPRB, 3.41760E-01_JPRB, 3.18995E-01_JPRB, & + & 2.97746E-01_JPRB, 2.77912E-01_JPRB, 2.59400E-01_JPRB, 2.42121E-01_JPRB, 2.25993E-01_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB10',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB10:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB10 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb11.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb11.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb11.F90 (revision 6016) @@ -0,0 +1,344 @@ +SUBROUTINE RRTM_KGB11 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 11: 1480-1800 cm-1 (low - H2O; high - H2O) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! abozzo 201306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO11, ONLY : KAO ,KBO ,SELFREFO, FORREFO, FRACREFAO ,FRACREFBO, & + & KAO_MO2,KBO_MO2, KAO_D, KBO_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB11',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB11:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB11:') +ENDIF + +! Planck fraction mapping level : P=1053.63 mb, T= 294.2 K + FRACREFAO(:) = (/ & + & 1.4601E-01_JPRB,1.3824E-01_JPRB,1.4240E-01_JPRB,1.3463E-01_JPRB,1.1948E-01_JPRB,1.0440E-01_JPRB, & + & 8.8667E-02_JPRB,6.5792E-02_JPRB,4.3893E-02_JPRB,4.7941E-03_JPRB,4.0760E-03_JPRB,3.3207E-03_JPRB, & + & 2.4087E-03_JPRB,1.3912E-03_JPRB,4.3482E-04_JPRB,6.0932E-05_JPRB/) + +! Planck fraction mapping level : P=0.353 mb, T = 262.11 K + FRACREFBO(:) = (/ & + & 7.2928E-02_JPRB,1.4900E-01_JPRB,1.6156E-01_JPRB,1.5603E-01_JPRB,1.3934E-01_JPRB,1.1394E-01_JPRB, & + & 8.8783E-02_JPRB,6.2411E-02_JPRB,4.0191E-02_JPRB,4.4587E-03_JPRB,3.9533E-03_JPRB,3.0847E-03_JPRB, & + & 2.2317E-03_JPRB,1.4410E-03_JPRB,5.6722E-04_JPRB,7.7933E-05_JPRB/) + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + + +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + + KAO_MO2(:, 1) = (/ & + & 2.31723E-06_JPRB, 2.28697E-06_JPRB, 2.25710E-06_JPRB, 2.22762E-06_JPRB, 2.19852E-06_JPRB, & + & 2.16981E-06_JPRB, 2.14147E-06_JPRB, 2.11350E-06_JPRB, 2.08590E-06_JPRB, 2.05865E-06_JPRB, & + & 2.03176E-06_JPRB, 2.00523E-06_JPRB, 1.97904E-06_JPRB, 1.95319E-06_JPRB, 1.92768E-06_JPRB, & + & 1.90250E-06_JPRB, 1.87765E-06_JPRB, 1.85313E-06_JPRB, 1.82893E-06_JPRB/) + KAO_MO2(:, 2) = (/ & + & 1.81980E-06_JPRB, 1.81352E-06_JPRB, 1.80726E-06_JPRB, 1.80101E-06_JPRB, 1.79479E-06_JPRB, & + & 1.78860E-06_JPRB, 1.78242E-06_JPRB, 1.77626E-06_JPRB, 1.77013E-06_JPRB, 1.76402E-06_JPRB, & + & 1.75792E-06_JPRB, 1.75185E-06_JPRB, 1.74580E-06_JPRB, 1.73977E-06_JPRB, 1.73377E-06_JPRB, & + & 1.72778E-06_JPRB, 1.72181E-06_JPRB, 1.71587E-06_JPRB, 1.70994E-06_JPRB/) + KAO_MO2(:, 3) = (/ & + & 2.26922E-06_JPRB, 2.25413E-06_JPRB, 2.23914E-06_JPRB, 2.22425E-06_JPRB, 2.20945E-06_JPRB, & + & 2.19476E-06_JPRB, 2.18016E-06_JPRB, 2.16566E-06_JPRB, 2.15126E-06_JPRB, 2.13695E-06_JPRB, & + & 2.12274E-06_JPRB, 2.10862E-06_JPRB, 2.09459E-06_JPRB, 2.08066E-06_JPRB, 2.06683E-06_JPRB, & + & 2.05308E-06_JPRB, 2.03942E-06_JPRB, 2.02586E-06_JPRB, 2.01239E-06_JPRB/) + KAO_MO2(:, 4) = (/ & + & 2.15555E-06_JPRB, 2.14539E-06_JPRB, 2.13527E-06_JPRB, 2.12520E-06_JPRB, 2.11517E-06_JPRB, & + & 2.10520E-06_JPRB, 2.09527E-06_JPRB, 2.08538E-06_JPRB, 2.07555E-06_JPRB, 2.06576E-06_JPRB, & + & 2.05601E-06_JPRB, 2.04631E-06_JPRB, 2.03666E-06_JPRB, 2.02706E-06_JPRB, 2.01749E-06_JPRB, & + & 2.00798E-06_JPRB, 1.99851E-06_JPRB, 1.98908E-06_JPRB, 1.97970E-06_JPRB/) + KAO_MO2(:, 5) = (/ & + & 2.05821E-06_JPRB, 2.04914E-06_JPRB, 2.04011E-06_JPRB, 2.03111E-06_JPRB, 2.02216E-06_JPRB, & + & 2.01324E-06_JPRB, 2.00437E-06_JPRB, 1.99553E-06_JPRB, 1.98673E-06_JPRB, 1.97798E-06_JPRB, & + & 1.96926E-06_JPRB, 1.96057E-06_JPRB, 1.95193E-06_JPRB, 1.94333E-06_JPRB, 1.93476E-06_JPRB, & + & 1.92623E-06_JPRB, 1.91774E-06_JPRB, 1.90928E-06_JPRB, 1.90087E-06_JPRB/) + KAO_MO2(:, 6) = (/ & + & 2.20148E-06_JPRB, 2.18998E-06_JPRB, 2.17854E-06_JPRB, 2.16717E-06_JPRB, 2.15585E-06_JPRB, & + & 2.14459E-06_JPRB, 2.13339E-06_JPRB, 2.12225E-06_JPRB, 2.11117E-06_JPRB, 2.10014E-06_JPRB, & + & 2.08918E-06_JPRB, 2.07827E-06_JPRB, 2.06741E-06_JPRB, 2.05662E-06_JPRB, 2.04588E-06_JPRB, & + & 2.03519E-06_JPRB, 2.02457E-06_JPRB, 2.01399E-06_JPRB, 2.00348E-06_JPRB/) + KAO_MO2(:, 7) = (/ & + & 2.28960E-06_JPRB, 2.27651E-06_JPRB, 2.26349E-06_JPRB, 2.25054E-06_JPRB, 2.23767E-06_JPRB, & + & 2.22487E-06_JPRB, 2.21215E-06_JPRB, 2.19950E-06_JPRB, 2.18692E-06_JPRB, 2.17441E-06_JPRB, & + & 2.16198E-06_JPRB, 2.14961E-06_JPRB, 2.13732E-06_JPRB, 2.12509E-06_JPRB, 2.11294E-06_JPRB, & + & 2.10085E-06_JPRB, 2.08884E-06_JPRB, 2.07689E-06_JPRB, 2.06501E-06_JPRB/) + KAO_MO2(:, 8) = (/ & + & 2.28564E-06_JPRB, 2.27363E-06_JPRB, 2.26168E-06_JPRB, 2.24980E-06_JPRB, 2.23798E-06_JPRB, & + & 2.22622E-06_JPRB, 2.21452E-06_JPRB, 2.20288E-06_JPRB, 2.19131E-06_JPRB, 2.17980E-06_JPRB, & + & 2.16834E-06_JPRB, 2.15695E-06_JPRB, 2.14562E-06_JPRB, 2.13434E-06_JPRB, 2.12313E-06_JPRB, & + & 2.11197E-06_JPRB, 2.10087E-06_JPRB, 2.08984E-06_JPRB, 2.07886E-06_JPRB/) + KAO_MO2(:, 9) = (/ & + & 2.28505E-06_JPRB, 2.27395E-06_JPRB, 2.26291E-06_JPRB, 2.25192E-06_JPRB, 2.24099E-06_JPRB, & + & 2.23011E-06_JPRB, 2.21928E-06_JPRB, 2.20850E-06_JPRB, 2.19778E-06_JPRB, 2.18711E-06_JPRB, & + & 2.17649E-06_JPRB, 2.16592E-06_JPRB, 2.15540E-06_JPRB, 2.14494E-06_JPRB, 2.13452E-06_JPRB, & + & 2.12416E-06_JPRB, 2.11385E-06_JPRB, 2.10358E-06_JPRB, 2.09337E-06_JPRB/) + KAO_MO2(:,10) = (/ & + & 2.25915E-06_JPRB, 2.24938E-06_JPRB, 2.23965E-06_JPRB, 2.22997E-06_JPRB, 2.22032E-06_JPRB, & + & 2.21072E-06_JPRB, 2.20116E-06_JPRB, 2.19164E-06_JPRB, 2.18216E-06_JPRB, 2.17272E-06_JPRB, & + & 2.16333E-06_JPRB, 2.15397E-06_JPRB, 2.14465E-06_JPRB, 2.13538E-06_JPRB, 2.12614E-06_JPRB, & + & 2.11695E-06_JPRB, 2.10779E-06_JPRB, 2.09868E-06_JPRB, 2.08960E-06_JPRB/) + KAO_MO2(:,11) = (/ & + & 2.52025E-06_JPRB, 2.50423E-06_JPRB, 2.48831E-06_JPRB, 2.47249E-06_JPRB, 2.45677E-06_JPRB, & + & 2.44115E-06_JPRB, 2.42563E-06_JPRB, 2.41021E-06_JPRB, 2.39489E-06_JPRB, 2.37967E-06_JPRB, & + & 2.36454E-06_JPRB, 2.34951E-06_JPRB, 2.33457E-06_JPRB, 2.31973E-06_JPRB, 2.30498E-06_JPRB, & + & 2.29033E-06_JPRB, 2.27577E-06_JPRB, 2.26130E-06_JPRB, 2.24692E-06_JPRB/) + KAO_MO2(:,12) = (/ & + & 2.52634E-06_JPRB, 2.51180E-06_JPRB, 2.49735E-06_JPRB, 2.48299E-06_JPRB, 2.46871E-06_JPRB, & + & 2.45451E-06_JPRB, 2.44039E-06_JPRB, 2.42635E-06_JPRB, 2.41239E-06_JPRB, 2.39851E-06_JPRB, & + & 2.38472E-06_JPRB, 2.37100E-06_JPRB, 2.35736E-06_JPRB, 2.34380E-06_JPRB, 2.33032E-06_JPRB, & + & 2.31691E-06_JPRB, 2.30358E-06_JPRB, 2.29033E-06_JPRB, 2.27716E-06_JPRB/) + KAO_MO2(:,13) = (/ & + & 2.66614E-06_JPRB, 2.64897E-06_JPRB, 2.63191E-06_JPRB, 2.61496E-06_JPRB, 2.59812E-06_JPRB, & + & 2.58138E-06_JPRB, 2.56476E-06_JPRB, 2.54824E-06_JPRB, 2.53183E-06_JPRB, 2.51552E-06_JPRB, & + & 2.49932E-06_JPRB, 2.48322E-06_JPRB, 2.46723E-06_JPRB, 2.45134E-06_JPRB, 2.43555E-06_JPRB, & + & 2.41987E-06_JPRB, 2.40428E-06_JPRB, 2.38880E-06_JPRB, 2.37341E-06_JPRB/) + KAO_MO2(:,14) = (/ & + & 2.96755E-06_JPRB, 2.94803E-06_JPRB, 2.92864E-06_JPRB, 2.90937E-06_JPRB, 2.89023E-06_JPRB, & + & 2.87122E-06_JPRB, 2.85233E-06_JPRB, 2.83357E-06_JPRB, 2.81493E-06_JPRB, 2.79641E-06_JPRB, & + & 2.77802E-06_JPRB, 2.75974E-06_JPRB, 2.74159E-06_JPRB, 2.72355E-06_JPRB, 2.70563E-06_JPRB, & + & 2.68784E-06_JPRB, 2.67015E-06_JPRB, 2.65259E-06_JPRB, 2.63514E-06_JPRB/) + KAO_MO2(:,15) = (/ & + & 1.30668E-06_JPRB, 1.31378E-06_JPRB, 1.32091E-06_JPRB, 1.32808E-06_JPRB, 1.33530E-06_JPRB, & + & 1.34255E-06_JPRB, 1.34984E-06_JPRB, 1.35717E-06_JPRB, 1.36454E-06_JPRB, 1.37195E-06_JPRB, & + & 1.37941E-06_JPRB, 1.38690E-06_JPRB, 1.39443E-06_JPRB, 1.40200E-06_JPRB, 1.40962E-06_JPRB, & + & 1.41727E-06_JPRB, 1.42497E-06_JPRB, 1.43271E-06_JPRB, 1.44049E-06_JPRB/) + KAO_MO2(:,16) = (/ & + & 5.99001E-07_JPRB, 6.16844E-07_JPRB, 6.35219E-07_JPRB, 6.54141E-07_JPRB, 6.73626E-07_JPRB, & + & 6.93692E-07_JPRB, 7.14356E-07_JPRB, 7.35635E-07_JPRB, 7.57548E-07_JPRB, 7.80114E-07_JPRB, & + & 8.03352E-07_JPRB, 8.27282E-07_JPRB, 8.51925E-07_JPRB, 8.77302E-07_JPRB, 9.03435E-07_JPRB, & + & 9.30347E-07_JPRB, 9.58060E-07_JPRB, 9.86599E-07_JPRB, 1.01599E-06_JPRB/) + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + + KBO_MO2(:, 1) = (/ & + & 4.97626E-07_JPRB, 5.05955E-07_JPRB, 5.14424E-07_JPRB, 5.23034E-07_JPRB, 5.31789E-07_JPRB, & + & 5.40690E-07_JPRB, 5.49739E-07_JPRB, 5.58941E-07_JPRB, 5.68296E-07_JPRB, 5.77808E-07_JPRB, & + & 5.87479E-07_JPRB, 5.97312E-07_JPRB, 6.07310E-07_JPRB, 6.17475E-07_JPRB, 6.27810E-07_JPRB, & + & 6.38318E-07_JPRB, 6.49002E-07_JPRB, 6.59865E-07_JPRB, 6.70910E-07_JPRB/) + KBO_MO2(:, 2) = (/ & + & 3.10232E-06_JPRB, 3.06339E-06_JPRB, 3.02496E-06_JPRB, 2.98700E-06_JPRB, 2.94952E-06_JPRB, & + & 2.91252E-06_JPRB, 2.87597E-06_JPRB, 2.83989E-06_JPRB, 2.80426E-06_JPRB, 2.76907E-06_JPRB, & + & 2.73433E-06_JPRB, 2.70002E-06_JPRB, 2.66614E-06_JPRB, 2.63269E-06_JPRB, 2.59966E-06_JPRB, & + & 2.56704E-06_JPRB, 2.53483E-06_JPRB, 2.50303E-06_JPRB, 2.47162E-06_JPRB/) + KBO_MO2(:, 3) = (/ & + & 2.91635E-06_JPRB, 2.88637E-06_JPRB, 2.85669E-06_JPRB, 2.82733E-06_JPRB, 2.79826E-06_JPRB, & + & 2.76949E-06_JPRB, 2.74102E-06_JPRB, 2.71284E-06_JPRB, 2.68495E-06_JPRB, 2.65735E-06_JPRB, & + & 2.63003E-06_JPRB, 2.60299E-06_JPRB, 2.57623E-06_JPRB, 2.54975E-06_JPRB, 2.52353E-06_JPRB, & + & 2.49759E-06_JPRB, 2.47191E-06_JPRB, 2.44650E-06_JPRB, 2.42135E-06_JPRB/) + KBO_MO2(:, 4) = (/ & + & 3.15584E-06_JPRB, 3.11986E-06_JPRB, 3.08430E-06_JPRB, 3.04914E-06_JPRB, 3.01438E-06_JPRB, & + & 2.98002E-06_JPRB, 2.94605E-06_JPRB, 2.91247E-06_JPRB, 2.87927E-06_JPRB, 2.84645E-06_JPRB, & + & 2.81400E-06_JPRB, 2.78192E-06_JPRB, 2.75021E-06_JPRB, 2.71886E-06_JPRB, 2.68787E-06_JPRB, & + & 2.65723E-06_JPRB, 2.62694E-06_JPRB, 2.59699E-06_JPRB, 2.56739E-06_JPRB/) + KBO_MO2(:, 5) = (/ & + & 2.52067E-06_JPRB, 2.50127E-06_JPRB, 2.48202E-06_JPRB, 2.46291E-06_JPRB, 2.44396E-06_JPRB, & + & 2.42515E-06_JPRB, 2.40648E-06_JPRB, 2.38796E-06_JPRB, 2.36958E-06_JPRB, 2.35134E-06_JPRB, & + & 2.33324E-06_JPRB, 2.31529E-06_JPRB, 2.29747E-06_JPRB, 2.27978E-06_JPRB, 2.26224E-06_JPRB, & + & 2.24482E-06_JPRB, 2.22755E-06_JPRB, 2.21040E-06_JPRB, 2.19339E-06_JPRB/) + KBO_MO2(:, 6) = (/ & + & 2.37304E-06_JPRB, 2.36340E-06_JPRB, 2.35380E-06_JPRB, 2.34423E-06_JPRB, 2.33471E-06_JPRB, & + & 2.32522E-06_JPRB, 2.31578E-06_JPRB, 2.30637E-06_JPRB, 2.29700E-06_JPRB, 2.28766E-06_JPRB, & + & 2.27837E-06_JPRB, 2.26911E-06_JPRB, 2.25989E-06_JPRB, 2.25071E-06_JPRB, 2.24157E-06_JPRB, & + & 2.23246E-06_JPRB, 2.22339E-06_JPRB, 2.21436E-06_JPRB, 2.20536E-06_JPRB/) + KBO_MO2(:, 7) = (/ & + & 2.56366E-06_JPRB, 2.56395E-06_JPRB, 2.56424E-06_JPRB, 2.56453E-06_JPRB, 2.56482E-06_JPRB, & + & 2.56510E-06_JPRB, 2.56539E-06_JPRB, 2.56568E-06_JPRB, 2.56597E-06_JPRB, 2.56625E-06_JPRB, & + & 2.56654E-06_JPRB, 2.56683E-06_JPRB, 2.56712E-06_JPRB, 2.56741E-06_JPRB, 2.56769E-06_JPRB, & + & 2.56798E-06_JPRB, 2.56827E-06_JPRB, 2.56856E-06_JPRB, 2.56885E-06_JPRB/) + KBO_MO2(:, 8) = (/ & + & 2.54502E-06_JPRB, 2.55393E-06_JPRB, 2.56287E-06_JPRB, 2.57185E-06_JPRB, 2.58085E-06_JPRB, & + & 2.58989E-06_JPRB, 2.59896E-06_JPRB, 2.60806E-06_JPRB, 2.61719E-06_JPRB, 2.62636E-06_JPRB, & + & 2.63555E-06_JPRB, 2.64478E-06_JPRB, 2.65404E-06_JPRB, 2.66334E-06_JPRB, 2.67266E-06_JPRB, & + & 2.68202E-06_JPRB, 2.69141E-06_JPRB, 2.70084E-06_JPRB, 2.71030E-06_JPRB/) + KBO_MO2(:, 9) = (/ & + & 1.84106E-06_JPRB, 1.83922E-06_JPRB, 1.83737E-06_JPRB, 1.83553E-06_JPRB, 1.83369E-06_JPRB, & + & 1.83186E-06_JPRB, 1.83002E-06_JPRB, 1.82819E-06_JPRB, 1.82636E-06_JPRB, 1.82453E-06_JPRB, & + & 1.82270E-06_JPRB, 1.82087E-06_JPRB, 1.81905E-06_JPRB, 1.81723E-06_JPRB, 1.81541E-06_JPRB, & + & 1.81359E-06_JPRB, 1.81177E-06_JPRB, 1.80996E-06_JPRB, 1.80814E-06_JPRB/) + KBO_MO2(:,10) = (/ & + & 1.83886E-06_JPRB, 1.83632E-06_JPRB, 1.83379E-06_JPRB, 1.83126E-06_JPRB, 1.82874E-06_JPRB, & + & 1.82622E-06_JPRB, 1.82370E-06_JPRB, 1.82119E-06_JPRB, 1.81868E-06_JPRB, 1.81617E-06_JPRB, & + & 1.81367E-06_JPRB, 1.81117E-06_JPRB, 1.80867E-06_JPRB, 1.80618E-06_JPRB, 1.80369E-06_JPRB, & + & 1.80120E-06_JPRB, 1.79872E-06_JPRB, 1.79624E-06_JPRB, 1.79377E-06_JPRB/) + KBO_MO2(:,11) = (/ & + & 2.30390E-06_JPRB, 2.30269E-06_JPRB, 2.30148E-06_JPRB, 2.30028E-06_JPRB, 2.29907E-06_JPRB, & + & 2.29787E-06_JPRB, 2.29667E-06_JPRB, 2.29546E-06_JPRB, 2.29426E-06_JPRB, 2.29306E-06_JPRB, & + & 2.29186E-06_JPRB, 2.29066E-06_JPRB, 2.28946E-06_JPRB, 2.28826E-06_JPRB, 2.28706E-06_JPRB, & + & 2.28586E-06_JPRB, 2.28466E-06_JPRB, 2.28347E-06_JPRB, 2.28227E-06_JPRB/) + KBO_MO2(:,12) = (/ & + & 2.38201E-06_JPRB, 2.36536E-06_JPRB, 2.34882E-06_JPRB, 2.33240E-06_JPRB, 2.31609E-06_JPRB, & + & 2.29990E-06_JPRB, 2.28382E-06_JPRB, 2.26785E-06_JPRB, 2.25199E-06_JPRB, 2.23625E-06_JPRB, & + & 2.22061E-06_JPRB, 2.20508E-06_JPRB, 2.18967E-06_JPRB, 2.17436E-06_JPRB, 2.15915E-06_JPRB, & + & 2.14406E-06_JPRB, 2.12907E-06_JPRB, 2.11418E-06_JPRB, 2.09940E-06_JPRB/) + KBO_MO2(:,13) = (/ & + & 2.33326E-06_JPRB, 2.32549E-06_JPRB, 2.31775E-06_JPRB, 2.31003E-06_JPRB, 2.30234E-06_JPRB, & + & 2.29467E-06_JPRB, 2.28703E-06_JPRB, 2.27941E-06_JPRB, 2.27182E-06_JPRB, 2.26426E-06_JPRB, & + & 2.25672E-06_JPRB, 2.24920E-06_JPRB, 2.24171E-06_JPRB, 2.23424E-06_JPRB, 2.22680E-06_JPRB, & + & 2.21939E-06_JPRB, 2.21200E-06_JPRB, 2.20463E-06_JPRB, 2.19729E-06_JPRB/) + KBO_MO2(:,14) = (/ & + & 2.75292E-06_JPRB, 2.75210E-06_JPRB, 2.75129E-06_JPRB, 2.75047E-06_JPRB, 2.74965E-06_JPRB, & + & 2.74883E-06_JPRB, 2.74801E-06_JPRB, 2.74720E-06_JPRB, 2.74638E-06_JPRB, 2.74556E-06_JPRB, & + & 2.74475E-06_JPRB, 2.74393E-06_JPRB, 2.74311E-06_JPRB, 2.74230E-06_JPRB, 2.74148E-06_JPRB, & + & 2.74067E-06_JPRB, 2.73985E-06_JPRB, 2.73904E-06_JPRB, 2.73822E-06_JPRB/) + KBO_MO2(:,15) = (/ & + & 2.55262E-06_JPRB, 2.53364E-06_JPRB, 2.51480E-06_JPRB, 2.49611E-06_JPRB, 2.47755E-06_JPRB, & + & 2.45913E-06_JPRB, 2.44084E-06_JPRB, 2.42269E-06_JPRB, 2.40468E-06_JPRB, 2.38680E-06_JPRB, & + & 2.36906E-06_JPRB, 2.35144E-06_JPRB, 2.33396E-06_JPRB, 2.31660E-06_JPRB, 2.29938E-06_JPRB, & + & 2.28228E-06_JPRB, 2.26531E-06_JPRB, 2.24847E-06_JPRB, 2.23175E-06_JPRB/) + KBO_MO2(:,16) = (/ & + & 3.11382E-06_JPRB, 3.08751E-06_JPRB, 3.06141E-06_JPRB, 3.03554E-06_JPRB, 3.00989E-06_JPRB, & + & 2.98445E-06_JPRB, 2.95923E-06_JPRB, 2.93422E-06_JPRB, 2.90942E-06_JPRB, 2.88483E-06_JPRB, & + & 2.86045E-06_JPRB, 2.83628E-06_JPRB, 2.81231E-06_JPRB, 2.78854E-06_JPRB, 2.76498E-06_JPRB, & + & 2.74161E-06_JPRB, 2.71844E-06_JPRB, 2.69547E-06_JPRB, 2.67269E-06_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &2.8858E-02_JPRB,3.6879E-02_JPRB,4.0746E-02_JPRB,4.2561E-02_JPRB,4.2740E-02_JPRB,4.2707E-02_JPRB, & + &4.4109E-02_JPRB,4.4540E-02_JPRB,4.5206E-02_JPRB,4.4679E-02_JPRB,4.5034E-02_JPRB,4.5364E-02_JPRB, & + &4.6790E-02_JPRB,4.7857E-02_JPRB,4.8328E-02_JPRB,4.8084E-02_JPRB/) + FORREFO(2,:) = (/ & + &2.7887E-02_JPRB,3.7376E-02_JPRB,4.0980E-02_JPRB,4.2986E-02_JPRB,4.3054E-02_JPRB,4.2975E-02_JPRB, & + &4.3754E-02_JPRB,4.4352E-02_JPRB,4.4723E-02_JPRB,4.6236E-02_JPRB,4.5273E-02_JPRB,4.5360E-02_JPRB, & + &4.5332E-02_JPRB,4.7587E-02_JPRB,4.7035E-02_JPRB,5.0267E-02_JPRB/) + FORREFO(3,:) = (/ & + &2.5846E-02_JPRB,3.6753E-02_JPRB,4.2334E-02_JPRB,4.3806E-02_JPRB,4.3848E-02_JPRB,4.3215E-02_JPRB, & + &4.3838E-02_JPRB,4.4278E-02_JPRB,4.4658E-02_JPRB,4.5403E-02_JPRB,4.5255E-02_JPRB,4.6347E-02_JPRB, & + &4.4722E-02_JPRB,4.6612E-02_JPRB,4.6836E-02_JPRB,4.8720E-02_JPRB/) + FORREFO(4,:) = (/ & + &2.8955E-02_JPRB,3.7608E-02_JPRB,4.1989E-02_JPRB,4.4919E-02_JPRB,4.2803E-02_JPRB,4.2842E-02_JPRB, & + &4.2632E-02_JPRB,4.1056E-02_JPRB,4.0086E-02_JPRB,4.1401E-02_JPRB,4.2746E-02_JPRB,4.2142E-02_JPRB, & + &4.1871E-02_JPRB,4.3917E-02_JPRB,4.5462E-02_JPRB,4.8359E-02_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 5.96496E-01_JPRB, 5.49171E-01_JPRB, 5.05600E-01_JPRB, 4.65486E-01_JPRB, 4.28555E-01_JPRB, & + & 3.94554E-01_JPRB, 3.63250E-01_JPRB, 3.34430E-01_JPRB, 3.07897E-01_JPRB, 2.83468E-01_JPRB/) + SELFREFO(:, 2) = (/ & + & 7.46455E-01_JPRB, 6.82459E-01_JPRB, 6.23950E-01_JPRB, 5.70457E-01_JPRB, 5.21550E-01_JPRB, & + & 4.76836E-01_JPRB, 4.35956E-01_JPRB, 3.98580E-01_JPRB, 3.64409E-01_JPRB, 3.33167E-01_JPRB/) + SELFREFO(:, 3) = (/ & + & 7.86805E-01_JPRB, 7.21186E-01_JPRB, 6.61040E-01_JPRB, 6.05910E-01_JPRB, 5.55378E-01_JPRB, & + & 5.09059E-01_JPRB, 4.66605E-01_JPRB, 4.27690E-01_JPRB, 3.92021E-01_JPRB, 3.59327E-01_JPRB/) + SELFREFO(:, 4) = (/ & + & 8.11740E-01_JPRB, 7.44359E-01_JPRB, 6.82570E-01_JPRB, 6.25910E-01_JPRB, 5.73954E-01_JPRB, & + & 5.26311E-01_JPRB, 4.82622E-01_JPRB, 4.42560E-01_JPRB, 4.05823E-01_JPRB, 3.72136E-01_JPRB/) + SELFREFO(:, 5) = (/ & + & 8.14870E-01_JPRB, 7.47200E-01_JPRB, 6.85150E-01_JPRB, 6.28253E-01_JPRB, 5.76081E-01_JPRB, & + & 5.28241E-01_JPRB, 4.84374E-01_JPRB, 4.44150E-01_JPRB, 4.07266E-01_JPRB, 3.73446E-01_JPRB/) + SELFREFO(:, 6) = (/ & + & 8.10104E-01_JPRB, 7.43259E-01_JPRB, 6.81930E-01_JPRB, 6.25661E-01_JPRB, 5.74035E-01_JPRB, & + & 5.26669E-01_JPRB, 4.83212E-01_JPRB, 4.43340E-01_JPRB, 4.06758E-01_JPRB, 3.73195E-01_JPRB/) + SELFREFO(:, 7) = (/ & + & 8.13119E-01_JPRB, 7.48127E-01_JPRB, 6.88330E-01_JPRB, 6.33312E-01_JPRB, 5.82692E-01_JPRB, & + & 5.36118E-01_JPRB, 4.93267E-01_JPRB, 4.53840E-01_JPRB, 4.17565E-01_JPRB, 3.84189E-01_JPRB/) + SELFREFO(:, 8) = (/ & + & 8.26137E-01_JPRB, 7.58984E-01_JPRB, 6.97290E-01_JPRB, 6.40611E-01_JPRB, 5.88539E-01_JPRB, & + & 5.40699E-01_JPRB, 4.96748E-01_JPRB, 4.56370E-01_JPRB, 4.19274E-01_JPRB, 3.85193E-01_JPRB/) + SELFREFO(:, 9) = (/ & + & 8.30566E-01_JPRB, 7.63984E-01_JPRB, 7.02740E-01_JPRB, 6.46405E-01_JPRB, 5.94587E-01_JPRB, & + & 5.46922E-01_JPRB, 5.03079E-01_JPRB, 4.62750E-01_JPRB, 4.25654E-01_JPRB, 3.91532E-01_JPRB/) + SELFREFO(:,10) = (/ & + & 8.67471E-01_JPRB, 7.91575E-01_JPRB, 7.22320E-01_JPRB, 6.59124E-01_JPRB, 6.01457E-01_JPRB, & + & 5.48835E-01_JPRB, 5.00817E-01_JPRB, 4.57000E-01_JPRB, 4.17017E-01_JPRB, 3.80532E-01_JPRB/) + SELFREFO(:,11) = (/ & + & 8.51029E-01_JPRB, 7.79373E-01_JPRB, 7.13750E-01_JPRB, 6.53652E-01_JPRB, 5.98615E-01_JPRB, & + & 5.48212E-01_JPRB, 5.02053E-01_JPRB, 4.59780E-01_JPRB, 4.21067E-01_JPRB, 3.85613E-01_JPRB/) + SELFREFO(:,12) = (/ & + & 8.36772E-01_JPRB, 7.68751E-01_JPRB, 7.06260E-01_JPRB, 6.48848E-01_JPRB, 5.96104E-01_JPRB, & + & 5.47647E-01_JPRB, 5.03129E-01_JPRB, 4.62230E-01_JPRB, 4.24655E-01_JPRB, 3.90136E-01_JPRB/) + SELFREFO(:,13) = (/ & + & 8.36551E-01_JPRB, 7.71089E-01_JPRB, 7.10750E-01_JPRB, 6.55133E-01_JPRB, 6.03867E-01_JPRB, & + & 5.56614E-01_JPRB, 5.13058E-01_JPRB, 4.72910E-01_JPRB, 4.35904E-01_JPRB, 4.01794E-01_JPRB/) + SELFREFO(:,14) = (/ & + & 8.84307E-01_JPRB, 8.11175E-01_JPRB, 7.44090E-01_JPRB, 6.82553E-01_JPRB, 6.26106E-01_JPRB, & + & 5.74326E-01_JPRB, 5.26829E-01_JPRB, 4.83260E-01_JPRB, 4.43294E-01_JPRB, 4.06633E-01_JPRB/) + SELFREFO(:,15) = (/ & + & 8.90356E-01_JPRB, 8.19830E-01_JPRB, 7.54890E-01_JPRB, 6.95094E-01_JPRB, 6.40035E-01_JPRB, & + & 5.89337E-01_JPRB, 5.42655E-01_JPRB, 4.99670E-01_JPRB, 4.60090E-01_JPRB, 4.23646E-01_JPRB/) + SELFREFO(:,16) = (/ & + & 9.67549E-01_JPRB, 8.79393E-01_JPRB, 7.99270E-01_JPRB, 7.26447E-01_JPRB, 6.60259E-01_JPRB, & + & 6.00101E-01_JPRB, 5.45425E-01_JPRB, 4.95730E-01_JPRB, 4.50563E-01_JPRB, 4.09511E-01_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB11',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB11:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB11 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb12.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb12.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb12.F90 (revision 6016) @@ -0,0 +1,182 @@ +SUBROUTINE RRTM_KGB12 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 12: 1800-2080 cm-1 (low - H2O,CO2; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO12, ONLY : KAO, KAO_D, SELFREFO, FORREFO, FRACREFAO + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB12',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D + KAO = REAL(KAO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB12:') +ENDIF + +! Planck fraction mapping level : P = 174.1640 mbar, T= 215.78 K + FRACREFAO(:, 1) = (/ & + & 1.3984E-01_JPRB,1.6809E-01_JPRB,1.8072E-01_JPRB,1.5400E-01_JPRB,1.2613E-01_JPRB,9.6959E-02_JPRB, & + & 5.9713E-02_JPRB,3.8631E-02_JPRB,2.6937E-02_JPRB,3.1711E-03_JPRB,2.3458E-03_JPRB,1.4653E-03_JPRB, & + & 1.0567E-03_JPRB,6.6504E-04_JPRB,2.4957E-04_JPRB,3.5172E-05_JPRB/) + FRACREFAO(:, 2) = (/ & + & 1.2745E-01_JPRB,1.6107E-01_JPRB,1.6568E-01_JPRB,1.5436E-01_JPRB,1.3183E-01_JPRB,1.0166E-01_JPRB, & + & 6.4506E-02_JPRB,4.7756E-02_JPRB,3.4472E-02_JPRB,3.7189E-03_JPRB,2.9349E-03_JPRB,2.1469E-03_JPRB, & + & 1.3746E-03_JPRB,7.1691E-04_JPRB,2.8057E-04_JPRB,5.6242E-05_JPRB/) + FRACREFAO(:, 3) = (/ & + & 1.2181E-01_JPRB,1.5404E-01_JPRB,1.6540E-01_JPRB,1.5255E-01_JPRB,1.3736E-01_JPRB,9.8856E-02_JPRB, & + & 6.8927E-02_JPRB,5.1385E-02_JPRB,3.7046E-02_JPRB,4.0302E-03_JPRB,3.0949E-03_JPRB,2.3772E-03_JPRB, & + & 1.6538E-03_JPRB,8.9641E-04_JPRB,4.6991E-04_JPRB,1.1251E-04_JPRB/) + FRACREFAO(:, 4) = (/ & + & 1.1794E-01_JPRB,1.4864E-01_JPRB,1.6316E-01_JPRB,1.5341E-01_JPRB,1.3986E-01_JPRB,9.6656E-02_JPRB, & + & 7.2478E-02_JPRB,5.5061E-02_JPRB,3.8886E-02_JPRB,4.3398E-03_JPRB,3.3576E-03_JPRB,2.4891E-03_JPRB, & + & 1.7674E-03_JPRB,1.0764E-03_JPRB,7.7689E-04_JPRB,1.1251E-04_JPRB/) + FRACREFAO(:, 5) = (/ & + & 1.1635E-01_JPRB,1.4342E-01_JPRB,1.5924E-01_JPRB,1.5670E-01_JPRB,1.3740E-01_JPRB,9.7087E-02_JPRB, & + & 7.6250E-02_JPRB,5.7802E-02_JPRB,4.0808E-02_JPRB,4.4113E-03_JPRB,3.6035E-03_JPRB,2.6269E-03_JPRB, & + & 1.7586E-03_JPRB,1.6498E-03_JPRB,7.7689E-04_JPRB,1.1251E-04_JPRB/) + FRACREFAO(:, 6) = (/ & + & 1.1497E-01_JPRB,1.3751E-01_JPRB,1.5587E-01_JPRB,1.5904E-01_JPRB,1.3140E-01_JPRB,1.0159E-01_JPRB, & + & 7.9729E-02_JPRB,6.1475E-02_JPRB,4.2382E-02_JPRB,4.5291E-03_JPRB,3.8161E-03_JPRB,2.7683E-03_JPRB, & + & 1.9899E-03_JPRB,2.0395E-03_JPRB,7.7720E-04_JPRB,1.1251E-04_JPRB/) + FRACREFAO(:, 7) = (/ & + & 1.1331E-01_JPRB,1.3015E-01_JPRB,1.5574E-01_JPRB,1.5489E-01_JPRB,1.2697E-01_JPRB,1.0746E-01_JPRB, & + & 8.4777E-02_JPRB,6.5145E-02_JPRB,4.4293E-02_JPRB,4.7426E-03_JPRB,3.8383E-03_JPRB,2.9065E-03_JPRB, & + & 2.8430E-03_JPRB,2.0401E-03_JPRB,7.7689E-04_JPRB,1.1251E-04_JPRB/) + FRACREFAO(:, 8) = (/ & + & 1.0993E-01_JPRB,1.2320E-01_JPRB,1.4893E-01_JPRB,1.4573E-01_JPRB,1.3174E-01_JPRB,1.1149E-01_JPRB, & + & 9.3326E-02_JPRB,6.9942E-02_JPRB,4.6762E-02_JPRB,4.9309E-03_JPRB,3.8583E-03_JPRB,4.1889E-03_JPRB, & + & 3.0415E-03_JPRB,2.0406E-03_JPRB,7.7720E-04_JPRB,1.1251E-04_JPRB/) + FRACREFAO(:, 9) = (/ & + & 1.2028E-01_JPRB,1.2091E-01_JPRB,1.3098E-01_JPRB,1.3442E-01_JPRB,1.3574E-01_JPRB,1.1739E-01_JPRB, & + & 9.5343E-02_JPRB,7.0224E-02_JPRB,5.3456E-02_JPRB,6.0206E-03_JPRB,5.0758E-03_JPRB,4.1906E-03_JPRB, & + & 3.0431E-03_JPRB,2.0400E-03_JPRB,7.7689E-04_JPRB,1.1251E-04_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &1.4739E-04_JPRB,3.1686E-04_JPRB,8.5973E-04_JPRB,1.9039E-03_JPRB,3.1820E-03_JPRB,3.6596E-03_JPRB, & + &3.8724E-03_JPRB,3.6785E-03_JPRB,3.7141E-03_JPRB,3.7646E-03_JPRB,4.2955E-03_JPRB,4.6343E-03_JPRB, & + &5.0612E-03_JPRB,4.0227E-03_JPRB,4.2966E-03_JPRB,4.6622E-03_JPRB/) + FORREFO(2,:) = (/ & + &1.9397E-04_JPRB,3.6322E-04_JPRB,8.9797E-04_JPRB,2.1001E-03_JPRB,3.0307E-03_JPRB,3.5563E-03_JPRB, & + &3.8498E-03_JPRB,3.5741E-03_JPRB,3.5914E-03_JPRB,3.7658E-03_JPRB,3.8895E-03_JPRB,4.4072E-03_JPRB, & + &4.7112E-03_JPRB,4.2230E-03_JPRB,4.2666E-03_JPRB,4.6634E-03_JPRB/) + FORREFO(3,:) = (/ & + &3.1506E-04_JPRB,7.3687E-04_JPRB,1.9678E-03_JPRB,2.5531E-03_JPRB,2.8345E-03_JPRB,2.7809E-03_JPRB, & + &2.9124E-03_JPRB,2.7125E-03_JPRB,2.6644E-03_JPRB,2.4907E-03_JPRB,2.7032E-03_JPRB,4.0967E-03_JPRB, & + &4.1971E-03_JPRB,4.4507E-03_JPRB,4.2293E-03_JPRB,4.6633E-03_JPRB/) + FORREFO(4,:) = (/ & + &8.8196E-04_JPRB,2.1125E-03_JPRB,2.8042E-03_JPRB,2.8891E-03_JPRB,2.4362E-03_JPRB,1.8733E-03_JPRB, & + &1.4078E-03_JPRB,1.1987E-03_JPRB,1.2808E-03_JPRB,8.9050E-04_JPRB,9.4375E-04_JPRB,7.8351E-04_JPRB, & + &1.0756E-03_JPRB,1.6586E-03_JPRB,1.7511E-03_JPRB,4.7803E-03_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 2.37879E-02_JPRB, 2.10719E-02_JPRB, 1.86660E-02_JPRB, 1.65348E-02_JPRB, 1.46469E-02_JPRB, & + & 1.29746E-02_JPRB, 1.14932E-02_JPRB, 1.01810E-02_JPRB, 9.01858E-03_JPRB, 7.98888E-03_JPRB/) + SELFREFO(:, 2) = (/ & + & 3.10625E-02_JPRB, 2.82664E-02_JPRB, 2.57220E-02_JPRB, 2.34066E-02_JPRB, 2.12997E-02_JPRB, & + & 1.93824E-02_JPRB, 1.76377E-02_JPRB, 1.60500E-02_JPRB, 1.46053E-02_JPRB, 1.32906E-02_JPRB/) + SELFREFO(:, 3) = (/ & + & 5.19103E-02_JPRB, 4.80004E-02_JPRB, 4.43850E-02_JPRB, 4.10419E-02_JPRB, 3.79506E-02_JPRB, & + & 3.50922E-02_JPRB, 3.24491E-02_JPRB, 3.00050E-02_JPRB, 2.77450E-02_JPRB, 2.56553E-02_JPRB/) + SELFREFO(:, 4) = (/ & + & 9.12444E-02_JPRB, 8.38675E-02_JPRB, 7.70870E-02_JPRB, 7.08547E-02_JPRB, 6.51263E-02_JPRB, & + & 5.98610E-02_JPRB, 5.50214E-02_JPRB, 5.05730E-02_JPRB, 4.64843E-02_JPRB, 4.27262E-02_JPRB/) + SELFREFO(:, 5) = (/ & + & 1.11323E-01_JPRB, 1.04217E-01_JPRB, 9.75650E-02_JPRB, 9.13376E-02_JPRB, 8.55076E-02_JPRB, & + & 8.00498E-02_JPRB, 7.49403E-02_JPRB, 7.01570E-02_JPRB, 6.56790E-02_JPRB, 6.14868E-02_JPRB/) + SELFREFO(:, 6) = (/ & + & 1.25301E-01_JPRB, 1.16877E-01_JPRB, 1.09020E-01_JPRB, 1.01691E-01_JPRB, 9.48543E-02_JPRB, & + & 8.84774E-02_JPRB, 8.25293E-02_JPRB, 7.69810E-02_JPRB, 7.18057E-02_JPRB, 6.69784E-02_JPRB/) + SELFREFO(:, 7) = (/ & + & 1.34063E-01_JPRB, 1.24662E-01_JPRB, 1.15920E-01_JPRB, 1.07791E-01_JPRB, 1.00232E-01_JPRB, & + & 9.32035E-02_JPRB, 8.66676E-02_JPRB, 8.05900E-02_JPRB, 7.49386E-02_JPRB, 6.96836E-02_JPRB/) + SELFREFO(:, 8) = (/ & + & 1.26997E-01_JPRB, 1.18306E-01_JPRB, 1.10210E-01_JPRB, 1.02668E-01_JPRB, 9.56417E-02_JPRB, & + & 8.90964E-02_JPRB, 8.29991E-02_JPRB, 7.73190E-02_JPRB, 7.20276E-02_JPRB, 6.70984E-02_JPRB/) + SELFREFO(:, 9) = (/ & + & 1.28823E-01_JPRB, 1.20235E-01_JPRB, 1.12220E-01_JPRB, 1.04739E-01_JPRB, 9.77569E-02_JPRB, & + & 9.12402E-02_JPRB, 8.51579E-02_JPRB, 7.94810E-02_JPRB, 7.41826E-02_JPRB, 6.92374E-02_JPRB/) + SELFREFO(:,10) = (/ & + & 1.35802E-01_JPRB, 1.25981E-01_JPRB, 1.16870E-01_JPRB, 1.08418E-01_JPRB, 1.00577E-01_JPRB, & + & 9.33034E-02_JPRB, 8.65557E-02_JPRB, 8.02960E-02_JPRB, 7.44890E-02_JPRB, 6.91020E-02_JPRB/) + SELFREFO(:,11) = (/ & + & 1.35475E-01_JPRB, 1.27572E-01_JPRB, 1.20130E-01_JPRB, 1.13122E-01_JPRB, 1.06523E-01_JPRB, & + & 1.00309E-01_JPRB, 9.44573E-02_JPRB, 8.89470E-02_JPRB, 8.37582E-02_JPRB, 7.88721E-02_JPRB/) + SELFREFO(:,12) = (/ & + & 1.51195E-01_JPRB, 1.41159E-01_JPRB, 1.31790E-01_JPRB, 1.23043E-01_JPRB, 1.14876E-01_JPRB, & + & 1.07251E-01_JPRB, 1.00132E-01_JPRB, 9.34860E-02_JPRB, 8.72809E-02_JPRB, 8.14877E-02_JPRB/) + SELFREFO(:,13) = (/ & + & 1.57538E-01_JPRB, 1.47974E-01_JPRB, 1.38990E-01_JPRB, 1.30552E-01_JPRB, 1.22626E-01_JPRB, & + & 1.15181E-01_JPRB, 1.08188E-01_JPRB, 1.01620E-01_JPRB, 9.54505E-02_JPRB, 8.96556E-02_JPRB/) + SELFREFO(:,14) = (/ & + & 1.53567E-01_JPRB, 1.41564E-01_JPRB, 1.30500E-01_JPRB, 1.20300E-01_JPRB, 1.10898E-01_JPRB, & + & 1.02231E-01_JPRB, 9.42406E-02_JPRB, 8.68750E-02_JPRB, 8.00851E-02_JPRB, 7.38259E-02_JPRB/) + SELFREFO(:,15) = (/ & + & 1.53687E-01_JPRB, 1.42981E-01_JPRB, 1.33020E-01_JPRB, 1.23753E-01_JPRB, 1.15132E-01_JPRB, & + & 1.07112E-01_JPRB, 9.96500E-02_JPRB, 9.27080E-02_JPRB, 8.62496E-02_JPRB, 8.02412E-02_JPRB/) + SELFREFO(:,16) = (/ & + & 1.65129E-01_JPRB, 1.53285E-01_JPRB, 1.42290E-01_JPRB, 1.32084E-01_JPRB, 1.22610E-01_JPRB, & + & 1.13815E-01_JPRB, 1.05651E-01_JPRB, 9.80730E-02_JPRB, 9.10384E-02_JPRB, 8.45083E-02_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB12',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB12:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB12 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb13.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb13.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb13.F90 (revision 6016) @@ -0,0 +1,1733 @@ +SUBROUTINE RRTM_KGB13 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 13: 2080-2250 cm-1 (low - H2O,N2O; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO13, ONLY : KAO, KAO_D, SELFREFO, FORREFO ,FRACREFAO, FRACREFBO, KAO_MCO2, KAO_MCO,KBO_MO3 + + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB13',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D + KAO = REAL(KAO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB13:') +ENDIF + +! Planck fraction mapping level : P=473.4280 mb, T = 259.83 K + FRACREFAO(:, 1) = (/ & + & 1.7534E-01_JPRB,1.7394E-01_JPRB,1.6089E-01_JPRB,1.3782E-01_JPRB,1.0696E-01_JPRB,8.5853E-02_JPRB, & + & 6.6548E-02_JPRB,4.9053E-02_JPRB,3.2064E-02_JPRB,3.4820E-03_JPRB,2.8763E-03_JPRB,2.2204E-03_JPRB, & + & 1.5612E-03_JPRB,9.8572E-04_JPRB,3.6853E-04_JPRB,5.1612E-05_JPRB/) + FRACREFAO(:, 2) = (/ & + & 1.7489E-01_JPRB,1.7309E-01_JPRB,1.5981E-01_JPRB,1.3782E-01_JPRB,1.0797E-01_JPRB,8.6367E-02_JPRB, & + & 6.7042E-02_JPRB,4.9257E-02_JPRB,3.2207E-02_JPRB,3.4820E-03_JPRB,2.8767E-03_JPRB,2.2203E-03_JPRB, & + & 1.5613E-03_JPRB,9.8571E-04_JPRB,3.6853E-04_JPRB,5.1612E-05_JPRB/) + FRACREFAO(:, 3) = (/ & + & 1.7459E-01_JPRB,1.7259E-01_JPRB,1.5948E-01_JPRB,1.3694E-01_JPRB,1.0815E-01_JPRB,8.7376E-02_JPRB, & + & 6.7339E-02_JPRB,4.9541E-02_JPRB,3.2333E-02_JPRB,3.5019E-03_JPRB,2.8958E-03_JPRB,2.2527E-03_JPRB, & + & 1.6099E-03_JPRB,9.8574E-04_JPRB,3.6853E-04_JPRB,5.1612E-05_JPRB/) + FRACREFAO(:, 4) = (/ & + & 1.7391E-01_JPRB,1.7244E-01_JPRB,1.5921E-01_JPRB,1.3644E-01_JPRB,1.0787E-01_JPRB,8.7776E-02_JPRB, & + & 6.8361E-02_JPRB,4.9628E-02_JPRB,3.2578E-02_JPRB,3.5117E-03_JPRB,2.9064E-03_JPRB,2.2571E-03_JPRB, & + & 1.6887E-03_JPRB,1.0045E-03_JPRB,3.6853E-04_JPRB,5.1612E-05_JPRB/) + FRACREFAO(:, 5) = (/ & + & 1.7338E-01_JPRB,1.7157E-01_JPRB,1.5957E-01_JPRB,1.3571E-01_JPRB,1.0773E-01_JPRB,8.7966E-02_JPRB, & + & 6.9000E-02_JPRB,5.0300E-02_JPRB,3.2813E-02_JPRB,3.5470E-03_JPRB,2.9425E-03_JPRB,2.2552E-03_JPRB, & + & 1.7038E-03_JPRB,1.1025E-03_JPRB,3.6853E-04_JPRB,5.1612E-05_JPRB/) + FRACREFAO(:, 6) = (/ & + & 1.7230E-01_JPRB,1.7082E-01_JPRB,1.5917E-01_JPRB,1.3562E-01_JPRB,1.0806E-01_JPRB,8.7635E-02_JPRB, & + & 6.9815E-02_JPRB,5.1155E-02_JPRB,3.3139E-02_JPRB,3.6264E-03_JPRB,2.9436E-03_JPRB,2.3417E-03_JPRB, & + & 1.7731E-03_JPRB,1.1156E-03_JPRB,4.4533E-04_JPRB,5.1612E-05_JPRB/) + FRACREFAO(:, 7) = (/ & + & 1.7073E-01_JPRB,1.6961E-01_JPRB,1.5844E-01_JPRB,1.3594E-01_JPRB,1.0821E-01_JPRB,8.7791E-02_JPRB, & + & 7.0502E-02_JPRB,5.1904E-02_JPRB,3.4107E-02_JPRB,3.5888E-03_JPRB,2.9574E-03_JPRB,2.5851E-03_JPRB, & + & 1.9127E-03_JPRB,1.1537E-03_JPRB,4.7789E-04_JPRB,1.0016E-04_JPRB/) + FRACREFAO(:, 8) = (/ & + & 1.6700E-01_JPRB,1.6848E-01_JPRB,1.5628E-01_JPRB,1.3448E-01_JPRB,1.1011E-01_JPRB,8.9016E-02_JPRB, & + & 7.1973E-02_JPRB,5.2798E-02_JPRB,3.5650E-02_JPRB,3.8534E-03_JPRB,3.4142E-03_JPRB,2.7799E-03_JPRB, & + & 2.1288E-03_JPRB,1.3043E-03_JPRB,6.2858E-04_JPRB,1.0016E-04_JPRB/) + FRACREFAO(:, 9) = (/ & + & 1.6338E-01_JPRB,1.5565E-01_JPRB,1.4470E-01_JPRB,1.3500E-01_JPRB,1.1909E-01_JPRB,9.8312E-02_JPRB, & + & 7.9023E-02_JPRB,5.5728E-02_JPRB,3.6831E-02_JPRB,3.6569E-03_JPRB,3.0552E-03_JPRB,2.3431E-03_JPRB, & + & 1.7088E-03_JPRB,1.1082E-03_JPRB,3.6829E-04_JPRB,5.1612E-05_JPRB/) + +! Planck fraction mapping level : P=4.758820 mb, T = 250.85 K + FRACREFBO(:) = (/ & + & 1.5411E-01_JPRB,1.3573E-01_JPRB,1.2527E-01_JPRB,1.2698E-01_JPRB,1.2394E-01_JPRB,1.0876E-01_JPRB, & + & 8.9906E-02_JPRB,6.9551E-02_JPRB,4.8240E-02_JPRB,5.2434E-03_JPRB,4.3630E-03_JPRB,3.4262E-03_JPRB, & + & 2.5124E-03_JPRB,1.5479E-03_JPRB,3.7294E-04_JPRB,5.1050E-05_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + + KAO_MCO2( 1, :, 1) = (/ & + & 1.09539E-04_JPRB, 1.17067E-04_JPRB, 1.25113E-04_JPRB, 1.33712E-04_JPRB, 1.42902E-04_JPRB, & + & 1.52724E-04_JPRB, 1.63221E-04_JPRB, 1.74439E-04_JPRB, 1.86428E-04_JPRB, 1.99241E-04_JPRB, & + & 2.12934E-04_JPRB, 2.27569E-04_JPRB, 2.43210E-04_JPRB, 2.59926E-04_JPRB, 2.77790E-04_JPRB, & + & 2.96883E-04_JPRB, 3.17287E-04_JPRB, 3.39094E-04_JPRB, 3.62400E-04_JPRB/) + KAO_MCO2( 2, :, 1) = (/ & + & 1.25202E-04_JPRB, 1.34718E-04_JPRB, 1.44957E-04_JPRB, 1.55974E-04_JPRB, 1.67829E-04_JPRB, & + & 1.80585E-04_JPRB, 1.94311E-04_JPRB, 2.09079E-04_JPRB, 2.24971E-04_JPRB, 2.42069E-04_JPRB, & + & 2.60468E-04_JPRB, 2.80265E-04_JPRB, 3.01567E-04_JPRB, 3.24488E-04_JPRB, 3.49150E-04_JPRB, & + & 3.75688E-04_JPRB, 4.04242E-04_JPRB, 4.34966E-04_JPRB, 4.68026E-04_JPRB/) + KAO_MCO2( 3, :, 1) = (/ & + & 1.12112E-04_JPRB, 1.21090E-04_JPRB, 1.30786E-04_JPRB, 1.41259E-04_JPRB, 1.52571E-04_JPRB, & + & 1.64788E-04_JPRB, 1.77984E-04_JPRB, 1.92237E-04_JPRB, 2.07631E-04_JPRB, 2.24257E-04_JPRB, & + & 2.42215E-04_JPRB, 2.61611E-04_JPRB, 2.82560E-04_JPRB, 3.05187E-04_JPRB, 3.29625E-04_JPRB, & + & 3.56021E-04_JPRB, 3.84530E-04_JPRB, 4.15322E-04_JPRB, 4.48580E-04_JPRB/) + KAO_MCO2( 4, :, 1) = (/ & + & 9.74130E-05_JPRB, 1.05372E-04_JPRB, 1.13982E-04_JPRB, 1.23295E-04_JPRB, 1.33369E-04_JPRB, & + & 1.44265E-04_JPRB, 1.56053E-04_JPRB, 1.68803E-04_JPRB, 1.82595E-04_JPRB, 1.97514E-04_JPRB, & + & 2.13652E-04_JPRB, 2.31109E-04_JPRB, 2.49992E-04_JPRB, 2.70418E-04_JPRB, 2.92512E-04_JPRB, & + & 3.16412E-04_JPRB, 3.42265E-04_JPRB, 3.70230E-04_JPRB, 4.00479E-04_JPRB/) + KAO_MCO2( 5, :, 1) = (/ & + & 8.71018E-05_JPRB, 9.40759E-05_JPRB, 1.01608E-04_JPRB, 1.09744E-04_JPRB, 1.18531E-04_JPRB, & + & 1.28022E-04_JPRB, 1.38272E-04_JPRB, 1.49343E-04_JPRB, 1.61301E-04_JPRB, 1.74216E-04_JPRB, & + & 1.88166E-04_JPRB, 2.03232E-04_JPRB, 2.19504E-04_JPRB, 2.37079E-04_JPRB, 2.56062E-04_JPRB, & + & 2.76565E-04_JPRB, 2.98709E-04_JPRB, 3.22626E-04_JPRB, 3.48458E-04_JPRB/) + KAO_MCO2( 6, :, 1) = (/ & + & 7.55256E-05_JPRB, 8.17414E-05_JPRB, 8.84688E-05_JPRB, 9.57500E-05_JPRB, 1.03630E-04_JPRB, & + & 1.12159E-04_JPRB, 1.21390E-04_JPRB, 1.31381E-04_JPRB, 1.42193E-04_JPRB, 1.53896E-04_JPRB, & + & 1.66562E-04_JPRB, 1.80270E-04_JPRB, 1.95107E-04_JPRB, 2.11164E-04_JPRB, 2.28543E-04_JPRB, & + & 2.47353E-04_JPRB, 2.67710E-04_JPRB, 2.89743E-04_JPRB, 3.13589E-04_JPRB/) + KAO_MCO2( 7, :, 1) = (/ & + & 5.31515E-05_JPRB, 6.06869E-05_JPRB, 6.92907E-05_JPRB, 7.91143E-05_JPRB, 9.03306E-05_JPRB, & + & 1.03137E-04_JPRB, 1.17759E-04_JPRB, 1.34454E-04_JPRB, 1.53516E-04_JPRB, 1.75281E-04_JPRB, & + & 2.00131E-04_JPRB, 2.28504E-04_JPRB, 2.60900E-04_JPRB, 2.97888E-04_JPRB, 3.40121E-04_JPRB, & + & 3.88341E-04_JPRB, 4.43397E-04_JPRB, 5.06259E-04_JPRB, 5.78033E-04_JPRB/) + KAO_MCO2( 8, :, 1) = (/ & + & 2.52471E-04_JPRB, 2.96005E-04_JPRB, 3.47045E-04_JPRB, 4.06886E-04_JPRB, 4.77045E-04_JPRB, & + & 5.59302E-04_JPRB, 6.55742E-04_JPRB, 7.68811E-04_JPRB, 9.01377E-04_JPRB, 1.05680E-03_JPRB, & + & 1.23902E-03_JPRB, 1.45267E-03_JPRB, 1.70315E-03_JPRB, 1.99683E-03_JPRB, 2.34114E-03_JPRB, & + & 2.74482E-03_JPRB, 3.21811E-03_JPRB, 3.77300E-03_JPRB, 4.42358E-03_JPRB/) + KAO_MCO2( 9, :, 1) = (/ & + & 4.06711E-05_JPRB, 4.53161E-05_JPRB, 5.04917E-05_JPRB, 5.62583E-05_JPRB, 6.26836E-05_JPRB, & + & 6.98427E-05_JPRB, 7.78194E-05_JPRB, 8.67071E-05_JPRB, 9.66100E-05_JPRB, 1.07644E-04_JPRB, & + & 1.19938E-04_JPRB, 1.33636E-04_JPRB, 1.48898E-04_JPRB, 1.65904E-04_JPRB, 1.84852E-04_JPRB, & + & 2.05964E-04_JPRB, 2.29487E-04_JPRB, 2.55697E-04_JPRB, 2.84900E-04_JPRB/) + KAO_MCO2( 1, :, 2) = (/ & + & 2.01759E-04_JPRB, 2.15641E-04_JPRB, 2.30478E-04_JPRB, 2.46336E-04_JPRB, 2.63285E-04_JPRB, & + & 2.81400E-04_JPRB, 3.00761E-04_JPRB, 3.21455E-04_JPRB, 3.43573E-04_JPRB, 3.67212E-04_JPRB, & + & 3.92477E-04_JPRB, 4.19482E-04_JPRB, 4.48344E-04_JPRB, 4.79192E-04_JPRB, 5.12162E-04_JPRB, & + & 5.47401E-04_JPRB, 5.85064E-04_JPRB, 6.25319E-04_JPRB, 6.68343E-04_JPRB/) + KAO_MCO2( 2, :, 2) = (/ & + & 2.53461E-04_JPRB, 2.70916E-04_JPRB, 2.89574E-04_JPRB, 3.09516E-04_JPRB, 3.30832E-04_JPRB, & + & 3.53616E-04_JPRB, 3.77969E-04_JPRB, 4.03999E-04_JPRB, 4.31822E-04_JPRB, 4.61561E-04_JPRB, & + & 4.93348E-04_JPRB, 5.27324E-04_JPRB, 5.63640E-04_JPRB, 6.02457E-04_JPRB, 6.43948E-04_JPRB, & + & 6.88295E-04_JPRB, 7.35697E-04_JPRB, 7.86364E-04_JPRB, 8.40519E-04_JPRB/) + KAO_MCO2( 3, :, 2) = (/ & + & 2.58821E-04_JPRB, 2.76943E-04_JPRB, 2.96334E-04_JPRB, 3.17082E-04_JPRB, 3.39283E-04_JPRB, & + & 3.63038E-04_JPRB, 3.88457E-04_JPRB, 4.15655E-04_JPRB, 4.44758E-04_JPRB, 4.75899E-04_JPRB, & + & 5.09220E-04_JPRB, 5.44874E-04_JPRB, 5.83024E-04_JPRB, 6.23845E-04_JPRB, 6.67525E-04_JPRB, & + & 7.14263E-04_JPRB, 7.64273E-04_JPRB, 8.17785E-04_JPRB, 8.75043E-04_JPRB/) + KAO_MCO2( 4, :, 2) = (/ & + & 2.46588E-04_JPRB, 2.64630E-04_JPRB, 2.83993E-04_JPRB, 3.04771E-04_JPRB, 3.27071E-04_JPRB, & + & 3.51001E-04_JPRB, 3.76683E-04_JPRB, 4.04244E-04_JPRB, 4.33821E-04_JPRB, 4.65563E-04_JPRB, & + & 4.99627E-04_JPRB, 5.36183E-04_JPRB, 5.75414E-04_JPRB, 6.17515E-04_JPRB, 6.62697E-04_JPRB, & + & 7.11185E-04_JPRB, 7.63220E-04_JPRB, 8.19063E-04_JPRB, 8.78991E-04_JPRB/) + KAO_MCO2( 5, :, 2) = (/ & + & 2.19140E-04_JPRB, 2.36464E-04_JPRB, 2.55158E-04_JPRB, 2.75330E-04_JPRB, 2.97097E-04_JPRB, & + & 3.20585E-04_JPRB, 3.45929E-04_JPRB, 3.73277E-04_JPRB, 4.02787E-04_JPRB, 4.34630E-04_JPRB, & + & 4.68991E-04_JPRB, 5.06068E-04_JPRB, 5.46076E-04_JPRB, 5.89247E-04_JPRB, 6.35831E-04_JPRB, & + & 6.86097E-04_JPRB, 7.40338E-04_JPRB, 7.98867E-04_JPRB, 8.62022E-04_JPRB/) + KAO_MCO2( 6, :, 2) = (/ & + & 1.74073E-04_JPRB, 1.92221E-04_JPRB, 2.12260E-04_JPRB, 2.34388E-04_JPRB, 2.58824E-04_JPRB, & + & 2.85807E-04_JPRB, 3.15603E-04_JPRB, 3.48505E-04_JPRB, 3.84837E-04_JPRB, 4.24957E-04_JPRB, & + & 4.69260E-04_JPRB, 5.18181E-04_JPRB, 5.72202E-04_JPRB, 6.31855E-04_JPRB, 6.97727E-04_JPRB, & + & 7.70466E-04_JPRB, 8.50789E-04_JPRB, 9.39485E-04_JPRB, 1.03743E-03_JPRB/) + KAO_MCO2( 7, :, 2) = (/ & + & 1.74359E-04_JPRB, 1.99276E-04_JPRB, 2.27753E-04_JPRB, 2.60299E-04_JPRB, 2.97497E-04_JPRB, & + & 3.40010E-04_JPRB, 3.88599E-04_JPRB, 4.44130E-04_JPRB, 5.07598E-04_JPRB, 5.80135E-04_JPRB, & + & 6.63039E-04_JPRB, 7.57789E-04_JPRB, 8.66079E-04_JPRB, 9.89845E-04_JPRB, 1.13130E-03_JPRB, & + & 1.29296E-03_JPRB, 1.47773E-03_JPRB, 1.68890E-03_JPRB, 1.93025E-03_JPRB/) + KAO_MCO2( 8, :, 2) = (/ & + & 1.08215E-03_JPRB, 1.20760E-03_JPRB, 1.34759E-03_JPRB, 1.50382E-03_JPRB, 1.67815E-03_JPRB, & + & 1.87270E-03_JPRB, 2.08980E-03_JPRB, 2.33206E-03_JPRB, 2.60242E-03_JPRB, 2.90411E-03_JPRB, & + & 3.24078E-03_JPRB, 3.61648E-03_JPRB, 4.03573E-03_JPRB, 4.50359E-03_JPRB, 5.02568E-03_JPRB, & + & 5.60830E-03_JPRB, 6.25846E-03_JPRB, 6.98399E-03_JPRB, 7.79363E-03_JPRB/) + KAO_MCO2( 9, :, 2) = (/ & + & 1.04969E-04_JPRB, 1.20766E-04_JPRB, 1.38939E-04_JPRB, 1.59848E-04_JPRB, 1.83903E-04_JPRB, & + & 2.11578E-04_JPRB, 2.43418E-04_JPRB, 2.80049E-04_JPRB, 3.22193E-04_JPRB, 3.70678E-04_JPRB, & + & 4.26461E-04_JPRB, 4.90638E-04_JPRB, 5.64472E-04_JPRB, 6.49418E-04_JPRB, 7.47147E-04_JPRB, & + & 8.59583E-04_JPRB, 9.88940E-04_JPRB, 1.13776E-03_JPRB, 1.30898E-03_JPRB/) + KAO_MCO2( 1, :, 3) = (/ & + & 3.72106E-04_JPRB, 3.96252E-04_JPRB, 4.21966E-04_JPRB, 4.49347E-04_JPRB, 4.78506E-04_JPRB, & + & 5.09557E-04_JPRB, 5.42623E-04_JPRB, 5.77834E-04_JPRB, 6.15330E-04_JPRB, 6.55260E-04_JPRB, & + & 6.97781E-04_JPRB, 7.43060E-04_JPRB, 7.91278E-04_JPRB, 8.42626E-04_JPRB, 8.97304E-04_JPRB, & + & 9.55532E-04_JPRB, 1.01754E-03_JPRB, 1.08357E-03_JPRB, 1.15388E-03_JPRB/) + KAO_MCO2( 2, :, 3) = (/ & + & 4.20563E-04_JPRB, 4.46162E-04_JPRB, 4.73319E-04_JPRB, 5.02130E-04_JPRB, 5.32693E-04_JPRB, & + & 5.65118E-04_JPRB, 5.99516E-04_JPRB, 6.36007E-04_JPRB, 6.74720E-04_JPRB, 7.15789E-04_JPRB, & + & 7.59358E-04_JPRB, 8.05579E-04_JPRB, 8.54613E-04_JPRB, 9.06632E-04_JPRB, 9.61817E-04_JPRB, & + & 1.02036E-03_JPRB, 1.08247E-03_JPRB, 1.14836E-03_JPRB, 1.21826E-03_JPRB/) + KAO_MCO2( 3, :, 3) = (/ & + & 4.89664E-04_JPRB, 5.18321E-04_JPRB, 5.48654E-04_JPRB, 5.80764E-04_JPRB, 6.14752E-04_JPRB, & + & 6.50729E-04_JPRB, 6.88812E-04_JPRB, 7.29124E-04_JPRB, 7.71795E-04_JPRB, 8.16963E-04_JPRB, & + & 8.64774E-04_JPRB, 9.15384E-04_JPRB, 9.68955E-04_JPRB, 1.02566E-03_JPRB, 1.08569E-03_JPRB, & + & 1.14922E-03_JPRB, 1.21648E-03_JPRB, 1.28767E-03_JPRB, 1.36303E-03_JPRB/) + KAO_MCO2( 4, :, 3) = (/ & + & 4.61143E-04_JPRB, 4.92198E-04_JPRB, 5.25343E-04_JPRB, 5.60720E-04_JPRB, 5.98480E-04_JPRB, & + & 6.38783E-04_JPRB, 6.81799E-04_JPRB, 7.27713E-04_JPRB, 7.76718E-04_JPRB, 8.29023E-04_JPRB, & + & 8.84851E-04_JPRB, 9.44438E-04_JPRB, 1.00804E-03_JPRB, 1.07592E-03_JPRB, 1.14837E-03_JPRB, & + & 1.22571E-03_JPRB, 1.30825E-03_JPRB, 1.39635E-03_JPRB, 1.49038E-03_JPRB/) + KAO_MCO2( 5, :, 3) = (/ & + & 4.01988E-04_JPRB, 4.36672E-04_JPRB, 4.74349E-04_JPRB, 5.15278E-04_JPRB, 5.59737E-04_JPRB, & + & 6.08032E-04_JPRB, 6.60495E-04_JPRB, 7.17484E-04_JPRB, 7.79390E-04_JPRB, 8.46638E-04_JPRB, & + & 9.19688E-04_JPRB, 9.99041E-04_JPRB, 1.08524E-03_JPRB, 1.17888E-03_JPRB, 1.28059E-03_JPRB, & + & 1.39109E-03_JPRB, 1.51111E-03_JPRB, 1.64149E-03_JPRB, 1.78313E-03_JPRB/) + KAO_MCO2( 6, :, 3) = (/ & + & 3.35536E-04_JPRB, 3.74371E-04_JPRB, 4.17700E-04_JPRB, 4.66045E-04_JPRB, 5.19985E-04_JPRB, & + & 5.80169E-04_JPRB, 6.47318E-04_JPRB, 7.22238E-04_JPRB, 8.05831E-04_JPRB, 8.99098E-04_JPRB, & + & 1.00316E-03_JPRB, 1.11927E-03_JPRB, 1.24881E-03_JPRB, 1.39335E-03_JPRB, 1.55461E-03_JPRB, & + & 1.73455E-03_JPRB, 1.93530E-03_JPRB, 2.15930E-03_JPRB, 2.40921E-03_JPRB/) + KAO_MCO2( 7, :, 3) = (/ & + & 3.24677E-04_JPRB, 3.75160E-04_JPRB, 4.33491E-04_JPRB, 5.00893E-04_JPRB, 5.78774E-04_JPRB, & + & 6.68765E-04_JPRB, 7.72749E-04_JPRB, 8.92900E-04_JPRB, 1.03173E-03_JPRB, 1.19215E-03_JPRB, & + & 1.37751E-03_JPRB, 1.59170E-03_JPRB, 1.83918E-03_JPRB, 2.12515E-03_JPRB, 2.45558E-03_JPRB, & + & 2.83738E-03_JPRB, 3.27856E-03_JPRB, 3.78832E-03_JPRB, 4.37735E-03_JPRB/) + KAO_MCO2( 8, :, 3) = (/ & + & 2.24656E-03_JPRB, 2.45550E-03_JPRB, 2.68386E-03_JPRB, 2.93347E-03_JPRB, 3.20629E-03_JPRB, & + & 3.50448E-03_JPRB, 3.83041E-03_JPRB, 4.18665E-03_JPRB, 4.57602E-03_JPRB, 5.00160E-03_JPRB, & + & 5.46677E-03_JPRB, 5.97519E-03_JPRB, 6.53090E-03_JPRB, 7.13829E-03_JPRB, 7.80217E-03_JPRB, & + & 8.52780E-03_JPRB, 9.32091E-03_JPRB, 1.01878E-02_JPRB, 1.11353E-02_JPRB/) + KAO_MCO2( 9, :, 3) = (/ & + & 2.07746E-04_JPRB, 2.38909E-04_JPRB, 2.74746E-04_JPRB, 3.15959E-04_JPRB, 3.63355E-04_JPRB, & + & 4.17860E-04_JPRB, 4.80541E-04_JPRB, 5.52625E-04_JPRB, 6.35521E-04_JPRB, 7.30852E-04_JPRB, & + & 8.40484E-04_JPRB, 9.66561E-04_JPRB, 1.11155E-03_JPRB, 1.27829E-03_JPRB, 1.47004E-03_JPRB, & + & 1.69055E-03_JPRB, 1.94414E-03_JPRB, 2.23577E-03_JPRB, 2.57115E-03_JPRB/) + KAO_MCO2( 1, :, 4) = (/ & + & 7.26052E-04_JPRB, 7.62476E-04_JPRB, 8.00726E-04_JPRB, 8.40896E-04_JPRB, 8.83081E-04_JPRB, & + & 9.27382E-04_JPRB, 9.73905E-04_JPRB, 1.02276E-03_JPRB, 1.07407E-03_JPRB, 1.12795E-03_JPRB, & + & 1.18454E-03_JPRB, 1.24396E-03_JPRB, 1.30637E-03_JPRB, 1.37190E-03_JPRB, 1.44073E-03_JPRB, & + & 1.51300E-03_JPRB, 1.58890E-03_JPRB, 1.66861E-03_JPRB, 1.75232E-03_JPRB/) + KAO_MCO2( 2, :, 4) = (/ & + & 4.65815E-04_JPRB, 5.01167E-04_JPRB, 5.39203E-04_JPRB, 5.80126E-04_JPRB, 6.24154E-04_JPRB, & + & 6.71524E-04_JPRB, 7.22489E-04_JPRB, 7.77322E-04_JPRB, 8.36316E-04_JPRB, 8.99788E-04_JPRB, & + & 9.68077E-04_JPRB, 1.04155E-03_JPRB, 1.12060E-03_JPRB, 1.20564E-03_JPRB, 1.29714E-03_JPRB, & + & 1.39559E-03_JPRB, 1.50151E-03_JPRB, 1.61546E-03_JPRB, 1.73807E-03_JPRB/) + KAO_MCO2( 3, :, 4) = (/ & + & 3.56225E-04_JPRB, 3.93073E-04_JPRB, 4.33732E-04_JPRB, 4.78598E-04_JPRB, 5.28105E-04_JPRB, & + & 5.82732E-04_JPRB, 6.43010E-04_JPRB, 7.09524E-04_JPRB, 7.82918E-04_JPRB, 8.63903E-04_JPRB, & + & 9.53266E-04_JPRB, 1.05187E-03_JPRB, 1.16068E-03_JPRB, 1.28074E-03_JPRB, 1.41322E-03_JPRB, & + & 1.55941E-03_JPRB, 1.72071E-03_JPRB, 1.89870E-03_JPRB, 2.09511E-03_JPRB/) + KAO_MCO2( 4, :, 4) = (/ & + & 3.37845E-04_JPRB, 3.79675E-04_JPRB, 4.26684E-04_JPRB, 4.79514E-04_JPRB, 5.38884E-04_JPRB, & + & 6.05606E-04_JPRB, 6.80589E-04_JPRB, 7.64855E-04_JPRB, 8.59555E-04_JPRB, 9.65980E-04_JPRB, & + & 1.08558E-03_JPRB, 1.21999E-03_JPRB, 1.37105E-03_JPRB, 1.54080E-03_JPRB, 1.73157E-03_JPRB, & + & 1.94597E-03_JPRB, 2.18691E-03_JPRB, 2.45767E-03_JPRB, 2.76197E-03_JPRB/) + KAO_MCO2( 5, :, 4) = (/ & + & 3.52456E-04_JPRB, 4.02782E-04_JPRB, 4.60294E-04_JPRB, 5.26017E-04_JPRB, 6.01126E-04_JPRB, & + & 6.86958E-04_JPRB, 7.85046E-04_JPRB, 8.97140E-04_JPRB, 1.02524E-03_JPRB, 1.17163E-03_JPRB, & + & 1.33892E-03_JPRB, 1.53010E-03_JPRB, 1.74858E-03_JPRB, 1.99825E-03_JPRB, 2.28358E-03_JPRB, & + & 2.60964E-03_JPRB, 2.98226E-03_JPRB, 3.40809E-03_JPRB, 3.89471E-03_JPRB/) + KAO_MCO2( 6, :, 4) = (/ & + & 4.42884E-04_JPRB, 5.08187E-04_JPRB, 5.83119E-04_JPRB, 6.69100E-04_JPRB, 7.67758E-04_JPRB, & + & 8.80963E-04_JPRB, 1.01086E-03_JPRB, 1.15991E-03_JPRB, 1.33094E-03_JPRB, 1.52718E-03_JPRB, & + & 1.75237E-03_JPRB, 2.01075E-03_JPRB, 2.30724E-03_JPRB, 2.64744E-03_JPRB, 3.03780E-03_JPRB, & + & 3.48572E-03_JPRB, 3.99969E-03_JPRB, 4.58944E-03_JPRB, 5.26614E-03_JPRB/) + KAO_MCO2( 7, :, 4) = (/ & + & 8.09850E-04_JPRB, 9.09940E-04_JPRB, 1.02240E-03_JPRB, 1.14876E-03_JPRB, 1.29074E-03_JPRB, & + & 1.45026E-03_JPRB, 1.62950E-03_JPRB, 1.83089E-03_JPRB, 2.05718E-03_JPRB, 2.31143E-03_JPRB, & + & 2.59710E-03_JPRB, 2.91808E-03_JPRB, 3.27873E-03_JPRB, 3.68395E-03_JPRB, 4.13926E-03_JPRB, & + & 4.65083E-03_JPRB, 5.22564E-03_JPRB, 5.87148E-03_JPRB, 6.59715E-03_JPRB/) + KAO_MCO2( 8, :, 4) = (/ & + & 3.13265E-03_JPRB, 3.42454E-03_JPRB, 3.74362E-03_JPRB, 4.09243E-03_JPRB, 4.47375E-03_JPRB, & + & 4.89059E-03_JPRB, 5.34627E-03_JPRB, 5.84441E-03_JPRB, 6.38897E-03_JPRB, 6.98426E-03_JPRB, & + & 7.63502E-03_JPRB, 8.34642E-03_JPRB, 9.12409E-03_JPRB, 9.97423E-03_JPRB, 1.09036E-02_JPRB, & + & 1.19195E-02_JPRB, 1.30301E-02_JPRB, 1.42442E-02_JPRB, 1.55714E-02_JPRB/) + KAO_MCO2( 9, :, 4) = (/ & + & 5.71287E-04_JPRB, 6.51252E-04_JPRB, 7.42411E-04_JPRB, 8.46330E-04_JPRB, 9.64794E-04_JPRB, & + & 1.09984E-03_JPRB, 1.25379E-03_JPRB, 1.42929E-03_JPRB, 1.62935E-03_JPRB, 1.85742E-03_JPRB, & + & 2.11741E-03_JPRB, 2.41380E-03_JPRB, 2.75167E-03_JPRB, 3.13683E-03_JPRB, 3.57591E-03_JPRB, & + & 4.07645E-03_JPRB, 4.64705E-03_JPRB, 5.29751E-03_JPRB, 6.03903E-03_JPRB/) + KAO_MCO2( 1, :, 5) = (/ & + & 2.92395E-04_JPRB, 3.32719E-04_JPRB, 3.78604E-04_JPRB, 4.30818E-04_JPRB, 4.90232E-04_JPRB, & + & 5.57839E-04_JPRB, 6.34771E-04_JPRB, 7.22312E-04_JPRB, 8.21927E-04_JPRB, 9.35278E-04_JPRB, & + & 1.06426E-03_JPRB, 1.21104E-03_JPRB, 1.37805E-03_JPRB, 1.56810E-03_JPRB, 1.78435E-03_JPRB, & + & 2.03043E-03_JPRB, 2.31045E-03_JPRB, 2.62908E-03_JPRB, 2.99166E-03_JPRB/) + KAO_MCO2( 2, :, 5) = (/ & + & 3.13069E-04_JPRB, 3.61343E-04_JPRB, 4.17061E-04_JPRB, 4.81371E-04_JPRB, 5.55597E-04_JPRB, & + & 6.41269E-04_JPRB, 7.40151E-04_JPRB, 8.54280E-04_JPRB, 9.86008E-04_JPRB, 1.13805E-03_JPRB, & + & 1.31353E-03_JPRB, 1.51608E-03_JPRB, 1.74985E-03_JPRB, 2.01967E-03_JPRB, 2.33110E-03_JPRB, & + & 2.69055E-03_JPRB, 3.10543E-03_JPRB, 3.58427E-03_JPRB, 4.13696E-03_JPRB/) + KAO_MCO2( 3, :, 5) = (/ & + & 3.06937E-04_JPRB, 3.57841E-04_JPRB, 4.17187E-04_JPRB, 4.86375E-04_JPRB, 5.67038E-04_JPRB, & + & 6.61078E-04_JPRB, 7.70714E-04_JPRB, 8.98532E-04_JPRB, 1.04755E-03_JPRB, 1.22128E-03_JPRB, & + & 1.42382E-03_JPRB, 1.65996E-03_JPRB, 1.93525E-03_JPRB, 2.25620E-03_JPRB, 2.63038E-03_JPRB, & + & 3.06661E-03_JPRB, 3.57519E-03_JPRB, 4.16812E-03_JPRB, 4.85937E-03_JPRB/) + KAO_MCO2( 4, :, 5) = (/ & + & 4.06428E-04_JPRB, 4.72379E-04_JPRB, 5.49033E-04_JPRB, 6.38125E-04_JPRB, 7.41674E-04_JPRB, & + & 8.62026E-04_JPRB, 1.00191E-03_JPRB, 1.16449E-03_JPRB, 1.35345E-03_JPRB, 1.57308E-03_JPRB, & + & 1.82834E-03_JPRB, 2.12503E-03_JPRB, 2.46986E-03_JPRB, 2.87064E-03_JPRB, 3.33647E-03_JPRB, & + & 3.87788E-03_JPRB, 4.50715E-03_JPRB, 5.23852E-03_JPRB, 6.08858E-03_JPRB/) + KAO_MCO2( 5, :, 5) = (/ & + & 6.01967E-04_JPRB, 6.90414E-04_JPRB, 7.91856E-04_JPRB, 9.08204E-04_JPRB, 1.04165E-03_JPRB, & + & 1.19470E-03_JPRB, 1.37023E-03_JPRB, 1.57156E-03_JPRB, 1.80247E-03_JPRB, 2.06731E-03_JPRB, & + & 2.37106E-03_JPRB, 2.71944E-03_JPRB, 3.11901E-03_JPRB, 3.57729E-03_JPRB, 4.10290E-03_JPRB, & + & 4.70574E-03_JPRB, 5.39716E-03_JPRB, 6.19017E-03_JPRB, 7.09969E-03_JPRB/) + KAO_MCO2( 6, :, 5) = (/ & + & 1.11622E-03_JPRB, 1.25799E-03_JPRB, 1.41776E-03_JPRB, 1.59783E-03_JPRB, 1.80077E-03_JPRB, & + & 2.02947E-03_JPRB, 2.28723E-03_JPRB, 2.57773E-03_JPRB, 2.90512E-03_JPRB, 3.27408E-03_JPRB, & + & 3.68992E-03_JPRB, 4.15856E-03_JPRB, 4.68673E-03_JPRB, 5.28197E-03_JPRB, 5.95282E-03_JPRB, & + & 6.70887E-03_JPRB, 7.56094E-03_JPRB, 8.52123E-03_JPRB, 9.60348E-03_JPRB/) + KAO_MCO2( 7, :, 5) = (/ & + & 3.63860E-03_JPRB, 3.96164E-03_JPRB, 4.31337E-03_JPRB, 4.69632E-03_JPRB, 5.11327E-03_JPRB, & + & 5.56724E-03_JPRB, 6.06151E-03_JPRB, 6.59967E-03_JPRB, 7.18561E-03_JPRB, 7.82356E-03_JPRB, & + & 8.51816E-03_JPRB, 9.27443E-03_JPRB, 1.00978E-02_JPRB, 1.09943E-02_JPRB, 1.19705E-02_JPRB, & + & 1.30332E-02_JPRB, 1.41904E-02_JPRB, 1.54502E-02_JPRB, 1.68219E-02_JPRB/) + KAO_MCO2( 8, :, 5) = (/ & + & 5.96957E-03_JPRB, 6.53049E-03_JPRB, 7.14412E-03_JPRB, 7.81541E-03_JPRB, 8.54977E-03_JPRB, & + & 9.35314E-03_JPRB, 1.02320E-02_JPRB, 1.11934E-02_JPRB, 1.22452E-02_JPRB, 1.33958E-02_JPRB, & + & 1.46545E-02_JPRB, 1.60315E-02_JPRB, 1.75379E-02_JPRB, 1.91858E-02_JPRB, 2.09886E-02_JPRB, & + & 2.29608E-02_JPRB, 2.51182E-02_JPRB, 2.74784E-02_JPRB, 3.00604E-02_JPRB/) + KAO_MCO2( 9, :, 5) = (/ & + & 1.19381E-03_JPRB, 1.33882E-03_JPRB, 1.50143E-03_JPRB, 1.68379E-03_JPRB, 1.88831E-03_JPRB, & + & 2.11767E-03_JPRB, 2.37488E-03_JPRB, 2.66333E-03_JPRB, 2.98683E-03_JPRB, 3.34961E-03_JPRB, & + & 3.75646E-03_JPRB, 4.21272E-03_JPRB, 4.72440E-03_JPRB, 5.29823E-03_JPRB, 5.94176E-03_JPRB, & + & 6.66345E-03_JPRB, 7.47280E-03_JPRB, 8.38045E-03_JPRB, 9.39835E-03_JPRB/) + KAO_MCO2( 1, :, 6) = (/ & + & 4.12429E-04_JPRB, 4.84830E-04_JPRB, 5.69942E-04_JPRB, 6.69995E-04_JPRB, 7.87613E-04_JPRB, & + & 9.25878E-04_JPRB, 1.08842E-03_JPRB, 1.27949E-03_JPRB, 1.50410E-03_JPRB, 1.76814E-03_JPRB, & + & 2.07854E-03_JPRB, 2.44343E-03_JPRB, 2.87237E-03_JPRB, 3.37662E-03_JPRB, 3.96938E-03_JPRB, & + & 4.66621E-03_JPRB, 5.48536E-03_JPRB, 6.44831E-03_JPRB, 7.58031E-03_JPRB/) + KAO_MCO2( 2, :, 6) = (/ & + & 6.43498E-04_JPRB, 7.46132E-04_JPRB, 8.65134E-04_JPRB, 1.00312E-03_JPRB, 1.16311E-03_JPRB, & + & 1.34861E-03_JPRB, 1.56371E-03_JPRB, 1.81310E-03_JPRB, 2.10228E-03_JPRB, 2.43758E-03_JPRB, & + & 2.82635E-03_JPRB, 3.27714E-03_JPRB, 3.79981E-03_JPRB, 4.40586E-03_JPRB, 5.10855E-03_JPRB, & + & 5.92333E-03_JPRB, 6.86806E-03_JPRB, 7.96346E-03_JPRB, 9.23357E-03_JPRB/) + KAO_MCO2( 3, :, 6) = (/ & + & 1.11336E-03_JPRB, 1.26910E-03_JPRB, 1.44662E-03_JPRB, 1.64897E-03_JPRB, 1.87962E-03_JPRB, & + & 2.14254E-03_JPRB, 2.44224E-03_JPRB, 2.78385E-03_JPRB, 3.17325E-03_JPRB, 3.61712E-03_JPRB, & + & 4.12308E-03_JPRB, 4.69981E-03_JPRB, 5.35720E-03_JPRB, 6.10656E-03_JPRB, 6.96073E-03_JPRB, & + & 7.93439E-03_JPRB, 9.04424E-03_JPRB, 1.03093E-02_JPRB, 1.17514E-02_JPRB/) + KAO_MCO2( 4, :, 6) = (/ & + & 1.87991E-03_JPRB, 2.10276E-03_JPRB, 2.35202E-03_JPRB, 2.63082E-03_JPRB, 2.94268E-03_JPRB, & + & 3.29150E-03_JPRB, 3.68168E-03_JPRB, 4.11810E-03_JPRB, 4.60626E-03_JPRB, 5.15228E-03_JPRB, & + & 5.76303E-03_JPRB, 6.44617E-03_JPRB, 7.21030E-03_JPRB, 8.06500E-03_JPRB, 9.02102E-03_JPRB, & + & 1.00904E-02_JPRB, 1.12865E-02_JPRB, 1.26244E-02_JPRB, 1.41208E-02_JPRB/) + KAO_MCO2( 5, :, 6) = (/ & + & 3.65848E-03_JPRB, 4.01372E-03_JPRB, 4.40346E-03_JPRB, 4.83104E-03_JPRB, 5.30015E-03_JPRB, & + & 5.81480E-03_JPRB, 6.37943E-03_JPRB, 6.99888E-03_JPRB, 7.67849E-03_JPRB, 8.42408E-03_JPRB, & + & 9.24208E-03_JPRB, 1.01395E-02_JPRB, 1.11241E-02_JPRB, 1.22042E-02_JPRB, 1.33893E-02_JPRB, & + & 1.46894E-02_JPRB, 1.61158E-02_JPRB, 1.76806E-02_JPRB, 1.93975E-02_JPRB/) + KAO_MCO2( 6, :, 6) = (/ & + & 5.38476E-03_JPRB, 5.85088E-03_JPRB, 6.35735E-03_JPRB, 6.90765E-03_JPRB, 7.50560E-03_JPRB, & + & 8.15530E-03_JPRB, 8.86124E-03_JPRB, 9.62829E-03_JPRB, 1.04617E-02_JPRB, 1.13673E-02_JPRB, & + & 1.23513E-02_JPRB, 1.34205E-02_JPRB, 1.45822E-02_JPRB, 1.58445E-02_JPRB, 1.72160E-02_JPRB, & + & 1.87062E-02_JPRB, 2.03255E-02_JPRB, 2.20849E-02_JPRB, 2.39966E-02_JPRB/) + KAO_MCO2( 7, :, 6) = (/ & + & 6.27017E-03_JPRB, 6.84772E-03_JPRB, 7.47846E-03_JPRB, 8.16731E-03_JPRB, 8.91960E-03_JPRB, & + & 9.74118E-03_JPRB, 1.06384E-02_JPRB, 1.16183E-02_JPRB, 1.26885E-02_JPRB, 1.38573E-02_JPRB, & + & 1.51336E-02_JPRB, 1.65276E-02_JPRB, 1.80500E-02_JPRB, 1.97125E-02_JPRB, 2.15283E-02_JPRB, & + & 2.35112E-02_JPRB, 2.56769E-02_JPRB, 2.80420E-02_JPRB, 3.06249E-02_JPRB/) + KAO_MCO2( 8, :, 6) = (/ & + & 9.61932E-03_JPRB, 1.04802E-02_JPRB, 1.14182E-02_JPRB, 1.24401E-02_JPRB, 1.35534E-02_JPRB, & + & 1.47664E-02_JPRB, 1.60880E-02_JPRB, 1.75278E-02_JPRB, 1.90965E-02_JPRB, 2.08056E-02_JPRB, & + & 2.26677E-02_JPRB, 2.46964E-02_JPRB, 2.69066E-02_JPRB, 2.93147E-02_JPRB, 3.19383E-02_JPRB, & + & 3.47967E-02_JPRB, 3.79110E-02_JPRB, 4.13039E-02_JPRB, 4.50005E-02_JPRB/) + KAO_MCO2( 9, :, 6) = (/ & + & 2.37921E-03_JPRB, 2.64556E-03_JPRB, 2.94173E-03_JPRB, 3.27105E-03_JPRB, 3.63724E-03_JPRB, & + & 4.04442E-03_JPRB, 4.49718E-03_JPRB, 5.00064E-03_JPRB, 5.56045E-03_JPRB, 6.18293E-03_JPRB, & + & 6.87510E-03_JPRB, 7.64475E-03_JPRB, 8.50057E-03_JPRB, 9.45219E-03_JPRB, 1.05103E-02_JPRB, & + & 1.16870E-02_JPRB, 1.29953E-02_JPRB, 1.44501E-02_JPRB, 1.60677E-02_JPRB/) + KAO_MCO2( 1, :, 7) = (/ & + & 4.64970E-03_JPRB, 5.13188E-03_JPRB, 5.66406E-03_JPRB, 6.25144E-03_JPRB, 6.89972E-03_JPRB, & + & 7.61523E-03_JPRB, 8.40493E-03_JPRB, 9.27654E-03_JPRB, 1.02385E-02_JPRB, 1.13003E-02_JPRB, & + & 1.24721E-02_JPRB, 1.37655E-02_JPRB, 1.51930E-02_JPRB, 1.67685E-02_JPRB, 1.85075E-02_JPRB, & + & 2.04267E-02_JPRB, 2.25450E-02_JPRB, 2.48829E-02_JPRB, 2.74633E-02_JPRB/) + KAO_MCO2( 2, :, 7) = (/ & + & 6.37148E-03_JPRB, 6.96805E-03_JPRB, 7.62046E-03_JPRB, 8.33397E-03_JPRB, 9.11428E-03_JPRB, & + & 9.96765E-03_JPRB, 1.09009E-02_JPRB, 1.19216E-02_JPRB, 1.30378E-02_JPRB, 1.42585E-02_JPRB, & + & 1.55935E-02_JPRB, 1.70536E-02_JPRB, 1.86503E-02_JPRB, 2.03965E-02_JPRB, 2.23062E-02_JPRB, & + & 2.43948E-02_JPRB, 2.66789E-02_JPRB, 2.91768E-02_JPRB, 3.19086E-02_JPRB/) + KAO_MCO2( 3, :, 7) = (/ & + & 7.79364E-03_JPRB, 8.48097E-03_JPRB, 9.22892E-03_JPRB, 1.00428E-02_JPRB, 1.09285E-02_JPRB, & + & 1.18923E-02_JPRB, 1.29411E-02_JPRB, 1.40825E-02_JPRB, 1.53244E-02_JPRB, 1.66759E-02_JPRB, & + & 1.81466E-02_JPRB, 1.97470E-02_JPRB, 2.14885E-02_JPRB, 2.33836E-02_JPRB, 2.54458E-02_JPRB, & + & 2.76899E-02_JPRB, 3.01320E-02_JPRB, 3.27893E-02_JPRB, 3.56811E-02_JPRB/) + KAO_MCO2( 4, :, 7) = (/ & + & 8.70586E-03_JPRB, 9.48737E-03_JPRB, 1.03390E-02_JPRB, 1.12672E-02_JPRB, 1.22786E-02_JPRB, & + & 1.33808E-02_JPRB, 1.45820E-02_JPRB, 1.58910E-02_JPRB, 1.73175E-02_JPRB, 1.88721E-02_JPRB, & + & 2.05662E-02_JPRB, 2.24124E-02_JPRB, 2.44243E-02_JPRB, 2.66169E-02_JPRB, 2.90062E-02_JPRB, & + & 3.16101E-02_JPRB, 3.44477E-02_JPRB, 3.75400E-02_JPRB, 4.09099E-02_JPRB/) + KAO_MCO2( 5, :, 7) = (/ & + & 9.24510E-03_JPRB, 1.00865E-02_JPRB, 1.10045E-02_JPRB, 1.20061E-02_JPRB, 1.30988E-02_JPRB, & + & 1.42910E-02_JPRB, 1.55916E-02_JPRB, 1.70106E-02_JPRB, 1.85588E-02_JPRB, 2.02479E-02_JPRB, & + & 2.20908E-02_JPRB, 2.41013E-02_JPRB, 2.62948E-02_JPRB, 2.86880E-02_JPRB, 3.12990E-02_JPRB, & + & 3.41476E-02_JPRB, 3.72555E-02_JPRB, 4.06462E-02_JPRB, 4.43455E-02_JPRB/) + KAO_MCO2( 6, :, 7) = (/ & + & 1.09559E-02_JPRB, 1.19933E-02_JPRB, 1.31290E-02_JPRB, 1.43722E-02_JPRB, 1.57331E-02_JPRB, & + & 1.72229E-02_JPRB, 1.88537E-02_JPRB, 2.06390E-02_JPRB, 2.25933E-02_JPRB, 2.47327E-02_JPRB, & + & 2.70747E-02_JPRB, 2.96384E-02_JPRB, 3.24449E-02_JPRB, 3.55171E-02_JPRB, 3.88802E-02_JPRB, & + & 4.25619E-02_JPRB, 4.65921E-02_JPRB, 5.10039E-02_JPRB, 5.58335E-02_JPRB/) + KAO_MCO2( 7, :, 7) = (/ & + & 1.36116E-02_JPRB, 1.48659E-02_JPRB, 1.62357E-02_JPRB, 1.77318E-02_JPRB, 1.93657E-02_JPRB, & + & 2.11502E-02_JPRB, 2.30991E-02_JPRB, 2.52276E-02_JPRB, 2.75522E-02_JPRB, 3.00910E-02_JPRB, & + & 3.28638E-02_JPRB, 3.58921E-02_JPRB, 3.91995E-02_JPRB, 4.28116E-02_JPRB, 4.67565E-02_JPRB, & + & 5.10650E-02_JPRB, 5.57704E-02_JPRB, 6.09095E-02_JPRB, 6.65221E-02_JPRB/) + KAO_MCO2( 8, :, 7) = (/ & + & 1.51783E-02_JPRB, 1.64551E-02_JPRB, 1.78392E-02_JPRB, 1.93399E-02_JPRB, 2.09667E-02_JPRB, & + & 2.27304E-02_JPRB, 2.46424E-02_JPRB, 2.67153E-02_JPRB, 2.89626E-02_JPRB, 3.13988E-02_JPRB, & + & 3.40401E-02_JPRB, 3.69035E-02_JPRB, 4.00077E-02_JPRB, 4.33731E-02_JPRB, 4.70216E-02_JPRB, & + & 5.09770E-02_JPRB, 5.52651E-02_JPRB, 5.99139E-02_JPRB, 6.49538E-02_JPRB/) + KAO_MCO2( 9, :, 7) = (/ & + & 1.00072E-02_JPRB, 1.08638E-02_JPRB, 1.17937E-02_JPRB, 1.28032E-02_JPRB, 1.38991E-02_JPRB, & + & 1.50888E-02_JPRB, 1.63803E-02_JPRB, 1.77824E-02_JPRB, 1.93045E-02_JPRB, 2.09568E-02_JPRB, & + & 2.27507E-02_JPRB, 2.46980E-02_JPRB, 2.68120E-02_JPRB, 2.91070E-02_JPRB, 3.15984E-02_JPRB, & + & 3.43031E-02_JPRB, 3.72393E-02_JPRB, 4.04268E-02_JPRB, 4.38872E-02_JPRB/) + KAO_MCO2( 1, :, 8) = (/ & + & 1.59610E-02_JPRB, 1.74387E-02_JPRB, 1.90532E-02_JPRB, 2.08171E-02_JPRB, 2.27444E-02_JPRB, & + & 2.48501E-02_JPRB, 2.71508E-02_JPRB, 2.96645E-02_JPRB, 3.24109E-02_JPRB, 3.54115E-02_JPRB, & + & 3.86900E-02_JPRB, 4.22720E-02_JPRB, 4.61856E-02_JPRB, 5.04616E-02_JPRB, 5.51334E-02_JPRB, & + & 6.02378E-02_JPRB, 6.58147E-02_JPRB, 7.19079E-02_JPRB, 7.85653E-02_JPRB/) + KAO_MCO2( 2, :, 8) = (/ & + & 1.61961E-02_JPRB, 1.76986E-02_JPRB, 1.93405E-02_JPRB, 2.11348E-02_JPRB, 2.30955E-02_JPRB, & + & 2.52381E-02_JPRB, 2.75794E-02_JPRB, 3.01380E-02_JPRB, 3.29340E-02_JPRB, 3.59893E-02_JPRB, & + & 3.93280E-02_JPRB, 4.29766E-02_JPRB, 4.69636E-02_JPRB, 5.13204E-02_JPRB, 5.60815E-02_JPRB, & + & 6.12843E-02_JPRB, 6.69697E-02_JPRB, 7.31826E-02_JPRB, 7.99718E-02_JPRB/) + KAO_MCO2( 3, :, 8) = (/ & + & 1.72034E-02_JPRB, 1.88241E-02_JPRB, 2.05974E-02_JPRB, 2.25377E-02_JPRB, 2.46609E-02_JPRB, & + & 2.69841E-02_JPRB, 2.95261E-02_JPRB, 3.23076E-02_JPRB, 3.53511E-02_JPRB, 3.86813E-02_JPRB, & + & 4.23253E-02_JPRB, 4.63126E-02_JPRB, 5.06754E-02_JPRB, 5.54493E-02_JPRB, 6.06728E-02_JPRB, & + & 6.63885E-02_JPRB, 7.26426E-02_JPRB, 7.94859E-02_JPRB, 8.69738E-02_JPRB/) + KAO_MCO2( 4, :, 8) = (/ & + & 1.79777E-02_JPRB, 1.96517E-02_JPRB, 2.14815E-02_JPRB, 2.34817E-02_JPRB, 2.56682E-02_JPRB, & + & 2.80583E-02_JPRB, 3.06709E-02_JPRB, 3.35268E-02_JPRB, 3.66486E-02_JPRB, 4.00611E-02_JPRB, & + & 4.37914E-02_JPRB, 4.78690E-02_JPRB, 5.23262E-02_JPRB, 5.71985E-02_JPRB, 6.25245E-02_JPRB, & + & 6.83464E-02_JPRB, 7.47104E-02_JPRB, 8.16670E-02_JPRB, 8.92713E-02_JPRB/) + KAO_MCO2( 5, :, 8) = (/ & + & 2.02540E-02_JPRB, 2.21214E-02_JPRB, 2.41610E-02_JPRB, 2.63887E-02_JPRB, 2.88218E-02_JPRB, & + & 3.14792E-02_JPRB, 3.43816E-02_JPRB, 3.75516E-02_JPRB, 4.10139E-02_JPRB, 4.47954E-02_JPRB, & + & 4.89256E-02_JPRB, 5.34366E-02_JPRB, 5.83635E-02_JPRB, 6.37447E-02_JPRB, 6.96220E-02_JPRB, & + & 7.60413E-02_JPRB, 8.30523E-02_JPRB, 9.07098E-02_JPRB, 9.90734E-02_JPRB/) + KAO_MCO2( 6, :, 8) = (/ & + & 2.19009E-02_JPRB, 2.38517E-02_JPRB, 2.59762E-02_JPRB, 2.82899E-02_JPRB, 3.08097E-02_JPRB, & + & 3.35540E-02_JPRB, 3.65427E-02_JPRB, 3.97976E-02_JPRB, 4.33424E-02_JPRB, 4.72030E-02_JPRB, & + & 5.14074E-02_JPRB, 5.59863E-02_JPRB, 6.09731E-02_JPRB, 6.64040E-02_JPRB, 7.23187E-02_JPRB, & + & 7.87603E-02_JPRB, 8.57755E-02_JPRB, 9.34157E-02_JPRB, 1.01736E-01_JPRB/) + KAO_MCO2( 7, :, 8) = (/ & + & 2.52383E-02_JPRB, 2.73978E-02_JPRB, 2.97421E-02_JPRB, 3.22869E-02_JPRB, 3.50496E-02_JPRB, & + & 3.80486E-02_JPRB, 4.13042E-02_JPRB, 4.48383E-02_JPRB, 4.86749E-02_JPRB, 5.28397E-02_JPRB, & + & 5.73610E-02_JPRB, 6.22690E-02_JPRB, 6.75970E-02_JPRB, 7.33810E-02_JPRB, 7.96598E-02_JPRB, & + & 8.64758E-02_JPRB, 9.38751E-02_JPRB, 1.01907E-01_JPRB, 1.10627E-01_JPRB/) + KAO_MCO2( 8, :, 8) = (/ & + & 3.36506E-02_JPRB, 3.59288E-02_JPRB, 3.83613E-02_JPRB, 4.09584E-02_JPRB, 4.37313E-02_JPRB, & + & 4.66920E-02_JPRB, 4.98531E-02_JPRB, 5.32283E-02_JPRB, 5.68319E-02_JPRB, 6.06795E-02_JPRB, & + & 6.47876E-02_JPRB, 6.91739E-02_JPRB, 7.38570E-02_JPRB, 7.88573E-02_JPRB, 8.41960E-02_JPRB, & + & 8.98962E-02_JPRB, 9.59824E-02_JPRB, 1.02481E-01_JPRB, 1.09419E-01_JPRB/) + KAO_MCO2( 9, :, 8) = (/ & + & 2.15151E-02_JPRB, 2.34420E-02_JPRB, 2.55415E-02_JPRB, 2.78291E-02_JPRB, 3.03215E-02_JPRB, & + & 3.30372E-02_JPRB, 3.59961E-02_JPRB, 3.92200E-02_JPRB, 4.27326E-02_JPRB, 4.65598E-02_JPRB, & + & 5.07299E-02_JPRB, 5.52734E-02_JPRB, 6.02238E-02_JPRB, 6.56176E-02_JPRB, 7.14944E-02_JPRB, & + & 7.78977E-02_JPRB, 8.48744E-02_JPRB, 9.24759E-02_JPRB, 1.00758E-01_JPRB/) + KAO_MCO2( 1, :, 9) = (/ & + & 3.34296E-02_JPRB, 3.64437E-02_JPRB, 3.97294E-02_JPRB, 4.33114E-02_JPRB, 4.72164E-02_JPRB, & + & 5.14734E-02_JPRB, 5.61143E-02_JPRB, 6.11735E-02_JPRB, 6.66890E-02_JPRB, 7.27016E-02_JPRB, & + & 7.92564E-02_JPRB, 8.64022E-02_JPRB, 9.41922E-02_JPRB, 1.02685E-01_JPRB, 1.11943E-01_JPRB, & + & 1.22035E-01_JPRB, 1.33038E-01_JPRB, 1.45033E-01_JPRB, 1.58109E-01_JPRB/) + KAO_MCO2( 2, :, 9) = (/ & + & 3.73946E-02_JPRB, 4.07543E-02_JPRB, 4.44160E-02_JPRB, 4.84066E-02_JPRB, 5.27558E-02_JPRB, & + & 5.74958E-02_JPRB, 6.26616E-02_JPRB, 6.82915E-02_JPRB, 7.44273E-02_JPRB, 8.11144E-02_JPRB, & + & 8.84023E-02_JPRB, 9.63449E-02_JPRB, 1.05001E-01_JPRB, 1.14435E-01_JPRB, 1.24717E-01_JPRB, & + & 1.35922E-01_JPRB, 1.48135E-01_JPRB, 1.61444E-01_JPRB, 1.75949E-01_JPRB/) + KAO_MCO2( 3, :, 9) = (/ & + & 4.24539E-02_JPRB, 4.61192E-02_JPRB, 5.01010E-02_JPRB, 5.44265E-02_JPRB, 5.91255E-02_JPRB, & + & 6.42302E-02_JPRB, 6.97756E-02_JPRB, 7.57998E-02_JPRB, 8.23442E-02_JPRB, 8.94535E-02_JPRB, & + & 9.71766E-02_JPRB, 1.05566E-01_JPRB, 1.14681E-01_JPRB, 1.24582E-01_JPRB, 1.35338E-01_JPRB, & + & 1.47022E-01_JPRB, 1.59716E-01_JPRB, 1.73505E-01_JPRB, 1.88485E-01_JPRB/) + KAO_MCO2( 4, :, 9) = (/ & + & 5.30296E-02_JPRB, 5.73416E-02_JPRB, 6.20043E-02_JPRB, 6.70462E-02_JPRB, 7.24980E-02_JPRB, & + & 7.83931E-02_JPRB, 8.47676E-02_JPRB, 9.16604E-02_JPRB, 9.91137E-02_JPRB, 1.07173E-01_JPRB, & + & 1.15888E-01_JPRB, 1.25311E-01_JPRB, 1.35501E-01_JPRB, 1.46519E-01_JPRB, 1.58433E-01_JPRB, & + & 1.71316E-01_JPRB, 1.85246E-01_JPRB, 2.00309E-01_JPRB, 2.16597E-01_JPRB/) + KAO_MCO2( 5, :, 9) = (/ & + & 6.26111E-02_JPRB, 6.74018E-02_JPRB, 7.25591E-02_JPRB, 7.81111E-02_JPRB, 8.40878E-02_JPRB, & + & 9.05218E-02_JPRB, 9.74482E-02_JPRB, 1.04904E-01_JPRB, 1.12931E-01_JPRB, 1.21572E-01_JPRB, & + & 1.30875E-01_JPRB, 1.40889E-01_JPRB, 1.51669E-01_JPRB, 1.63274E-01_JPRB, 1.75767E-01_JPRB, & + & 1.89216E-01_JPRB, 2.03694E-01_JPRB, 2.19279E-01_JPRB, 2.36058E-01_JPRB/) + KAO_MCO2( 6, :, 9) = (/ & + & 7.59080E-02_JPRB, 8.13446E-02_JPRB, 8.71706E-02_JPRB, 9.34139E-02_JPRB, 1.00104E-01_JPRB, & + & 1.07274E-01_JPRB, 1.14957E-01_JPRB, 1.23190E-01_JPRB, 1.32013E-01_JPRB, 1.41468E-01_JPRB, & + & 1.51600E-01_JPRB, 1.62458E-01_JPRB, 1.74094E-01_JPRB, 1.86562E-01_JPRB, 1.99924E-01_JPRB, & + & 2.14243E-01_JPRB, 2.29587E-01_JPRB, 2.46031E-01_JPRB, 2.63652E-01_JPRB/) + KAO_MCO2( 7, :, 9) = (/ & + & 8.81942E-02_JPRB, 9.39942E-02_JPRB, 1.00176E-01_JPRB, 1.06763E-01_JPRB, 1.13784E-01_JPRB, & + & 1.21267E-01_JPRB, 1.29242E-01_JPRB, 1.37742E-01_JPRB, 1.46800E-01_JPRB, 1.56454E-01_JPRB, & + & 1.66743E-01_JPRB, 1.77708E-01_JPRB, 1.89395E-01_JPRB, 2.01850E-01_JPRB, 2.15124E-01_JPRB, & + & 2.29272E-01_JPRB, 2.44349E-01_JPRB, 2.60418E-01_JPRB, 2.77544E-01_JPRB/) + KAO_MCO2( 8, :, 9) = (/ & + & 6.28535E-02_JPRB, 6.69314E-02_JPRB, 7.12740E-02_JPRB, 7.58982E-02_JPRB, 8.08225E-02_JPRB, & + & 8.60662E-02_JPRB, 9.16502E-02_JPRB, 9.75965E-02_JPRB, 1.03929E-01_JPRB, 1.10671E-01_JPRB, & + & 1.17852E-01_JPRB, 1.25498E-01_JPRB, 1.33640E-01_JPRB, 1.42311E-01_JPRB, 1.51544E-01_JPRB, & + & 1.61376E-01_JPRB, 1.71846E-01_JPRB, 1.82996E-01_JPRB, 1.94868E-01_JPRB/) + KAO_MCO2( 9, :, 9) = (/ & + & 6.39196E-02_JPRB, 6.86702E-02_JPRB, 7.37738E-02_JPRB, 7.92568E-02_JPRB, 8.51473E-02_JPRB, & + & 9.14756E-02_JPRB, 9.82742E-02_JPRB, 1.05578E-01_JPRB, 1.13425E-01_JPRB, 1.21855E-01_JPRB, & + & 1.30911E-01_JPRB, 1.40641E-01_JPRB, 1.51093E-01_JPRB, 1.62323E-01_JPRB, 1.74387E-01_JPRB, & + & 1.87348E-01_JPRB, 2.01272E-01_JPRB, 2.16231E-01_JPRB, 2.32301E-01_JPRB/) + KAO_MCO2( 1, :,10) = (/ & + & 9.44086E-02_JPRB, 1.02788E-01_JPRB, 1.11911E-01_JPRB, 1.21844E-01_JPRB, 1.32659E-01_JPRB, & + & 1.44434E-01_JPRB, 1.57253E-01_JPRB, 1.71211E-01_JPRB, 1.86407E-01_JPRB, 2.02952E-01_JPRB, & + & 2.20966E-01_JPRB, 2.40578E-01_JPRB, 2.61932E-01_JPRB, 2.85180E-01_JPRB, 3.10492E-01_JPRB, & + & 3.38051E-01_JPRB, 3.68056E-01_JPRB, 4.00723E-01_JPRB, 4.36291E-01_JPRB/) + KAO_MCO2( 2, :,10) = (/ & + & 1.29528E-01_JPRB, 1.39646E-01_JPRB, 1.50554E-01_JPRB, 1.62315E-01_JPRB, 1.74994E-01_JPRB, & + & 1.88664E-01_JPRB, 2.03401E-01_JPRB, 2.19290E-01_JPRB, 2.36419E-01_JPRB, 2.54887E-01_JPRB, & + & 2.74798E-01_JPRB, 2.96263E-01_JPRB, 3.19406E-01_JPRB, 3.44356E-01_JPRB, 3.71255E-01_JPRB, & + & 4.00256E-01_JPRB, 4.31522E-01_JPRB, 4.65230E-01_JPRB, 5.01571E-01_JPRB/) + KAO_MCO2( 3, :,10) = (/ & + & 1.52325E-01_JPRB, 1.62991E-01_JPRB, 1.74404E-01_JPRB, 1.86616E-01_JPRB, 1.99684E-01_JPRB, & + & 2.13666E-01_JPRB, 2.28628E-01_JPRB, 2.44637E-01_JPRB, 2.61767E-01_JPRB, 2.80096E-01_JPRB, & + & 2.99710E-01_JPRB, 3.20696E-01_JPRB, 3.43152E-01_JPRB, 3.67181E-01_JPRB, 3.92892E-01_JPRB, & + & 4.20403E-01_JPRB, 4.49841E-01_JPRB, 4.81340E-01_JPRB, 5.15045E-01_JPRB/) + KAO_MCO2( 4, :,10) = (/ & + & 1.59763E-01_JPRB, 1.70378E-01_JPRB, 1.81698E-01_JPRB, 1.93770E-01_JPRB, 2.06644E-01_JPRB, & + & 2.20373E-01_JPRB, 2.35015E-01_JPRB, 2.50629E-01_JPRB, 2.67281E-01_JPRB, 2.85039E-01_JPRB, & + & 3.03977E-01_JPRB, 3.24174E-01_JPRB, 3.45712E-01_JPRB, 3.68681E-01_JPRB, 3.93176E-01_JPRB, & + & 4.19299E-01_JPRB, 4.47157E-01_JPRB, 4.76866E-01_JPRB, 5.08549E-01_JPRB/) + KAO_MCO2( 5, :,10) = (/ & + & 1.79202E-01_JPRB, 1.91125E-01_JPRB, 2.03840E-01_JPRB, 2.17402E-01_JPRB, 2.31866E-01_JPRB, & + & 2.47292E-01_JPRB, 2.63744E-01_JPRB, 2.81291E-01_JPRB, 3.00005E-01_JPRB, 3.19964E-01_JPRB, & + & 3.41251E-01_JPRB, 3.63955E-01_JPRB, 3.88169E-01_JPRB, 4.13994E-01_JPRB, 4.41537E-01_JPRB, & + & 4.70912E-01_JPRB, 5.02242E-01_JPRB, 5.35656E-01_JPRB, 5.71293E-01_JPRB/) + KAO_MCO2( 6, :,10) = (/ & + & 1.66628E-01_JPRB, 1.76984E-01_JPRB, 1.87984E-01_JPRB, 1.99668E-01_JPRB, 2.12078E-01_JPRB, & + & 2.25259E-01_JPRB, 2.39259E-01_JPRB, 2.54129E-01_JPRB, 2.69924E-01_JPRB, 2.86700E-01_JPRB, & + & 3.04519E-01_JPRB, 3.23446E-01_JPRB, 3.43549E-01_JPRB, 3.64901E-01_JPRB, 3.87580E-01_JPRB, & + & 4.11669E-01_JPRB, 4.37255E-01_JPRB, 4.64431E-01_JPRB, 4.93297E-01_JPRB/) + KAO_MCO2( 7, :,10) = (/ & + & 2.03980E-01_JPRB, 2.17141E-01_JPRB, 2.31152E-01_JPRB, 2.46067E-01_JPRB, 2.61945E-01_JPRB, & + & 2.78847E-01_JPRB, 2.96839E-01_JPRB, 3.15993E-01_JPRB, 3.36382E-01_JPRB, 3.58087E-01_JPRB, & + & 3.81193E-01_JPRB, 4.05789E-01_JPRB, 4.31972E-01_JPRB, 4.59845E-01_JPRB, 4.89517E-01_JPRB, & + & 5.21103E-01_JPRB, 5.54727E-01_JPRB, 5.90520E-01_JPRB, 6.28623E-01_JPRB/) + KAO_MCO2( 8, :,10) = (/ & + & 1.96161E-04_JPRB, 2.07177E-04_JPRB, 2.18812E-04_JPRB, 2.31101E-04_JPRB, 2.44079E-04_JPRB, & + & 2.57787E-04_JPRB, 2.72264E-04_JPRB, 2.87554E-04_JPRB, 3.03703E-04_JPRB, 3.20758E-04_JPRB, & + & 3.38772E-04_JPRB, 3.57797E-04_JPRB, 3.77891E-04_JPRB, 3.99113E-04_JPRB, 4.21527E-04_JPRB, & + & 4.45200E-04_JPRB, 4.70202E-04_JPRB, 4.96608E-04_JPRB, 5.24498E-04_JPRB/) + KAO_MCO2( 9, :,10) = (/ & + & 1.76275E-01_JPRB, 1.88091E-01_JPRB, 2.00699E-01_JPRB, 2.14152E-01_JPRB, 2.28507E-01_JPRB, & + & 2.43824E-01_JPRB, 2.60168E-01_JPRB, 2.77607E-01_JPRB, 2.96216E-01_JPRB, 3.16071E-01_JPRB, & + & 3.37258E-01_JPRB, 3.59865E-01_JPRB, 3.83987E-01_JPRB, 4.09726E-01_JPRB, 4.37190E-01_JPRB, & + & 4.66495E-01_JPRB, 4.97765E-01_JPRB, 5.31131E-01_JPRB, 5.66733E-01_JPRB/) + KAO_MCO2( 1, :,11) = (/ & + & 1.99797E-01_JPRB, 2.14154E-01_JPRB, 2.29543E-01_JPRB, 2.46038E-01_JPRB, 2.63718E-01_JPRB, & + & 2.82669E-01_JPRB, 3.02981E-01_JPRB, 3.24753E-01_JPRB, 3.48090E-01_JPRB, 3.73104E-01_JPRB, & + & 3.99915E-01_JPRB, 4.28652E-01_JPRB, 4.59455E-01_JPRB, 4.92471E-01_JPRB, 5.27859E-01_JPRB, & + & 5.65791E-01_JPRB, 6.06448E-01_JPRB, 6.50027E-01_JPRB, 6.96738E-01_JPRB/) + KAO_MCO2( 2, :,11) = (/ & + & 2.20638E-01_JPRB, 2.35685E-01_JPRB, 2.51759E-01_JPRB, 2.68929E-01_JPRB, 2.87271E-01_JPRB, & + & 3.06863E-01_JPRB, 3.27791E-01_JPRB, 3.50146E-01_JPRB, 3.74026E-01_JPRB, 3.99535E-01_JPRB, & + & 4.26784E-01_JPRB, 4.55891E-01_JPRB, 4.86983E-01_JPRB, 5.20195E-01_JPRB, 5.55673E-01_JPRB, & + & 5.93570E-01_JPRB, 6.34052E-01_JPRB, 6.77294E-01_JPRB, 7.23486E-01_JPRB/) + KAO_MCO2( 3, :,11) = (/ & + & 2.62988E-01_JPRB, 2.80924E-01_JPRB, 3.00085E-01_JPRB, 3.20552E-01_JPRB, 3.42414E-01_JPRB, & + & 3.65768E-01_JPRB, 3.90715E-01_JPRB, 4.17363E-01_JPRB, 4.45829E-01_JPRB, 4.76237E-01_JPRB, & + & 5.08718E-01_JPRB, 5.43414E-01_JPRB, 5.80477E-01_JPRB, 6.20068E-01_JPRB, 6.62359E-01_JPRB, & + & 7.07535E-01_JPRB, 7.55791E-01_JPRB, 8.07339E-01_JPRB, 8.62403E-01_JPRB/) + KAO_MCO2( 4, :,11) = (/ & + & 2.43674E-01_JPRB, 2.59946E-01_JPRB, 2.77304E-01_JPRB, 2.95821E-01_JPRB, 3.15575E-01_JPRB, & + & 3.36647E-01_JPRB, 3.59127E-01_JPRB, 3.83108E-01_JPRB, 4.08691E-01_JPRB, 4.35981E-01_JPRB, & + & 4.65094E-01_JPRB, 4.96152E-01_JPRB, 5.29282E-01_JPRB, 5.64626E-01_JPRB, 6.02329E-01_JPRB, & + & 6.42550E-01_JPRB, 6.85457E-01_JPRB, 7.31229E-01_JPRB, 7.80057E-01_JPRB/) + KAO_MCO2( 5, :,11) = (/ & + & 2.23323E-01_JPRB, 2.37553E-01_JPRB, 2.52689E-01_JPRB, 2.68791E-01_JPRB, 2.85918E-01_JPRB, & + & 3.04136E-01_JPRB, 3.23515E-01_JPRB, 3.44129E-01_JPRB, 3.66057E-01_JPRB, 3.89381E-01_JPRB, & + & 4.14192E-01_JPRB, 4.40584E-01_JPRB, 4.68657E-01_JPRB, 4.98520E-01_JPRB, 5.30285E-01_JPRB, & + & 5.64074E-01_JPRB, 6.00016E-01_JPRB, 6.38248E-01_JPRB, 6.78917E-01_JPRB/) + KAO_MCO2( 6, :,11) = (/ & + & 2.83716E-01_JPRB, 3.02622E-01_JPRB, 3.22788E-01_JPRB, 3.44298E-01_JPRB, 3.67241E-01_JPRB, & + & 3.91713E-01_JPRB, 4.17816E-01_JPRB, 4.45658E-01_JPRB, 4.75356E-01_JPRB, 5.07033E-01_JPRB, & + & 5.40820E-01_JPRB, 5.76859E-01_JPRB, 6.15300E-01_JPRB, 6.56302E-01_JPRB, 7.00037E-01_JPRB, & + & 7.46686E-01_JPRB, 7.96443E-01_JPRB, 8.49516E-01_JPRB, 9.06126E-01_JPRB/) + KAO_MCO2( 7, :,11) = (/ & + & 1.00497E-03_JPRB, 1.06500E-03_JPRB, 1.12863E-03_JPRB, 1.19606E-03_JPRB, 1.26751E-03_JPRB, & + & 1.34323E-03_JPRB, 1.42348E-03_JPRB, 1.50852E-03_JPRB, 1.59864E-03_JPRB, 1.69414E-03_JPRB, & + & 1.79535E-03_JPRB, 1.90261E-03_JPRB, 2.01628E-03_JPRB, 2.13673E-03_JPRB, 2.26438E-03_JPRB, & + & 2.39966E-03_JPRB, 2.54302E-03_JPRB, 2.69494E-03_JPRB, 2.85594E-03_JPRB/) + KAO_MCO2( 8, :,11) = (/ & + & 3.22623E-04_JPRB, 3.39937E-04_JPRB, 3.58181E-04_JPRB, 3.77404E-04_JPRB, 3.97658E-04_JPRB, & + & 4.19000E-04_JPRB, 4.41487E-04_JPRB, 4.65180E-04_JPRB, 4.90146E-04_JPRB, 5.16451E-04_JPRB, & + & 5.44167E-04_JPRB, 5.73372E-04_JPRB, 6.04143E-04_JPRB, 6.36567E-04_JPRB, 6.70730E-04_JPRB, & + & 7.06726E-04_JPRB, 7.44655E-04_JPRB, 7.84619E-04_JPRB, 8.26727E-04_JPRB/) + KAO_MCO2( 9, :,11) = (/ & + & 2.23872E-01_JPRB, 2.38360E-01_JPRB, 2.53786E-01_JPRB, 2.70210E-01_JPRB, 2.87697E-01_JPRB, & + & 3.06316E-01_JPRB, 3.26140E-01_JPRB, 3.47247E-01_JPRB, 3.69720E-01_JPRB, 3.93647E-01_JPRB, & + & 4.19122E-01_JPRB, 4.46246E-01_JPRB, 4.75126E-01_JPRB, 5.05874E-01_JPRB, 5.38613E-01_JPRB, & + & 5.73470E-01_JPRB, 6.10583E-01_JPRB, 6.50098E-01_JPRB, 6.92170E-01_JPRB/) + KAO_MCO2( 1, :,12) = (/ & + & 3.52418E-01_JPRB, 3.76085E-01_JPRB, 4.01341E-01_JPRB, 4.28293E-01_JPRB, 4.57055E-01_JPRB, & + & 4.87749E-01_JPRB, 5.20504E-01_JPRB, 5.55458E-01_JPRB, 5.92760E-01_JPRB, 6.32567E-01_JPRB, & + & 6.75047E-01_JPRB, 7.20380E-01_JPRB, 7.68757E-01_JPRB, 8.20383E-01_JPRB, 8.75476E-01_JPRB, & + & 9.34268E-01_JPRB, 9.97009E-01_JPRB, 1.06396E+00_JPRB, 1.13541E+00_JPRB/) + KAO_MCO2( 2, :,12) = (/ & + & 3.38812E-01_JPRB, 3.61001E-01_JPRB, 3.84645E-01_JPRB, 4.09836E-01_JPRB, 4.36678E-01_JPRB, & + & 4.65278E-01_JPRB, 4.95750E-01_JPRB, 5.28219E-01_JPRB, 5.62814E-01_JPRB, 5.99674E-01_JPRB, & + & 6.38949E-01_JPRB, 6.80796E-01_JPRB, 7.25384E-01_JPRB, 7.72892E-01_JPRB, 8.23511E-01_JPRB, & + & 8.77446E-01_JPRB, 9.34913E-01_JPRB, 9.96144E-01_JPRB, 1.06138E+00_JPRB/) + KAO_MCO2( 3, :,12) = (/ & + & 3.44644E-01_JPRB, 3.66671E-01_JPRB, 3.90105E-01_JPRB, 4.15038E-01_JPRB, 4.41564E-01_JPRB, & + & 4.69785E-01_JPRB, 4.99810E-01_JPRB, 5.31754E-01_JPRB, 5.65740E-01_JPRB, 6.01897E-01_JPRB, & + & 6.40366E-01_JPRB, 6.81293E-01_JPRB, 7.24836E-01_JPRB, 7.71162E-01_JPRB, 8.20448E-01_JPRB, & + & 8.72885E-01_JPRB, 9.28673E-01_JPRB, 9.88027E-01_JPRB, 1.05117E+00_JPRB/) + KAO_MCO2( 4, :,12) = (/ & + & 4.20358E-01_JPRB, 4.47809E-01_JPRB, 4.77053E-01_JPRB, 5.08207E-01_JPRB, 5.41395E-01_JPRB, & + & 5.76750E-01_JPRB, 6.14414E-01_JPRB, 6.54538E-01_JPRB, 6.97282E-01_JPRB, 7.42818E-01_JPRB, & + & 7.91327E-01_JPRB, 8.43004E-01_JPRB, 8.98056E-01_JPRB, 9.56703E-01_JPRB, 1.01918E+00_JPRB, & + & 1.08574E+00_JPRB, 1.15664E+00_JPRB, 1.23217E+00_JPRB, 1.31264E+00_JPRB/) + KAO_MCO2( 5, :,12) = (/ & + & 4.42756E-01_JPRB, 4.72000E-01_JPRB, 5.03174E-01_JPRB, 5.36408E-01_JPRB, 5.71837E-01_JPRB, & + & 6.09606E-01_JPRB, 6.49870E-01_JPRB, 6.92793E-01_JPRB, 7.38551E-01_JPRB, 7.87331E-01_JPRB, & + & 8.39333E-01_JPRB, 8.94770E-01_JPRB, 9.53868E-01_JPRB, 1.01687E+00_JPRB, 1.08403E+00_JPRB, & + & 1.15563E+00_JPRB, 1.23196E+00_JPRB, 1.31333E+00_JPRB, 1.40007E+00_JPRB/) + KAO_MCO2( 6, :,12) = (/ & + & 1.53662E-01_JPRB, 1.63104E-01_JPRB, 1.73126E-01_JPRB, 1.83764E-01_JPRB, 1.95055E-01_JPRB, & + & 2.07040E-01_JPRB, 2.19762E-01_JPRB, 2.33265E-01_JPRB, 2.47598E-01_JPRB, 2.62811E-01_JPRB, & + & 2.78960E-01_JPRB, 2.96100E-01_JPRB, 3.14294E-01_JPRB, 3.33606E-01_JPRB, 3.54104E-01_JPRB, & + & 3.75862E-01_JPRB, 3.98956E-01_JPRB, 4.23470E-01_JPRB, 4.49490E-01_JPRB/) + KAO_MCO2( 7, :,12) = (/ & + & 5.41472E-04_JPRB, 5.65116E-04_JPRB, 5.89793E-04_JPRB, 6.15547E-04_JPRB, 6.42426E-04_JPRB, & + & 6.70479E-04_JPRB, 6.99757E-04_JPRB, 7.30313E-04_JPRB, 7.62203E-04_JPRB, 7.95486E-04_JPRB, & + & 8.30223E-04_JPRB, 8.66476E-04_JPRB, 9.04312E-04_JPRB, 9.43801E-04_JPRB, 9.85013E-04_JPRB, & + & 1.02803E-03_JPRB, 1.07292E-03_JPRB, 1.11977E-03_JPRB, 1.16866E-03_JPRB/) + KAO_MCO2( 8, :,12) = (/ & + & 5.94251E-04_JPRB, 6.17650E-04_JPRB, 6.41969E-04_JPRB, 6.67246E-04_JPRB, 6.93518E-04_JPRB, & + & 7.20824E-04_JPRB, 7.49206E-04_JPRB, 7.78705E-04_JPRB, 8.09366E-04_JPRB, 8.41234E-04_JPRB, & + & 8.74356E-04_JPRB, 9.08783E-04_JPRB, 9.44566E-04_JPRB, 9.81757E-04_JPRB, 1.02041E-03_JPRB, & + & 1.06059E-03_JPRB, 1.10235E-03_JPRB, 1.14575E-03_JPRB, 1.19087E-03_JPRB/) + KAO_MCO2( 9, :,12) = (/ & + & 4.21683E-01_JPRB, 4.49025E-01_JPRB, 4.78140E-01_JPRB, 5.09142E-01_JPRB, 5.42155E-01_JPRB, & + & 5.77309E-01_JPRB, 6.14741E-01_JPRB, 6.54601E-01_JPRB, 6.97046E-01_JPRB, 7.42242E-01_JPRB, & + & 7.90369E-01_JPRB, 8.41617E-01_JPRB, 8.96188E-01_JPRB, 9.54297E-01_JPRB, 1.01617E+00_JPRB, & + & 1.08206E+00_JPRB, 1.15222E+00_JPRB, 1.22693E+00_JPRB, 1.30649E+00_JPRB/) + KAO_MCO2( 1, :,13) = (/ & + & 5.61805E-01_JPRB, 5.98988E-01_JPRB, 6.38631E-01_JPRB, 6.80898E-01_JPRB, 7.25962E-01_JPRB, & + & 7.74009E-01_JPRB, 8.25236E-01_JPRB, 8.79853E-01_JPRB, 9.38085E-01_JPRB, 1.00017E+00_JPRB, & + & 1.06637E+00_JPRB, 1.13694E+00_JPRB, 1.21219E+00_JPRB, 1.29242E+00_JPRB, 1.37795E+00_JPRB, & + & 1.46915E+00_JPRB, 1.56638E+00_JPRB, 1.67005E+00_JPRB, 1.78058E+00_JPRB/) + KAO_MCO2( 2, :,13) = (/ & + & 5.55938E-01_JPRB, 5.91800E-01_JPRB, 6.29976E-01_JPRB, 6.70615E-01_JPRB, 7.13876E-01_JPRB, & + & 7.59927E-01_JPRB, 8.08949E-01_JPRB, 8.61133E-01_JPRB, 9.16683E-01_JPRB, 9.75817E-01_JPRB, & + & 1.03877E+00_JPRB, 1.10577E+00_JPRB, 1.17711E+00_JPRB, 1.25304E+00_JPRB, 1.33387E+00_JPRB, & + & 1.41992E+00_JPRB, 1.51152E+00_JPRB, 1.60902E+00_JPRB, 1.71282E+00_JPRB/) + KAO_MCO2( 3, :,13) = (/ & + & 5.94615E-01_JPRB, 6.33277E-01_JPRB, 6.74453E-01_JPRB, 7.18307E-01_JPRB, 7.65012E-01_JPRB, & + & 8.14753E-01_JPRB, 8.67729E-01_JPRB, 9.24149E-01_JPRB, 9.84238E-01_JPRB, 1.04823E+00_JPRB, & + & 1.11639E+00_JPRB, 1.18898E+00_JPRB, 1.26629E+00_JPRB, 1.34862E+00_JPRB, 1.43631E+00_JPRB, & + & 1.52970E+00_JPRB, 1.62916E+00_JPRB, 1.73509E+00_JPRB, 1.84791E+00_JPRB/) + KAO_MCO2( 4, :,13) = (/ & + & 5.48973E-01_JPRB, 5.84145E-01_JPRB, 6.21570E-01_JPRB, 6.61394E-01_JPRB, 7.03768E-01_JPRB, & + & 7.48858E-01_JPRB, 7.96836E-01_JPRB, 8.47889E-01_JPRB, 9.02212E-01_JPRB, 9.60015E-01_JPRB, & + & 1.02152E+00_JPRB, 1.08697E+00_JPRB, 1.15661E+00_JPRB, 1.23071E+00_JPRB, 1.30956E+00_JPRB, & + & 1.39347E+00_JPRB, 1.48274E+00_JPRB, 1.57774E+00_JPRB, 1.67883E+00_JPRB/) + KAO_MCO2( 5, :,13) = (/ & + & 1.49742E-01_JPRB, 1.59049E-01_JPRB, 1.68934E-01_JPRB, 1.79434E-01_JPRB, 1.90586E-01_JPRB, & + & 2.02432E-01_JPRB, 2.15013E-01_JPRB, 2.28377E-01_JPRB, 2.42571E-01_JPRB, 2.57648E-01_JPRB, & + & 2.73661E-01_JPRB, 2.90670E-01_JPRB, 3.08736E-01_JPRB, 3.27925E-01_JPRB, 3.48307E-01_JPRB, & + & 3.69955E-01_JPRB, 3.92949E-01_JPRB, 4.17372E-01_JPRB, 4.43312E-01_JPRB/) + KAO_MCO2( 6, :,13) = (/ & + & 8.81777E-04_JPRB, 9.16690E-04_JPRB, 9.52985E-04_JPRB, 9.90718E-04_JPRB, 1.02994E-03_JPRB, & + & 1.07072E-03_JPRB, 1.11312E-03_JPRB, 1.15719E-03_JPRB, 1.20301E-03_JPRB, 1.25064E-03_JPRB, & + & 1.30016E-03_JPRB, 1.35163E-03_JPRB, 1.40515E-03_JPRB, 1.46079E-03_JPRB, 1.51862E-03_JPRB, & + & 1.57875E-03_JPRB, 1.64126E-03_JPRB, 1.70624E-03_JPRB, 1.77380E-03_JPRB/) + KAO_MCO2( 7, :,13) = (/ & + & 8.84366E-04_JPRB, 9.20446E-04_JPRB, 9.57999E-04_JPRB, 9.97083E-04_JPRB, 1.03776E-03_JPRB, & + & 1.08010E-03_JPRB, 1.12417E-03_JPRB, 1.17003E-03_JPRB, 1.21777E-03_JPRB, 1.26745E-03_JPRB, & + & 1.31916E-03_JPRB, 1.37298E-03_JPRB, 1.42899E-03_JPRB, 1.48729E-03_JPRB, 1.54797E-03_JPRB, & + & 1.61113E-03_JPRB, 1.67686E-03_JPRB, 1.74527E-03_JPRB, 1.81647E-03_JPRB/) + KAO_MCO2( 8, :,13) = (/ & + & 8.92597E-04_JPRB, 9.33069E-04_JPRB, 9.75377E-04_JPRB, 1.01960E-03_JPRB, 1.06583E-03_JPRB, & + & 1.11416E-03_JPRB, 1.16468E-03_JPRB, 1.21749E-03_JPRB, 1.27269E-03_JPRB, 1.33040E-03_JPRB, & + & 1.39073E-03_JPRB, 1.45378E-03_JPRB, 1.51970E-03_JPRB, 1.58861E-03_JPRB, 1.66064E-03_JPRB, & + & 1.73594E-03_JPRB, 1.81465E-03_JPRB, 1.89693E-03_JPRB, 1.98294E-03_JPRB/) + KAO_MCO2( 9, :,13) = (/ & + & 1.46280E-01_JPRB, 1.55378E-01_JPRB, 1.65043E-01_JPRB, 1.75308E-01_JPRB, 1.86212E-01_JPRB, & + & 1.97794E-01_JPRB, 2.10097E-01_JPRB, 2.23164E-01_JPRB, 2.37045E-01_JPRB, 2.51788E-01_JPRB, & + & 2.67449E-01_JPRB, 2.84084E-01_JPRB, 3.01754E-01_JPRB, 3.20522E-01_JPRB, 3.40458E-01_JPRB, & + & 3.61634E-01_JPRB, 3.84127E-01_JPRB, 4.08020E-01_JPRB, 4.33398E-01_JPRB/) + KAO_MCO2( 1, :,14) = (/ & + & 9.20236E-01_JPRB, 9.80010E-01_JPRB, 1.04367E+00_JPRB, 1.11146E+00_JPRB, 1.18366E+00_JPRB, & + & 1.26054E+00_JPRB, 1.34242E+00_JPRB, 1.42962E+00_JPRB, 1.52248E+00_JPRB, 1.62137E+00_JPRB, & + & 1.72669E+00_JPRB, 1.83885E+00_JPRB, 1.95829E+00_JPRB, 2.08549E+00_JPRB, 2.22096E+00_JPRB, & + & 2.36522E+00_JPRB, 2.51886E+00_JPRB, 2.68247E+00_JPRB, 2.85671E+00_JPRB/) + KAO_MCO2( 2, :,14) = (/ & + & 8.39823E-01_JPRB, 8.95471E-01_JPRB, 9.54806E-01_JPRB, 1.01807E+00_JPRB, 1.08553E+00_JPRB, & + & 1.15746E+00_JPRB, 1.23416E+00_JPRB, 1.31593E+00_JPRB, 1.40313E+00_JPRB, 1.49610E+00_JPRB, & + & 1.59523E+00_JPRB, 1.70094E+00_JPRB, 1.81364E+00_JPRB, 1.93382E+00_JPRB, 2.06195E+00_JPRB, & + & 2.19858E+00_JPRB, 2.34426E+00_JPRB, 2.49960E+00_JPRB, 2.66522E+00_JPRB/) + KAO_MCO2( 3, :,14) = (/ & + & 5.39252E-01_JPRB, 5.73971E-01_JPRB, 6.10925E-01_JPRB, 6.50259E-01_JPRB, 6.92125E-01_JPRB, & + & 7.36686E-01_JPRB, 7.84117E-01_JPRB, 8.34601E-01_JPRB, 8.88336E-01_JPRB, 9.45530E-01_JPRB, & + & 1.00641E+00_JPRB, 1.07120E+00_JPRB, 1.14017E+00_JPRB, 1.21358E+00_JPRB, 1.29171E+00_JPRB, & + & 1.37488E+00_JPRB, 1.46340E+00_JPRB, 1.55762E+00_JPRB, 1.65790E+00_JPRB/) + KAO_MCO2( 4, :,14) = (/ & + & 1.14837E-03_JPRB, 1.19701E-03_JPRB, 1.24770E-03_JPRB, 1.30055E-03_JPRB, 1.35563E-03_JPRB, & + & 1.41305E-03_JPRB, 1.47289E-03_JPRB, 1.53528E-03_JPRB, 1.60030E-03_JPRB, 1.66808E-03_JPRB, & + & 1.73873E-03_JPRB, 1.81237E-03_JPRB, 1.88913E-03_JPRB, 1.96914E-03_JPRB, 2.05254E-03_JPRB, & + & 2.13947E-03_JPRB, 2.23009E-03_JPRB, 2.32454E-03_JPRB, 2.42299E-03_JPRB/) + KAO_MCO2( 5, :,14) = (/ & + & 1.14611E-03_JPRB, 1.19424E-03_JPRB, 1.24440E-03_JPRB, 1.29666E-03_JPRB, 1.35111E-03_JPRB, & + & 1.40786E-03_JPRB, 1.46698E-03_JPRB, 1.52859E-03_JPRB, 1.59279E-03_JPRB, 1.65968E-03_JPRB, & + & 1.72938E-03_JPRB, 1.80201E-03_JPRB, 1.87769E-03_JPRB, 1.95655E-03_JPRB, 2.03872E-03_JPRB, & + & 2.12434E-03_JPRB, 2.21355E-03_JPRB, 2.30651E-03_JPRB, 2.40338E-03_JPRB/) + KAO_MCO2( 6, :,14) = (/ & + & 1.14203E-03_JPRB, 1.18930E-03_JPRB, 1.23852E-03_JPRB, 1.28979E-03_JPRB, 1.34317E-03_JPRB, & + & 1.39877E-03_JPRB, 1.45666E-03_JPRB, 1.51695E-03_JPRB, 1.57974E-03_JPRB, 1.64513E-03_JPRB, & + & 1.71322E-03_JPRB, 1.78413E-03_JPRB, 1.85798E-03_JPRB, 1.93488E-03_JPRB, 2.01497E-03_JPRB, & + & 2.09837E-03_JPRB, 2.18522E-03_JPRB, 2.27567E-03_JPRB, 2.36986E-03_JPRB/) + KAO_MCO2( 7, :,14) = (/ & + & 1.11217E-03_JPRB, 1.15727E-03_JPRB, 1.20421E-03_JPRB, 1.25305E-03_JPRB, 1.30386E-03_JPRB, & + & 1.35674E-03_JPRB, 1.41177E-03_JPRB, 1.46902E-03_JPRB, 1.52860E-03_JPRB, 1.59059E-03_JPRB, & + & 1.65510E-03_JPRB, 1.72222E-03_JPRB, 1.79207E-03_JPRB, 1.86475E-03_JPRB, 1.94037E-03_JPRB, & + & 2.01907E-03_JPRB, 2.10095E-03_JPRB, 2.18616E-03_JPRB, 2.27482E-03_JPRB/) + KAO_MCO2( 8, :,14) = (/ & + & 1.21596E-03_JPRB, 1.25817E-03_JPRB, 1.30183E-03_JPRB, 1.34702E-03_JPRB, 1.39377E-03_JPRB, & + & 1.44214E-03_JPRB, 1.49219E-03_JPRB, 1.54398E-03_JPRB, 1.59757E-03_JPRB, 1.65302E-03_JPRB, & + & 1.71039E-03_JPRB, 1.76975E-03_JPRB, 1.83117E-03_JPRB, 1.89473E-03_JPRB, 1.96049E-03_JPRB, & + & 2.02853E-03_JPRB, 2.09893E-03_JPRB, 2.17178E-03_JPRB, 2.24716E-03_JPRB/) + KAO_MCO2( 9, :,14) = (/ & + & 1.14611E-03_JPRB, 1.19424E-03_JPRB, 1.24440E-03_JPRB, 1.29666E-03_JPRB, 1.35111E-03_JPRB, & + & 1.40786E-03_JPRB, 1.46698E-03_JPRB, 1.52859E-03_JPRB, 1.59279E-03_JPRB, 1.65968E-03_JPRB, & + & 1.72938E-03_JPRB, 1.80201E-03_JPRB, 1.87769E-03_JPRB, 1.95655E-03_JPRB, 2.03872E-03_JPRB, & + & 2.12434E-03_JPRB, 2.21355E-03_JPRB, 2.30651E-03_JPRB, 2.40338E-03_JPRB/) + KAO_MCO2( 1, :,15) = (/ & + & 1.29470E+00_JPRB, 1.37848E+00_JPRB, 1.46768E+00_JPRB, 1.56266E+00_JPRB, 1.66378E+00_JPRB, & + & 1.77145E+00_JPRB, 1.88609E+00_JPRB, 2.00814E+00_JPRB, 2.13809E+00_JPRB, 2.27645E+00_JPRB, & + & 2.42376E+00_JPRB, 2.58061E+00_JPRB, 2.74761E+00_JPRB, 2.92541E+00_JPRB, 3.11472E+00_JPRB, & + & 3.31628E+00_JPRB, 3.53088E+00_JPRB, 3.75938E+00_JPRB, 4.00265E+00_JPRB/) + KAO_MCO2( 2, :,15) = (/ & + & 7.23701E-01_JPRB, 7.68508E-01_JPRB, 8.16089E-01_JPRB, 8.66616E-01_JPRB, 9.20272E-01_JPRB, & + & 9.77250E-01_JPRB, 1.03775E+00_JPRB, 1.10201E+00_JPRB, 1.17024E+00_JPRB, 1.24269E+00_JPRB, & + & 1.31963E+00_JPRB, 1.40133E+00_JPRB, 1.48809E+00_JPRB, 1.58023E+00_JPRB, 1.67807E+00_JPRB, & + & 1.78196E+00_JPRB, 1.89229E+00_JPRB, 2.00945E+00_JPRB, 2.13386E+00_JPRB/) + KAO_MCO2( 3, :,15) = (/ & + & 1.81684E-03_JPRB, 1.85424E-03_JPRB, 1.89241E-03_JPRB, 1.93137E-03_JPRB, 1.97114E-03_JPRB, & + & 2.01172E-03_JPRB, 2.05313E-03_JPRB, 2.09540E-03_JPRB, 2.13854E-03_JPRB, 2.18257E-03_JPRB, & + & 2.22750E-03_JPRB, 2.27336E-03_JPRB, 2.32016E-03_JPRB, 2.36793E-03_JPRB, 2.41668E-03_JPRB, & + & 2.46643E-03_JPRB, 2.51721E-03_JPRB, 2.56903E-03_JPRB, 2.62192E-03_JPRB/) + KAO_MCO2( 4, :,15) = (/ & + & 1.84644E-03_JPRB, 1.88437E-03_JPRB, 1.92309E-03_JPRB, 1.96260E-03_JPRB, 2.00293E-03_JPRB, & + & 2.04408E-03_JPRB, 2.08608E-03_JPRB, 2.12894E-03_JPRB, 2.17268E-03_JPRB, 2.21732E-03_JPRB, & + & 2.26288E-03_JPRB, 2.30938E-03_JPRB, 2.35683E-03_JPRB, 2.40525E-03_JPRB, 2.45467E-03_JPRB, & + & 2.50510E-03_JPRB, 2.55658E-03_JPRB, 2.60910E-03_JPRB, 2.66271E-03_JPRB/) + KAO_MCO2( 5, :,15) = (/ & + & 1.88579E-03_JPRB, 1.92454E-03_JPRB, 1.96408E-03_JPRB, 2.00443E-03_JPRB, 2.04561E-03_JPRB, & + & 2.08764E-03_JPRB, 2.13054E-03_JPRB, 2.17431E-03_JPRB, 2.21898E-03_JPRB, 2.26457E-03_JPRB, & + & 2.31110E-03_JPRB, 2.35858E-03_JPRB, 2.40704E-03_JPRB, 2.45650E-03_JPRB, 2.50697E-03_JPRB, & + & 2.55848E-03_JPRB, 2.61104E-03_JPRB, 2.66469E-03_JPRB, 2.71943E-03_JPRB/) + KAO_MCO2( 6, :,15) = (/ & + & 1.95322E-03_JPRB, 1.99316E-03_JPRB, 2.03391E-03_JPRB, 2.07549E-03_JPRB, 2.11793E-03_JPRB, & + & 2.16123E-03_JPRB, 2.20542E-03_JPRB, 2.25051E-03_JPRB, 2.29652E-03_JPRB, 2.34347E-03_JPRB, & + & 2.39139E-03_JPRB, 2.44028E-03_JPRB, 2.49017E-03_JPRB, 2.54109E-03_JPRB, 2.59304E-03_JPRB, & + & 2.64605E-03_JPRB, 2.70015E-03_JPRB, 2.75536E-03_JPRB, 2.81169E-03_JPRB/) + KAO_MCO2( 7, :,15) = (/ & + & 2.13640E-03_JPRB, 2.17976E-03_JPRB, 2.22400E-03_JPRB, 2.26914E-03_JPRB, 2.31520E-03_JPRB, & + & 2.36219E-03_JPRB, 2.41013E-03_JPRB, 2.45905E-03_JPRB, 2.50896E-03_JPRB, 2.55988E-03_JPRB, & + & 2.61184E-03_JPRB, 2.66485E-03_JPRB, 2.71893E-03_JPRB, 2.77412E-03_JPRB, 2.83042E-03_JPRB, & + & 2.88787E-03_JPRB, 2.94648E-03_JPRB, 3.00629E-03_JPRB, 3.06730E-03_JPRB/) + KAO_MCO2( 8, :,15) = (/ & + & 2.17014E-03_JPRB, 2.21411E-03_JPRB, 2.25897E-03_JPRB, 2.30474E-03_JPRB, 2.35143E-03_JPRB, & + & 2.39908E-03_JPRB, 2.44769E-03_JPRB, 2.49728E-03_JPRB, 2.54788E-03_JPRB, 2.59950E-03_JPRB, & + & 2.65217E-03_JPRB, 2.70591E-03_JPRB, 2.76073E-03_JPRB, 2.81667E-03_JPRB, 2.87374E-03_JPRB, & + & 2.93197E-03_JPRB, 2.99137E-03_JPRB, 3.05198E-03_JPRB, 3.11382E-03_JPRB/) + KAO_MCO2( 9, :,15) = (/ & + & 1.88579E-03_JPRB, 1.92454E-03_JPRB, 1.96408E-03_JPRB, 2.00443E-03_JPRB, 2.04561E-03_JPRB, & + & 2.08764E-03_JPRB, 2.13054E-03_JPRB, 2.17431E-03_JPRB, 2.21898E-03_JPRB, 2.26457E-03_JPRB, & + & 2.31110E-03_JPRB, 2.35858E-03_JPRB, 2.40704E-03_JPRB, 2.45650E-03_JPRB, 2.50697E-03_JPRB, & + & 2.55848E-03_JPRB, 2.61104E-03_JPRB, 2.66469E-03_JPRB, 2.71943E-03_JPRB/) + KAO_MCO2( 1, :,16) = (/ & + & 1.48989E+00_JPRB, 1.58377E+00_JPRB, 1.68356E+00_JPRB, 1.78964E+00_JPRB, 1.90241E+00_JPRB, & + & 2.02228E+00_JPRB, 2.14971E+00_JPRB, 2.28516E+00_JPRB, 2.42915E+00_JPRB, 2.58221E+00_JPRB, & + & 2.74492E+00_JPRB, 2.91788E+00_JPRB, 3.10174E+00_JPRB, 3.29718E+00_JPRB, 3.50494E+00_JPRB, & + & 3.72578E+00_JPRB, 3.96055E+00_JPRB, 4.21010E+00_JPRB, 4.47538E+00_JPRB/) + KAO_MCO2( 2, :,16) = (/ & + & 2.10609E-03_JPRB, 2.14759E-03_JPRB, 2.18992E-03_JPRB, 2.23307E-03_JPRB, 2.27708E-03_JPRB, & + & 2.32196E-03_JPRB, 2.36771E-03_JPRB, 2.41438E-03_JPRB, 2.46196E-03_JPRB, 2.51047E-03_JPRB, & + & 2.55995E-03_JPRB, 2.61040E-03_JPRB, 2.66184E-03_JPRB, 2.71430E-03_JPRB, 2.76779E-03_JPRB, & + & 2.82234E-03_JPRB, 2.87796E-03_JPRB, 2.93467E-03_JPRB, 2.99251E-03_JPRB/) + KAO_MCO2( 3, :,16) = (/ & + & 2.10609E-03_JPRB, 2.14759E-03_JPRB, 2.18992E-03_JPRB, 2.23307E-03_JPRB, 2.27708E-03_JPRB, & + & 2.32196E-03_JPRB, 2.36771E-03_JPRB, 2.41438E-03_JPRB, 2.46196E-03_JPRB, 2.51047E-03_JPRB, & + & 2.55995E-03_JPRB, 2.61040E-03_JPRB, 2.66184E-03_JPRB, 2.71430E-03_JPRB, 2.76779E-03_JPRB, & + & 2.82234E-03_JPRB, 2.87796E-03_JPRB, 2.93467E-03_JPRB, 2.99251E-03_JPRB/) + KAO_MCO2( 4, :,16) = (/ & + & 2.10609E-03_JPRB, 2.14759E-03_JPRB, 2.18992E-03_JPRB, 2.23307E-03_JPRB, 2.27708E-03_JPRB, & + & 2.32196E-03_JPRB, 2.36771E-03_JPRB, 2.41438E-03_JPRB, 2.46196E-03_JPRB, 2.51047E-03_JPRB, & + & 2.55995E-03_JPRB, 2.61040E-03_JPRB, 2.66184E-03_JPRB, 2.71430E-03_JPRB, 2.76779E-03_JPRB, & + & 2.82234E-03_JPRB, 2.87796E-03_JPRB, 2.93467E-03_JPRB, 2.99251E-03_JPRB/) + KAO_MCO2( 5, :,16) = (/ & + & 2.10609E-03_JPRB, 2.14759E-03_JPRB, 2.18992E-03_JPRB, 2.23307E-03_JPRB, 2.27708E-03_JPRB, & + & 2.32196E-03_JPRB, 2.36771E-03_JPRB, 2.41438E-03_JPRB, 2.46196E-03_JPRB, 2.51047E-03_JPRB, & + & 2.55995E-03_JPRB, 2.61040E-03_JPRB, 2.66184E-03_JPRB, 2.71430E-03_JPRB, 2.76779E-03_JPRB, & + & 2.82234E-03_JPRB, 2.87796E-03_JPRB, 2.93467E-03_JPRB, 2.99251E-03_JPRB/) + KAO_MCO2( 6, :,16) = (/ & + & 2.10609E-03_JPRB, 2.14759E-03_JPRB, 2.18992E-03_JPRB, 2.23307E-03_JPRB, 2.27708E-03_JPRB, & + & 2.32196E-03_JPRB, 2.36771E-03_JPRB, 2.41438E-03_JPRB, 2.46196E-03_JPRB, 2.51047E-03_JPRB, & + & 2.55995E-03_JPRB, 2.61040E-03_JPRB, 2.66184E-03_JPRB, 2.71430E-03_JPRB, 2.76779E-03_JPRB, & + & 2.82234E-03_JPRB, 2.87796E-03_JPRB, 2.93467E-03_JPRB, 2.99251E-03_JPRB/) + KAO_MCO2( 7, :,16) = (/ & + & 2.09970E-03_JPRB, 2.14101E-03_JPRB, 2.18312E-03_JPRB, 2.22606E-03_JPRB, 2.26985E-03_JPRB, & + & 2.31450E-03_JPRB, 2.36003E-03_JPRB, 2.40645E-03_JPRB, 2.45379E-03_JPRB, 2.50205E-03_JPRB, & + & 2.55127E-03_JPRB, 2.60146E-03_JPRB, 2.65263E-03_JPRB, 2.70481E-03_JPRB, 2.75801E-03_JPRB, & + & 2.81226E-03_JPRB, 2.86758E-03_JPRB, 2.92399E-03_JPRB, 2.98150E-03_JPRB/) + KAO_MCO2( 8, :,16) = (/ & + & 2.09970E-03_JPRB, 2.14101E-03_JPRB, 2.18312E-03_JPRB, 2.22606E-03_JPRB, 2.26985E-03_JPRB, & + & 2.31450E-03_JPRB, 2.36003E-03_JPRB, 2.40645E-03_JPRB, 2.45379E-03_JPRB, 2.50205E-03_JPRB, & + & 2.55127E-03_JPRB, 2.60146E-03_JPRB, 2.65263E-03_JPRB, 2.70481E-03_JPRB, 2.75801E-03_JPRB, & + & 2.81226E-03_JPRB, 2.86758E-03_JPRB, 2.92399E-03_JPRB, 2.98150E-03_JPRB/) + KAO_MCO2( 9, :,16) = (/ & + & 2.10609E-03_JPRB, 2.14759E-03_JPRB, 2.18992E-03_JPRB, 2.23307E-03_JPRB, 2.27708E-03_JPRB, & + & 2.32196E-03_JPRB, 2.36771E-03_JPRB, 2.41438E-03_JPRB, 2.46196E-03_JPRB, 2.51047E-03_JPRB, & + & 2.55995E-03_JPRB, 2.61040E-03_JPRB, 2.66184E-03_JPRB, 2.71430E-03_JPRB, 2.76779E-03_JPRB, & + & 2.82234E-03_JPRB, 2.87796E-03_JPRB, 2.93467E-03_JPRB, 2.99251E-03_JPRB/) + + KAO_MCO( 1, :, 1) = (/ & + & 4.58355E-01_JPRB, 4.47074E-01_JPRB, 4.36070E-01_JPRB, 4.25337E-01_JPRB, 4.14868E-01_JPRB, & + & 4.04657E-01_JPRB, 3.94697E-01_JPRB, 3.84982E-01_JPRB, 3.75506E-01_JPRB, 3.66264E-01_JPRB, & + & 3.57249E-01_JPRB, 3.48456E-01_JPRB, 3.39879E-01_JPRB, 3.31514E-01_JPRB, 3.23354E-01_JPRB, & + & 3.15395E-01_JPRB, 3.07632E-01_JPRB, 3.00061E-01_JPRB, 2.92675E-01_JPRB/) + KAO_MCO( 2, :, 1) = (/ & + & 7.03080E-01_JPRB, 6.84132E-01_JPRB, 6.65696E-01_JPRB, 6.47756E-01_JPRB, 6.30300E-01_JPRB, & + & 6.13314E-01_JPRB, 5.96786E-01_JPRB, 5.80703E-01_JPRB, 5.65053E-01_JPRB, 5.49826E-01_JPRB, & + & 5.35009E-01_JPRB, 5.20591E-01_JPRB, 5.06561E-01_JPRB, 4.92910E-01_JPRB, 4.79627E-01_JPRB, & + & 4.66701E-01_JPRB, 4.54124E-01_JPRB, 4.41886E-01_JPRB, 4.29978E-01_JPRB/) + KAO_MCO( 3, :, 1) = (/ & + & 8.53018E-01_JPRB, 8.29537E-01_JPRB, 8.06703E-01_JPRB, 7.84497E-01_JPRB, 7.62903E-01_JPRB, & + & 7.41903E-01_JPRB, 7.21481E-01_JPRB, 7.01621E-01_JPRB, 6.82307E-01_JPRB, 6.63526E-01_JPRB, & + & 6.45261E-01_JPRB, 6.27499E-01_JPRB, 6.10226E-01_JPRB, 5.93429E-01_JPRB, 5.77094E-01_JPRB, & + & 5.61208E-01_JPRB, 5.45760E-01_JPRB, 5.30737E-01_JPRB, 5.16128E-01_JPRB/) + KAO_MCO( 4, :, 1) = (/ & + & 9.58866E-01_JPRB, 9.31881E-01_JPRB, 9.05654E-01_JPRB, 8.80166E-01_JPRB, 8.55395E-01_JPRB, & + & 8.31321E-01_JPRB, 8.07925E-01_JPRB, 7.85187E-01_JPRB, 7.63089E-01_JPRB, 7.41613E-01_JPRB, & + & 7.20742E-01_JPRB, 7.00457E-01_JPRB, 6.80744E-01_JPRB, 6.61586E-01_JPRB, 6.42966E-01_JPRB, & + & 6.24871E-01_JPRB, 6.07285E-01_JPRB, 5.90194E-01_JPRB, 5.73584E-01_JPRB/) + KAO_MCO( 5, :, 1) = (/ & + & 1.07140E+00_JPRB, 1.04056E+00_JPRB, 1.01061E+00_JPRB, 9.81521E-01_JPRB, 9.53269E-01_JPRB, & + & 9.25829E-01_JPRB, 8.99180E-01_JPRB, 8.73297E-01_JPRB, 8.48160E-01_JPRB, 8.23746E-01_JPRB, & + & 8.00035E-01_JPRB, 7.77006E-01_JPRB, 7.54641E-01_JPRB, 7.32919E-01_JPRB, 7.11822E-01_JPRB, & + & 6.91333E-01_JPRB, 6.71433E-01_JPRB, 6.52106E-01_JPRB, 6.33336E-01_JPRB/) + KAO_MCO( 6, :, 1) = (/ & + & 1.21046E+00_JPRB, 1.17478E+00_JPRB, 1.14015E+00_JPRB, 1.10655E+00_JPRB, 1.07393E+00_JPRB, & + & 1.04228E+00_JPRB, 1.01156E+00_JPRB, 9.81740E-01_JPRB, 9.52803E-01_JPRB, 9.24720E-01_JPRB, & + & 8.97463E-01_JPRB, 8.71011E-01_JPRB, 8.45338E-01_JPRB, 8.20422E-01_JPRB, 7.96240E-01_JPRB, & + & 7.72771E-01_JPRB, 7.49993E-01_JPRB, 7.27887E-01_JPRB, 7.06433E-01_JPRB/) + KAO_MCO( 7, :, 1) = (/ & + & 1.57730E+00_JPRB, 1.52919E+00_JPRB, 1.48255E+00_JPRB, 1.43733E+00_JPRB, 1.39349E+00_JPRB, & + & 1.35099E+00_JPRB, 1.30978E+00_JPRB, 1.26983E+00_JPRB, 1.23110E+00_JPRB, 1.19355E+00_JPRB, & + & 1.15715E+00_JPRB, 1.12186E+00_JPRB, 1.08764E+00_JPRB, 1.05446E+00_JPRB, 1.02230E+00_JPRB, & + & 9.91121E-01_JPRB, 9.60890E-01_JPRB, 9.31583E-01_JPRB, 9.03169E-01_JPRB/) + KAO_MCO( 8, :, 1) = (/ & + & 2.43678E+00_JPRB, 2.36595E+00_JPRB, 2.29719E+00_JPRB, 2.23042E+00_JPRB, 2.16560E+00_JPRB, & + & 2.10266E+00_JPRB, 2.04154E+00_JPRB, 1.98221E+00_JPRB, 1.92460E+00_JPRB, 1.86866E+00_JPRB, & + & 1.81435E+00_JPRB, 1.76162E+00_JPRB, 1.71042E+00_JPRB, 1.66070E+00_JPRB, 1.61244E+00_JPRB, & + & 1.56557E+00_JPRB, 1.52007E+00_JPRB, 1.47589E+00_JPRB, 1.43300E+00_JPRB/) + KAO_MCO( 9, :, 1) = (/ & + & 9.66296E-01_JPRB, 9.39903E-01_JPRB, 9.14232E-01_JPRB, 8.89262E-01_JPRB, 8.64973E-01_JPRB, & + & 8.41348E-01_JPRB, 8.18369E-01_JPRB, 7.96017E-01_JPRB, 7.74275E-01_JPRB, 7.53128E-01_JPRB, & + & 7.32558E-01_JPRB, 7.12549E-01_JPRB, 6.93088E-01_JPRB, 6.74157E-01_JPRB, 6.55744E-01_JPRB, & + & 6.37834E-01_JPRB, 6.20413E-01_JPRB, 6.03468E-01_JPRB, 5.86985E-01_JPRB/) + KAO_MCO( 1, :, 2) = (/ & + & 1.15047E+00_JPRB, 1.12127E+00_JPRB, 1.09281E+00_JPRB, 1.06507E+00_JPRB, 1.03804E+00_JPRB, & + & 1.01169E+00_JPRB, 9.86010E-01_JPRB, 9.60983E-01_JPRB, 9.36591E-01_JPRB, 9.12818E-01_JPRB, & + & 8.89649E-01_JPRB, 8.67067E-01_JPRB, 8.45059E-01_JPRB, 8.23610E-01_JPRB, 8.02705E-01_JPRB, & + & 7.82330E-01_JPRB, 7.62473E-01_JPRB, 7.43119E-01_JPRB, 7.24257E-01_JPRB/) + KAO_MCO( 2, :, 2) = (/ & + & 1.43243E+00_JPRB, 1.39430E+00_JPRB, 1.35719E+00_JPRB, 1.32106E+00_JPRB, 1.28590E+00_JPRB, & + & 1.25167E+00_JPRB, 1.21836E+00_JPRB, 1.18593E+00_JPRB, 1.15436E+00_JPRB, 1.12364E+00_JPRB, & + & 1.09373E+00_JPRB, 1.06462E+00_JPRB, 1.03628E+00_JPRB, 1.00870E+00_JPRB, 9.81848E-01_JPRB, & + & 9.55714E-01_JPRB, 9.30275E-01_JPRB, 9.05514E-01_JPRB, 8.81412E-01_JPRB/) + KAO_MCO( 3, :, 2) = (/ & + & 1.61389E+00_JPRB, 1.56911E+00_JPRB, 1.52556E+00_JPRB, 1.48323E+00_JPRB, 1.44207E+00_JPRB, & + & 1.40205E+00_JPRB, 1.36314E+00_JPRB, 1.32531E+00_JPRB, 1.28854E+00_JPRB, 1.25278E+00_JPRB, & + & 1.21801E+00_JPRB, 1.18421E+00_JPRB, 1.15135E+00_JPRB, 1.11940E+00_JPRB, 1.08834E+00_JPRB, & + & 1.05814E+00_JPRB, 1.02877E+00_JPRB, 1.00022E+00_JPRB, 9.72466E-01_JPRB/) + KAO_MCO( 4, :, 2) = (/ & + & 1.78458E+00_JPRB, 1.73440E+00_JPRB, 1.68564E+00_JPRB, 1.63825E+00_JPRB, 1.59219E+00_JPRB, & + & 1.54742E+00_JPRB, 1.50391E+00_JPRB, 1.46163E+00_JPRB, 1.42053E+00_JPRB, 1.38059E+00_JPRB, & + & 1.34178E+00_JPRB, 1.30405E+00_JPRB, 1.26739E+00_JPRB, 1.23175E+00_JPRB, 1.19712E+00_JPRB, & + & 1.16346E+00_JPRB, 1.13075E+00_JPRB, 1.09896E+00_JPRB, 1.06806E+00_JPRB/) + KAO_MCO( 5, :, 2) = (/ & + & 1.92622E+00_JPRB, 1.87172E+00_JPRB, 1.81876E+00_JPRB, 1.76730E+00_JPRB, 1.71730E+00_JPRB, & + & 1.66871E+00_JPRB, 1.62150E+00_JPRB, 1.57562E+00_JPRB, 1.53104E+00_JPRB, 1.48772E+00_JPRB, & + & 1.44563E+00_JPRB, 1.40473E+00_JPRB, 1.36498E+00_JPRB, 1.32636E+00_JPRB, 1.28883E+00_JPRB, & + & 1.25237E+00_JPRB, 1.21693E+00_JPRB, 1.18250E+00_JPRB, 1.14905E+00_JPRB/) + KAO_MCO( 6, :, 2) = (/ & + & 2.23194E+00_JPRB, 2.16782E+00_JPRB, 2.10554E+00_JPRB, 2.04505E+00_JPRB, 1.98630E+00_JPRB, & + & 1.92924E+00_JPRB, 1.87381E+00_JPRB, 1.81998E+00_JPRB, 1.76770E+00_JPRB, 1.71691E+00_JPRB, & + & 1.66759E+00_JPRB, 1.61968E+00_JPRB, 1.57315E+00_JPRB, 1.52796E+00_JPRB, 1.48406E+00_JPRB, & + & 1.44143E+00_JPRB, 1.40002E+00_JPRB, 1.35980E+00_JPRB, 1.32073E+00_JPRB/) + KAO_MCO( 7, :, 2) = (/ & + & 2.64692E+00_JPRB, 2.57290E+00_JPRB, 2.50096E+00_JPRB, 2.43103E+00_JPRB, 2.36305E+00_JPRB, & + & 2.29697E+00_JPRB, 2.23275E+00_JPRB, 2.17031E+00_JPRB, 2.10963E+00_JPRB, 2.05064E+00_JPRB, & + & 1.99330E+00_JPRB, 1.93756E+00_JPRB, 1.88338E+00_JPRB, 1.83072E+00_JPRB, 1.77953E+00_JPRB, & + & 1.72977E+00_JPRB, 1.68140E+00_JPRB, 1.63438E+00_JPRB, 1.58868E+00_JPRB/) + KAO_MCO( 8, :, 2) = (/ & + & 2.86812E+00_JPRB, 2.80121E+00_JPRB, 2.73586E+00_JPRB, 2.67204E+00_JPRB, 2.60970E+00_JPRB, & + & 2.54882E+00_JPRB, 2.48936E+00_JPRB, 2.43129E+00_JPRB, 2.37457E+00_JPRB, 2.31917E+00_JPRB, & + & 2.26507E+00_JPRB, 2.21223E+00_JPRB, 2.16062E+00_JPRB, 2.11022E+00_JPRB, 2.06099E+00_JPRB, & + & 2.01291E+00_JPRB, 1.96595E+00_JPRB, 1.92009E+00_JPRB, 1.87529E+00_JPRB/) + KAO_MCO( 9, :, 2) = (/ & + & 1.25243E+00_JPRB, 1.22790E+00_JPRB, 1.20385E+00_JPRB, 1.18027E+00_JPRB, 1.15716E+00_JPRB, & + & 1.13449E+00_JPRB, 1.11227E+00_JPRB, 1.09049E+00_JPRB, 1.06913E+00_JPRB, 1.04819E+00_JPRB, & + & 1.02766E+00_JPRB, 1.00754E+00_JPRB, 9.87804E-01_JPRB, 9.68457E-01_JPRB, 9.49490E-01_JPRB, & + & 9.30894E-01_JPRB, 9.12662E-01_JPRB, 8.94787E-01_JPRB, 8.77263E-01_JPRB/) + KAO_MCO( 1, :, 3) = (/ & + & 2.55598E+00_JPRB, 2.48729E+00_JPRB, 2.42045E+00_JPRB, 2.35541E+00_JPRB, 2.29211E+00_JPRB, & + & 2.23052E+00_JPRB, 2.17058E+00_JPRB, 2.11225E+00_JPRB, 2.05549E+00_JPRB, 2.00025E+00_JPRB, & + & 1.94650E+00_JPRB, 1.89419E+00_JPRB, 1.84329E+00_JPRB, 1.79376E+00_JPRB, 1.74555E+00_JPRB, & + & 1.69865E+00_JPRB, 1.65300E+00_JPRB, 1.60858E+00_JPRB, 1.56535E+00_JPRB/) + KAO_MCO( 2, :, 3) = (/ & + & 2.93113E+00_JPRB, 2.85257E+00_JPRB, 2.77612E+00_JPRB, 2.70172E+00_JPRB, 2.62932E+00_JPRB, & + & 2.55885E+00_JPRB, 2.49028E+00_JPRB, 2.42354E+00_JPRB, 2.35859E+00_JPRB, 2.29538E+00_JPRB, & + & 2.23386E+00_JPRB, 2.17400E+00_JPRB, 2.11573E+00_JPRB, 2.05903E+00_JPRB, 2.00385E+00_JPRB, & + & 1.95015E+00_JPRB, 1.89788E+00_JPRB, 1.84702E+00_JPRB, 1.79752E+00_JPRB/) + KAO_MCO( 3, :, 3) = (/ & + & 3.26626E+00_JPRB, 3.18025E+00_JPRB, 3.09651E+00_JPRB, 3.01497E+00_JPRB, 2.93558E+00_JPRB, & + & 2.85828E+00_JPRB, 2.78302E+00_JPRB, 2.70973E+00_JPRB, 2.63838E+00_JPRB, 2.56891E+00_JPRB, & + & 2.50126E+00_JPRB, 2.43540E+00_JPRB, 2.37127E+00_JPRB, 2.30883E+00_JPRB, 2.24803E+00_JPRB, & + & 2.18883E+00_JPRB, 2.13120E+00_JPRB, 2.07508E+00_JPRB, 2.02044E+00_JPRB/) + KAO_MCO( 4, :, 3) = (/ & + & 3.65895E+00_JPRB, 3.56418E+00_JPRB, 3.47187E+00_JPRB, 3.38194E+00_JPRB, 3.29435E+00_JPRB, & + & 3.20903E+00_JPRB, 3.12591E+00_JPRB, 3.04495E+00_JPRB, 2.96608E+00_JPRB, 2.88926E+00_JPRB, & + & 2.81443E+00_JPRB, 2.74153E+00_JPRB, 2.67053E+00_JPRB, 2.60136E+00_JPRB, 2.53398E+00_JPRB, & + & 2.46835E+00_JPRB, 2.40442E+00_JPRB, 2.34214E+00_JPRB, 2.28148E+00_JPRB/) + KAO_MCO( 5, :, 3) = (/ & + & 4.13692E+00_JPRB, 4.03459E+00_JPRB, 3.93479E+00_JPRB, 3.83746E+00_JPRB, 3.74254E+00_JPRB, & + & 3.64997E+00_JPRB, 3.55968E+00_JPRB, 3.47163E+00_JPRB, 3.38576E+00_JPRB, 3.30201E+00_JPRB, & + & 3.22034E+00_JPRB, 3.14068E+00_JPRB, 3.06299E+00_JPRB, 2.98723E+00_JPRB, 2.91334E+00_JPRB, & + & 2.84128E+00_JPRB, 2.77100E+00_JPRB, 2.70246E+00_JPRB, 2.63561E+00_JPRB/) + KAO_MCO( 6, :, 3) = (/ & + & 4.42856E+00_JPRB, 4.32480E+00_JPRB, 4.22348E+00_JPRB, 4.12453E+00_JPRB, 4.02790E+00_JPRB, & + & 3.93353E+00_JPRB, 3.84137E+00_JPRB, 3.75137E+00_JPRB, 3.66348E+00_JPRB, 3.57765E+00_JPRB, & + & 3.49383E+00_JPRB, 3.41198E+00_JPRB, 3.33204E+00_JPRB, 3.25397E+00_JPRB, 3.17774E+00_JPRB, & + & 3.10329E+00_JPRB, 3.03058E+00_JPRB, 2.95958E+00_JPRB, 2.89024E+00_JPRB/) + KAO_MCO( 7, :, 3) = (/ & + & 4.31306E+00_JPRB, 4.21750E+00_JPRB, 4.12406E+00_JPRB, 4.03268E+00_JPRB, 3.94333E+00_JPRB, & + & 3.85596E+00_JPRB, 3.77053E+00_JPRB, 3.68699E+00_JPRB, 3.60530E+00_JPRB, 3.52542E+00_JPRB, & + & 3.44731E+00_JPRB, 3.37093E+00_JPRB, 3.29624E+00_JPRB, 3.22321E+00_JPRB, 3.15179E+00_JPRB, & + & 3.08196E+00_JPRB, 3.01368E+00_JPRB, 2.94691E+00_JPRB, 2.88161E+00_JPRB/) + KAO_MCO( 8, :, 3) = (/ & + & 4.38922E+00_JPRB, 4.32180E+00_JPRB, 4.25543E+00_JPRB, 4.19007E+00_JPRB, 4.12571E+00_JPRB, & + & 4.06234E+00_JPRB, 3.99995E+00_JPRB, 3.93851E+00_JPRB, 3.87802E+00_JPRB, 3.81846E+00_JPRB, & + & 3.75981E+00_JPRB, 3.70206E+00_JPRB, 3.64520E+00_JPRB, 3.58922E+00_JPRB, 3.53409E+00_JPRB, & + & 3.47981E+00_JPRB, 3.42636E+00_JPRB, 3.37374E+00_JPRB, 3.32192E+00_JPRB/) + KAO_MCO( 9, :, 3) = (/ & + & 1.56810E+00_JPRB, 1.54211E+00_JPRB, 1.51654E+00_JPRB, 1.49139E+00_JPRB, 1.46667E+00_JPRB, & + & 1.44235E+00_JPRB, 1.41844E+00_JPRB, 1.39492E+00_JPRB, 1.37179E+00_JPRB, 1.34905E+00_JPRB, & + & 1.32668E+00_JPRB, 1.30469E+00_JPRB, 1.28306E+00_JPRB, 1.26178E+00_JPRB, 1.24086E+00_JPRB, & + & 1.22029E+00_JPRB, 1.20006E+00_JPRB, 1.18016E+00_JPRB, 1.16059E+00_JPRB/) + KAO_MCO( 1, :, 4) = (/ & + & 6.58275E+00_JPRB, 6.43026E+00_JPRB, 6.28130E+00_JPRB, 6.13579E+00_JPRB, 5.99365E+00_JPRB, & + & 5.85481E+00_JPRB, 5.71918E+00_JPRB, 5.58669E+00_JPRB, 5.45727E+00_JPRB, 5.33085E+00_JPRB, & + & 5.20736E+00_JPRB, 5.08673E+00_JPRB, 4.96889E+00_JPRB, 4.85379E+00_JPRB, 4.74135E+00_JPRB, & + & 4.63151E+00_JPRB, 4.52422E+00_JPRB, 4.41942E+00_JPRB, 4.31704E+00_JPRB/) + KAO_MCO( 2, :, 4) = (/ & + & 6.59883E+00_JPRB, 6.45139E+00_JPRB, 6.30725E+00_JPRB, 6.16633E+00_JPRB, 6.02855E+00_JPRB, & + & 5.89386E+00_JPRB, 5.76217E+00_JPRB, 5.63342E+00_JPRB, 5.50756E+00_JPRB, 5.38450E+00_JPRB, & + & 5.26419E+00_JPRB, 5.14657E+00_JPRB, 5.03158E+00_JPRB, 4.91916E+00_JPRB, 4.80925E+00_JPRB, & + & 4.70180E+00_JPRB, 4.59675E+00_JPRB, 4.49404E+00_JPRB, 4.39363E+00_JPRB/) + KAO_MCO( 3, :, 4) = (/ & + & 6.58521E+00_JPRB, 6.44452E+00_JPRB, 6.30683E+00_JPRB, 6.17209E+00_JPRB, 6.04023E+00_JPRB, & + & 5.91118E+00_JPRB, 5.78489E+00_JPRB, 5.66130E+00_JPRB, 5.54034E+00_JPRB, 5.42198E+00_JPRB, & + & 5.30614E+00_JPRB, 5.19277E+00_JPRB, 5.08183E+00_JPRB, 4.97326E+00_JPRB, 4.86701E+00_JPRB, & + & 4.76303E+00_JPRB, 4.66127E+00_JPRB, 4.56168E+00_JPRB, 4.46422E+00_JPRB/) + KAO_MCO( 4, :, 4) = (/ & + & 6.33742E+00_JPRB, 6.20870E+00_JPRB, 6.08260E+00_JPRB, 5.95905E+00_JPRB, 5.83802E+00_JPRB, & + & 5.71945E+00_JPRB, 5.60328E+00_JPRB, 5.48947E+00_JPRB, 5.37798E+00_JPRB, 5.26875E+00_JPRB, & + & 5.16174E+00_JPRB, 5.05690E+00_JPRB, 4.95419E+00_JPRB, 4.85357E+00_JPRB, 4.75499E+00_JPRB, & + & 4.65841E+00_JPRB, 4.56379E+00_JPRB, 4.47110E+00_JPRB, 4.38029E+00_JPRB/) + KAO_MCO( 5, :, 4) = (/ & + & 5.99732E+00_JPRB, 5.88459E+00_JPRB, 5.77398E+00_JPRB, 5.66545E+00_JPRB, 5.55896E+00_JPRB, & + & 5.45447E+00_JPRB, 5.35194E+00_JPRB, 5.25134E+00_JPRB, 5.15263E+00_JPRB, 5.05578E+00_JPRB, & + & 4.96075E+00_JPRB, 4.86750E+00_JPRB, 4.77601E+00_JPRB, 4.68623E+00_JPRB, 4.59815E+00_JPRB, & + & 4.51171E+00_JPRB, 4.42691E+00_JPRB, 4.34370E+00_JPRB, 4.26205E+00_JPRB/) + KAO_MCO( 6, :, 4) = (/ & + & 5.74529E+00_JPRB, 5.65249E+00_JPRB, 5.56119E+00_JPRB, 5.47136E+00_JPRB, 5.38299E+00_JPRB, & + & 5.29604E+00_JPRB, 5.21049E+00_JPRB, 5.12633E+00_JPRB, 5.04353E+00_JPRB, 4.96206E+00_JPRB, & + & 4.88191E+00_JPRB, 4.80306E+00_JPRB, 4.72547E+00_JPRB, 4.64915E+00_JPRB, 4.57405E+00_JPRB, & + & 4.50017E+00_JPRB, 4.42748E+00_JPRB, 4.35596E+00_JPRB, 4.28560E+00_JPRB/) + KAO_MCO( 7, :, 4) = (/ & + & 5.87251E+00_JPRB, 5.79956E+00_JPRB, 5.72753E+00_JPRB, 5.65638E+00_JPRB, 5.58613E+00_JPRB, & + & 5.51674E+00_JPRB, 5.44822E+00_JPRB, 5.38054E+00_JPRB, 5.31371E+00_JPRB, 5.24771E+00_JPRB, & + & 5.18253E+00_JPRB, 5.11815E+00_JPRB, 5.05458E+00_JPRB, 4.99180E+00_JPRB, 4.92979E+00_JPRB, & + & 4.86856E+00_JPRB, 4.80809E+00_JPRB, 4.74837E+00_JPRB, 4.68939E+00_JPRB/) + KAO_MCO( 8, :, 4) = (/ & + & 5.68503E+00_JPRB, 5.62827E+00_JPRB, 5.57207E+00_JPRB, 5.51644E+00_JPRB, 5.46136E+00_JPRB, & + & 5.40684E+00_JPRB, 5.35285E+00_JPRB, 5.29941E+00_JPRB, 5.24650E+00_JPRB, 5.19412E+00_JPRB, & + & 5.14226E+00_JPRB, 5.09092E+00_JPRB, 5.04009E+00_JPRB, 4.98977E+00_JPRB, 4.93995E+00_JPRB, & + & 4.89063E+00_JPRB, 4.84180E+00_JPRB, 4.79346E+00_JPRB, 4.74560E+00_JPRB/) + KAO_MCO( 9, :, 4) = (/ & + & 2.69278E+00_JPRB, 2.65058E+00_JPRB, 2.60903E+00_JPRB, 2.56814E+00_JPRB, 2.52789E+00_JPRB, & + & 2.48827E+00_JPRB, 2.44927E+00_JPRB, 2.41088E+00_JPRB, 2.37310E+00_JPRB, 2.33590E+00_JPRB, & + & 2.29929E+00_JPRB, 2.26325E+00_JPRB, 2.22778E+00_JPRB, 2.19286E+00_JPRB, 2.15849E+00_JPRB, & + & 2.12466E+00_JPRB, 2.09136E+00_JPRB, 2.05859E+00_JPRB, 2.02632E+00_JPRB/) + KAO_MCO( 1, :, 5) = (/ & + & 9.12231E+00_JPRB, 9.00052E+00_JPRB, 8.88036E+00_JPRB, 8.76180E+00_JPRB, 8.64482E+00_JPRB, & + & 8.52941E+00_JPRB, 8.41553E+00_JPRB, 8.30318E+00_JPRB, 8.19233E+00_JPRB, 8.08295E+00_JPRB, & + & 7.97504E+00_JPRB, 7.86857E+00_JPRB, 7.76352E+00_JPRB, 7.65987E+00_JPRB, 7.55760E+00_JPRB, & + & 7.45671E+00_JPRB, 7.35715E+00_JPRB, 7.25893E+00_JPRB, 7.16202E+00_JPRB/) + KAO_MCO( 2, :, 5) = (/ & + & 8.37315E+00_JPRB, 8.27808E+00_JPRB, 8.18410E+00_JPRB, 8.09118E+00_JPRB, 7.99931E+00_JPRB, & + & 7.90849E+00_JPRB, 7.81871E+00_JPRB, 7.72994E+00_JPRB, 7.64217E+00_JPRB, 7.55541E+00_JPRB, & + & 7.46963E+00_JPRB, 7.38482E+00_JPRB, 7.30098E+00_JPRB, 7.21809E+00_JPRB, 7.13614E+00_JPRB, & + & 7.05512E+00_JPRB, 6.97502E+00_JPRB, 6.89582E+00_JPRB, 6.81753E+00_JPRB/) + KAO_MCO( 3, :, 5) = (/ & + & 8.14557E+00_JPRB, 8.06533E+00_JPRB, 7.98587E+00_JPRB, 7.90720E+00_JPRB, 7.82930E+00_JPRB, & + & 7.75217E+00_JPRB, 7.67580E+00_JPRB, 7.60018E+00_JPRB, 7.52530E+00_JPRB, 7.45117E+00_JPRB, & + & 7.37776E+00_JPRB, 7.30508E+00_JPRB, 7.23311E+00_JPRB, 7.16186E+00_JPRB, 7.09130E+00_JPRB, & + & 7.02144E+00_JPRB, 6.95227E+00_JPRB, 6.88378E+00_JPRB, 6.81596E+00_JPRB/) + KAO_MCO( 4, :, 5) = (/ & + & 8.18046E+00_JPRB, 8.11056E+00_JPRB, 8.04126E+00_JPRB, 7.97256E+00_JPRB, 7.90444E+00_JPRB, & + & 7.83690E+00_JPRB, 7.76994E+00_JPRB, 7.70355E+00_JPRB, 7.63773E+00_JPRB, 7.57247E+00_JPRB, & + & 7.50777E+00_JPRB, 7.44362E+00_JPRB, 7.38002E+00_JPRB, 7.31697E+00_JPRB, 7.25445E+00_JPRB, & + & 7.19247E+00_JPRB, 7.13101E+00_JPRB, 7.07008E+00_JPRB, 7.00968E+00_JPRB/) + KAO_MCO( 5, :, 5) = (/ & + & 8.30092E+00_JPRB, 8.23529E+00_JPRB, 8.17019E+00_JPRB, 8.10559E+00_JPRB, 8.04151E+00_JPRB, & + & 7.97794E+00_JPRB, 7.91487E+00_JPRB, 7.85230E+00_JPRB, 7.79022E+00_JPRB, 7.72863E+00_JPRB, & + & 7.66753E+00_JPRB, 7.60691E+00_JPRB, 7.54678E+00_JPRB, 7.48711E+00_JPRB, 7.42792E+00_JPRB, & + & 7.36920E+00_JPRB, 7.31094E+00_JPRB, 7.25314E+00_JPRB, 7.19580E+00_JPRB/) + KAO_MCO( 6, :, 5) = (/ & + & 8.30014E+00_JPRB, 8.24466E+00_JPRB, 8.18955E+00_JPRB, 8.13481E+00_JPRB, 8.08044E+00_JPRB, & + & 8.02642E+00_JPRB, 7.97277E+00_JPRB, 7.91948E+00_JPRB, 7.86655E+00_JPRB, 7.81396E+00_JPRB, & + & 7.76173E+00_JPRB, 7.70985E+00_JPRB, 7.65832E+00_JPRB, 7.60713E+00_JPRB, 7.55628E+00_JPRB, & + & 7.50577E+00_JPRB, 7.45560E+00_JPRB, 7.40577E+00_JPRB, 7.35627E+00_JPRB/) + KAO_MCO( 7, :, 5) = (/ & + & 7.95931E+00_JPRB, 7.93958E+00_JPRB, 7.91989E+00_JPRB, 7.90025E+00_JPRB, 7.88066E+00_JPRB, & + & 7.86112E+00_JPRB, 7.84163E+00_JPRB, 7.82219E+00_JPRB, 7.80279E+00_JPRB, 7.78344E+00_JPRB, & + & 7.76414E+00_JPRB, 7.74489E+00_JPRB, 7.72568E+00_JPRB, 7.70653E+00_JPRB, 7.68742E+00_JPRB, & + & 7.66836E+00_JPRB, 7.64934E+00_JPRB, 7.63038E+00_JPRB, 7.61146E+00_JPRB/) + KAO_MCO( 8, :, 5) = (/ & + & 9.32576E+00_JPRB, 9.31747E+00_JPRB, 9.30919E+00_JPRB, 9.30092E+00_JPRB, 9.29265E+00_JPRB, & + & 9.28439E+00_JPRB, 9.27613E+00_JPRB, 9.26789E+00_JPRB, 9.25965E+00_JPRB, 9.25142E+00_JPRB, & + & 9.24320E+00_JPRB, 9.23498E+00_JPRB, 9.22677E+00_JPRB, 9.21857E+00_JPRB, 9.21038E+00_JPRB, & + & 9.20219E+00_JPRB, 9.19401E+00_JPRB, 9.18584E+00_JPRB, 9.17767E+00_JPRB/) + KAO_MCO( 9, :, 5) = (/ & + & 4.13116E+00_JPRB, 4.08426E+00_JPRB, 4.03788E+00_JPRB, 3.99204E+00_JPRB, 3.94671E+00_JPRB, & + & 3.90190E+00_JPRB, 3.85760E+00_JPRB, 3.81380E+00_JPRB, 3.77049E+00_JPRB, 3.72768E+00_JPRB, & + & 3.68536E+00_JPRB, 3.64351E+00_JPRB, 3.60214E+00_JPRB, 3.56124E+00_JPRB, 3.52081E+00_JPRB, & + & 3.48083E+00_JPRB, 3.44131E+00_JPRB, 3.40224E+00_JPRB, 3.36361E+00_JPRB/) + KAO_MCO( 1, :, 6) = (/ & + & 1.21200E+01_JPRB, 1.21580E+01_JPRB, 1.21961E+01_JPRB, 1.22344E+01_JPRB, 1.22728E+01_JPRB, & + & 1.23113E+01_JPRB, 1.23499E+01_JPRB, 1.23886E+01_JPRB, 1.24275E+01_JPRB, 1.24664E+01_JPRB, & + & 1.25056E+01_JPRB, 1.25448E+01_JPRB, 1.25841E+01_JPRB, 1.26236E+01_JPRB, 1.26632E+01_JPRB, & + & 1.27029E+01_JPRB, 1.27428E+01_JPRB, 1.27827E+01_JPRB, 1.28228E+01_JPRB/) + KAO_MCO( 2, :, 6) = (/ & + & 1.25231E+01_JPRB, 1.25625E+01_JPRB, 1.26020E+01_JPRB, 1.26417E+01_JPRB, 1.26815E+01_JPRB, & + & 1.27214E+01_JPRB, 1.27614E+01_JPRB, 1.28015E+01_JPRB, 1.28418E+01_JPRB, 1.28822E+01_JPRB, & + & 1.29228E+01_JPRB, 1.29634E+01_JPRB, 1.30042E+01_JPRB, 1.30451E+01_JPRB, 1.30862E+01_JPRB, & + & 1.31274E+01_JPRB, 1.31687E+01_JPRB, 1.32101E+01_JPRB, 1.32517E+01_JPRB/) + KAO_MCO( 3, :, 6) = (/ & + & 1.27566E+01_JPRB, 1.27983E+01_JPRB, 1.28401E+01_JPRB, 1.28820E+01_JPRB, 1.29241E+01_JPRB, & + & 1.29663E+01_JPRB, 1.30087E+01_JPRB, 1.30512E+01_JPRB, 1.30938E+01_JPRB, 1.31366E+01_JPRB, & + & 1.31795E+01_JPRB, 1.32225E+01_JPRB, 1.32657E+01_JPRB, 1.33090E+01_JPRB, 1.33525E+01_JPRB, & + & 1.33961E+01_JPRB, 1.34399E+01_JPRB, 1.34838E+01_JPRB, 1.35278E+01_JPRB/) + KAO_MCO( 4, :, 6) = (/ & + & 1.27132E+01_JPRB, 1.27454E+01_JPRB, 1.27777E+01_JPRB, 1.28101E+01_JPRB, 1.28425E+01_JPRB, & + & 1.28750E+01_JPRB, 1.29077E+01_JPRB, 1.29403E+01_JPRB, 1.29731E+01_JPRB, 1.30060E+01_JPRB, & + & 1.30389E+01_JPRB, 1.30720E+01_JPRB, 1.31051E+01_JPRB, 1.31383E+01_JPRB, 1.31716E+01_JPRB, & + & 1.32049E+01_JPRB, 1.32384E+01_JPRB, 1.32719E+01_JPRB, 1.33055E+01_JPRB/) + KAO_MCO( 5, :, 6) = (/ & + & 1.33151E+01_JPRB, 1.33523E+01_JPRB, 1.33896E+01_JPRB, 1.34271E+01_JPRB, 1.34646E+01_JPRB, & + & 1.35022E+01_JPRB, 1.35400E+01_JPRB, 1.35779E+01_JPRB, 1.36158E+01_JPRB, 1.36539E+01_JPRB, & + & 1.36921E+01_JPRB, 1.37303E+01_JPRB, 1.37687E+01_JPRB, 1.38072E+01_JPRB, 1.38458E+01_JPRB, & + & 1.38846E+01_JPRB, 1.39234E+01_JPRB, 1.39623E+01_JPRB, 1.40013E+01_JPRB/) + KAO_MCO( 6, :, 6) = (/ & + & 1.41448E+01_JPRB, 1.41902E+01_JPRB, 1.42357E+01_JPRB, 1.42814E+01_JPRB, 1.43272E+01_JPRB, & + & 1.43732E+01_JPRB, 1.44194E+01_JPRB, 1.44656E+01_JPRB, 1.45121E+01_JPRB, 1.45586E+01_JPRB, & + & 1.46054E+01_JPRB, 1.46522E+01_JPRB, 1.46993E+01_JPRB, 1.47464E+01_JPRB, 1.47938E+01_JPRB, & + & 1.48413E+01_JPRB, 1.48889E+01_JPRB, 1.49367E+01_JPRB, 1.49846E+01_JPRB/) + KAO_MCO( 7, :, 6) = (/ & + & 1.56578E+01_JPRB, 1.56938E+01_JPRB, 1.57299E+01_JPRB, 1.57661E+01_JPRB, 1.58024E+01_JPRB, & + & 1.58388E+01_JPRB, 1.58752E+01_JPRB, 1.59117E+01_JPRB, 1.59484E+01_JPRB, 1.59851E+01_JPRB, & + & 1.60218E+01_JPRB, 1.60587E+01_JPRB, 1.60957E+01_JPRB, 1.61327E+01_JPRB, 1.61698E+01_JPRB, & + & 1.62070E+01_JPRB, 1.62443E+01_JPRB, 1.62817E+01_JPRB, 1.63192E+01_JPRB/) + KAO_MCO( 8, :, 6) = (/ & + & 1.73627E+01_JPRB, 1.74761E+01_JPRB, 1.75903E+01_JPRB, 1.77052E+01_JPRB, 1.78208E+01_JPRB, & + & 1.79373E+01_JPRB, 1.80544E+01_JPRB, 1.81724E+01_JPRB, 1.82911E+01_JPRB, 1.84106E+01_JPRB, & + & 1.85309E+01_JPRB, 1.86519E+01_JPRB, 1.87738E+01_JPRB, 1.88964E+01_JPRB, 1.90198E+01_JPRB, & + & 1.91441E+01_JPRB, 1.92692E+01_JPRB, 1.93950E+01_JPRB, 1.95217E+01_JPRB/) + KAO_MCO( 9, :, 6) = (/ & + & 7.16326E+00_JPRB, 7.12921E+00_JPRB, 7.09531E+00_JPRB, 7.06158E+00_JPRB, 7.02800E+00_JPRB, & + & 6.99459E+00_JPRB, 6.96133E+00_JPRB, 6.92824E+00_JPRB, 6.89530E+00_JPRB, 6.86252E+00_JPRB, & + & 6.82989E+00_JPRB, 6.79742E+00_JPRB, 6.76510E+00_JPRB, 6.73293E+00_JPRB, 6.70092E+00_JPRB, & + & 6.66906E+00_JPRB, 6.63736E+00_JPRB, 6.60580E+00_JPRB, 6.57439E+00_JPRB/) + KAO_MCO( 1, :, 7) = (/ & + & 2.09288E+01_JPRB, 2.10487E+01_JPRB, 2.11692E+01_JPRB, 2.12904E+01_JPRB, 2.14124E+01_JPRB, & + & 2.15350E+01_JPRB, 2.16583E+01_JPRB, 2.17823E+01_JPRB, 2.19070E+01_JPRB, 2.20325E+01_JPRB, & + & 2.21587E+01_JPRB, 2.22855E+01_JPRB, 2.24132E+01_JPRB, 2.25415E+01_JPRB, 2.26706E+01_JPRB, & + & 2.28004E+01_JPRB, 2.29310E+01_JPRB, 2.30623E+01_JPRB, 2.31943E+01_JPRB/) + KAO_MCO( 2, :, 7) = (/ & + & 2.08159E+01_JPRB, 2.09509E+01_JPRB, 2.10867E+01_JPRB, 2.12234E+01_JPRB, 2.13610E+01_JPRB, & + & 2.14994E+01_JPRB, 2.16388E+01_JPRB, 2.17791E+01_JPRB, 2.19202E+01_JPRB, 2.20623E+01_JPRB, & + & 2.22053E+01_JPRB, 2.23493E+01_JPRB, 2.24942E+01_JPRB, 2.26400E+01_JPRB, 2.27867E+01_JPRB, & + & 2.29345E+01_JPRB, 2.30831E+01_JPRB, 2.32328E+01_JPRB, 2.33834E+01_JPRB/) + KAO_MCO( 3, :, 7) = (/ & + & 2.10827E+01_JPRB, 2.12409E+01_JPRB, 2.14002E+01_JPRB, 2.15608E+01_JPRB, 2.17225E+01_JPRB, & + & 2.18855E+01_JPRB, 2.20497E+01_JPRB, 2.22151E+01_JPRB, 2.23818E+01_JPRB, 2.25497E+01_JPRB, & + & 2.27189E+01_JPRB, 2.28893E+01_JPRB, 2.30611E+01_JPRB, 2.32341E+01_JPRB, 2.34084E+01_JPRB, & + & 2.35840E+01_JPRB, 2.37609E+01_JPRB, 2.39392E+01_JPRB, 2.41188E+01_JPRB/) + KAO_MCO( 4, :, 7) = (/ & + & 2.13866E+01_JPRB, 2.15772E+01_JPRB, 2.17694E+01_JPRB, 2.19634E+01_JPRB, 2.21590E+01_JPRB, & + & 2.23565E+01_JPRB, 2.25556E+01_JPRB, 2.27566E+01_JPRB, 2.29594E+01_JPRB, 2.31639E+01_JPRB, & + & 2.33703E+01_JPRB, 2.35785E+01_JPRB, 2.37886E+01_JPRB, 2.40005E+01_JPRB, 2.42144E+01_JPRB, & + & 2.44301E+01_JPRB, 2.46477E+01_JPRB, 2.48673E+01_JPRB, 2.50889E+01_JPRB/) + KAO_MCO( 5, :, 7) = (/ & + & 1.93714E+01_JPRB, 1.95595E+01_JPRB, 1.97493E+01_JPRB, 1.99410E+01_JPRB, 2.01345E+01_JPRB, & + & 2.03300E+01_JPRB, 2.05273E+01_JPRB, 2.07265E+01_JPRB, 2.09277E+01_JPRB, 2.11308E+01_JPRB, & + & 2.13359E+01_JPRB, 2.15430E+01_JPRB, 2.17521E+01_JPRB, 2.19632E+01_JPRB, 2.21764E+01_JPRB, & + & 2.23917E+01_JPRB, 2.26090E+01_JPRB, 2.28284E+01_JPRB, 2.30500E+01_JPRB/) + KAO_MCO( 6, :, 7) = (/ & + & 1.70418E+01_JPRB, 1.72109E+01_JPRB, 1.73817E+01_JPRB, 1.75541E+01_JPRB, 1.77283E+01_JPRB, & + & 1.79041E+01_JPRB, 1.80818E+01_JPRB, 1.82612E+01_JPRB, 1.84423E+01_JPRB, 1.86253E+01_JPRB, & + & 1.88101E+01_JPRB, 1.89967E+01_JPRB, 1.91852E+01_JPRB, 1.93755E+01_JPRB, 1.95678E+01_JPRB, & + & 1.97619E+01_JPRB, 1.99580E+01_JPRB, 2.01560E+01_JPRB, 2.03560E+01_JPRB/) + KAO_MCO( 7, :, 7) = (/ & + & 1.31735E+01_JPRB, 1.32921E+01_JPRB, 1.34118E+01_JPRB, 1.35326E+01_JPRB, 1.36545E+01_JPRB, & + & 1.37775E+01_JPRB, 1.39015E+01_JPRB, 1.40267E+01_JPRB, 1.41531E+01_JPRB, 1.42805E+01_JPRB, & + & 1.44091E+01_JPRB, 1.45389E+01_JPRB, 1.46698E+01_JPRB, 1.48019E+01_JPRB, 1.49353E+01_JPRB, & + & 1.50698E+01_JPRB, 1.52055E+01_JPRB, 1.53424E+01_JPRB, 1.54806E+01_JPRB/) + KAO_MCO( 8, :, 7) = (/ & + & 4.97361E+00_JPRB, 4.96550E+00_JPRB, 4.95740E+00_JPRB, 4.94931E+00_JPRB, 4.94124E+00_JPRB, & + & 4.93318E+00_JPRB, 4.92513E+00_JPRB, 4.91709E+00_JPRB, 4.90907E+00_JPRB, 4.90106E+00_JPRB, & + & 4.89307E+00_JPRB, 4.88509E+00_JPRB, 4.87712E+00_JPRB, 4.86916E+00_JPRB, 4.86122E+00_JPRB, & + & 4.85329E+00_JPRB, 4.84537E+00_JPRB, 4.83747E+00_JPRB, 4.82958E+00_JPRB/) + KAO_MCO( 9, :, 7) = (/ & + & 1.76121E+01_JPRB, 1.75887E+01_JPRB, 1.75653E+01_JPRB, 1.75420E+01_JPRB, 1.75187E+01_JPRB, & + & 1.74955E+01_JPRB, 1.74722E+01_JPRB, 1.74490E+01_JPRB, 1.74259E+01_JPRB, 1.74027E+01_JPRB, & + & 1.73796E+01_JPRB, 1.73566E+01_JPRB, 1.73335E+01_JPRB, 1.73105E+01_JPRB, 1.72875E+01_JPRB, & + & 1.72646E+01_JPRB, 1.72416E+01_JPRB, 1.72188E+01_JPRB, 1.71959E+01_JPRB/) + KAO_MCO( 1, :, 8) = (/ & + & 5.99126E+00_JPRB, 6.08386E+00_JPRB, 6.17790E+00_JPRB, 6.27339E+00_JPRB, 6.37035E+00_JPRB, & + & 6.46881E+00_JPRB, 6.56880E+00_JPRB, 6.67033E+00_JPRB, 6.77343E+00_JPRB, 6.87812E+00_JPRB, & + & 6.98443E+00_JPRB, 7.09238E+00_JPRB, 7.20201E+00_JPRB, 7.31332E+00_JPRB, 7.42636E+00_JPRB, & + & 7.54115E+00_JPRB, 7.65771E+00_JPRB, 7.77607E+00_JPRB, 7.89626E+00_JPRB/) + KAO_MCO( 2, :, 8) = (/ & + & 4.71621E+00_JPRB, 4.78830E+00_JPRB, 4.86149E+00_JPRB, 4.93580E+00_JPRB, 5.01124E+00_JPRB, & + & 5.08784E+00_JPRB, 5.16561E+00_JPRB, 5.24456E+00_JPRB, 5.32473E+00_JPRB, 5.40612E+00_JPRB, & + & 5.48875E+00_JPRB, 5.57264E+00_JPRB, 5.65782E+00_JPRB, 5.74430E+00_JPRB, 5.83211E+00_JPRB, & + & 5.92125E+00_JPRB, 6.01176E+00_JPRB, 6.10365E+00_JPRB, 6.19694E+00_JPRB/) + KAO_MCO( 3, :, 8) = (/ & + & 2.77067E+00_JPRB, 2.81437E+00_JPRB, 2.85876E+00_JPRB, 2.90385E+00_JPRB, 2.94965E+00_JPRB, & + & 2.99617E+00_JPRB, 3.04343E+00_JPRB, 3.09143E+00_JPRB, 3.14019E+00_JPRB, 3.18972E+00_JPRB, & + & 3.24003E+00_JPRB, 3.29114E+00_JPRB, 3.34305E+00_JPRB, 3.39578E+00_JPRB, 3.44934E+00_JPRB, & + & 3.50374E+00_JPRB, 3.55901E+00_JPRB, 3.61514E+00_JPRB, 3.67216E+00_JPRB/) + KAO_MCO( 4, :, 8) = (/ & + & 1.22388E+00_JPRB, 1.24248E+00_JPRB, 1.26136E+00_JPRB, 1.28053E+00_JPRB, 1.29999E+00_JPRB, & + & 1.31974E+00_JPRB, 1.33979E+00_JPRB, 1.36015E+00_JPRB, 1.38082E+00_JPRB, 1.40181E+00_JPRB, & + & 1.42311E+00_JPRB, 1.44473E+00_JPRB, 1.46669E+00_JPRB, 1.48897E+00_JPRB, 1.51160E+00_JPRB, & + & 1.53457E+00_JPRB, 1.55789E+00_JPRB, 1.58156E+00_JPRB, 1.60559E+00_JPRB/) + KAO_MCO( 5, :, 8) = (/ & + & 1.41479E+00_JPRB, 1.43540E+00_JPRB, 1.45631E+00_JPRB, 1.47752E+00_JPRB, 1.49904E+00_JPRB, & + & 1.52088E+00_JPRB, 1.54303E+00_JPRB, 1.56550E+00_JPRB, 1.58831E+00_JPRB, 1.61144E+00_JPRB, & + & 1.63491E+00_JPRB, 1.65872E+00_JPRB, 1.68288E+00_JPRB, 1.70740E+00_JPRB, 1.73227E+00_JPRB, & + & 1.75750E+00_JPRB, 1.78310E+00_JPRB, 1.80907E+00_JPRB, 1.83542E+00_JPRB/) + KAO_MCO( 6, :, 8) = (/ & + & 1.43154E+00_JPRB, 1.46074E+00_JPRB, 1.49053E+00_JPRB, 1.52093E+00_JPRB, 1.55196E+00_JPRB, & + & 1.58361E+00_JPRB, 1.61591E+00_JPRB, 1.64887E+00_JPRB, 1.68250E+00_JPRB, 1.71682E+00_JPRB, & + & 1.75184E+00_JPRB, 1.78757E+00_JPRB, 1.82403E+00_JPRB, 1.86123E+00_JPRB, 1.89920E+00_JPRB, & + & 1.93793E+00_JPRB, 1.97746E+00_JPRB, 2.01779E+00_JPRB, 2.05895E+00_JPRB/) + KAO_MCO( 7, :, 8) = (/ & + & 2.49358E+00_JPRB, 2.56028E+00_JPRB, 2.62875E+00_JPRB, 2.69906E+00_JPRB, 2.77124E+00_JPRB, & + & 2.84536E+00_JPRB, 2.92146E+00_JPRB, 2.99960E+00_JPRB, 3.07982E+00_JPRB, 3.16219E+00_JPRB, & + & 3.24677E+00_JPRB, 3.33360E+00_JPRB, 3.42276E+00_JPRB, 3.51430E+00_JPRB, 3.60829E+00_JPRB, & + & 3.70480E+00_JPRB, 3.80388E+00_JPRB, 3.90562E+00_JPRB, 4.01007E+00_JPRB/) + KAO_MCO( 8, :, 8) = (/ & + & 4.32513E+00_JPRB, 4.39903E+00_JPRB, 4.47420E+00_JPRB, 4.55065E+00_JPRB, 4.62841E+00_JPRB, & + & 4.70750E+00_JPRB, 4.78794E+00_JPRB, 4.86975E+00_JPRB, 4.95296E+00_JPRB, 5.03759E+00_JPRB, & + & 5.12367E+00_JPRB, 5.21122E+00_JPRB, 5.30027E+00_JPRB, 5.39084E+00_JPRB, 5.48295E+00_JPRB, & + & 5.57664E+00_JPRB, 5.67193E+00_JPRB, 5.76885E+00_JPRB, 5.86743E+00_JPRB/) + KAO_MCO( 9, :, 8) = (/ & + & 3.35160E+01_JPRB, 3.36789E+01_JPRB, 3.38425E+01_JPRB, 3.40069E+01_JPRB, 3.41722E+01_JPRB, & + & 3.43382E+01_JPRB, 3.45050E+01_JPRB, 3.46727E+01_JPRB, 3.48412E+01_JPRB, 3.50105E+01_JPRB, & + & 3.51806E+01_JPRB, 3.53515E+01_JPRB, 3.55233E+01_JPRB, 3.56959E+01_JPRB, 3.58693E+01_JPRB, & + & 3.60436E+01_JPRB, 3.62187E+01_JPRB, 3.63947E+01_JPRB, 3.65715E+01_JPRB/) + KAO_MCO( 1, :, 9) = (/ & + & 8.68159E-01_JPRB, 9.13680E-01_JPRB, 9.61587E-01_JPRB, 1.01201E+00_JPRB, 1.06507E+00_JPRB, & + & 1.12091E+00_JPRB, 1.17969E+00_JPRB, 1.24154E+00_JPRB, 1.30664E+00_JPRB, 1.37515E+00_JPRB, & + & 1.44726E+00_JPRB, 1.52314E+00_JPRB, 1.60300E+00_JPRB, 1.68705E+00_JPRB, 1.77551E+00_JPRB, & + & 1.86861E+00_JPRB, 1.96658E+00_JPRB, 2.06970E+00_JPRB, 2.17822E+00_JPRB/) + KAO_MCO( 2, :, 9) = (/ & + & 9.04391E-01_JPRB, 9.49669E-01_JPRB, 9.97214E-01_JPRB, 1.04714E+00_JPRB, 1.09956E+00_JPRB, & + & 1.15461E+00_JPRB, 1.21242E+00_JPRB, 1.27312E+00_JPRB, 1.33685E+00_JPRB, 1.40378E+00_JPRB, & + & 1.47406E+00_JPRB, 1.54786E+00_JPRB, 1.62535E+00_JPRB, 1.70673E+00_JPRB, 1.79217E+00_JPRB, & + & 1.88190E+00_JPRB, 1.97611E+00_JPRB, 2.07505E+00_JPRB, 2.17893E+00_JPRB/) + KAO_MCO( 3, :, 9) = (/ & + & 9.67479E-01_JPRB, 1.01312E+00_JPRB, 1.06092E+00_JPRB, 1.11098E+00_JPRB, 1.16339E+00_JPRB, & + & 1.21828E+00_JPRB, 1.27576E+00_JPRB, 1.33595E+00_JPRB, 1.39898E+00_JPRB, 1.46499E+00_JPRB, & + & 1.53411E+00_JPRB, 1.60649E+00_JPRB, 1.68228E+00_JPRB, 1.76165E+00_JPRB, 1.84476E+00_JPRB, & + & 1.93180E+00_JPRB, 2.02294E+00_JPRB, 2.11839E+00_JPRB, 2.21833E+00_JPRB/) + KAO_MCO( 4, :, 9) = (/ & + & 1.05240E+00_JPRB, 1.09817E+00_JPRB, 1.14592E+00_JPRB, 1.19576E+00_JPRB, 1.24776E+00_JPRB, & + & 1.30202E+00_JPRB, 1.35864E+00_JPRB, 1.41772E+00_JPRB, 1.47937E+00_JPRB, 1.54371E+00_JPRB, & + & 1.61084E+00_JPRB, 1.68089E+00_JPRB, 1.75398E+00_JPRB, 1.83026E+00_JPRB, 1.90985E+00_JPRB, & + & 1.99290E+00_JPRB, 2.07957E+00_JPRB, 2.17000E+00_JPRB, 2.26437E+00_JPRB/) + KAO_MCO( 5, :, 9) = (/ & + & 1.25800E+00_JPRB, 1.30557E+00_JPRB, 1.35494E+00_JPRB, 1.40618E+00_JPRB, 1.45935E+00_JPRB, & + & 1.51454E+00_JPRB, 1.57181E+00_JPRB, 1.63125E+00_JPRB, 1.69293E+00_JPRB, 1.75695E+00_JPRB, & + & 1.82339E+00_JPRB, 1.89234E+00_JPRB, 1.96389E+00_JPRB, 2.03816E+00_JPRB, 2.11523E+00_JPRB, & + & 2.19522E+00_JPRB, 2.27823E+00_JPRB, 2.36438E+00_JPRB, 2.45378E+00_JPRB/) + KAO_MCO( 6, :, 9) = (/ & + & 1.76509E+00_JPRB, 1.80550E+00_JPRB, 1.84683E+00_JPRB, 1.88911E+00_JPRB, 1.93235E+00_JPRB, & + & 1.97658E+00_JPRB, 2.02183E+00_JPRB, 2.06811E+00_JPRB, 2.11546E+00_JPRB, 2.16388E+00_JPRB, & + & 2.21342E+00_JPRB, 2.26408E+00_JPRB, 2.31591E+00_JPRB, 2.36893E+00_JPRB, 2.42315E+00_JPRB, & + & 2.47862E+00_JPRB, 2.53536E+00_JPRB, 2.59340E+00_JPRB, 2.65277E+00_JPRB/) + KAO_MCO( 7, :, 9) = (/ & + & 2.03543E+00_JPRB, 2.05285E+00_JPRB, 2.07042E+00_JPRB, 2.08815E+00_JPRB, 2.10602E+00_JPRB, & + & 2.12405E+00_JPRB, 2.14223E+00_JPRB, 2.16057E+00_JPRB, 2.17907E+00_JPRB, 2.19772E+00_JPRB, & + & 2.21654E+00_JPRB, 2.23551E+00_JPRB, 2.25465E+00_JPRB, 2.27395E+00_JPRB, 2.29342E+00_JPRB, & + & 2.31305E+00_JPRB, 2.33285E+00_JPRB, 2.35282E+00_JPRB, 2.37296E+00_JPRB/) + KAO_MCO( 8, :, 9) = (/ & + & 3.18883E+00_JPRB, 3.20538E+00_JPRB, 3.22200E+00_JPRB, 3.23872E+00_JPRB, 3.25552E+00_JPRB, & + & 3.27241E+00_JPRB, 3.28939E+00_JPRB, 3.30645E+00_JPRB, 3.32360E+00_JPRB, 3.34085E+00_JPRB, & + & 3.35818E+00_JPRB, 3.37560E+00_JPRB, 3.39311E+00_JPRB, 3.41071E+00_JPRB, 3.42841E+00_JPRB, & + & 3.44619E+00_JPRB, 3.46407E+00_JPRB, 3.48204E+00_JPRB, 3.50011E+00_JPRB/) + KAO_MCO( 9, :, 9) = (/ & + & 3.97585E+00_JPRB, 3.96333E+00_JPRB, 3.95084E+00_JPRB, 3.93839E+00_JPRB, 3.92598E+00_JPRB, & + & 3.91361E+00_JPRB, 3.90128E+00_JPRB, 3.88899E+00_JPRB, 3.87674E+00_JPRB, 3.86452E+00_JPRB, & + & 3.85235E+00_JPRB, 3.84021E+00_JPRB, 3.82811E+00_JPRB, 3.81605E+00_JPRB, 3.80402E+00_JPRB, & + & 3.79204E+00_JPRB, 3.78009E+00_JPRB, 3.76818E+00_JPRB, 3.75631E+00_JPRB/) + KAO_MCO( 1, :,10) = (/ & + & 8.62646E-01_JPRB, 9.35164E-01_JPRB, 1.01378E+00_JPRB, 1.09900E+00_JPRB, 1.19139E+00_JPRB, & + & 1.29154E+00_JPRB, 1.40011E+00_JPRB, 1.51781E+00_JPRB, 1.64541E+00_JPRB, 1.78373E+00_JPRB, & + & 1.93367E+00_JPRB, 2.09623E+00_JPRB, 2.27245E+00_JPRB, 2.46348E+00_JPRB, 2.67057E+00_JPRB, & + & 2.89507E+00_JPRB, 3.13844E+00_JPRB, 3.40227E+00_JPRB, 3.68828E+00_JPRB/) + KAO_MCO( 2, :,10) = (/ & + & 8.04693E-01_JPRB, 8.72167E-01_JPRB, 9.45298E-01_JPRB, 1.02456E+00_JPRB, 1.11047E+00_JPRB, & + & 1.20358E+00_JPRB, 1.30450E+00_JPRB, 1.41389E+00_JPRB, 1.53244E+00_JPRB, 1.66094E+00_JPRB, & + & 1.80021E+00_JPRB, 1.95115E+00_JPRB, 2.11476E+00_JPRB, 2.29208E+00_JPRB, 2.48427E+00_JPRB, & + & 2.69258E+00_JPRB, 2.91835E+00_JPRB, 3.16305E+00_JPRB, 3.42827E+00_JPRB/) + KAO_MCO( 3, :,10) = (/ & + & 7.66566E-01_JPRB, 8.24651E-01_JPRB, 8.87137E-01_JPRB, 9.54358E-01_JPRB, 1.02667E+00_JPRB, & + & 1.10447E+00_JPRB, 1.18815E+00_JPRB, 1.27818E+00_JPRB, 1.37503E+00_JPRB, 1.47922E+00_JPRB, & + & 1.59131E+00_JPRB, 1.71189E+00_JPRB, 1.84160E+00_JPRB, 1.98114E+00_JPRB, 2.13126E+00_JPRB, & + & 2.29275E+00_JPRB, 2.46648E+00_JPRB, 2.65337E+00_JPRB, 2.85442E+00_JPRB/) + KAO_MCO( 4, :,10) = (/ & + & 5.40305E-01_JPRB, 5.77106E-01_JPRB, 6.16414E-01_JPRB, 6.58400E-01_JPRB, 7.03245E-01_JPRB, & + & 7.51145E-01_JPRB, 8.02307E-01_JPRB, 8.56954E-01_JPRB, 9.15323E-01_JPRB, 9.77668E-01_JPRB, & + & 1.04426E+00_JPRB, 1.11539E+00_JPRB, 1.19136E+00_JPRB, 1.27250E+00_JPRB, 1.35918E+00_JPRB, & + & 1.45175E+00_JPRB, 1.55064E+00_JPRB, 1.65625E+00_JPRB, 1.76906E+00_JPRB/) + KAO_MCO( 5, :,10) = (/ & + & 8.22474E-01_JPRB, 8.02911E-01_JPRB, 7.83814E-01_JPRB, 7.65171E-01_JPRB, 7.46971E-01_JPRB, & + & 7.29204E-01_JPRB, 7.11860E-01_JPRB, 6.94928E-01_JPRB, 6.78399E-01_JPRB, 6.62263E-01_JPRB, & + & 6.46511E-01_JPRB, 6.31133E-01_JPRB, 6.16122E-01_JPRB, 6.01467E-01_JPRB, 5.87161E-01_JPRB, & + & 5.73195E-01_JPRB, 5.59562E-01_JPRB, 5.46252E-01_JPRB, 5.33260E-01_JPRB/) + KAO_MCO( 6, :,10) = (/ & + & 1.28162E+00_JPRB, 1.25110E+00_JPRB, 1.22131E+00_JPRB, 1.19223E+00_JPRB, 1.16384E+00_JPRB, & + & 1.13613E+00_JPRB, 1.10908E+00_JPRB, 1.08267E+00_JPRB, 1.05689E+00_JPRB, 1.03173E+00_JPRB, & + & 1.00716E+00_JPRB, 9.83184E-01_JPRB, 9.59774E-01_JPRB, 9.36921E-01_JPRB, 9.14613E-01_JPRB, & + & 8.92836E-01_JPRB, 8.71577E-01_JPRB, 8.50825E-01_JPRB, 8.30567E-01_JPRB/) + KAO_MCO( 7, :,10) = (/ & + & 1.92679E+00_JPRB, 1.90551E+00_JPRB, 1.88446E+00_JPRB, 1.86365E+00_JPRB, 1.84307E+00_JPRB, & + & 1.82271E+00_JPRB, 1.80258E+00_JPRB, 1.78267E+00_JPRB, 1.76298E+00_JPRB, 1.74351E+00_JPRB, & + & 1.72425E+00_JPRB, 1.70520E+00_JPRB, 1.68637E+00_JPRB, 1.66774E+00_JPRB, 1.64932E+00_JPRB, & + & 1.63111E+00_JPRB, 1.61309E+00_JPRB, 1.59527E+00_JPRB, 1.57765E+00_JPRB/) + KAO_MCO( 8, :,10) = (/ & + & 4.66485E+00_JPRB, 4.60869E+00_JPRB, 4.55320E+00_JPRB, 4.49838E+00_JPRB, 4.44423E+00_JPRB, & + & 4.39072E+00_JPRB, 4.33786E+00_JPRB, 4.28563E+00_JPRB, 4.23404E+00_JPRB, 4.18306E+00_JPRB, & + & 4.13270E+00_JPRB, 4.08295E+00_JPRB, 4.03379E+00_JPRB, 3.98523E+00_JPRB, 3.93725E+00_JPRB, & + & 3.88985E+00_JPRB, 3.84301E+00_JPRB, 3.79675E+00_JPRB, 3.75104E+00_JPRB/) + KAO_MCO( 9, :,10) = (/ & + & 1.41505E+00_JPRB, 1.37820E+00_JPRB, 1.34232E+00_JPRB, 1.30736E+00_JPRB, 1.27332E+00_JPRB, & + & 1.24016E+00_JPRB, 1.20786E+00_JPRB, 1.17641E+00_JPRB, 1.14578E+00_JPRB, 1.11594E+00_JPRB, & + & 1.08688E+00_JPRB, 1.05858E+00_JPRB, 1.03101E+00_JPRB, 1.00416E+00_JPRB, 9.78015E-01_JPRB, & + & 9.52547E-01_JPRB, 9.27742E-01_JPRB, 9.03583E-01_JPRB, 8.80053E-01_JPRB/) + KAO_MCO( 1, :,11) = (/ & + & 3.40468E-03_JPRB, 4.05994E-03_JPRB, 4.84130E-03_JPRB, 5.77305E-03_JPRB, 6.88412E-03_JPRB, & + & 8.20902E-03_JPRB, 9.78890E-03_JPRB, 1.16728E-02_JPRB, 1.39194E-02_JPRB, 1.65983E-02_JPRB, & + & 1.97927E-02_JPRB, 2.36020E-02_JPRB, 2.81444E-02_JPRB, 3.35610E-02_JPRB, 4.00200E-02_JPRB, & + & 4.77222E-02_JPRB, 5.69067E-02_JPRB, 6.78588E-02_JPRB, 8.09187E-02_JPRB/) + KAO_MCO( 2, :,11) = (/ & + & 3.85021E-02_JPRB, 4.02208E-02_JPRB, 4.20162E-02_JPRB, 4.38918E-02_JPRB, 4.58512E-02_JPRB, & + & 4.78980E-02_JPRB, 5.00361E-02_JPRB, 5.22697E-02_JPRB, 5.46031E-02_JPRB, 5.70405E-02_JPRB, & + & 5.95868E-02_JPRB, 6.22468E-02_JPRB, 6.50254E-02_JPRB, 6.79282E-02_JPRB, 7.09605E-02_JPRB, & + & 7.41282E-02_JPRB, 7.74372E-02_JPRB, 8.08940E-02_JPRB, 8.45051E-02_JPRB/) + KAO_MCO( 3, :,11) = (/ & + & 5.24852E-01_JPRB, 5.10480E-01_JPRB, 4.96501E-01_JPRB, 4.82905E-01_JPRB, 4.69681E-01_JPRB, & + & 4.56820E-01_JPRB, 4.44310E-01_JPRB, 4.32143E-01_JPRB, 4.20310E-01_JPRB, 4.08800E-01_JPRB, & + & 3.97606E-01_JPRB, 3.86718E-01_JPRB, 3.76128E-01_JPRB, 3.65828E-01_JPRB, 3.55810E-01_JPRB, & + & 3.46067E-01_JPRB, 3.36590E-01_JPRB, 3.27373E-01_JPRB, 3.18409E-01_JPRB/) + KAO_MCO( 4, :,11) = (/ & + & 5.86290E-01_JPRB, 5.70241E-01_JPRB, 5.54632E-01_JPRB, 5.39450E-01_JPRB, 5.24683E-01_JPRB, & + & 5.10321E-01_JPRB, 4.96352E-01_JPRB, 4.82765E-01_JPRB, 4.69550E-01_JPRB, 4.56697E-01_JPRB, & + & 4.44196E-01_JPRB, 4.32036E-01_JPRB, 4.20210E-01_JPRB, 4.08708E-01_JPRB, 3.97520E-01_JPRB, & + & 3.86638E-01_JPRB, 3.76055E-01_JPRB, 3.65761E-01_JPRB, 3.55749E-01_JPRB/) + KAO_MCO( 5, :,11) = (/ & + & 1.66977E+00_JPRB, 1.61807E+00_JPRB, 1.56798E+00_JPRB, 1.51943E+00_JPRB, 1.47239E+00_JPRB, & + & 1.42681E+00_JPRB, 1.38264E+00_JPRB, 1.33983E+00_JPRB, 1.29835E+00_JPRB, 1.25815E+00_JPRB, & + & 1.21920E+00_JPRB, 1.18146E+00_JPRB, 1.14488E+00_JPRB, 1.10943E+00_JPRB, 1.07509E+00_JPRB, & + & 1.04180E+00_JPRB, 1.00955E+00_JPRB, 9.78295E-01_JPRB, 9.48008E-01_JPRB/) + KAO_MCO( 6, :,11) = (/ & + & 1.96627E+00_JPRB, 1.90948E+00_JPRB, 1.85432E+00_JPRB, 1.80076E+00_JPRB, 1.74875E+00_JPRB, & + & 1.69823E+00_JPRB, 1.64918E+00_JPRB, 1.60155E+00_JPRB, 1.55529E+00_JPRB, 1.51036E+00_JPRB, & + & 1.46674E+00_JPRB, 1.42437E+00_JPRB, 1.38323E+00_JPRB, 1.34328E+00_JPRB, 1.30448E+00_JPRB, & + & 1.26680E+00_JPRB, 1.23021E+00_JPRB, 1.19467E+00_JPRB, 1.16016E+00_JPRB/) + KAO_MCO( 7, :,11) = (/ & + & 1.67574E+00_JPRB, 1.63510E+00_JPRB, 1.59544E+00_JPRB, 1.55674E+00_JPRB, 1.51898E+00_JPRB, & + & 1.48213E+00_JPRB, 1.44618E+00_JPRB, 1.41111E+00_JPRB, 1.37688E+00_JPRB, 1.34348E+00_JPRB, & + & 1.31090E+00_JPRB, 1.27910E+00_JPRB, 1.24808E+00_JPRB, 1.21780E+00_JPRB, 1.18826E+00_JPRB, & + & 1.15944E+00_JPRB, 1.13132E+00_JPRB, 1.10388E+00_JPRB, 1.07710E+00_JPRB/) + KAO_MCO( 8, :,11) = (/ & + & 2.00764E+00_JPRB, 1.96233E+00_JPRB, 1.91803E+00_JPRB, 1.87474E+00_JPRB, 1.83242E+00_JPRB, & + & 1.79106E+00_JPRB, 1.75063E+00_JPRB, 1.71111E+00_JPRB, 1.67249E+00_JPRB, 1.63474E+00_JPRB, & + & 1.59784E+00_JPRB, 1.56177E+00_JPRB, 1.52652E+00_JPRB, 1.49206E+00_JPRB, 1.45838E+00_JPRB, & + & 1.42546E+00_JPRB, 1.39329E+00_JPRB, 1.36184E+00_JPRB, 1.33110E+00_JPRB/) + KAO_MCO( 9, :,11) = (/ & + & 1.83026E+00_JPRB, 1.77349E+00_JPRB, 1.71849E+00_JPRB, 1.66519E+00_JPRB, 1.61355E+00_JPRB, & + & 1.56350E+00_JPRB, 1.51501E+00_JPRB, 1.46803E+00_JPRB, 1.42250E+00_JPRB, 1.37838E+00_JPRB, & + & 1.33563E+00_JPRB, 1.29421E+00_JPRB, 1.25407E+00_JPRB, 1.21517E+00_JPRB, 1.17749E+00_JPRB, & + & 1.14097E+00_JPRB, 1.10558E+00_JPRB, 1.07129E+00_JPRB, 1.03807E+00_JPRB/) + KAO_MCO( 1, :,12) = (/ & + & 3.90309E-04_JPRB, 4.81310E-04_JPRB, 5.93528E-04_JPRB, 7.31909E-04_JPRB, 9.02554E-04_JPRB, & + & 1.11299E-03_JPRB, 1.37248E-03_JPRB, 1.69247E-03_JPRB, 2.08708E-03_JPRB, 2.57368E-03_JPRB, & + & 3.17374E-03_JPRB, 3.91370E-03_JPRB, 4.82617E-03_JPRB, 5.95140E-03_JPRB, 7.33897E-03_JPRB, & + & 9.05007E-03_JPRB, 1.11601E-02_JPRB, 1.37621E-02_JPRB, 1.69707E-02_JPRB/) + KAO_MCO( 2, :,12) = (/ & + & 9.80585E-02_JPRB, 9.77457E-02_JPRB, 9.74339E-02_JPRB, 9.71231E-02_JPRB, 9.68132E-02_JPRB, & + & 9.65044E-02_JPRB, 9.61965E-02_JPRB, 9.58897E-02_JPRB, 9.55838E-02_JPRB, 9.52789E-02_JPRB, & + & 9.49749E-02_JPRB, 9.46719E-02_JPRB, 9.43699E-02_JPRB, 9.40689E-02_JPRB, 9.37688E-02_JPRB, & + & 9.34697E-02_JPRB, 9.31715E-02_JPRB, 9.28743E-02_JPRB, 9.25780E-02_JPRB/) + KAO_MCO( 3, :,12) = (/ & + & 3.15258E-01_JPRB, 3.09936E-01_JPRB, 3.04704E-01_JPRB, 2.99560E-01_JPRB, 2.94503E-01_JPRB, & + & 2.89532E-01_JPRB, 2.84645E-01_JPRB, 2.79840E-01_JPRB, 2.75116E-01_JPRB, 2.70472E-01_JPRB, & + & 2.65906E-01_JPRB, 2.61417E-01_JPRB, 2.57004E-01_JPRB, 2.52666E-01_JPRB, 2.48401E-01_JPRB, & + & 2.44207E-01_JPRB, 2.40085E-01_JPRB, 2.36032E-01_JPRB, 2.32048E-01_JPRB/) + KAO_MCO( 4, :,12) = (/ & + & 9.74407E-01_JPRB, 9.46900E-01_JPRB, 9.20170E-01_JPRB, 8.94195E-01_JPRB, 8.68952E-01_JPRB, & + & 8.44422E-01_JPRB, 8.20585E-01_JPRB, 7.97421E-01_JPRB, 7.74910E-01_JPRB, 7.53035E-01_JPRB, & + & 7.31777E-01_JPRB, 7.11120E-01_JPRB, 6.91046E-01_JPRB, 6.71538E-01_JPRB, 6.52581E-01_JPRB, & + & 6.34159E-01_JPRB, 6.16257E-01_JPRB, 5.98861E-01_JPRB, 5.81956E-01_JPRB/) + KAO_MCO( 5, :,12) = (/ & + & 1.04234E+00_JPRB, 1.01364E+00_JPRB, 9.85726E-01_JPRB, 9.58581E-01_JPRB, 9.32184E-01_JPRB, & + & 9.06514E-01_JPRB, 8.81551E-01_JPRB, 8.57275E-01_JPRB, 8.33668E-01_JPRB, 8.10710E-01_JPRB, & + & 7.88385E-01_JPRB, 7.66675E-01_JPRB, 7.45563E-01_JPRB, 7.25032E-01_JPRB, 7.05066E-01_JPRB, & + & 6.85650E-01_JPRB, 6.66769E-01_JPRB, 6.48408E-01_JPRB, 6.30552E-01_JPRB/) + KAO_MCO( 6, :,12) = (/ & + & 1.79052E+00_JPRB, 1.73725E+00_JPRB, 1.68557E+00_JPRB, 1.63543E+00_JPRB, 1.58678E+00_JPRB, & + & 1.53957E+00_JPRB, 1.49377E+00_JPRB, 1.44933E+00_JPRB, 1.40622E+00_JPRB, 1.36439E+00_JPRB, & + & 1.32380E+00_JPRB, 1.28442E+00_JPRB, 1.24621E+00_JPRB, 1.20913E+00_JPRB, 1.17316E+00_JPRB, & + & 1.13826E+00_JPRB, 1.10440E+00_JPRB, 1.07155E+00_JPRB, 1.03967E+00_JPRB/) + KAO_MCO( 7, :,12) = (/ & + & 2.99551E+00_JPRB, 2.90366E+00_JPRB, 2.81462E+00_JPRB, 2.72831E+00_JPRB, 2.64464E+00_JPRB, & + & 2.56355E+00_JPRB, 2.48494E+00_JPRB, 2.40874E+00_JPRB, 2.33487E+00_JPRB, 2.26328E+00_JPRB, & + & 2.19387E+00_JPRB, 2.12660E+00_JPRB, 2.06139E+00_JPRB, 1.99818E+00_JPRB, 1.93690E+00_JPRB, & + & 1.87751E+00_JPRB, 1.81993E+00_JPRB, 1.76413E+00_JPRB, 1.71003E+00_JPRB/) + KAO_MCO( 8, :,12) = (/ & + & 2.89665E+00_JPRB, 2.81184E+00_JPRB, 2.72951E+00_JPRB, 2.64960E+00_JPRB, 2.57202E+00_JPRB, & + & 2.49672E+00_JPRB, 2.42362E+00_JPRB, 2.35266E+00_JPRB, 2.28378E+00_JPRB, 2.21692E+00_JPRB, & + & 2.15201E+00_JPRB, 2.08900E+00_JPRB, 2.02784E+00_JPRB, 1.96847E+00_JPRB, 1.91084E+00_JPRB, & + & 1.85489E+00_JPRB, 1.80059E+00_JPRB, 1.74787E+00_JPRB, 1.69669E+00_JPRB/) + KAO_MCO( 9, :,12) = (/ & + & 1.03145E+00_JPRB, 1.00335E+00_JPRB, 9.76014E-01_JPRB, 9.49426E-01_JPRB, 9.23561E-01_JPRB, & + & 8.98402E-01_JPRB, 8.73927E-01_JPRB, 8.50120E-01_JPRB, 8.26961E-01_JPRB, 8.04433E-01_JPRB, & + & 7.82518E-01_JPRB, 7.61201E-01_JPRB, 7.40464E-01_JPRB, 7.20293E-01_JPRB, 7.00670E-01_JPRB, & + & 6.81583E-01_JPRB, 6.63015E-01_JPRB, 6.44953E-01_JPRB, 6.27383E-01_JPRB/) + KAO_MCO( 1, :,13) = (/ & + & 5.27769E-04_JPRB, 6.65449E-04_JPRB, 8.39047E-04_JPRB, 1.05793E-03_JPRB, 1.33392E-03_JPRB, & + & 1.68190E-03_JPRB, 2.12066E-03_JPRB, 2.67388E-03_JPRB, 3.37143E-03_JPRB, 4.25094E-03_JPRB, & + & 5.35990E-03_JPRB, 6.75816E-03_JPRB, 8.52117E-03_JPRB, 1.07441E-02_JPRB, 1.35470E-02_JPRB, & + & 1.70810E-02_JPRB, 2.15370E-02_JPRB, 2.71554E-02_JPRB, 3.42395E-02_JPRB/) + KAO_MCO( 2, :,13) = (/ & + & 1.08329E-01_JPRB, 1.10179E-01_JPRB, 1.12060E-01_JPRB, 1.13974E-01_JPRB, 1.15920E-01_JPRB, & + & 1.17899E-01_JPRB, 1.19913E-01_JPRB, 1.21960E-01_JPRB, 1.24043E-01_JPRB, 1.26161E-01_JPRB, & + & 1.28316E-01_JPRB, 1.30507E-01_JPRB, 1.32735E-01_JPRB, 1.35002E-01_JPRB, 1.37307E-01_JPRB, & + & 1.39652E-01_JPRB, 1.42037E-01_JPRB, 1.44462E-01_JPRB, 1.46929E-01_JPRB/) + KAO_MCO( 3, :,13) = (/ & + & 1.95992E-01_JPRB, 1.94515E-01_JPRB, 1.93049E-01_JPRB, 1.91594E-01_JPRB, 1.90150E-01_JPRB, & + & 1.88717E-01_JPRB, 1.87294E-01_JPRB, 1.85882E-01_JPRB, 1.84481E-01_JPRB, 1.83091E-01_JPRB, & + & 1.81711E-01_JPRB, 1.80341E-01_JPRB, 1.78982E-01_JPRB, 1.77633E-01_JPRB, 1.76294E-01_JPRB, & + & 1.74965E-01_JPRB, 1.73646E-01_JPRB, 1.72337E-01_JPRB, 1.71038E-01_JPRB/) + KAO_MCO( 4, :,13) = (/ & + & 4.49766E-01_JPRB, 4.42749E-01_JPRB, 4.35841E-01_JPRB, 4.29042E-01_JPRB, 4.22348E-01_JPRB, & + & 4.15759E-01_JPRB, 4.09272E-01_JPRB, 4.02887E-01_JPRB, 3.96601E-01_JPRB, 3.90414E-01_JPRB, & + & 3.84323E-01_JPRB, 3.78327E-01_JPRB, 3.72424E-01_JPRB, 3.66614E-01_JPRB, 3.60894E-01_JPRB, & + & 3.55264E-01_JPRB, 3.49721E-01_JPRB, 3.44265E-01_JPRB, 3.38894E-01_JPRB/) + KAO_MCO( 5, :,13) = (/ & + & 1.07498E+00_JPRB, 1.04736E+00_JPRB, 1.02045E+00_JPRB, 9.94232E-01_JPRB, 9.68686E-01_JPRB, & + & 9.43797E-01_JPRB, 9.19547E-01_JPRB, 8.95920E-01_JPRB, 8.72900E-01_JPRB, 8.50471E-01_JPRB, & + & 8.28619E-01_JPRB, 8.07329E-01_JPRB, 7.86585E-01_JPRB, 7.66374E-01_JPRB, 7.46683E-01_JPRB, & + & 7.27498E-01_JPRB, 7.08805E-01_JPRB, 6.90593E-01_JPRB, 6.72849E-01_JPRB/) + KAO_MCO( 6, :,13) = (/ & + & 1.66569E+00_JPRB, 1.61740E+00_JPRB, 1.57052E+00_JPRB, 1.52500E+00_JPRB, 1.48080E+00_JPRB, & + & 1.43787E+00_JPRB, 1.39620E+00_JPRB, 1.35573E+00_JPRB, 1.31643E+00_JPRB, 1.27827E+00_JPRB, & + & 1.24122E+00_JPRB, 1.20524E+00_JPRB, 1.17031E+00_JPRB, 1.13638E+00_JPRB, 1.10344E+00_JPRB, & + & 1.07146E+00_JPRB, 1.04040E+00_JPRB, 1.01025E+00_JPRB, 9.80963E-01_JPRB/) + KAO_MCO( 7, :,13) = (/ & + & 1.52948E+00_JPRB, 1.48763E+00_JPRB, 1.44693E+00_JPRB, 1.40735E+00_JPRB, 1.36884E+00_JPRB, & + & 1.33139E+00_JPRB, 1.29497E+00_JPRB, 1.25954E+00_JPRB, 1.22508E+00_JPRB, 1.19156E+00_JPRB, & + & 1.15896E+00_JPRB, 1.12725E+00_JPRB, 1.09641E+00_JPRB, 1.06641E+00_JPRB, 1.03724E+00_JPRB, & + & 1.00886E+00_JPRB, 9.81259E-01_JPRB, 9.54412E-01_JPRB, 9.28301E-01_JPRB/) + KAO_MCO( 8, :,13) = (/ & + & 3.81027E+00_JPRB, 3.69422E+00_JPRB, 3.58170E+00_JPRB, 3.47261E+00_JPRB, 3.36684E+00_JPRB, & + & 3.26429E+00_JPRB, 3.16486E+00_JPRB, 3.06847E+00_JPRB, 2.97501E+00_JPRB, 2.88439E+00_JPRB, & + & 2.79654E+00_JPRB, 2.71136E+00_JPRB, 2.62878E+00_JPRB, 2.54871E+00_JPRB, 2.47108E+00_JPRB, & + & 2.39581E+00_JPRB, 2.32284E+00_JPRB, 2.25209E+00_JPRB, 2.18350E+00_JPRB/) + KAO_MCO( 9, :,13) = (/ & + & 1.12516E+00_JPRB, 1.09531E+00_JPRB, 1.06625E+00_JPRB, 1.03796E+00_JPRB, 1.01042E+00_JPRB, & + & 9.83616E-01_JPRB, 9.57520E-01_JPRB, 9.32117E-01_JPRB, 9.07387E-01_JPRB, 8.83314E-01_JPRB, & + & 8.59880E-01_JPRB, 8.37067E-01_JPRB, 8.14859E-01_JPRB, 7.93241E-01_JPRB, 7.72196E-01_JPRB, & + & 7.51709E-01_JPRB, 7.31766E-01_JPRB, 7.12352E-01_JPRB, 6.93454E-01_JPRB/) + KAO_MCO( 1, :,14) = (/ & + & 4.79165E-04_JPRB, 6.26966E-04_JPRB, 8.20356E-04_JPRB, 1.07340E-03_JPRB, 1.40450E-03_JPRB, & + & 1.83772E-03_JPRB, 2.40457E-03_JPRB, 3.14628E-03_JPRB, 4.11676E-03_JPRB, 5.38660E-03_JPRB, & + & 7.04813E-03_JPRB, 9.22216E-03_JPRB, 1.20668E-02_JPRB, 1.57889E-02_JPRB, 2.06590E-02_JPRB, & + & 2.70314E-02_JPRB, 3.53694E-02_JPRB, 4.62792E-02_JPRB, 6.05542E-02_JPRB/) + KAO_MCO( 2, :,14) = (/ & + & 4.75367E-04_JPRB, 6.21987E-04_JPRB, 8.13830E-04_JPRB, 1.06484E-03_JPRB, 1.39328E-03_JPRB, & + & 1.82302E-03_JPRB, 2.38530E-03_JPRB, 3.12101E-03_JPRB, 4.08365E-03_JPRB, 5.34318E-03_JPRB, & + & 6.99121E-03_JPRB, 9.14756E-03_JPRB, 1.19690E-02_JPRB, 1.56607E-02_JPRB, 2.04909E-02_JPRB, & + & 2.68111E-02_JPRB, 3.50806E-02_JPRB, 4.59007E-02_JPRB, 6.00580E-02_JPRB/) + KAO_MCO( 3, :,14) = (/ & + & 1.39594E-01_JPRB, 1.42407E-01_JPRB, 1.45276E-01_JPRB, 1.48202E-01_JPRB, 1.51188E-01_JPRB, & + & 1.54234E-01_JPRB, 1.57342E-01_JPRB, 1.60512E-01_JPRB, 1.63745E-01_JPRB, 1.67044E-01_JPRB, & + & 1.70410E-01_JPRB, 1.73843E-01_JPRB, 1.77345E-01_JPRB, 1.80918E-01_JPRB, 1.84563E-01_JPRB, & + & 1.88282E-01_JPRB, 1.92075E-01_JPRB, 1.95945E-01_JPRB, 1.99892E-01_JPRB/) + KAO_MCO( 4, :,14) = (/ & + & 2.73418E-01_JPRB, 2.71322E-01_JPRB, 2.69242E-01_JPRB, 2.67177E-01_JPRB, 2.65129E-01_JPRB, & + & 2.63096E-01_JPRB, 2.61079E-01_JPRB, 2.59077E-01_JPRB, 2.57091E-01_JPRB, 2.55120E-01_JPRB, & + & 2.53164E-01_JPRB, 2.51223E-01_JPRB, 2.49297E-01_JPRB, 2.47386E-01_JPRB, 2.45489E-01_JPRB, & + & 2.43607E-01_JPRB, 2.41739E-01_JPRB, 2.39886E-01_JPRB, 2.38047E-01_JPRB/) + KAO_MCO( 5, :,14) = (/ & + & 5.01880E-01_JPRB, 4.95066E-01_JPRB, 4.88344E-01_JPRB, 4.81713E-01_JPRB, 4.75173E-01_JPRB, & + & 4.68721E-01_JPRB, 4.62357E-01_JPRB, 4.56079E-01_JPRB, 4.49887E-01_JPRB, 4.43778E-01_JPRB, & + & 4.37753E-01_JPRB, 4.31809E-01_JPRB, 4.25946E-01_JPRB, 4.20163E-01_JPRB, 4.14458E-01_JPRB, & + & 4.08830E-01_JPRB, 4.03279E-01_JPRB, 3.97804E-01_JPRB, 3.92403E-01_JPRB/) + KAO_MCO( 6, :,14) = (/ & + & 9.46125E-01_JPRB, 9.29642E-01_JPRB, 9.13447E-01_JPRB, 8.97533E-01_JPRB, 8.81897E-01_JPRB, & + & 8.66533E-01_JPRB, 8.51437E-01_JPRB, 8.36603E-01_JPRB, 8.22029E-01_JPRB, 8.07708E-01_JPRB, & + & 7.93636E-01_JPRB, 7.79810E-01_JPRB, 7.66225E-01_JPRB, 7.52876E-01_JPRB, 7.39760E-01_JPRB, & + & 7.26872E-01_JPRB, 7.14209E-01_JPRB, 7.01766E-01_JPRB, 6.89540E-01_JPRB/) + KAO_MCO( 7, :,14) = (/ & + & 2.47697E+00_JPRB, 2.41183E+00_JPRB, 2.34840E+00_JPRB, 2.28664E+00_JPRB, 2.22650E+00_JPRB, & + & 2.16795E+00_JPRB, 2.11093E+00_JPRB, 2.05541E+00_JPRB, 2.00136E+00_JPRB, 1.94872E+00_JPRB, & + & 1.89747E+00_JPRB, 1.84757E+00_JPRB, 1.79898E+00_JPRB, 1.75167E+00_JPRB, 1.70560E+00_JPRB, & + & 1.66074E+00_JPRB, 1.61707E+00_JPRB, 1.57454E+00_JPRB, 1.53313E+00_JPRB/) + KAO_MCO( 8, :,14) = (/ & + & 2.19323E+00_JPRB, 2.13926E+00_JPRB, 2.08662E+00_JPRB, 2.03528E+00_JPRB, 1.98519E+00_JPRB, & + & 1.93635E+00_JPRB, 1.88870E+00_JPRB, 1.84222E+00_JPRB, 1.79689E+00_JPRB, 1.75268E+00_JPRB, & + & 1.70955E+00_JPRB, 1.66748E+00_JPRB, 1.62645E+00_JPRB, 1.58643E+00_JPRB, 1.54739E+00_JPRB, & + & 1.50932E+00_JPRB, 1.47218E+00_JPRB, 1.43595E+00_JPRB, 1.40062E+00_JPRB/) + KAO_MCO( 9, :,14) = (/ & + & 5.68351E-01_JPRB, 5.60360E-01_JPRB, 5.52481E-01_JPRB, 5.44712E-01_JPRB, 5.37053E-01_JPRB, & + & 5.29502E-01_JPRB, 5.22057E-01_JPRB, 5.14716E-01_JPRB, 5.07479E-01_JPRB, 5.00343E-01_JPRB, & + & 4.93308E-01_JPRB, 4.86372E-01_JPRB, 4.79533E-01_JPRB, 4.72790E-01_JPRB, 4.66142E-01_JPRB, & + & 4.59588E-01_JPRB, 4.53126E-01_JPRB, 4.46754E-01_JPRB, 4.40473E-01_JPRB/) + KAO_MCO( 1, :,15) = (/ & + & 7.87937E-04_JPRB, 1.01733E-03_JPRB, 1.31351E-03_JPRB, 1.69591E-03_JPRB, 2.18964E-03_JPRB, & + & 2.82712E-03_JPRB, 3.65018E-03_JPRB, 4.71286E-03_JPRB, 6.08493E-03_JPRB, 7.85644E-03_JPRB, & + & 1.01437E-02_JPRB, 1.30969E-02_JPRB, 1.69098E-02_JPRB, 2.18327E-02_JPRB, 2.81889E-02_JPRB, & + & 3.63956E-02_JPRB, 4.69915E-02_JPRB, 6.06722E-02_JPRB, 7.83357E-02_JPRB/) + KAO_MCO( 2, :,15) = (/ & + & 7.87937E-04_JPRB, 1.01733E-03_JPRB, 1.31351E-03_JPRB, 1.69591E-03_JPRB, 2.18964E-03_JPRB, & + & 2.82712E-03_JPRB, 3.65018E-03_JPRB, 4.71286E-03_JPRB, 6.08493E-03_JPRB, 7.85644E-03_JPRB, & + & 1.01437E-02_JPRB, 1.30969E-02_JPRB, 1.69098E-02_JPRB, 2.18327E-02_JPRB, 2.81889E-02_JPRB, & + & 3.63956E-02_JPRB, 4.69915E-02_JPRB, 6.06722E-02_JPRB, 7.83357E-02_JPRB/) + KAO_MCO( 3, :,15) = (/ & + & 1.97281E-01_JPRB, 2.00714E-01_JPRB, 2.04206E-01_JPRB, 2.07760E-01_JPRB, 2.11375E-01_JPRB, & + & 2.15053E-01_JPRB, 2.18795E-01_JPRB, 2.22603E-01_JPRB, 2.26476E-01_JPRB, 2.30417E-01_JPRB, & + & 2.34426E-01_JPRB, 2.38506E-01_JPRB, 2.42656E-01_JPRB, 2.46878E-01_JPRB, 2.51174E-01_JPRB, & + & 2.55545E-01_JPRB, 2.59992E-01_JPRB, 2.64516E-01_JPRB, 2.69119E-01_JPRB/) + KAO_MCO( 4, :,15) = (/ & + & 4.47509E-01_JPRB, 4.52222E-01_JPRB, 4.56985E-01_JPRB, 4.61799E-01_JPRB, 4.66663E-01_JPRB, & + & 4.71578E-01_JPRB, 4.76545E-01_JPRB, 4.81565E-01_JPRB, 4.86637E-01_JPRB, 4.91763E-01_JPRB, & + & 4.96942E-01_JPRB, 5.02177E-01_JPRB, 5.07466E-01_JPRB, 5.12811E-01_JPRB, 5.18213E-01_JPRB, & + & 5.23671E-01_JPRB, 5.29187E-01_JPRB, 5.34761E-01_JPRB, 5.40393E-01_JPRB/) + KAO_MCO( 5, :,15) = (/ & + & 1.02732E+00_JPRB, 1.02091E+00_JPRB, 1.01453E+00_JPRB, 1.00820E+00_JPRB, 1.00191E+00_JPRB, & + & 9.95660E-01_JPRB, 9.89447E-01_JPRB, 9.83273E-01_JPRB, 9.77137E-01_JPRB, 9.71039E-01_JPRB, & + & 9.64980E-01_JPRB, 9.58958E-01_JPRB, 9.52974E-01_JPRB, 9.47027E-01_JPRB, 9.41118E-01_JPRB, & + & 9.35245E-01_JPRB, 9.29409E-01_JPRB, 9.23609E-01_JPRB, 9.17846E-01_JPRB/) + KAO_MCO( 6, :,15) = (/ & + & 1.13766E+00_JPRB, 1.12944E+00_JPRB, 1.12128E+00_JPRB, 1.11318E+00_JPRB, 1.10514E+00_JPRB, & + & 1.09715E+00_JPRB, 1.08923E+00_JPRB, 1.08136E+00_JPRB, 1.07355E+00_JPRB, 1.06579E+00_JPRB, & + & 1.05809E+00_JPRB, 1.05045E+00_JPRB, 1.04286E+00_JPRB, 1.03532E+00_JPRB, 1.02784E+00_JPRB, & + & 1.02042E+00_JPRB, 1.01305E+00_JPRB, 1.00573E+00_JPRB, 9.98462E-01_JPRB/) + KAO_MCO( 7, :,15) = (/ & + & 1.13268E+00_JPRB, 1.12496E+00_JPRB, 1.11730E+00_JPRB, 1.10969E+00_JPRB, 1.10213E+00_JPRB, & + & 1.09462E+00_JPRB, 1.08717E+00_JPRB, 1.07976E+00_JPRB, 1.07241E+00_JPRB, 1.06510E+00_JPRB, & + & 1.05785E+00_JPRB, 1.05064E+00_JPRB, 1.04349E+00_JPRB, 1.03638E+00_JPRB, 1.02932E+00_JPRB, & + & 1.02231E+00_JPRB, 1.01535E+00_JPRB, 1.00843E+00_JPRB, 1.00156E+00_JPRB/) + KAO_MCO( 8, :,15) = (/ & + & 1.11982E+00_JPRB, 1.11343E+00_JPRB, 1.10707E+00_JPRB, 1.10075E+00_JPRB, 1.09447E+00_JPRB, & + & 1.08822E+00_JPRB, 1.08201E+00_JPRB, 1.07583E+00_JPRB, 1.06969E+00_JPRB, 1.06358E+00_JPRB, & + & 1.05751E+00_JPRB, 1.05147E+00_JPRB, 1.04547E+00_JPRB, 1.03950E+00_JPRB, 1.03356E+00_JPRB, & + & 1.02766E+00_JPRB, 1.02180E+00_JPRB, 1.01596E+00_JPRB, 1.01016E+00_JPRB/) + KAO_MCO( 9, :,15) = (/ & + & 1.03561E+00_JPRB, 1.02902E+00_JPRB, 1.02246E+00_JPRB, 1.01595E+00_JPRB, 1.00948E+00_JPRB, & + & 1.00305E+00_JPRB, 9.96667E-01_JPRB, 9.90320E-01_JPRB, 9.84013E-01_JPRB, 9.77747E-01_JPRB, & + & 9.71520E-01_JPRB, 9.65334E-01_JPRB, 9.59186E-01_JPRB, 9.53078E-01_JPRB, 9.47008E-01_JPRB, & + & 9.40978E-01_JPRB, 9.34985E-01_JPRB, 9.29031E-01_JPRB, 9.23115E-01_JPRB/) + KAO_MCO( 1, :,16) = (/ & + & 1.22217E-03_JPRB, 1.56836E-03_JPRB, 2.01261E-03_JPRB, 2.58271E-03_JPRB, 3.31429E-03_JPRB, & + & 4.25310E-03_JPRB, 5.45784E-03_JPRB, 7.00383E-03_JPRB, 8.98775E-03_JPRB, 1.15336E-02_JPRB, & + & 1.48007E-02_JPRB, 1.89931E-02_JPRB, 2.43731E-02_JPRB, 3.12771E-02_JPRB, 4.01367E-02_JPRB, & + & 5.15059E-02_JPRB, 6.60956E-02_JPRB, 8.48179E-02_JPRB, 1.08843E-01_JPRB/) + KAO_MCO( 2, :,16) = (/ & + & 1.22217E-03_JPRB, 1.56836E-03_JPRB, 2.01261E-03_JPRB, 2.58271E-03_JPRB, 3.31429E-03_JPRB, & + & 4.25310E-03_JPRB, 5.45784E-03_JPRB, 7.00383E-03_JPRB, 8.98775E-03_JPRB, 1.15336E-02_JPRB, & + & 1.48007E-02_JPRB, 1.89931E-02_JPRB, 2.43731E-02_JPRB, 3.12771E-02_JPRB, 4.01367E-02_JPRB, & + & 5.15059E-02_JPRB, 6.60956E-02_JPRB, 8.48179E-02_JPRB, 1.08843E-01_JPRB/) + KAO_MCO( 3, :,16) = (/ & + & 1.22217E-03_JPRB, 1.56836E-03_JPRB, 2.01261E-03_JPRB, 2.58271E-03_JPRB, 3.31429E-03_JPRB, & + & 4.25310E-03_JPRB, 5.45784E-03_JPRB, 7.00383E-03_JPRB, 8.98775E-03_JPRB, 1.15336E-02_JPRB, & + & 1.48007E-02_JPRB, 1.89931E-02_JPRB, 2.43731E-02_JPRB, 3.12771E-02_JPRB, 4.01367E-02_JPRB, & + & 5.15059E-02_JPRB, 6.60956E-02_JPRB, 8.48179E-02_JPRB, 1.08843E-01_JPRB/) + KAO_MCO( 4, :,16) = (/ & + & 1.01221E+00_JPRB, 1.01660E+00_JPRB, 1.02101E+00_JPRB, 1.02544E+00_JPRB, 1.02989E+00_JPRB, & + & 1.03436E+00_JPRB, 1.03884E+00_JPRB, 1.04335E+00_JPRB, 1.04788E+00_JPRB, 1.05243E+00_JPRB, & + & 1.05699E+00_JPRB, 1.06158E+00_JPRB, 1.06619E+00_JPRB, 1.07081E+00_JPRB, 1.07546E+00_JPRB, & + & 1.08012E+00_JPRB, 1.08481E+00_JPRB, 1.08952E+00_JPRB, 1.09425E+00_JPRB/) + KAO_MCO( 5, :,16) = (/ & + & 1.01221E+00_JPRB, 1.01660E+00_JPRB, 1.02101E+00_JPRB, 1.02544E+00_JPRB, 1.02989E+00_JPRB, & + & 1.03436E+00_JPRB, 1.03884E+00_JPRB, 1.04335E+00_JPRB, 1.04788E+00_JPRB, 1.05243E+00_JPRB, & + & 1.05699E+00_JPRB, 1.06158E+00_JPRB, 1.06619E+00_JPRB, 1.07081E+00_JPRB, 1.07546E+00_JPRB, & + & 1.08012E+00_JPRB, 1.08481E+00_JPRB, 1.08952E+00_JPRB, 1.09425E+00_JPRB/) + KAO_MCO( 6, :,16) = (/ & + & 1.01221E+00_JPRB, 1.01660E+00_JPRB, 1.02101E+00_JPRB, 1.02544E+00_JPRB, 1.02989E+00_JPRB, & + & 1.03436E+00_JPRB, 1.03884E+00_JPRB, 1.04335E+00_JPRB, 1.04788E+00_JPRB, 1.05243E+00_JPRB, & + & 1.05699E+00_JPRB, 1.06158E+00_JPRB, 1.06619E+00_JPRB, 1.07081E+00_JPRB, 1.07546E+00_JPRB, & + & 1.08012E+00_JPRB, 1.08481E+00_JPRB, 1.08952E+00_JPRB, 1.09425E+00_JPRB/) + KAO_MCO( 7, :,16) = (/ & + & 1.01221E+00_JPRB, 1.01660E+00_JPRB, 1.02101E+00_JPRB, 1.02544E+00_JPRB, 1.02989E+00_JPRB, & + & 1.03436E+00_JPRB, 1.03884E+00_JPRB, 1.04335E+00_JPRB, 1.04788E+00_JPRB, 1.05243E+00_JPRB, & + & 1.05699E+00_JPRB, 1.06158E+00_JPRB, 1.06619E+00_JPRB, 1.07081E+00_JPRB, 1.07546E+00_JPRB, & + & 1.08012E+00_JPRB, 1.08481E+00_JPRB, 1.08952E+00_JPRB, 1.09425E+00_JPRB/) + KAO_MCO( 8, :,16) = (/ & + & 1.01221E+00_JPRB, 1.01660E+00_JPRB, 1.02101E+00_JPRB, 1.02544E+00_JPRB, 1.02989E+00_JPRB, & + & 1.03436E+00_JPRB, 1.03884E+00_JPRB, 1.04335E+00_JPRB, 1.04788E+00_JPRB, 1.05243E+00_JPRB, & + & 1.05699E+00_JPRB, 1.06158E+00_JPRB, 1.06619E+00_JPRB, 1.07081E+00_JPRB, 1.07546E+00_JPRB, & + & 1.08012E+00_JPRB, 1.08481E+00_JPRB, 1.08952E+00_JPRB, 1.09425E+00_JPRB/) + KAO_MCO( 9, :,16) = (/ & + & 1.01221E+00_JPRB, 1.01660E+00_JPRB, 1.02101E+00_JPRB, 1.02544E+00_JPRB, 1.02989E+00_JPRB, & + & 1.03436E+00_JPRB, 1.03884E+00_JPRB, 1.04335E+00_JPRB, 1.04788E+00_JPRB, 1.05243E+00_JPRB, & + & 1.05699E+00_JPRB, 1.06158E+00_JPRB, 1.06619E+00_JPRB, 1.07081E+00_JPRB, 1.07546E+00_JPRB, & + & 1.08012E+00_JPRB, 1.08481E+00_JPRB, 1.08952E+00_JPRB, 1.09425E+00_JPRB/) + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + + KBO_MO3(:, 1) = (/ & + & 1.07596E-02_JPRB, 1.12146E-02_JPRB, 1.16887E-02_JPRB, 1.21830E-02_JPRB, 1.26981E-02_JPRB, & + & 1.32350E-02_JPRB, 1.37946E-02_JPRB, 1.43779E-02_JPRB, 1.49858E-02_JPRB, 1.56194E-02_JPRB, & + & 1.62799E-02_JPRB, 1.69682E-02_JPRB, 1.76857E-02_JPRB, 1.84334E-02_JPRB, 1.92129E-02_JPRB, & + & 2.00252E-02_JPRB, 2.08719E-02_JPRB, 2.17544E-02_JPRB, 2.26743E-02_JPRB/) + KBO_MO3(:, 2) = (/ & + & 9.48276E-02_JPRB, 9.66591E-02_JPRB, 9.85260E-02_JPRB, 1.00429E-01_JPRB, 1.02369E-01_JPRB, & + & 1.04346E-01_JPRB, 1.06361E-01_JPRB, 1.08416E-01_JPRB, 1.10510E-01_JPRB, 1.12644E-01_JPRB, & + & 1.14820E-01_JPRB, 1.17037E-01_JPRB, 1.19298E-01_JPRB, 1.21602E-01_JPRB, 1.23951E-01_JPRB, & + & 1.26345E-01_JPRB, 1.28785E-01_JPRB, 1.31273E-01_JPRB, 1.33808E-01_JPRB/) + KBO_MO3(:, 3) = (/ & + & 3.54721E-01_JPRB, 3.55779E-01_JPRB, 3.56841E-01_JPRB, 3.57906E-01_JPRB, 3.58973E-01_JPRB, & + & 3.60044E-01_JPRB, 3.61119E-01_JPRB, 3.62196E-01_JPRB, 3.63277E-01_JPRB, 3.64360E-01_JPRB, & + & 3.65448E-01_JPRB, 3.66538E-01_JPRB, 3.67631E-01_JPRB, 3.68728E-01_JPRB, 3.69828E-01_JPRB, & + & 3.70932E-01_JPRB, 3.72038E-01_JPRB, 3.73148E-01_JPRB, 3.74262E-01_JPRB/) + KBO_MO3(:, 4) = (/ & + & 6.46454E-01_JPRB, 6.43823E-01_JPRB, 6.41202E-01_JPRB, 6.38593E-01_JPRB, 6.35994E-01_JPRB, & + & 6.33405E-01_JPRB, 6.30827E-01_JPRB, 6.28260E-01_JPRB, 6.25703E-01_JPRB, 6.23156E-01_JPRB, & + & 6.20620E-01_JPRB, 6.18094E-01_JPRB, 6.15578E-01_JPRB, 6.13073E-01_JPRB, 6.10578E-01_JPRB, & + & 6.08093E-01_JPRB, 6.05618E-01_JPRB, 6.03153E-01_JPRB, 6.00698E-01_JPRB/) + KBO_MO3(:, 5) = (/ & + & 9.29832E-01_JPRB, 9.22877E-01_JPRB, 9.15975E-01_JPRB, 9.09124E-01_JPRB, 9.02324E-01_JPRB, & + & 8.95576E-01_JPRB, 8.88877E-01_JPRB, 8.82229E-01_JPRB, 8.75631E-01_JPRB, 8.69082E-01_JPRB, & + & 8.62582E-01_JPRB, 8.56130E-01_JPRB, 8.49727E-01_JPRB, 8.43372E-01_JPRB, 8.37064E-01_JPRB, & + & 8.30803E-01_JPRB, 8.24589E-01_JPRB, 8.18422E-01_JPRB, 8.12301E-01_JPRB/) + KBO_MO3(:, 6) = (/ & + & 1.43531E+00_JPRB, 1.42616E+00_JPRB, 1.41706E+00_JPRB, 1.40802E+00_JPRB, 1.39903E+00_JPRB, & + & 1.39010E+00_JPRB, 1.38124E+00_JPRB, 1.37242E+00_JPRB, 1.36367E+00_JPRB, 1.35496E+00_JPRB, & + & 1.34632E+00_JPRB, 1.33773E+00_JPRB, 1.32919E+00_JPRB, 1.32071E+00_JPRB, 1.31229E+00_JPRB, & + & 1.30391E+00_JPRB, 1.29559E+00_JPRB, 1.28733E+00_JPRB, 1.27911E+00_JPRB/) + KBO_MO3(:, 7) = (/ & + & 2.68664E+00_JPRB, 2.67196E+00_JPRB, 2.65736E+00_JPRB, 2.64284E+00_JPRB, 2.62840E+00_JPRB, & + & 2.61404E+00_JPRB, 2.59975E+00_JPRB, 2.58555E+00_JPRB, 2.57142E+00_JPRB, 2.55737E+00_JPRB, & + & 2.54340E+00_JPRB, 2.52950E+00_JPRB, 2.51568E+00_JPRB, 2.50193E+00_JPRB, 2.48826E+00_JPRB, & + & 2.47466E+00_JPRB, 2.46114E+00_JPRB, 2.44769E+00_JPRB, 2.43432E+00_JPRB/) + KBO_MO3(:, 8) = (/ & + & 2.45343E+00_JPRB, 2.43442E+00_JPRB, 2.41556E+00_JPRB, 2.39684E+00_JPRB, 2.37827E+00_JPRB, & + & 2.35984E+00_JPRB, 2.34156E+00_JPRB, 2.32342E+00_JPRB, 2.30541E+00_JPRB, 2.28755E+00_JPRB, & + & 2.26983E+00_JPRB, 2.25224E+00_JPRB, 2.23479E+00_JPRB, 2.21747E+00_JPRB, 2.20029E+00_JPRB, & + & 2.18324E+00_JPRB, 2.16633E+00_JPRB, 2.14954E+00_JPRB, 2.13289E+00_JPRB/) + KBO_MO3(:, 9) = (/ & + & 1.55879E-01_JPRB, 1.55998E-01_JPRB, 1.56118E-01_JPRB, 1.56238E-01_JPRB, 1.56358E-01_JPRB, & + & 1.56478E-01_JPRB, 1.56599E-01_JPRB, 1.56719E-01_JPRB, 1.56840E-01_JPRB, 1.56960E-01_JPRB, & + & 1.57081E-01_JPRB, 1.57201E-01_JPRB, 1.57322E-01_JPRB, 1.57443E-01_JPRB, 1.57564E-01_JPRB, & + & 1.57685E-01_JPRB, 1.57806E-01_JPRB, 1.57928E-01_JPRB, 1.58049E-01_JPRB/) + KBO_MO3(:,10) = (/ & + & 8.75149E-03_JPRB, 8.88794E-03_JPRB, 9.02651E-03_JPRB, 9.16725E-03_JPRB, 9.31018E-03_JPRB, & + & 9.45534E-03_JPRB, 9.60276E-03_JPRB, 9.75248E-03_JPRB, 9.90454E-03_JPRB, 1.00590E-02_JPRB, & + & 1.02158E-02_JPRB, 1.03751E-02_JPRB, 1.05368E-02_JPRB, 1.07011E-02_JPRB, 1.08680E-02_JPRB, & + & 1.10374E-02_JPRB, 1.12095E-02_JPRB, 1.13843E-02_JPRB, 1.15618E-02_JPRB/) + KBO_MO3(:,11) = (/ & + & 8.83874E-03_JPRB, 8.97926E-03_JPRB, 9.12201E-03_JPRB, 9.26703E-03_JPRB, 9.41436E-03_JPRB, & + & 9.56403E-03_JPRB, 9.71608E-03_JPRB, 9.87055E-03_JPRB, 1.00275E-02_JPRB, 1.01869E-02_JPRB, & + & 1.03488E-02_JPRB, 1.05134E-02_JPRB, 1.06805E-02_JPRB, 1.08503E-02_JPRB, 1.10228E-02_JPRB, & + & 1.11980E-02_JPRB, 1.13761E-02_JPRB, 1.15569E-02_JPRB, 1.17407E-02_JPRB/) + KBO_MO3(:,12) = (/ & + & 9.59461E-03_JPRB, 9.70417E-03_JPRB, 9.81498E-03_JPRB, 9.92705E-03_JPRB, 1.00404E-02_JPRB, & + & 1.01550E-02_JPRB, 1.02710E-02_JPRB, 1.03883E-02_JPRB, 1.05069E-02_JPRB, 1.06269E-02_JPRB, & + & 1.07482E-02_JPRB, 1.08709E-02_JPRB, 1.09951E-02_JPRB, 1.11206E-02_JPRB, 1.12476E-02_JPRB, & + & 1.13760E-02_JPRB, 1.15059E-02_JPRB, 1.16373E-02_JPRB, 1.17702E-02_JPRB/) + KBO_MO3(:,13) = (/ & + & 1.13077E-02_JPRB, 1.14079E-02_JPRB, 1.15089E-02_JPRB, 1.16109E-02_JPRB, 1.17138E-02_JPRB, & + & 1.18176E-02_JPRB, 1.19223E-02_JPRB, 1.20279E-02_JPRB, 1.21344E-02_JPRB, 1.22419E-02_JPRB, & + & 1.23504E-02_JPRB, 1.24598E-02_JPRB, 1.25702E-02_JPRB, 1.26816E-02_JPRB, 1.27939E-02_JPRB, & + & 1.29073E-02_JPRB, 1.30216E-02_JPRB, 1.31370E-02_JPRB, 1.32534E-02_JPRB/) + KBO_MO3(:,14) = (/ & + & 6.74844E-03_JPRB, 6.82637E-03_JPRB, 6.90519E-03_JPRB, 6.98493E-03_JPRB, 7.06558E-03_JPRB, & + & 7.14717E-03_JPRB, 7.22970E-03_JPRB, 7.31318E-03_JPRB, 7.39762E-03_JPRB, 7.48304E-03_JPRB, & + & 7.56945E-03_JPRB, 7.65686E-03_JPRB, 7.74527E-03_JPRB, 7.83470E-03_JPRB, 7.92517E-03_JPRB, & + & 8.01668E-03_JPRB, 8.10925E-03_JPRB, 8.20289E-03_JPRB, 8.29761E-03_JPRB/) + KBO_MO3(:,15) = (/ & + & 7.94595E-03_JPRB, 8.00015E-03_JPRB, 8.05472E-03_JPRB, 8.10966E-03_JPRB, 8.16497E-03_JPRB, & + & 8.22067E-03_JPRB, 8.27674E-03_JPRB, 8.33320E-03_JPRB, 8.39004E-03_JPRB, 8.44727E-03_JPRB, & + & 8.50489E-03_JPRB, 8.56290E-03_JPRB, 8.62130E-03_JPRB, 8.68011E-03_JPRB, 8.73932E-03_JPRB, & + & 8.79893E-03_JPRB, 8.85895E-03_JPRB, 8.91937E-03_JPRB, 8.98021E-03_JPRB/) + KBO_MO3(:,16) = (/ & + & 1.85967E-03_JPRB, 1.86082E-03_JPRB, 1.86197E-03_JPRB, 1.86312E-03_JPRB, 1.86428E-03_JPRB, & + & 1.86543E-03_JPRB, 1.86658E-03_JPRB, 1.86774E-03_JPRB, 1.86889E-03_JPRB, 1.87005E-03_JPRB, & + & 1.87121E-03_JPRB, 1.87236E-03_JPRB, 1.87352E-03_JPRB, 1.87468E-03_JPRB, 1.87584E-03_JPRB, & + & 1.87700E-03_JPRB, 1.87816E-03_JPRB, 1.87932E-03_JPRB, 1.88049E-03_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &1.6586E-05_JPRB,1.9995E-05_JPRB,1.8582E-05_JPRB,1.3988E-05_JPRB,1.3650E-05_JPRB,1.1079E-05_JPRB, & + &9.5855E-06_JPRB,8.4062E-06_JPRB,1.3558E-05_JPRB,1.8620E-05_JPRB,2.2652E-05_JPRB,1.7883E-05_JPRB, & + &2.6241E-05_JPRB,3.1171E-05_JPRB,3.9386E-05_JPRB,4.4415E-05_JPRB/) + FORREFO(2,:) = (/ & + &2.0730E-05_JPRB,2.3258E-05_JPRB,2.1543E-05_JPRB,1.5660E-05_JPRB,9.7872E-06_JPRB,8.1078E-06_JPRB, & + &7.0246E-06_JPRB,6.0428E-06_JPRB,4.8793E-06_JPRB,4.4937E-06_JPRB,4.7078E-06_JPRB,4.6898E-06_JPRB, & + &6.9481E-06_JPRB,8.6269E-06_JPRB,3.1761E-06_JPRB,3.1440E-06_JPRB/) + FORREFO(3,:) = (/ & + &1.5737E-05_JPRB,2.2501E-05_JPRB,2.3520E-05_JPRB,2.0288E-05_JPRB,1.2083E-05_JPRB,6.8256E-06_JPRB, & + &6.0637E-06_JPRB,5.5434E-06_JPRB,4.3888E-06_JPRB,3.8435E-06_JPRB,3.8477E-06_JPRB,3.8314E-06_JPRB, & + &3.8251E-06_JPRB,3.3637E-06_JPRB,3.1950E-06_JPRB,3.1440E-06_JPRB/) + FORREFO(4,:) = (/ & + &1.1400E-05_JPRB,7.9751E-06_JPRB,8.8659E-06_JPRB,1.5884E-05_JPRB,1.9118E-05_JPRB,1.9429E-05_JPRB, & + &2.0532E-05_JPRB,2.2155E-05_JPRB,2.3894E-05_JPRB,2.2984E-05_JPRB,2.3731E-05_JPRB,2.4538E-05_JPRB, & + &2.6697E-05_JPRB,1.9329E-05_JPRB,3.3306E-06_JPRB,3.2018E-06_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 9.62275E-03_JPRB, 8.29909E-03_JPRB, 7.15750E-03_JPRB, 6.17294E-03_JPRB, 5.32382E-03_JPRB, & + & 4.59150E-03_JPRB, 3.95991E-03_JPRB, 3.41520E-03_JPRB, 2.94542E-03_JPRB, 2.54026E-03_JPRB/) + SELFREFO(:, 2) = (/ & + & 9.76664E-03_JPRB, 8.47783E-03_JPRB, 7.35910E-03_JPRB, 6.38799E-03_JPRB, 5.54504E-03_JPRB, & + & 4.81331E-03_JPRB, 4.17815E-03_JPRB, 3.62680E-03_JPRB, 3.14821E-03_JPRB, 2.73277E-03_JPRB/) + SELFREFO(:, 3) = (/ & + & 9.53856E-03_JPRB, 8.23750E-03_JPRB, 7.11390E-03_JPRB, 6.14356E-03_JPRB, 5.30558E-03_JPRB, & + & 4.58190E-03_JPRB, 3.95693E-03_JPRB, 3.41720E-03_JPRB, 2.95109E-03_JPRB, 2.54856E-03_JPRB/) + SELFREFO(:, 4) = (/ & + & 8.47621E-03_JPRB, 7.29518E-03_JPRB, 6.27870E-03_JPRB, 5.40385E-03_JPRB, 4.65091E-03_JPRB, & + & 4.00287E-03_JPRB, 3.44513E-03_JPRB, 2.96510E-03_JPRB, 2.55196E-03_JPRB, 2.19638E-03_JPRB/) + SELFREFO(:, 5) = (/ & + & 6.71258E-03_JPRB, 5.95346E-03_JPRB, 5.28020E-03_JPRB, 4.68307E-03_JPRB, 4.15348E-03_JPRB, & + & 3.68377E-03_JPRB, 3.26718E-03_JPRB, 2.89770E-03_JPRB, 2.57000E-03_JPRB, 2.27937E-03_JPRB/) + SELFREFO(:, 6) = (/ & + & 6.29140E-03_JPRB, 5.55557E-03_JPRB, 4.90580E-03_JPRB, 4.33203E-03_JPRB, 3.82536E-03_JPRB, & + & 3.37795E-03_JPRB, 2.98287E-03_JPRB, 2.63400E-03_JPRB, 2.32593E-03_JPRB, 2.05389E-03_JPRB/) + SELFREFO(:, 7) = (/ & + & 6.00229E-03_JPRB, 5.28180E-03_JPRB, 4.64780E-03_JPRB, 4.08990E-03_JPRB, 3.59897E-03_JPRB, & + & 3.16696E-03_JPRB, 2.78682E-03_JPRB, 2.45230E-03_JPRB, 2.15794E-03_JPRB, 1.89891E-03_JPRB/) + SELFREFO(:, 8) = (/ & + & 5.78892E-03_JPRB, 5.07191E-03_JPRB, 4.44370E-03_JPRB, 3.89330E-03_JPRB, 3.41108E-03_JPRB, & + & 2.98858E-03_JPRB, 2.61842E-03_JPRB, 2.29410E-03_JPRB, 2.00995E-03_JPRB, 1.76100E-03_JPRB/) + SELFREFO(:, 9) = (/ & + & 4.96186E-03_JPRB, 4.56767E-03_JPRB, 4.20480E-03_JPRB, 3.87076E-03_JPRB, 3.56325E-03_JPRB, & + & 3.28017E-03_JPRB, 3.01959E-03_JPRB, 2.77970E-03_JPRB, 2.55887E-03_JPRB, 2.35559E-03_JPRB/) + SELFREFO(:,10) = (/ & + & 4.56849E-03_JPRB, 4.35527E-03_JPRB, 4.15200E-03_JPRB, 3.95822E-03_JPRB, 3.77348E-03_JPRB, & + & 3.59736E-03_JPRB, 3.42946E-03_JPRB, 3.26940E-03_JPRB, 3.11681E-03_JPRB, 2.97134E-03_JPRB/) + SELFREFO(:,11) = (/ & + & 4.47310E-03_JPRB, 4.32453E-03_JPRB, 4.18090E-03_JPRB, 4.04204E-03_JPRB, 3.90779E-03_JPRB, & + & 3.77799E-03_JPRB, 3.65251E-03_JPRB, 3.53120E-03_JPRB, 3.41392E-03_JPRB, 3.30053E-03_JPRB/) + SELFREFO(:,12) = (/ & + & 4.46459E-03_JPRB, 4.24031E-03_JPRB, 4.02730E-03_JPRB, 3.82499E-03_JPRB, 3.63284E-03_JPRB, & + & 3.45035E-03_JPRB, 3.27702E-03_JPRB, 3.11240E-03_JPRB, 2.95605E-03_JPRB, 2.80755E-03_JPRB/) + SELFREFO(:,13) = (/ & + & 4.43961E-03_JPRB, 4.35658E-03_JPRB, 4.27510E-03_JPRB, 4.19514E-03_JPRB, 4.11669E-03_JPRB, & + & 4.03969E-03_JPRB, 3.96414E-03_JPRB, 3.89000E-03_JPRB, 3.81725E-03_JPRB, 3.74585E-03_JPRB/) + SELFREFO(:,14) = (/ & + & 4.40512E-03_JPRB, 4.41515E-03_JPRB, 4.42520E-03_JPRB, 4.43527E-03_JPRB, 4.44537E-03_JPRB, & + & 4.45549E-03_JPRB, 4.46563E-03_JPRB, 4.47580E-03_JPRB, 4.48599E-03_JPRB, 4.49620E-03_JPRB/) + SELFREFO(:,15) = (/ & + & 3.21965E-03_JPRB, 3.42479E-03_JPRB, 3.64300E-03_JPRB, 3.87512E-03_JPRB, 4.12202E-03_JPRB, & + & 4.38466E-03_JPRB, 4.66403E-03_JPRB, 4.96120E-03_JPRB, 5.27731E-03_JPRB, 5.61355E-03_JPRB/) + SELFREFO(:,16) = (/ & + & 3.11402E-03_JPRB, 3.35870E-03_JPRB, 3.62260E-03_JPRB, 3.90724E-03_JPRB, 4.21424E-03_JPRB, & + & 4.54536E-03_JPRB, 4.90250E-03_JPRB, 5.28770E-03_JPRB, 5.70317E-03_JPRB, 6.15128E-03_JPRB/) + + + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB13',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB13:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB13 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb14.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb14.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb14.F90 (revision 6016) @@ -0,0 +1,170 @@ +SUBROUTINE RRTM_KGB14 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 14: 2250-2380 cm-1 (low - CO2; high - CO2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO14, ONLY : KAO ,KBO ,SELFREFO, FORREFO ,FRACREFAO ,FRACREFBO, & + & KAO_D, KBO_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB14',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB14:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB14:') +ENDIF + +! Planck fraction mapping level : P = 142.5940 mb, T = 215.70 K + FRACREFAO(:) = (/ & + & 1.9360E-01_JPRB, 1.7276E-01_JPRB, 1.4811E-01_JPRB, 1.2238E-01_JPRB, & + & 1.0242E-01_JPRB, 8.6830E-02_JPRB, 7.1890E-02_JPRB, 5.4030E-02_JPRB, & + & 3.5075E-02_JPRB, 3.8052E-03_JPRB, 3.1458E-03_JPRB, 2.4873E-03_JPRB, & + & 1.8182E-03_JPRB, 1.1563E-03_JPRB, 4.3251E-04_JPRB, 5.7744E-05_JPRB/) + +! Planck fraction mapping level : P = 4.758820mb, T = 250.85 K + FRACREFBO(:) = (/ & + & 1.8599E-01_JPRB, 1.6646E-01_JPRB, 1.4264E-01_JPRB, 1.2231E-01_JPRB, & + & 1.0603E-01_JPRB, 9.2014E-02_JPRB, 7.5287E-02_JPRB, 5.6758E-02_JPRB, & + & 3.8386E-02_JPRB, 4.2139E-03_JPRB, 3.5399E-03_JPRB, 2.7381E-03_JPRB, & + & 1.9202E-03_JPRB, 1.2083E-03_JPRB, 4.5395E-04_JPRB, 6.2699E-05_JPRB/) + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &2.7075E-06_JPRB,2.2609E-06_JPRB,1.5633E-06_JPRB,8.7484E-07_JPRB,5.5470E-07_JPRB,4.8456E-07_JPRB, & + &4.7463E-07_JPRB,4.6154E-07_JPRB,4.4425E-07_JPRB,4.2960E-07_JPRB,4.2626E-07_JPRB,4.1715E-07_JPRB, & + &4.2607E-07_JPRB,3.6616E-07_JPRB,2.6366E-07_JPRB,2.6029E-07_JPRB/) + FORREFO(2,:) = (/ & + &2.6759E-06_JPRB,2.2237E-06_JPRB,1.4466E-06_JPRB,9.3032E-07_JPRB,6.4927E-07_JPRB,5.4809E-07_JPRB, & + &4.9504E-07_JPRB,4.6305E-07_JPRB,4.4873E-07_JPRB,4.2146E-07_JPRB,4.2176E-07_JPRB,4.2812E-07_JPRB, & + &4.0529E-07_JPRB,4.0969E-07_JPRB,2.9442E-07_JPRB,2.6821E-07_JPRB/) + FORREFO(3,:) = (/ & + &2.6608E-06_JPRB,2.1140E-06_JPRB,1.4838E-06_JPRB,9.2083E-07_JPRB,6.3350E-07_JPRB,5.7195E-07_JPRB, & + &6.2253E-07_JPRB,5.1783E-07_JPRB,4.4749E-07_JPRB,4.3261E-07_JPRB,4.2553E-07_JPRB,4.2175E-07_JPRB, & + &4.1085E-07_JPRB,4.0358E-07_JPRB,3.5340E-07_JPRB,2.7191E-07_JPRB/) + FORREFO(4,:) = (/ & + &2.6412E-06_JPRB,1.9814E-06_JPRB,1.2672E-06_JPRB,8.1129E-07_JPRB,7.1447E-07_JPRB,7.5026E-07_JPRB, & + &7.4386E-07_JPRB,7.2759E-07_JPRB,7.3583E-07_JPRB,7.6493E-07_JPRB,8.8959E-07_JPRB,7.5534E-07_JPRB, & + &5.3734E-07_JPRB,4.5572E-07_JPRB,4.1676E-07_JPRB,3.6198E-07_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 4.67262E-03_JPRB, 3.95211E-03_JPRB, 3.34270E-03_JPRB, 2.82726E-03_JPRB, 2.39130E-03_JPRB, & + & 2.02256E-03_JPRB, 1.71069E-03_JPRB, 1.44690E-03_JPRB, 1.22379E-03_JPRB, 1.03508E-03_JPRB/) + SELFREFO(:, 2) = (/ & + & 4.42593E-03_JPRB, 3.73338E-03_JPRB, 3.14920E-03_JPRB, 2.65643E-03_JPRB, 2.24076E-03_JPRB, & + & 1.89014E-03_JPRB, 1.59438E-03_JPRB, 1.34490E-03_JPRB, 1.13446E-03_JPRB, 9.56943E-04_JPRB/) + SELFREFO(:, 3) = (/ & + & 3.96072E-03_JPRB, 3.33789E-03_JPRB, 2.81300E-03_JPRB, 2.37065E-03_JPRB, 1.99786E-03_JPRB, & + & 1.68369E-03_JPRB, 1.41893E-03_JPRB, 1.19580E-03_JPRB, 1.00776E-03_JPRB, 8.49286E-04_JPRB/) + SELFREFO(:, 4) = (/ & + & 3.71833E-03_JPRB, 3.10030E-03_JPRB, 2.58500E-03_JPRB, 2.15535E-03_JPRB, 1.79711E-03_JPRB, & + & 1.49841E-03_JPRB, 1.24936E-03_JPRB, 1.04170E-03_JPRB, 8.68558E-04_JPRB, 7.24195E-04_JPRB/) + SELFREFO(:, 5) = (/ & + & 3.55755E-03_JPRB, 2.95355E-03_JPRB, 2.45210E-03_JPRB, 2.03578E-03_JPRB, 1.69015E-03_JPRB, & + & 1.40320E-03_JPRB, 1.16497E-03_JPRB, 9.67180E-04_JPRB, 8.02973E-04_JPRB, 6.66646E-04_JPRB/) + SELFREFO(:, 6) = (/ & + & 3.47601E-03_JPRB, 2.88628E-03_JPRB, 2.39660E-03_JPRB, 1.99000E-03_JPRB, 1.65238E-03_JPRB, & + & 1.37204E-03_JPRB, 1.13927E-03_JPRB, 9.45980E-04_JPRB, 7.85487E-04_JPRB, 6.52224E-04_JPRB/) + SELFREFO(:, 7) = (/ & + & 3.44479E-03_JPRB, 2.86224E-03_JPRB, 2.37820E-03_JPRB, 1.97602E-03_JPRB, 1.64185E-03_JPRB, & + & 1.36420E-03_JPRB, 1.13350E-03_JPRB, 9.41810E-04_JPRB, 7.82539E-04_JPRB, 6.50204E-04_JPRB/) + SELFREFO(:, 8) = (/ & + & 3.40154E-03_JPRB, 2.82953E-03_JPRB, 2.35370E-03_JPRB, 1.95789E-03_JPRB, 1.62864E-03_JPRB, & + & 1.35476E-03_JPRB, 1.12694E-03_JPRB, 9.37430E-04_JPRB, 7.79788E-04_JPRB, 6.48655E-04_JPRB/) + SELFREFO(:, 9) = (/ & + & 3.39380E-03_JPRB, 2.82288E-03_JPRB, 2.34800E-03_JPRB, 1.95301E-03_JPRB, 1.62446E-03_JPRB, & + & 1.35119E-03_JPRB, 1.12389E-03_JPRB, 9.34820E-04_JPRB, 7.77560E-04_JPRB, 6.46755E-04_JPRB/) + SELFREFO(:,10) = (/ & + & 3.37185E-03_JPRB, 2.80654E-03_JPRB, 2.33600E-03_JPRB, 1.94435E-03_JPRB, 1.61837E-03_JPRB, & + & 1.34704E-03_JPRB, 1.12120E-03_JPRB, 9.33220E-04_JPRB, 7.76759E-04_JPRB, 6.46530E-04_JPRB/) + SELFREFO(:,11) = (/ & + & 3.37924E-03_JPRB, 2.81172E-03_JPRB, 2.33950E-03_JPRB, 1.94659E-03_JPRB, 1.61967E-03_JPRB, & + & 1.34765E-03_JPRB, 1.12132E-03_JPRB, 9.33000E-04_JPRB, 7.76306E-04_JPRB, 6.45930E-04_JPRB/) + SELFREFO(:,12) = (/ & + & 3.39658E-03_JPRB, 2.82289E-03_JPRB, 2.34610E-03_JPRB, 1.94984E-03_JPRB, 1.62051E-03_JPRB, & + & 1.34680E-03_JPRB, 1.11933E-03_JPRB, 9.30270E-04_JPRB, 7.73146E-04_JPRB, 6.42561E-04_JPRB/) + SELFREFO(:,13) = (/ & + & 3.36070E-03_JPRB, 2.79913E-03_JPRB, 2.33140E-03_JPRB, 1.94183E-03_JPRB, 1.61735E-03_JPRB, & + & 1.34709E-03_JPRB, 1.12199E-03_JPRB, 9.34510E-04_JPRB, 7.78354E-04_JPRB, 6.48292E-04_JPRB/) + SELFREFO(:,14) = (/ & + & 3.40428E-03_JPRB, 2.81994E-03_JPRB, 2.33590E-03_JPRB, 1.93495E-03_JPRB, 1.60282E-03_JPRB, & + & 1.32770E-03_JPRB, 1.09980E-03_JPRB, 9.11020E-04_JPRB, 7.54645E-04_JPRB, 6.25111E-04_JPRB/) + SELFREFO(:,15) = (/ & + & 3.27075E-03_JPRB, 2.70783E-03_JPRB, 2.24180E-03_JPRB, 1.85597E-03_JPRB, 1.53655E-03_JPRB, & + & 1.27210E-03_JPRB, 1.05317E-03_JPRB, 8.71910E-04_JPRB, 7.21849E-04_JPRB, 5.97615E-04_JPRB/) + SELFREFO(:,16) = (/ & + & 3.23123E-03_JPRB, 2.67891E-03_JPRB, 2.22100E-03_JPRB, 1.84136E-03_JPRB, 1.52661E-03_JPRB, & + & 1.26567E-03_JPRB, 1.04932E-03_JPRB, 8.69960E-04_JPRB, 7.21256E-04_JPRB, 5.97970E-04_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB14',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB14:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB14 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb15.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb15.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb15.F90 (revision 6016) @@ -0,0 +1,918 @@ +SUBROUTINE RRTM_KGB15 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 15: 2380-2600 cm-1 (low - N2O,CO2; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 2001306 updated to rrtmg v4.85 +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD +USE YOMMP0 , ONLY : NPROC, MYPROC + +USE YOERRTO15, ONLY : KAO,KAO_MN2 ,SELFREFO,FORREFO ,FRACREFAO, KAO_D + + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB15',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D + KAO = REAL(KAO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB15:') +ENDIF + +! Planck fraction mapping level : P = 1053. mb, T = 294.2 K + FRACREFAO(:, 1) = (/ & + & 1.0689E-01_JPRB,1.1563E-01_JPRB,1.2447E-01_JPRB,1.2921E-01_JPRB,1.2840E-01_JPRB,1.2113E-01_JPRB, & + & 1.0643E-01_JPRB,8.4987E-02_JPRB,6.0142E-02_JPRB,6.6798E-03_JPRB,5.5293E-03_JPRB,4.3700E-03_JPRB, & + & 3.2061E-03_JPRB,2.0476E-03_JPRB,7.7366E-04_JPRB,1.0897E-04_JPRB/) + FRACREFAO(:, 2) = (/ & + & 1.0782E-01_JPRB,1.1637E-01_JPRB,1.2290E-01_JPRB,1.2911E-01_JPRB,1.2841E-01_JPRB,1.2113E-01_JPRB, & + & 1.0643E-01_JPRB,8.4987E-02_JPRB,6.0142E-02_JPRB,6.6798E-03_JPRB,5.5293E-03_JPRB,4.3700E-03_JPRB, & + & 3.2061E-03_JPRB,2.0476E-03_JPRB,7.7366E-04_JPRB,1.0897E-04_JPRB/) + FRACREFAO(:, 3) = (/ & + & 1.0858E-01_JPRB,1.1860E-01_JPRB,1.2237E-01_JPRB,1.2665E-01_JPRB,1.2841E-01_JPRB,1.2111E-01_JPRB, & + & 1.0642E-01_JPRB,8.4987E-02_JPRB,6.0142E-02_JPRB,6.6798E-03_JPRB,5.5293E-03_JPRB,4.3700E-03_JPRB, & + & 3.2061E-03_JPRB,2.0476E-03_JPRB,7.7366E-04_JPRB,1.0897E-04_JPRB/) + FRACREFAO(:, 4) = (/ & + & 1.1022E-01_JPRB,1.1965E-01_JPRB,1.2334E-01_JPRB,1.2383E-01_JPRB,1.2761E-01_JPRB,1.2109E-01_JPRB, & + & 1.0642E-01_JPRB,8.4987E-02_JPRB,6.0142E-02_JPRB,6.6798E-03_JPRB,5.5293E-03_JPRB,4.3700E-03_JPRB, & + & 3.2061E-03_JPRB,2.0476E-03_JPRB,7.7366E-04_JPRB,1.0897E-04_JPRB/) + FRACREFAO(:, 5) = (/ & + & 1.1342E-01_JPRB,1.2069E-01_JPRB,1.2360E-01_JPRB,1.2447E-01_JPRB,1.2340E-01_JPRB,1.2020E-01_JPRB, & + & 1.0639E-01_JPRB,8.4987E-02_JPRB,6.0142E-02_JPRB,6.6798E-03_JPRB,5.5293E-03_JPRB,4.3700E-03_JPRB, & + & 3.2061E-03_JPRB,2.0476E-03_JPRB,7.7366E-04_JPRB,1.0897E-04_JPRB/) + FRACREFAO(:, 6) = (/ & + & 1.1771E-01_JPRB,1.2280E-01_JPRB,1.2177E-01_JPRB,1.2672E-01_JPRB,1.2398E-01_JPRB,1.1787E-01_JPRB, & + & 1.0131E-01_JPRB,8.4987E-02_JPRB,6.0142E-02_JPRB,6.6798E-03_JPRB,5.5293E-03_JPRB,4.3700E-03_JPRB, & + & 3.2061E-03_JPRB,2.0476E-03_JPRB,7.7366E-04_JPRB,1.0897E-04_JPRB/) + FRACREFAO(:, 7) = (/ & + & 1.2320E-01_JPRB,1.2491E-01_JPRB,1.2001E-01_JPRB,1.2936E-01_JPRB,1.2653E-01_JPRB,1.1929E-01_JPRB, & + & 9.8955E-02_JPRB,7.4887E-02_JPRB,6.0142E-02_JPRB,6.6798E-03_JPRB,5.5293E-03_JPRB,4.3700E-03_JPRB, & + & 3.2061E-03_JPRB,2.0476E-03_JPRB,7.7366E-04_JPRB,1.0897E-04_JPRB/) + FRACREFAO(:, 8) = (/ & + & 1.3105E-01_JPRB,1.2563E-01_JPRB,1.3055E-01_JPRB,1.2854E-01_JPRB,1.3402E-01_JPRB,1.1571E-01_JPRB, & + & 9.4876E-02_JPRB,6.0459E-02_JPRB,5.6457E-02_JPRB,6.6798E-03_JPRB,5.5293E-03_JPRB,4.3700E-03_JPRB, & + & 3.2061E-03_JPRB,2.0476E-03_JPRB,7.7366E-04_JPRB,1.0897E-04_JPRB/) + FRACREFAO(:, 9) = (/ & + & 1.1375E-01_JPRB,1.2090E-01_JPRB,1.2348E-01_JPRB,1.2458E-01_JPRB,1.2406E-01_JPRB,1.1921E-01_JPRB, & + & 1.0802E-01_JPRB,8.6613E-02_JPRB,5.8125E-02_JPRB,6.2984E-03_JPRB,5.2359E-03_JPRB,4.0641E-03_JPRB, & + & 2.9379E-03_JPRB,1.9001E-03_JPRB,7.2646E-04_JPRB,1.0553E-04_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array KA_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + + KAO_MN2( 1, :, 1) = (/ & + & 3.24352E-08_JPRB, 3.39625E-08_JPRB, 3.55618E-08_JPRB, 3.72364E-08_JPRB, 3.89899E-08_JPRB, & + & 4.08259E-08_JPRB, 4.27484E-08_JPRB, 4.47614E-08_JPRB, 4.68692E-08_JPRB, 4.90763E-08_JPRB, & + & 5.13873E-08_JPRB, 5.38071E-08_JPRB, 5.63409E-08_JPRB, 5.89940E-08_JPRB, 6.17720E-08_JPRB, & + & 6.46808E-08_JPRB, 6.77266E-08_JPRB, 7.09158E-08_JPRB, 7.42553E-08_JPRB/) + KAO_MN2( 2, :, 1) = (/ & + & 3.44203E-08_JPRB, 3.60254E-08_JPRB, 3.77053E-08_JPRB, 3.94636E-08_JPRB, 4.13038E-08_JPRB, & + & 4.32299E-08_JPRB, 4.52458E-08_JPRB, 4.73557E-08_JPRB, 4.95640E-08_JPRB, 5.18753E-08_JPRB, & + & 5.42943E-08_JPRB, 5.68262E-08_JPRB, 5.94761E-08_JPRB, 6.22496E-08_JPRB, 6.51524E-08_JPRB, & + & 6.81906E-08_JPRB, 7.13704E-08_JPRB, 7.46986E-08_JPRB, 7.81819E-08_JPRB/) + KAO_MN2( 3, :, 1) = (/ & + & 3.44344E-08_JPRB, 3.61485E-08_JPRB, 3.79480E-08_JPRB, 3.98370E-08_JPRB, 4.18201E-08_JPRB, & + & 4.39019E-08_JPRB, 4.60873E-08_JPRB, 4.83815E-08_JPRB, 5.07899E-08_JPRB, 5.33182E-08_JPRB, & + & 5.59723E-08_JPRB, 5.87586E-08_JPRB, 6.16836E-08_JPRB, 6.47541E-08_JPRB, 6.79776E-08_JPRB, & + & 7.13614E-08_JPRB, 7.49138E-08_JPRB, 7.86429E-08_JPRB, 8.25577E-08_JPRB/) + KAO_MN2( 4, :, 1) = (/ & + & 4.21102E-08_JPRB, 4.38921E-08_JPRB, 4.57493E-08_JPRB, 4.76852E-08_JPRB, 4.97029E-08_JPRB, & + & 5.18061E-08_JPRB, 5.39982E-08_JPRB, 5.62831E-08_JPRB, 5.86647E-08_JPRB, 6.11470E-08_JPRB, & + & 6.37344E-08_JPRB, 6.64313E-08_JPRB, 6.92422E-08_JPRB, 7.21722E-08_JPRB, 7.52261E-08_JPRB, & + & 7.84092E-08_JPRB, 8.17270E-08_JPRB, 8.51852E-08_JPRB, 8.87897E-08_JPRB/) + KAO_MN2( 5, :, 1) = (/ & + & 4.78813E-08_JPRB, 5.01015E-08_JPRB, 5.24246E-08_JPRB, 5.48554E-08_JPRB, 5.73989E-08_JPRB, & + & 6.00603E-08_JPRB, 6.28452E-08_JPRB, 6.57592E-08_JPRB, 6.88083E-08_JPRB, 7.19987E-08_JPRB, & + & 7.53371E-08_JPRB, 7.88304E-08_JPRB, 8.24855E-08_JPRB, 8.63102E-08_JPRB, 9.03122E-08_JPRB, & + & 9.44997E-08_JPRB, 9.88815E-08_JPRB, 1.03466E-07_JPRB, 1.08264E-07_JPRB/) + KAO_MN2( 6, :, 1) = (/ & + & 7.03115E-08_JPRB, 7.27877E-08_JPRB, 7.53511E-08_JPRB, 7.80048E-08_JPRB, 8.07519E-08_JPRB, & + & 8.35958E-08_JPRB, 8.65398E-08_JPRB, 8.95875E-08_JPRB, 9.27426E-08_JPRB, 9.60087E-08_JPRB, & + & 9.93899E-08_JPRB, 1.02890E-07_JPRB, 1.06514E-07_JPRB, 1.10265E-07_JPRB, 1.14148E-07_JPRB, & + & 1.18168E-07_JPRB, 1.22330E-07_JPRB, 1.26638E-07_JPRB, 1.31098E-07_JPRB/) + KAO_MN2( 7, :, 1) = (/ & + & 8.86454E-08_JPRB, 9.20065E-08_JPRB, 9.54951E-08_JPRB, 9.91159E-08_JPRB, 1.02874E-07_JPRB, & + & 1.06775E-07_JPRB, 1.10823E-07_JPRB, 1.15025E-07_JPRB, 1.19387E-07_JPRB, 1.23913E-07_JPRB, & + & 1.28612E-07_JPRB, 1.33488E-07_JPRB, 1.38550E-07_JPRB, 1.43803E-07_JPRB, 1.49255E-07_JPRB, & + & 1.54915E-07_JPRB, 1.60788E-07_JPRB, 1.66885E-07_JPRB, 1.73213E-07_JPRB/) + KAO_MN2( 8, :, 1) = (/ & + & 1.34118E-07_JPRB, 1.38267E-07_JPRB, 1.42545E-07_JPRB, 1.46955E-07_JPRB, 1.51502E-07_JPRB, & + & 1.56189E-07_JPRB, 1.61022E-07_JPRB, 1.66004E-07_JPRB, 1.71140E-07_JPRB, 1.76435E-07_JPRB, & + & 1.81893E-07_JPRB, 1.87521E-07_JPRB, 1.93323E-07_JPRB, 1.99304E-07_JPRB, 2.05470E-07_JPRB, & + & 2.11827E-07_JPRB, 2.18381E-07_JPRB, 2.25138E-07_JPRB, 2.32103E-07_JPRB/) + KAO_MN2( 9, :, 1) = (/ & + & 5.08256E-08_JPRB, 5.30384E-08_JPRB, 5.53476E-08_JPRB, 5.77573E-08_JPRB, 6.02718E-08_JPRB, & + & 6.28959E-08_JPRB, 6.56342E-08_JPRB, 6.84917E-08_JPRB, 7.14737E-08_JPRB, 7.45854E-08_JPRB, & + & 7.78327E-08_JPRB, 8.12213E-08_JPRB, 8.47574E-08_JPRB, 8.84475E-08_JPRB, 9.22983E-08_JPRB, & + & 9.63167E-08_JPRB, 1.00510E-07_JPRB, 1.04886E-07_JPRB, 1.09452E-07_JPRB/) + KAO_MN2( 1, :, 2) = (/ & + & 8.23958E-08_JPRB, 8.39092E-08_JPRB, 8.54504E-08_JPRB, 8.70200E-08_JPRB, 8.86183E-08_JPRB, & + & 9.02460E-08_JPRB, 9.19036E-08_JPRB, 9.35917E-08_JPRB, 9.53107E-08_JPRB, 9.70614E-08_JPRB, & + & 9.88442E-08_JPRB, 1.00660E-07_JPRB, 1.02509E-07_JPRB, 1.04391E-07_JPRB, 1.06309E-07_JPRB, & + & 1.08261E-07_JPRB, 1.10250E-07_JPRB, 1.12275E-07_JPRB, 1.14337E-07_JPRB/) + KAO_MN2( 2, :, 2) = (/ & + & 8.52335E-08_JPRB, 8.69254E-08_JPRB, 8.86509E-08_JPRB, 9.04107E-08_JPRB, 9.22054E-08_JPRB, & + & 9.40357E-08_JPRB, 9.59024E-08_JPRB, 9.78061E-08_JPRB, 9.97476E-08_JPRB, 1.01728E-07_JPRB, & + & 1.03747E-07_JPRB, 1.05806E-07_JPRB, 1.07907E-07_JPRB, 1.10049E-07_JPRB, 1.12233E-07_JPRB, & + & 1.14461E-07_JPRB, 1.16733E-07_JPRB, 1.19050E-07_JPRB, 1.21414E-07_JPRB/) + KAO_MN2( 3, :, 2) = (/ & + & 1.04608E-07_JPRB, 1.06067E-07_JPRB, 1.07546E-07_JPRB, 1.09046E-07_JPRB, 1.10567E-07_JPRB, & + & 1.12110E-07_JPRB, 1.13673E-07_JPRB, 1.15259E-07_JPRB, 1.16866E-07_JPRB, 1.18496E-07_JPRB, & + & 1.20149E-07_JPRB, 1.21825E-07_JPRB, 1.23524E-07_JPRB, 1.25247E-07_JPRB, 1.26994E-07_JPRB, & + & 1.28765E-07_JPRB, 1.30561E-07_JPRB, 1.32382E-07_JPRB, 1.34229E-07_JPRB/) + KAO_MN2( 4, :, 2) = (/ & + & 1.17504E-07_JPRB, 1.18763E-07_JPRB, 1.20036E-07_JPRB, 1.21322E-07_JPRB, 1.22622E-07_JPRB, & + & 1.23936E-07_JPRB, 1.25265E-07_JPRB, 1.26607E-07_JPRB, 1.27964E-07_JPRB, 1.29335E-07_JPRB, & + & 1.30721E-07_JPRB, 1.32122E-07_JPRB, 1.33538E-07_JPRB, 1.34969E-07_JPRB, 1.36415E-07_JPRB, & + & 1.37877E-07_JPRB, 1.39354E-07_JPRB, 1.40848E-07_JPRB, 1.42357E-07_JPRB/) + KAO_MN2( 5, :, 2) = (/ & + & 1.23552E-07_JPRB, 1.25200E-07_JPRB, 1.26870E-07_JPRB, 1.28562E-07_JPRB, 1.30277E-07_JPRB, & + & 1.32015E-07_JPRB, 1.33776E-07_JPRB, 1.35560E-07_JPRB, 1.37368E-07_JPRB, 1.39200E-07_JPRB, & + & 1.41057E-07_JPRB, 1.42938E-07_JPRB, 1.44845E-07_JPRB, 1.46777E-07_JPRB, 1.48735E-07_JPRB, & + & 1.50718E-07_JPRB, 1.52729E-07_JPRB, 1.54766E-07_JPRB, 1.56830E-07_JPRB/) + KAO_MN2( 6, :, 2) = (/ & + & 1.29682E-07_JPRB, 1.32226E-07_JPRB, 1.34820E-07_JPRB, 1.37464E-07_JPRB, 1.40161E-07_JPRB, & + & 1.42910E-07_JPRB, 1.45713E-07_JPRB, 1.48571E-07_JPRB, 1.51486E-07_JPRB, 1.54457E-07_JPRB, & + & 1.57487E-07_JPRB, 1.60576E-07_JPRB, 1.63726E-07_JPRB, 1.66937E-07_JPRB, 1.70212E-07_JPRB, & + & 1.73551E-07_JPRB, 1.76955E-07_JPRB, 1.80426E-07_JPRB, 1.83965E-07_JPRB/) + KAO_MN2( 7, :, 2) = (/ & + & 1.77416E-07_JPRB, 1.78627E-07_JPRB, 1.79846E-07_JPRB, 1.81073E-07_JPRB, 1.82309E-07_JPRB, & + & 1.83554E-07_JPRB, 1.84806E-07_JPRB, 1.86068E-07_JPRB, 1.87338E-07_JPRB, 1.88616E-07_JPRB, & + & 1.89904E-07_JPRB, 1.91200E-07_JPRB, 1.92505E-07_JPRB, 1.93819E-07_JPRB, 1.95142E-07_JPRB, & + & 1.96474E-07_JPRB, 1.97815E-07_JPRB, 1.99165E-07_JPRB, 2.00524E-07_JPRB/) + KAO_MN2( 8, :, 2) = (/ & + & 2.20695E-07_JPRB, 2.20451E-07_JPRB, 2.20208E-07_JPRB, 2.19965E-07_JPRB, 2.19722E-07_JPRB, & + & 2.19480E-07_JPRB, 2.19238E-07_JPRB, 2.18996E-07_JPRB, 2.18754E-07_JPRB, 2.18513E-07_JPRB, & + & 2.18272E-07_JPRB, 2.18031E-07_JPRB, 2.17790E-07_JPRB, 2.17550E-07_JPRB, 2.17310E-07_JPRB, & + & 2.17070E-07_JPRB, 2.16831E-07_JPRB, 2.16591E-07_JPRB, 2.16352E-07_JPRB/) + KAO_MN2( 9, :, 2) = (/ & + & 1.23015E-07_JPRB, 1.24808E-07_JPRB, 1.26626E-07_JPRB, 1.28471E-07_JPRB, 1.30343E-07_JPRB, & + & 1.32242E-07_JPRB, 1.34168E-07_JPRB, 1.36123E-07_JPRB, 1.38106E-07_JPRB, 1.40118E-07_JPRB, & + & 1.42160E-07_JPRB, 1.44231E-07_JPRB, 1.46332E-07_JPRB, 1.48464E-07_JPRB, 1.50627E-07_JPRB, & + & 1.52822E-07_JPRB, 1.55048E-07_JPRB, 1.57307E-07_JPRB, 1.59599E-07_JPRB/) + KAO_MN2( 1, :, 3) = (/ & + & 1.87585E-07_JPRB, 1.89503E-07_JPRB, 1.91440E-07_JPRB, 1.93398E-07_JPRB, 1.95375E-07_JPRB, & + & 1.97372E-07_JPRB, 1.99390E-07_JPRB, 2.01429E-07_JPRB, 2.03488E-07_JPRB, 2.05568E-07_JPRB, & + & 2.07670E-07_JPRB, 2.09793E-07_JPRB, 2.11938E-07_JPRB, 2.14105E-07_JPRB, 2.16294E-07_JPRB, & + & 2.18505E-07_JPRB, 2.20739E-07_JPRB, 2.22996E-07_JPRB, 2.25275E-07_JPRB/) + KAO_MN2( 2, :, 3) = (/ & + & 1.82585E-07_JPRB, 1.84249E-07_JPRB, 1.85929E-07_JPRB, 1.87624E-07_JPRB, 1.89335E-07_JPRB, & + & 1.91061E-07_JPRB, 1.92803E-07_JPRB, 1.94561E-07_JPRB, 1.96335E-07_JPRB, 1.98125E-07_JPRB, & + & 1.99932E-07_JPRB, 2.01755E-07_JPRB, 2.03594E-07_JPRB, 2.05451E-07_JPRB, 2.07324E-07_JPRB, & + & 2.09214E-07_JPRB, 2.11122E-07_JPRB, 2.13047E-07_JPRB, 2.14989E-07_JPRB/) + KAO_MN2( 3, :, 3) = (/ & + & 1.64711E-07_JPRB, 1.67539E-07_JPRB, 1.70417E-07_JPRB, 1.73343E-07_JPRB, 1.76321E-07_JPRB, & + & 1.79349E-07_JPRB, 1.82429E-07_JPRB, 1.85562E-07_JPRB, 1.88749E-07_JPRB, 1.91990E-07_JPRB, & + & 1.95288E-07_JPRB, 1.98642E-07_JPRB, 2.02053E-07_JPRB, 2.05523E-07_JPRB, 2.09053E-07_JPRB, & + & 2.12643E-07_JPRB, 2.16295E-07_JPRB, 2.20010E-07_JPRB, 2.23788E-07_JPRB/) + KAO_MN2( 4, :, 3) = (/ & + & 1.67494E-07_JPRB, 1.71011E-07_JPRB, 1.74601E-07_JPRB, 1.78267E-07_JPRB, 1.82009E-07_JPRB, & + & 1.85831E-07_JPRB, 1.89732E-07_JPRB, 1.93715E-07_JPRB, 1.97782E-07_JPRB, 2.01935E-07_JPRB, & + & 2.06174E-07_JPRB, 2.10503E-07_JPRB, 2.14922E-07_JPRB, 2.19434E-07_JPRB, 2.24041E-07_JPRB, & + & 2.28745E-07_JPRB, 2.33548E-07_JPRB, 2.38451E-07_JPRB, 2.43457E-07_JPRB/) + KAO_MN2( 5, :, 3) = (/ & + & 1.97399E-07_JPRB, 2.00092E-07_JPRB, 2.02821E-07_JPRB, 2.05588E-07_JPRB, 2.08393E-07_JPRB, & + & 2.11236E-07_JPRB, 2.14118E-07_JPRB, 2.17039E-07_JPRB, 2.20000E-07_JPRB, 2.23001E-07_JPRB, & + & 2.26043E-07_JPRB, 2.29127E-07_JPRB, 2.32252E-07_JPRB, 2.35421E-07_JPRB, 2.38633E-07_JPRB, & + & 2.41888E-07_JPRB, 2.45188E-07_JPRB, 2.48533E-07_JPRB, 2.51923E-07_JPRB/) + KAO_MN2( 6, :, 3) = (/ & + & 2.24021E-07_JPRB, 2.24970E-07_JPRB, 2.25923E-07_JPRB, 2.26880E-07_JPRB, 2.27840E-07_JPRB, & + & 2.28805E-07_JPRB, 2.29774E-07_JPRB, 2.30747E-07_JPRB, 2.31725E-07_JPRB, 2.32706E-07_JPRB, & + & 2.33692E-07_JPRB, 2.34681E-07_JPRB, 2.35675E-07_JPRB, 2.36673E-07_JPRB, 2.37675E-07_JPRB, & + & 2.38682E-07_JPRB, 2.39693E-07_JPRB, 2.40708E-07_JPRB, 2.41727E-07_JPRB/) + KAO_MN2( 7, :, 3) = (/ & + & 1.98178E-07_JPRB, 2.00676E-07_JPRB, 2.03205E-07_JPRB, 2.05766E-07_JPRB, 2.08359E-07_JPRB, & + & 2.10986E-07_JPRB, 2.13645E-07_JPRB, 2.16337E-07_JPRB, 2.19064E-07_JPRB, 2.21825E-07_JPRB, & + & 2.24621E-07_JPRB, 2.27452E-07_JPRB, 2.30319E-07_JPRB, 2.33222E-07_JPRB, 2.36161E-07_JPRB, & + & 2.39138E-07_JPRB, 2.42152E-07_JPRB, 2.45204E-07_JPRB, 2.48294E-07_JPRB/) + KAO_MN2( 8, :, 3) = (/ & + & 2.83042E-07_JPRB, 2.89941E-07_JPRB, 2.97009E-07_JPRB, 3.04250E-07_JPRB, 3.11666E-07_JPRB, & + & 3.19264E-07_JPRB, 3.27047E-07_JPRB, 3.35019E-07_JPRB, 3.43186E-07_JPRB, 3.51552E-07_JPRB, & + & 3.60122E-07_JPRB, 3.68901E-07_JPRB, 3.77893E-07_JPRB, 3.87105E-07_JPRB, 3.96542E-07_JPRB, & + & 4.06208E-07_JPRB, 4.16111E-07_JPRB, 4.26254E-07_JPRB, 4.36645E-07_JPRB/) + KAO_MN2( 9, :, 3) = (/ & + & 1.98963E-07_JPRB, 2.01576E-07_JPRB, 2.04224E-07_JPRB, 2.06907E-07_JPRB, 2.09626E-07_JPRB, & + & 2.12379E-07_JPRB, 2.15169E-07_JPRB, 2.17996E-07_JPRB, 2.20860E-07_JPRB, 2.23761E-07_JPRB, & + & 2.26701E-07_JPRB, 2.29679E-07_JPRB, 2.32696E-07_JPRB, 2.35753E-07_JPRB, 2.38851E-07_JPRB, & + & 2.41988E-07_JPRB, 2.45167E-07_JPRB, 2.48388E-07_JPRB, 2.51651E-07_JPRB/) + KAO_MN2( 1, :, 4) = (/ & + & 3.75434E-07_JPRB, 3.79581E-07_JPRB, 3.83775E-07_JPRB, 3.88014E-07_JPRB, 3.92301E-07_JPRB, & + & 3.96634E-07_JPRB, 4.01016E-07_JPRB, 4.05446E-07_JPRB, 4.09925E-07_JPRB, 4.14453E-07_JPRB, & + & 4.19032E-07_JPRB, 4.23661E-07_JPRB, 4.28341E-07_JPRB, 4.33073E-07_JPRB, 4.37857E-07_JPRB, & + & 4.42694E-07_JPRB, 4.47585E-07_JPRB, 4.52529E-07_JPRB, 4.57528E-07_JPRB/) + KAO_MN2( 2, :, 4) = (/ & + & 3.76756E-07_JPRB, 3.80760E-07_JPRB, 3.84805E-07_JPRB, 3.88894E-07_JPRB, 3.93027E-07_JPRB, & + & 3.97203E-07_JPRB, 4.01423E-07_JPRB, 4.05689E-07_JPRB, 4.10000E-07_JPRB, 4.14356E-07_JPRB, & + & 4.18759E-07_JPRB, 4.23209E-07_JPRB, 4.27706E-07_JPRB, 4.32250E-07_JPRB, 4.36843E-07_JPRB, & + & 4.41485E-07_JPRB, 4.46176E-07_JPRB, 4.50917E-07_JPRB, 4.55708E-07_JPRB/) + KAO_MN2( 3, :, 4) = (/ & + & 3.76258E-07_JPRB, 3.78929E-07_JPRB, 3.81619E-07_JPRB, 3.84329E-07_JPRB, 3.87057E-07_JPRB, & + & 3.89805E-07_JPRB, 3.92572E-07_JPRB, 3.95359E-07_JPRB, 3.98166E-07_JPRB, 4.00993E-07_JPRB, & + & 4.03839E-07_JPRB, 4.06706E-07_JPRB, 4.09594E-07_JPRB, 4.12502E-07_JPRB, 4.15430E-07_JPRB, & + & 4.18379E-07_JPRB, 4.21349E-07_JPRB, 4.24341E-07_JPRB, 4.27353E-07_JPRB/) + KAO_MN2( 4, :, 4) = (/ & + & 3.17796E-07_JPRB, 3.22447E-07_JPRB, 3.27166E-07_JPRB, 3.31954E-07_JPRB, 3.36812E-07_JPRB, & + & 3.41742E-07_JPRB, 3.46743E-07_JPRB, 3.51818E-07_JPRB, 3.56967E-07_JPRB, 3.62191E-07_JPRB, & + & 3.67492E-07_JPRB, 3.72870E-07_JPRB, 3.78328E-07_JPRB, 3.83865E-07_JPRB, 3.89483E-07_JPRB, & + & 3.95183E-07_JPRB, 4.00967E-07_JPRB, 4.06835E-07_JPRB, 4.12789E-07_JPRB/) + KAO_MN2( 5, :, 4) = (/ & + & 3.33793E-07_JPRB, 3.38941E-07_JPRB, 3.44169E-07_JPRB, 3.49478E-07_JPRB, 3.54868E-07_JPRB, & + & 3.60342E-07_JPRB, 3.65900E-07_JPRB, 3.71544E-07_JPRB, 3.77275E-07_JPRB, 3.83094E-07_JPRB, & + & 3.89003E-07_JPRB, 3.95003E-07_JPRB, 4.01096E-07_JPRB, 4.07283E-07_JPRB, 4.13565E-07_JPRB, & + & 4.19944E-07_JPRB, 4.26421E-07_JPRB, 4.32999E-07_JPRB, 4.39677E-07_JPRB/) + KAO_MN2( 6, :, 4) = (/ & + & 3.60052E-07_JPRB, 3.66686E-07_JPRB, 3.73442E-07_JPRB, 3.80323E-07_JPRB, 3.87330E-07_JPRB, & + & 3.94466E-07_JPRB, 4.01734E-07_JPRB, 4.09136E-07_JPRB, 4.16674E-07_JPRB, 4.24351E-07_JPRB, & + & 4.32169E-07_JPRB, 4.40132E-07_JPRB, 4.48241E-07_JPRB, 4.56500E-07_JPRB, 4.64910E-07_JPRB, & + & 4.73476E-07_JPRB, 4.82200E-07_JPRB, 4.91084E-07_JPRB, 5.00132E-07_JPRB/) + KAO_MN2( 7, :, 4) = (/ & + & 4.14713E-07_JPRB, 4.21885E-07_JPRB, 4.29181E-07_JPRB, 4.36603E-07_JPRB, 4.44153E-07_JPRB, & + & 4.51834E-07_JPRB, 4.59648E-07_JPRB, 4.67598E-07_JPRB, 4.75684E-07_JPRB, 4.83910E-07_JPRB, & + & 4.92279E-07_JPRB, 5.00793E-07_JPRB, 5.09453E-07_JPRB, 5.18264E-07_JPRB, 5.27226E-07_JPRB, & + & 5.36344E-07_JPRB, 5.45620E-07_JPRB, 5.55055E-07_JPRB, 5.64654E-07_JPRB/) + KAO_MN2( 8, :, 4) = (/ & + & 4.15352E-07_JPRB, 4.24386E-07_JPRB, 4.33617E-07_JPRB, 4.43049E-07_JPRB, 4.52685E-07_JPRB, & + & 4.62532E-07_JPRB, 4.72592E-07_JPRB, 4.82872E-07_JPRB, 4.93374E-07_JPRB, 5.04106E-07_JPRB, & + & 5.15071E-07_JPRB, 5.26274E-07_JPRB, 5.37721E-07_JPRB, 5.49417E-07_JPRB, 5.61367E-07_JPRB, & + & 5.73577E-07_JPRB, 5.86053E-07_JPRB, 5.98800E-07_JPRB, 6.11825E-07_JPRB/) + KAO_MN2( 9, :, 4) = (/ & + & 3.33820E-07_JPRB, 3.39144E-07_JPRB, 3.44553E-07_JPRB, 3.50048E-07_JPRB, 3.55631E-07_JPRB, & + & 3.61302E-07_JPRB, 3.67065E-07_JPRB, 3.72919E-07_JPRB, 3.78866E-07_JPRB, 3.84908E-07_JPRB, & + & 3.91047E-07_JPRB, 3.97284E-07_JPRB, 4.03620E-07_JPRB, 4.10057E-07_JPRB, 4.16597E-07_JPRB, & + & 4.23241E-07_JPRB, 4.29991E-07_JPRB, 4.36849E-07_JPRB, 4.43816E-07_JPRB/) + KAO_MN2( 1, :, 5) = (/ & + & 6.99819E-07_JPRB, 7.04629E-07_JPRB, 7.09472E-07_JPRB, 7.14349E-07_JPRB, 7.19258E-07_JPRB, & + & 7.24202E-07_JPRB, 7.29180E-07_JPRB, 7.34192E-07_JPRB, 7.39238E-07_JPRB, 7.44319E-07_JPRB, & + & 7.49435E-07_JPRB, 7.54586E-07_JPRB, 7.59773E-07_JPRB, 7.64995E-07_JPRB, 7.70253E-07_JPRB, & + & 7.75547E-07_JPRB, 7.80877E-07_JPRB, 7.86245E-07_JPRB, 7.91649E-07_JPRB/) + KAO_MN2( 2, :, 5) = (/ & + & 6.98257E-07_JPRB, 7.03182E-07_JPRB, 7.08143E-07_JPRB, 7.13138E-07_JPRB, 7.18169E-07_JPRB, & + & 7.23235E-07_JPRB, 7.28336E-07_JPRB, 7.33474E-07_JPRB, 7.38648E-07_JPRB, 7.43858E-07_JPRB, & + & 7.49106E-07_JPRB, 7.54390E-07_JPRB, 7.59711E-07_JPRB, 7.65071E-07_JPRB, 7.70467E-07_JPRB, & + & 7.75902E-07_JPRB, 7.81376E-07_JPRB, 7.86887E-07_JPRB, 7.92438E-07_JPRB/) + KAO_MN2( 3, :, 5) = (/ & + & 6.98531E-07_JPRB, 7.03429E-07_JPRB, 7.08361E-07_JPRB, 7.13328E-07_JPRB, 7.18329E-07_JPRB, & + & 7.23365E-07_JPRB, 7.28437E-07_JPRB, 7.33545E-07_JPRB, 7.38688E-07_JPRB, 7.43867E-07_JPRB, & + & 7.49082E-07_JPRB, 7.54335E-07_JPRB, 7.59623E-07_JPRB, 7.64950E-07_JPRB, 7.70313E-07_JPRB, & + & 7.75714E-07_JPRB, 7.81153E-07_JPRB, 7.86630E-07_JPRB, 7.92145E-07_JPRB/) + KAO_MN2( 4, :, 5) = (/ & + & 7.37210E-07_JPRB, 7.38869E-07_JPRB, 7.40532E-07_JPRB, 7.42198E-07_JPRB, 7.43868E-07_JPRB, & + & 7.45542E-07_JPRB, 7.47219E-07_JPRB, 7.48901E-07_JPRB, 7.50586E-07_JPRB, 7.52275E-07_JPRB, & + & 7.53967E-07_JPRB, 7.55664E-07_JPRB, 7.57364E-07_JPRB, 7.59068E-07_JPRB, 7.60777E-07_JPRB, & + & 7.62488E-07_JPRB, 7.64204E-07_JPRB, 7.65924E-07_JPRB, 7.67647E-07_JPRB/) + KAO_MN2( 5, :, 5) = (/ & + & 6.07063E-07_JPRB, 6.12893E-07_JPRB, 6.18779E-07_JPRB, 6.24722E-07_JPRB, 6.30721E-07_JPRB, & + & 6.36778E-07_JPRB, 6.42893E-07_JPRB, 6.49067E-07_JPRB, 6.55301E-07_JPRB, 6.61594E-07_JPRB, & + & 6.67947E-07_JPRB, 6.74362E-07_JPRB, 6.80838E-07_JPRB, 6.87376E-07_JPRB, 6.93978E-07_JPRB, & + & 7.00642E-07_JPRB, 7.07371E-07_JPRB, 7.14164E-07_JPRB, 7.21022E-07_JPRB/) + KAO_MN2( 6, :, 5) = (/ & + & 6.13354E-07_JPRB, 6.20147E-07_JPRB, 6.27016E-07_JPRB, 6.33961E-07_JPRB, 6.40983E-07_JPRB, & + & 6.48082E-07_JPRB, 6.55260E-07_JPRB, 6.62518E-07_JPRB, 6.69856E-07_JPRB, 6.77276E-07_JPRB, & + & 6.84777E-07_JPRB, 6.92362E-07_JPRB, 7.00030E-07_JPRB, 7.07784E-07_JPRB, 7.15624E-07_JPRB, & + & 7.23550E-07_JPRB, 7.31564E-07_JPRB, 7.39667E-07_JPRB, 7.47859E-07_JPRB/) + KAO_MN2( 7, :, 5) = (/ & + & 6.86666E-07_JPRB, 6.92902E-07_JPRB, 6.99195E-07_JPRB, 7.05545E-07_JPRB, 7.11952E-07_JPRB, & + & 7.18418E-07_JPRB, 7.24943E-07_JPRB, 7.31526E-07_JPRB, 7.38170E-07_JPRB, 7.44874E-07_JPRB, & + & 7.51639E-07_JPRB, 7.58465E-07_JPRB, 7.65353E-07_JPRB, 7.72304E-07_JPRB, 7.79318E-07_JPRB, & + & 7.86395E-07_JPRB, 7.93537E-07_JPRB, 8.00744E-07_JPRB, 8.08016E-07_JPRB/) + KAO_MN2( 8, :, 5) = (/ & + & 9.39664E-07_JPRB, 9.39765E-07_JPRB, 9.39866E-07_JPRB, 9.39966E-07_JPRB, 9.40067E-07_JPRB, & + & 9.40168E-07_JPRB, 9.40268E-07_JPRB, 9.40369E-07_JPRB, 9.40470E-07_JPRB, 9.40571E-07_JPRB, & + & 9.40671E-07_JPRB, 9.40772E-07_JPRB, 9.40873E-07_JPRB, 9.40974E-07_JPRB, 9.41074E-07_JPRB, & + & 9.41175E-07_JPRB, 9.41276E-07_JPRB, 9.41377E-07_JPRB, 9.41478E-07_JPRB/) + KAO_MN2( 9, :, 5) = (/ & + & 6.02847E-07_JPRB, 6.09726E-07_JPRB, 6.16684E-07_JPRB, 6.23722E-07_JPRB, 6.30839E-07_JPRB, & + & 6.38038E-07_JPRB, 6.45320E-07_JPRB, 6.52684E-07_JPRB, 6.60132E-07_JPRB, 6.67665E-07_JPRB, & + & 6.75284E-07_JPRB, 6.82991E-07_JPRB, 6.90785E-07_JPRB, 6.98668E-07_JPRB, 7.06641E-07_JPRB, & + & 7.14705E-07_JPRB, 7.22861E-07_JPRB, 7.31110E-07_JPRB, 7.39453E-07_JPRB/) + KAO_MN2( 1, :, 6) = (/ & + & 1.13692E-06_JPRB, 1.13231E-06_JPRB, 1.12772E-06_JPRB, 1.12315E-06_JPRB, 1.11859E-06_JPRB, & + & 1.11406E-06_JPRB, 1.10954E-06_JPRB, 1.10505E-06_JPRB, 1.10057E-06_JPRB, 1.09610E-06_JPRB, & + & 1.09166E-06_JPRB, 1.08724E-06_JPRB, 1.08283E-06_JPRB, 1.07844E-06_JPRB, 1.07407E-06_JPRB, & + & 1.06971E-06_JPRB, 1.06538E-06_JPRB, 1.06106E-06_JPRB, 1.05676E-06_JPRB/) + KAO_MN2( 2, :, 6) = (/ & + & 1.13682E-06_JPRB, 1.13221E-06_JPRB, 1.12762E-06_JPRB, 1.12305E-06_JPRB, 1.11849E-06_JPRB, & + & 1.11396E-06_JPRB, 1.10944E-06_JPRB, 1.10495E-06_JPRB, 1.10047E-06_JPRB, 1.09600E-06_JPRB, & + & 1.09156E-06_JPRB, 1.08714E-06_JPRB, 1.08273E-06_JPRB, 1.07834E-06_JPRB, 1.07397E-06_JPRB, & + & 1.06961E-06_JPRB, 1.06528E-06_JPRB, 1.06096E-06_JPRB, 1.05666E-06_JPRB/) + KAO_MN2( 3, :, 6) = (/ & + & 1.13642E-06_JPRB, 1.13181E-06_JPRB, 1.12722E-06_JPRB, 1.12265E-06_JPRB, 1.11809E-06_JPRB, & + & 1.11356E-06_JPRB, 1.10904E-06_JPRB, 1.10455E-06_JPRB, 1.10007E-06_JPRB, 1.09560E-06_JPRB, & + & 1.09116E-06_JPRB, 1.08674E-06_JPRB, 1.08233E-06_JPRB, 1.07794E-06_JPRB, 1.07357E-06_JPRB, & + & 1.06921E-06_JPRB, 1.06488E-06_JPRB, 1.06056E-06_JPRB, 1.05626E-06_JPRB/) + KAO_MN2( 4, :, 6) = (/ & + & 1.13626E-06_JPRB, 1.13160E-06_JPRB, 1.12696E-06_JPRB, 1.12233E-06_JPRB, 1.11773E-06_JPRB, & + & 1.11314E-06_JPRB, 1.10858E-06_JPRB, 1.10403E-06_JPRB, 1.09950E-06_JPRB, 1.09498E-06_JPRB, & + & 1.09049E-06_JPRB, 1.08602E-06_JPRB, 1.08156E-06_JPRB, 1.07712E-06_JPRB, 1.07270E-06_JPRB, & + & 1.06830E-06_JPRB, 1.06392E-06_JPRB, 1.05955E-06_JPRB, 1.05520E-06_JPRB/) + KAO_MN2( 5, :, 6) = (/ & + & 1.22429E-06_JPRB, 1.21163E-06_JPRB, 1.19909E-06_JPRB, 1.18669E-06_JPRB, 1.17441E-06_JPRB, & + & 1.16226E-06_JPRB, 1.15024E-06_JPRB, 1.13834E-06_JPRB, 1.12656E-06_JPRB, 1.11491E-06_JPRB, & + & 1.10338E-06_JPRB, 1.09196E-06_JPRB, 1.08067E-06_JPRB, 1.06949E-06_JPRB, 1.05842E-06_JPRB, & + & 1.04747E-06_JPRB, 1.03664E-06_JPRB, 1.02591E-06_JPRB, 1.01530E-06_JPRB/) + KAO_MN2( 6, :, 6) = (/ & + & 1.02400E-06_JPRB, 1.02238E-06_JPRB, 1.02077E-06_JPRB, 1.01916E-06_JPRB, 1.01755E-06_JPRB, & + & 1.01594E-06_JPRB, 1.01433E-06_JPRB, 1.01273E-06_JPRB, 1.01113E-06_JPRB, 1.00953E-06_JPRB, & + & 1.00794E-06_JPRB, 1.00635E-06_JPRB, 1.00476E-06_JPRB, 1.00317E-06_JPRB, 1.00159E-06_JPRB, & + & 1.00000E-06_JPRB, 9.98425E-07_JPRB, 9.96848E-07_JPRB, 9.95273E-07_JPRB/) + KAO_MN2( 7, :, 6) = (/ & + & 1.08594E-06_JPRB, 1.08185E-06_JPRB, 1.07778E-06_JPRB, 1.07373E-06_JPRB, 1.06969E-06_JPRB, & + & 1.06566E-06_JPRB, 1.06165E-06_JPRB, 1.05766E-06_JPRB, 1.05368E-06_JPRB, 1.04971E-06_JPRB, & + & 1.04576E-06_JPRB, 1.04183E-06_JPRB, 1.03791E-06_JPRB, 1.03400E-06_JPRB, 1.03011E-06_JPRB, & + & 1.02623E-06_JPRB, 1.02237E-06_JPRB, 1.01852E-06_JPRB, 1.01469E-06_JPRB/) + KAO_MN2( 8, :, 6) = (/ & + & 1.25029E-06_JPRB, 1.22508E-06_JPRB, 1.20038E-06_JPRB, 1.17618E-06_JPRB, 1.15247E-06_JPRB, & + & 1.12924E-06_JPRB, 1.10647E-06_JPRB, 1.08416E-06_JPRB, 1.06231E-06_JPRB, 1.04089E-06_JPRB, & + & 1.01990E-06_JPRB, 9.99343E-07_JPRB, 9.79196E-07_JPRB, 9.59454E-07_JPRB, 9.40111E-07_JPRB, & + & 9.21158E-07_JPRB, 9.02587E-07_JPRB, 8.84390E-07_JPRB, 8.66560E-07_JPRB/) + KAO_MN2( 9, :, 6) = (/ & + & 1.21299E-06_JPRB, 1.19953E-06_JPRB, 1.18622E-06_JPRB, 1.17305E-06_JPRB, 1.16003E-06_JPRB, & + & 1.14716E-06_JPRB, 1.13443E-06_JPRB, 1.12184E-06_JPRB, 1.10939E-06_JPRB, 1.09708E-06_JPRB, & + & 1.08491E-06_JPRB, 1.07287E-06_JPRB, 1.06096E-06_JPRB, 1.04919E-06_JPRB, 1.03755E-06_JPRB, & + & 1.02603E-06_JPRB, 1.01465E-06_JPRB, 1.00339E-06_JPRB, 9.92253E-07_JPRB/) + KAO_MN2( 1, :, 7) = (/ & + & 1.53893E-06_JPRB, 1.51743E-06_JPRB, 1.49623E-06_JPRB, 1.47532E-06_JPRB, 1.45471E-06_JPRB, & + & 1.43438E-06_JPRB, 1.41434E-06_JPRB, 1.39458E-06_JPRB, 1.37509E-06_JPRB, 1.35588E-06_JPRB, & + & 1.33694E-06_JPRB, 1.31826E-06_JPRB, 1.29984E-06_JPRB, 1.28167E-06_JPRB, 1.26377E-06_JPRB, & + & 1.24611E-06_JPRB, 1.22870E-06_JPRB, 1.21153E-06_JPRB, 1.19460E-06_JPRB/) + KAO_MN2( 2, :, 7) = (/ & + & 1.53809E-06_JPRB, 1.51665E-06_JPRB, 1.49552E-06_JPRB, 1.47467E-06_JPRB, 1.45412E-06_JPRB, & + & 1.43386E-06_JPRB, 1.41388E-06_JPRB, 1.39418E-06_JPRB, 1.37475E-06_JPRB, 1.35559E-06_JPRB, & + & 1.33670E-06_JPRB, 1.31807E-06_JPRB, 1.29970E-06_JPRB, 1.28159E-06_JPRB, 1.26373E-06_JPRB, & + & 1.24612E-06_JPRB, 1.22875E-06_JPRB, 1.21163E-06_JPRB, 1.19475E-06_JPRB/) + KAO_MN2( 3, :, 7) = (/ & + & 1.53883E-06_JPRB, 1.51733E-06_JPRB, 1.49613E-06_JPRB, 1.47522E-06_JPRB, 1.45461E-06_JPRB, & + & 1.43428E-06_JPRB, 1.41424E-06_JPRB, 1.39448E-06_JPRB, 1.37499E-06_JPRB, 1.35578E-06_JPRB, & + & 1.33684E-06_JPRB, 1.31816E-06_JPRB, 1.29974E-06_JPRB, 1.28157E-06_JPRB, 1.26367E-06_JPRB, & + & 1.24601E-06_JPRB, 1.22860E-06_JPRB, 1.21143E-06_JPRB, 1.19450E-06_JPRB/) + KAO_MN2( 4, :, 7) = (/ & + & 1.53789E-06_JPRB, 1.51645E-06_JPRB, 1.49532E-06_JPRB, 1.47448E-06_JPRB, 1.45393E-06_JPRB, & + & 1.43366E-06_JPRB, 1.41368E-06_JPRB, 1.39398E-06_JPRB, 1.37455E-06_JPRB, 1.35539E-06_JPRB, & + & 1.33650E-06_JPRB, 1.31787E-06_JPRB, 1.29950E-06_JPRB, 1.28139E-06_JPRB, 1.26353E-06_JPRB, & + & 1.24592E-06_JPRB, 1.22856E-06_JPRB, 1.21143E-06_JPRB, 1.19455E-06_JPRB/) + KAO_MN2( 5, :, 7) = (/ & + & 1.54059E-06_JPRB, 1.51888E-06_JPRB, 1.49747E-06_JPRB, 1.47637E-06_JPRB, 1.45557E-06_JPRB, & + & 1.43505E-06_JPRB, 1.41483E-06_JPRB, 1.39489E-06_JPRB, 1.37523E-06_JPRB, 1.35585E-06_JPRB, & + & 1.33675E-06_JPRB, 1.31791E-06_JPRB, 1.29934E-06_JPRB, 1.28103E-06_JPRB, 1.26297E-06_JPRB, & + & 1.24517E-06_JPRB, 1.22763E-06_JPRB, 1.21033E-06_JPRB, 1.19327E-06_JPRB/) + KAO_MN2( 6, :, 7) = (/ & + & 1.70605E-06_JPRB, 1.65759E-06_JPRB, 1.61052E-06_JPRB, 1.56478E-06_JPRB, 1.52034E-06_JPRB, & + & 1.47716E-06_JPRB, 1.43521E-06_JPRB, 1.39445E-06_JPRB, 1.35485E-06_JPRB, 1.31637E-06_JPRB, & + & 1.27898E-06_JPRB, 1.24266E-06_JPRB, 1.20737E-06_JPRB, 1.17308E-06_JPRB, 1.13976E-06_JPRB, & + & 1.10739E-06_JPRB, 1.07594E-06_JPRB, 1.04539E-06_JPRB, 1.01570E-06_JPRB/) + KAO_MN2( 7, :, 7) = (/ & + & 1.39128E-06_JPRB, 1.36388E-06_JPRB, 1.33702E-06_JPRB, 1.31068E-06_JPRB, 1.28487E-06_JPRB, & + & 1.25956E-06_JPRB, 1.23475E-06_JPRB, 1.21044E-06_JPRB, 1.18659E-06_JPRB, 1.16322E-06_JPRB, & + & 1.14031E-06_JPRB, 1.11785E-06_JPRB, 1.09584E-06_JPRB, 1.07425E-06_JPRB, 1.05309E-06_JPRB, & + & 1.03235E-06_JPRB, 1.01202E-06_JPRB, 9.92088E-07_JPRB, 9.72548E-07_JPRB/) + KAO_MN2( 8, :, 7) = (/ & + & 1.15676E-06_JPRB, 1.13709E-06_JPRB, 1.11775E-06_JPRB, 1.09874E-06_JPRB, 1.08005E-06_JPRB, & + & 1.06168E-06_JPRB, 1.04362E-06_JPRB, 1.02587E-06_JPRB, 1.00842E-06_JPRB, 9.91271E-07_JPRB, & + & 9.74411E-07_JPRB, 9.57838E-07_JPRB, 9.41547E-07_JPRB, 9.25532E-07_JPRB, 9.09791E-07_JPRB, & + & 8.94316E-07_JPRB, 8.79105E-07_JPRB, 8.64153E-07_JPRB, 8.49455E-07_JPRB/) + KAO_MN2( 9, :, 7) = (/ & + & 1.53483E-06_JPRB, 1.51352E-06_JPRB, 1.49252E-06_JPRB, 1.47180E-06_JPRB, 1.45138E-06_JPRB, & + & 1.43123E-06_JPRB, 1.41137E-06_JPRB, 1.39178E-06_JPRB, 1.37246E-06_JPRB, 1.35341E-06_JPRB, & + & 1.33463E-06_JPRB, 1.31610E-06_JPRB, 1.29784E-06_JPRB, 1.27982E-06_JPRB, 1.26206E-06_JPRB, & + & 1.24454E-06_JPRB, 1.22727E-06_JPRB, 1.21024E-06_JPRB, 1.19344E-06_JPRB/) + KAO_MN2( 1, :, 8) = (/ & + & 1.70380E-06_JPRB, 1.67470E-06_JPRB, 1.64609E-06_JPRB, 1.61796E-06_JPRB, 1.59032E-06_JPRB, & + & 1.56315E-06_JPRB, 1.53645E-06_JPRB, 1.51020E-06_JPRB, 1.48440E-06_JPRB, 1.45904E-06_JPRB, & + & 1.43411E-06_JPRB, 1.40961E-06_JPRB, 1.38553E-06_JPRB, 1.36186E-06_JPRB, 1.33859E-06_JPRB, & + & 1.31572E-06_JPRB, 1.29324E-06_JPRB, 1.27115E-06_JPRB, 1.24943E-06_JPRB/) + KAO_MN2( 2, :, 8) = (/ & + & 1.70380E-06_JPRB, 1.67470E-06_JPRB, 1.64609E-06_JPRB, 1.61796E-06_JPRB, 1.59032E-06_JPRB, & + & 1.56315E-06_JPRB, 1.53645E-06_JPRB, 1.51020E-06_JPRB, 1.48440E-06_JPRB, 1.45904E-06_JPRB, & + & 1.43411E-06_JPRB, 1.40961E-06_JPRB, 1.38553E-06_JPRB, 1.36186E-06_JPRB, 1.33859E-06_JPRB, & + & 1.31572E-06_JPRB, 1.29324E-06_JPRB, 1.27115E-06_JPRB, 1.24943E-06_JPRB/) + KAO_MN2( 3, :, 8) = (/ & + & 1.70380E-06_JPRB, 1.67470E-06_JPRB, 1.64609E-06_JPRB, 1.61796E-06_JPRB, 1.59032E-06_JPRB, & + & 1.56315E-06_JPRB, 1.53645E-06_JPRB, 1.51020E-06_JPRB, 1.48440E-06_JPRB, 1.45904E-06_JPRB, & + & 1.43411E-06_JPRB, 1.40961E-06_JPRB, 1.38553E-06_JPRB, 1.36186E-06_JPRB, 1.33859E-06_JPRB, & + & 1.31572E-06_JPRB, 1.29324E-06_JPRB, 1.27115E-06_JPRB, 1.24943E-06_JPRB/) + KAO_MN2( 4, :, 8) = (/ & + & 1.70380E-06_JPRB, 1.67470E-06_JPRB, 1.64609E-06_JPRB, 1.61796E-06_JPRB, 1.59032E-06_JPRB, & + & 1.56315E-06_JPRB, 1.53645E-06_JPRB, 1.51020E-06_JPRB, 1.48440E-06_JPRB, 1.45904E-06_JPRB, & + & 1.43411E-06_JPRB, 1.40961E-06_JPRB, 1.38553E-06_JPRB, 1.36186E-06_JPRB, 1.33859E-06_JPRB, & + & 1.31572E-06_JPRB, 1.29324E-06_JPRB, 1.27115E-06_JPRB, 1.24943E-06_JPRB/) + KAO_MN2( 5, :, 8) = (/ & + & 1.70380E-06_JPRB, 1.67470E-06_JPRB, 1.64609E-06_JPRB, 1.61796E-06_JPRB, 1.59032E-06_JPRB, & + & 1.56315E-06_JPRB, 1.53645E-06_JPRB, 1.51020E-06_JPRB, 1.48440E-06_JPRB, 1.45904E-06_JPRB, & + & 1.43411E-06_JPRB, 1.40961E-06_JPRB, 1.38553E-06_JPRB, 1.36186E-06_JPRB, 1.33859E-06_JPRB, & + & 1.31572E-06_JPRB, 1.29324E-06_JPRB, 1.27115E-06_JPRB, 1.24943E-06_JPRB/) + KAO_MN2( 6, :, 8) = (/ & + & 1.70380E-06_JPRB, 1.67470E-06_JPRB, 1.64609E-06_JPRB, 1.61796E-06_JPRB, 1.59032E-06_JPRB, & + & 1.56315E-06_JPRB, 1.53645E-06_JPRB, 1.51020E-06_JPRB, 1.48440E-06_JPRB, 1.45904E-06_JPRB, & + & 1.43411E-06_JPRB, 1.40961E-06_JPRB, 1.38553E-06_JPRB, 1.36186E-06_JPRB, 1.33859E-06_JPRB, & + & 1.31572E-06_JPRB, 1.29324E-06_JPRB, 1.27115E-06_JPRB, 1.24943E-06_JPRB/) + KAO_MN2( 7, :, 8) = (/ & + & 1.71827E-06_JPRB, 1.65481E-06_JPRB, 1.59370E-06_JPRB, 1.53484E-06_JPRB, 1.47816E-06_JPRB, & + & 1.42357E-06_JPRB, 1.37099E-06_JPRB, 1.32036E-06_JPRB, 1.27160E-06_JPRB, 1.22464E-06_JPRB, & + & 1.17941E-06_JPRB, 1.13585E-06_JPRB, 1.09390E-06_JPRB, 1.05350E-06_JPRB, 1.01459E-06_JPRB, & + & 9.77124E-07_JPRB, 9.41037E-07_JPRB, 9.06284E-07_JPRB, 8.72813E-07_JPRB/) + KAO_MN2( 8, :, 8) = (/ & + & 1.77169E-06_JPRB, 1.62858E-06_JPRB, 1.49703E-06_JPRB, 1.37610E-06_JPRB, 1.26494E-06_JPRB, & + & 1.16276E-06_JPRB, 1.06883E-06_JPRB, 9.82495E-07_JPRB, 9.03131E-07_JPRB, 8.30177E-07_JPRB, & + & 7.63117E-07_JPRB, 7.01473E-07_JPRB, 6.44810E-07_JPRB, 5.92723E-07_JPRB, 5.44844E-07_JPRB, & + & 5.00832E-07_JPRB, 4.60376E-07_JPRB, 4.23187E-07_JPRB, 3.89003E-07_JPRB/) + KAO_MN2( 9, :, 8) = (/ & + & 1.70025E-06_JPRB, 1.67042E-06_JPRB, 1.64110E-06_JPRB, 1.61231E-06_JPRB, 1.58401E-06_JPRB, & + & 1.55622E-06_JPRB, 1.52891E-06_JPRB, 1.50208E-06_JPRB, 1.47572E-06_JPRB, 1.44982E-06_JPRB, & + & 1.42438E-06_JPRB, 1.39939E-06_JPRB, 1.37483E-06_JPRB, 1.35071E-06_JPRB, 1.32700E-06_JPRB, & + & 1.30372E-06_JPRB, 1.28084E-06_JPRB, 1.25836E-06_JPRB, 1.23628E-06_JPRB/) + KAO_MN2( 1, :, 9) = (/ & + & 1.74004E-06_JPRB, 1.70661E-06_JPRB, 1.67383E-06_JPRB, 1.64167E-06_JPRB, 1.61014E-06_JPRB, & + & 1.57921E-06_JPRB, 1.54887E-06_JPRB, 1.51912E-06_JPRB, 1.48994E-06_JPRB, 1.46132E-06_JPRB, & + & 1.43325E-06_JPRB, 1.40572E-06_JPRB, 1.37871E-06_JPRB, 1.35223E-06_JPRB, 1.32625E-06_JPRB, & + & 1.30078E-06_JPRB, 1.27579E-06_JPRB, 1.25128E-06_JPRB, 1.22725E-06_JPRB/) + KAO_MN2( 2, :, 9) = (/ & + & 1.74004E-06_JPRB, 1.70661E-06_JPRB, 1.67383E-06_JPRB, 1.64167E-06_JPRB, 1.61014E-06_JPRB, & + & 1.57921E-06_JPRB, 1.54887E-06_JPRB, 1.51912E-06_JPRB, 1.48994E-06_JPRB, 1.46132E-06_JPRB, & + & 1.43325E-06_JPRB, 1.40572E-06_JPRB, 1.37871E-06_JPRB, 1.35223E-06_JPRB, 1.32625E-06_JPRB, & + & 1.30078E-06_JPRB, 1.27579E-06_JPRB, 1.25128E-06_JPRB, 1.22725E-06_JPRB/) + KAO_MN2( 3, :, 9) = (/ & + & 1.74004E-06_JPRB, 1.70661E-06_JPRB, 1.67383E-06_JPRB, 1.64167E-06_JPRB, 1.61014E-06_JPRB, & + & 1.57921E-06_JPRB, 1.54887E-06_JPRB, 1.51912E-06_JPRB, 1.48994E-06_JPRB, 1.46132E-06_JPRB, & + & 1.43325E-06_JPRB, 1.40572E-06_JPRB, 1.37871E-06_JPRB, 1.35223E-06_JPRB, 1.32625E-06_JPRB, & + & 1.30078E-06_JPRB, 1.27579E-06_JPRB, 1.25128E-06_JPRB, 1.22725E-06_JPRB/) + KAO_MN2( 4, :, 9) = (/ & + & 1.74004E-06_JPRB, 1.70661E-06_JPRB, 1.67383E-06_JPRB, 1.64167E-06_JPRB, 1.61014E-06_JPRB, & + & 1.57921E-06_JPRB, 1.54887E-06_JPRB, 1.51912E-06_JPRB, 1.48994E-06_JPRB, 1.46132E-06_JPRB, & + & 1.43325E-06_JPRB, 1.40572E-06_JPRB, 1.37871E-06_JPRB, 1.35223E-06_JPRB, 1.32625E-06_JPRB, & + & 1.30078E-06_JPRB, 1.27579E-06_JPRB, 1.25128E-06_JPRB, 1.22725E-06_JPRB/) + KAO_MN2( 5, :, 9) = (/ & + & 1.74004E-06_JPRB, 1.70661E-06_JPRB, 1.67383E-06_JPRB, 1.64167E-06_JPRB, 1.61014E-06_JPRB, & + & 1.57921E-06_JPRB, 1.54887E-06_JPRB, 1.51912E-06_JPRB, 1.48994E-06_JPRB, 1.46132E-06_JPRB, & + & 1.43325E-06_JPRB, 1.40572E-06_JPRB, 1.37871E-06_JPRB, 1.35223E-06_JPRB, 1.32625E-06_JPRB, & + & 1.30078E-06_JPRB, 1.27579E-06_JPRB, 1.25128E-06_JPRB, 1.22725E-06_JPRB/) + KAO_MN2( 6, :, 9) = (/ & + & 1.74004E-06_JPRB, 1.70661E-06_JPRB, 1.67383E-06_JPRB, 1.64167E-06_JPRB, 1.61014E-06_JPRB, & + & 1.57921E-06_JPRB, 1.54887E-06_JPRB, 1.51912E-06_JPRB, 1.48994E-06_JPRB, 1.46132E-06_JPRB, & + & 1.43325E-06_JPRB, 1.40572E-06_JPRB, 1.37871E-06_JPRB, 1.35223E-06_JPRB, 1.32625E-06_JPRB, & + & 1.30078E-06_JPRB, 1.27579E-06_JPRB, 1.25128E-06_JPRB, 1.22725E-06_JPRB/) + KAO_MN2( 7, :, 9) = (/ & + & 1.74004E-06_JPRB, 1.70661E-06_JPRB, 1.67383E-06_JPRB, 1.64167E-06_JPRB, 1.61014E-06_JPRB, & + & 1.57921E-06_JPRB, 1.54887E-06_JPRB, 1.51912E-06_JPRB, 1.48994E-06_JPRB, 1.46132E-06_JPRB, & + & 1.43325E-06_JPRB, 1.40572E-06_JPRB, 1.37871E-06_JPRB, 1.35223E-06_JPRB, 1.32625E-06_JPRB, & + & 1.30078E-06_JPRB, 1.27579E-06_JPRB, 1.25128E-06_JPRB, 1.22725E-06_JPRB/) + KAO_MN2( 8, :, 9) = (/ & + & 1.08654E-06_JPRB, 1.09039E-06_JPRB, 1.09425E-06_JPRB, 1.09812E-06_JPRB, 1.10201E-06_JPRB, & + & 1.10592E-06_JPRB, 1.10983E-06_JPRB, 1.11376E-06_JPRB, 1.11771E-06_JPRB, 1.12167E-06_JPRB, & + & 1.12564E-06_JPRB, 1.12962E-06_JPRB, 1.13363E-06_JPRB, 1.13764E-06_JPRB, 1.14167E-06_JPRB, & + & 1.14571E-06_JPRB, 1.14977E-06_JPRB, 1.15384E-06_JPRB, 1.15793E-06_JPRB/) + KAO_MN2( 9, :, 9) = (/ & + & 1.74382E-06_JPRB, 1.71092E-06_JPRB, 1.67864E-06_JPRB, 1.64697E-06_JPRB, 1.61589E-06_JPRB, & + & 1.58541E-06_JPRB, 1.55549E-06_JPRB, 1.52615E-06_JPRB, 1.49735E-06_JPRB, 1.46910E-06_JPRB, & + & 1.44138E-06_JPRB, 1.41419E-06_JPRB, 1.38751E-06_JPRB, 1.36133E-06_JPRB, 1.33564E-06_JPRB, & + & 1.31045E-06_JPRB, 1.28572E-06_JPRB, 1.26146E-06_JPRB, 1.23766E-06_JPRB/) + KAO_MN2( 1, :,10) = (/ & + & 1.73703E-06_JPRB, 1.70249E-06_JPRB, 1.66863E-06_JPRB, 1.63544E-06_JPRB, 1.60292E-06_JPRB, & + & 1.57104E-06_JPRB, 1.53980E-06_JPRB, 1.50917E-06_JPRB, 1.47916E-06_JPRB, 1.44974E-06_JPRB, & + & 1.42091E-06_JPRB, 1.39265E-06_JPRB, 1.36496E-06_JPRB, 1.33781E-06_JPRB, 1.31121E-06_JPRB, & + & 1.28513E-06_JPRB, 1.25957E-06_JPRB, 1.23452E-06_JPRB, 1.20997E-06_JPRB/) + KAO_MN2( 2, :,10) = (/ & + & 1.73703E-06_JPRB, 1.70249E-06_JPRB, 1.66863E-06_JPRB, 1.63544E-06_JPRB, 1.60292E-06_JPRB, & + & 1.57104E-06_JPRB, 1.53980E-06_JPRB, 1.50917E-06_JPRB, 1.47916E-06_JPRB, 1.44974E-06_JPRB, & + & 1.42091E-06_JPRB, 1.39265E-06_JPRB, 1.36496E-06_JPRB, 1.33781E-06_JPRB, 1.31121E-06_JPRB, & + & 1.28513E-06_JPRB, 1.25957E-06_JPRB, 1.23452E-06_JPRB, 1.20997E-06_JPRB/) + KAO_MN2( 3, :,10) = (/ & + & 1.73703E-06_JPRB, 1.70249E-06_JPRB, 1.66863E-06_JPRB, 1.63544E-06_JPRB, 1.60292E-06_JPRB, & + & 1.57104E-06_JPRB, 1.53980E-06_JPRB, 1.50917E-06_JPRB, 1.47916E-06_JPRB, 1.44974E-06_JPRB, & + & 1.42091E-06_JPRB, 1.39265E-06_JPRB, 1.36496E-06_JPRB, 1.33781E-06_JPRB, 1.31121E-06_JPRB, & + & 1.28513E-06_JPRB, 1.25957E-06_JPRB, 1.23452E-06_JPRB, 1.20997E-06_JPRB/) + KAO_MN2( 4, :,10) = (/ & + & 1.73703E-06_JPRB, 1.70249E-06_JPRB, 1.66863E-06_JPRB, 1.63544E-06_JPRB, 1.60292E-06_JPRB, & + & 1.57104E-06_JPRB, 1.53980E-06_JPRB, 1.50917E-06_JPRB, 1.47916E-06_JPRB, 1.44974E-06_JPRB, & + & 1.42091E-06_JPRB, 1.39265E-06_JPRB, 1.36496E-06_JPRB, 1.33781E-06_JPRB, 1.31121E-06_JPRB, & + & 1.28513E-06_JPRB, 1.25957E-06_JPRB, 1.23452E-06_JPRB, 1.20997E-06_JPRB/) + KAO_MN2( 5, :,10) = (/ & + & 1.73703E-06_JPRB, 1.70249E-06_JPRB, 1.66863E-06_JPRB, 1.63544E-06_JPRB, 1.60292E-06_JPRB, & + & 1.57104E-06_JPRB, 1.53980E-06_JPRB, 1.50917E-06_JPRB, 1.47916E-06_JPRB, 1.44974E-06_JPRB, & + & 1.42091E-06_JPRB, 1.39265E-06_JPRB, 1.36496E-06_JPRB, 1.33781E-06_JPRB, 1.31121E-06_JPRB, & + & 1.28513E-06_JPRB, 1.25957E-06_JPRB, 1.23452E-06_JPRB, 1.20997E-06_JPRB/) + KAO_MN2( 6, :,10) = (/ & + & 1.73703E-06_JPRB, 1.70249E-06_JPRB, 1.66863E-06_JPRB, 1.63544E-06_JPRB, 1.60292E-06_JPRB, & + & 1.57104E-06_JPRB, 1.53980E-06_JPRB, 1.50917E-06_JPRB, 1.47916E-06_JPRB, 1.44974E-06_JPRB, & + & 1.42091E-06_JPRB, 1.39265E-06_JPRB, 1.36496E-06_JPRB, 1.33781E-06_JPRB, 1.31121E-06_JPRB, & + & 1.28513E-06_JPRB, 1.25957E-06_JPRB, 1.23452E-06_JPRB, 1.20997E-06_JPRB/) + KAO_MN2( 7, :,10) = (/ & + & 1.73703E-06_JPRB, 1.70249E-06_JPRB, 1.66863E-06_JPRB, 1.63544E-06_JPRB, 1.60292E-06_JPRB, & + & 1.57104E-06_JPRB, 1.53980E-06_JPRB, 1.50917E-06_JPRB, 1.47916E-06_JPRB, 1.44974E-06_JPRB, & + & 1.42091E-06_JPRB, 1.39265E-06_JPRB, 1.36496E-06_JPRB, 1.33781E-06_JPRB, 1.31121E-06_JPRB, & + & 1.28513E-06_JPRB, 1.25957E-06_JPRB, 1.23452E-06_JPRB, 1.20997E-06_JPRB/) + KAO_MN2( 8, :,10) = (/ & + & 1.73703E-06_JPRB, 1.70249E-06_JPRB, 1.66863E-06_JPRB, 1.63544E-06_JPRB, 1.60292E-06_JPRB, & + & 1.57104E-06_JPRB, 1.53980E-06_JPRB, 1.50917E-06_JPRB, 1.47916E-06_JPRB, 1.44974E-06_JPRB, & + & 1.42091E-06_JPRB, 1.39265E-06_JPRB, 1.36496E-06_JPRB, 1.33781E-06_JPRB, 1.31121E-06_JPRB, & + & 1.28513E-06_JPRB, 1.25957E-06_JPRB, 1.23452E-06_JPRB, 1.20997E-06_JPRB/) + KAO_MN2( 9, :,10) = (/ & + & 1.82903E-06_JPRB, 1.78673E-06_JPRB, 1.74541E-06_JPRB, 1.70505E-06_JPRB, 1.66562E-06_JPRB, & + & 1.62710E-06_JPRB, 1.58947E-06_JPRB, 1.55271E-06_JPRB, 1.51680E-06_JPRB, 1.48172E-06_JPRB, & + & 1.44745E-06_JPRB, 1.41398E-06_JPRB, 1.38128E-06_JPRB, 1.34933E-06_JPRB, 1.31813E-06_JPRB, & + & 1.28765E-06_JPRB, 1.25787E-06_JPRB, 1.22878E-06_JPRB, 1.20036E-06_JPRB/) + KAO_MN2( 1, :,11) = (/ & + & 1.73118E-06_JPRB, 1.69710E-06_JPRB, 1.66370E-06_JPRB, 1.63095E-06_JPRB, 1.59885E-06_JPRB, & + & 1.56737E-06_JPRB, 1.53652E-06_JPRB, 1.50628E-06_JPRB, 1.47663E-06_JPRB, 1.44756E-06_JPRB, & + & 1.41907E-06_JPRB, 1.39114E-06_JPRB, 1.36376E-06_JPRB, 1.33691E-06_JPRB, 1.31060E-06_JPRB, & + & 1.28480E-06_JPRB, 1.25951E-06_JPRB, 1.23472E-06_JPRB, 1.21041E-06_JPRB/) + KAO_MN2( 2, :,11) = (/ & + & 1.73118E-06_JPRB, 1.69710E-06_JPRB, 1.66370E-06_JPRB, 1.63095E-06_JPRB, 1.59885E-06_JPRB, & + & 1.56737E-06_JPRB, 1.53652E-06_JPRB, 1.50628E-06_JPRB, 1.47663E-06_JPRB, 1.44756E-06_JPRB, & + & 1.41907E-06_JPRB, 1.39114E-06_JPRB, 1.36376E-06_JPRB, 1.33691E-06_JPRB, 1.31060E-06_JPRB, & + & 1.28480E-06_JPRB, 1.25951E-06_JPRB, 1.23472E-06_JPRB, 1.21041E-06_JPRB/) + KAO_MN2( 3, :,11) = (/ & + & 1.73118E-06_JPRB, 1.69710E-06_JPRB, 1.66370E-06_JPRB, 1.63095E-06_JPRB, 1.59885E-06_JPRB, & + & 1.56737E-06_JPRB, 1.53652E-06_JPRB, 1.50628E-06_JPRB, 1.47663E-06_JPRB, 1.44756E-06_JPRB, & + & 1.41907E-06_JPRB, 1.39114E-06_JPRB, 1.36376E-06_JPRB, 1.33691E-06_JPRB, 1.31060E-06_JPRB, & + & 1.28480E-06_JPRB, 1.25951E-06_JPRB, 1.23472E-06_JPRB, 1.21041E-06_JPRB/) + KAO_MN2( 4, :,11) = (/ & + & 1.73118E-06_JPRB, 1.69710E-06_JPRB, 1.66370E-06_JPRB, 1.63095E-06_JPRB, 1.59885E-06_JPRB, & + & 1.56737E-06_JPRB, 1.53652E-06_JPRB, 1.50628E-06_JPRB, 1.47663E-06_JPRB, 1.44756E-06_JPRB, & + & 1.41907E-06_JPRB, 1.39114E-06_JPRB, 1.36376E-06_JPRB, 1.33691E-06_JPRB, 1.31060E-06_JPRB, & + & 1.28480E-06_JPRB, 1.25951E-06_JPRB, 1.23472E-06_JPRB, 1.21041E-06_JPRB/) + KAO_MN2( 5, :,11) = (/ & + & 1.73118E-06_JPRB, 1.69710E-06_JPRB, 1.66370E-06_JPRB, 1.63095E-06_JPRB, 1.59885E-06_JPRB, & + & 1.56737E-06_JPRB, 1.53652E-06_JPRB, 1.50628E-06_JPRB, 1.47663E-06_JPRB, 1.44756E-06_JPRB, & + & 1.41907E-06_JPRB, 1.39114E-06_JPRB, 1.36376E-06_JPRB, 1.33691E-06_JPRB, 1.31060E-06_JPRB, & + & 1.28480E-06_JPRB, 1.25951E-06_JPRB, 1.23472E-06_JPRB, 1.21041E-06_JPRB/) + KAO_MN2( 6, :,11) = (/ & + & 1.73118E-06_JPRB, 1.69710E-06_JPRB, 1.66370E-06_JPRB, 1.63095E-06_JPRB, 1.59885E-06_JPRB, & + & 1.56737E-06_JPRB, 1.53652E-06_JPRB, 1.50628E-06_JPRB, 1.47663E-06_JPRB, 1.44756E-06_JPRB, & + & 1.41907E-06_JPRB, 1.39114E-06_JPRB, 1.36376E-06_JPRB, 1.33691E-06_JPRB, 1.31060E-06_JPRB, & + & 1.28480E-06_JPRB, 1.25951E-06_JPRB, 1.23472E-06_JPRB, 1.21041E-06_JPRB/) + KAO_MN2( 7, :,11) = (/ & + & 1.73118E-06_JPRB, 1.69710E-06_JPRB, 1.66370E-06_JPRB, 1.63095E-06_JPRB, 1.59885E-06_JPRB, & + & 1.56737E-06_JPRB, 1.53652E-06_JPRB, 1.50628E-06_JPRB, 1.47663E-06_JPRB, 1.44756E-06_JPRB, & + & 1.41907E-06_JPRB, 1.39114E-06_JPRB, 1.36376E-06_JPRB, 1.33691E-06_JPRB, 1.31060E-06_JPRB, & + & 1.28480E-06_JPRB, 1.25951E-06_JPRB, 1.23472E-06_JPRB, 1.21041E-06_JPRB/) + KAO_MN2( 8, :,11) = (/ & + & 1.73118E-06_JPRB, 1.69710E-06_JPRB, 1.66370E-06_JPRB, 1.63095E-06_JPRB, 1.59885E-06_JPRB, & + & 1.56737E-06_JPRB, 1.53652E-06_JPRB, 1.50628E-06_JPRB, 1.47663E-06_JPRB, 1.44756E-06_JPRB, & + & 1.41907E-06_JPRB, 1.39114E-06_JPRB, 1.36376E-06_JPRB, 1.33691E-06_JPRB, 1.31060E-06_JPRB, & + & 1.28480E-06_JPRB, 1.25951E-06_JPRB, 1.23472E-06_JPRB, 1.21041E-06_JPRB/) + KAO_MN2( 9, :,11) = (/ & + & 1.81037E-06_JPRB, 1.76948E-06_JPRB, 1.72952E-06_JPRB, 1.69045E-06_JPRB, 1.65228E-06_JPRB, & + & 1.61496E-06_JPRB, 1.57848E-06_JPRB, 1.54283E-06_JPRB, 1.50799E-06_JPRB, 1.47393E-06_JPRB, & + & 1.44064E-06_JPRB, 1.40810E-06_JPRB, 1.37630E-06_JPRB, 1.34522E-06_JPRB, 1.31484E-06_JPRB, & + & 1.28514E-06_JPRB, 1.25611E-06_JPRB, 1.22774E-06_JPRB, 1.20002E-06_JPRB/) + KAO_MN2( 1, :,12) = (/ & + & 1.73338E-06_JPRB, 1.69915E-06_JPRB, 1.66560E-06_JPRB, 1.63271E-06_JPRB, 1.60046E-06_JPRB, & + & 1.56886E-06_JPRB, 1.53788E-06_JPRB, 1.50751E-06_JPRB, 1.47774E-06_JPRB, 1.44856E-06_JPRB, & + & 1.41995E-06_JPRB, 1.39191E-06_JPRB, 1.36442E-06_JPRB, 1.33748E-06_JPRB, 1.31107E-06_JPRB, & + & 1.28518E-06_JPRB, 1.25980E-06_JPRB, 1.23492E-06_JPRB, 1.21053E-06_JPRB/) + KAO_MN2( 2, :,12) = (/ & + & 1.73338E-06_JPRB, 1.69915E-06_JPRB, 1.66560E-06_JPRB, 1.63271E-06_JPRB, 1.60046E-06_JPRB, & + & 1.56886E-06_JPRB, 1.53788E-06_JPRB, 1.50751E-06_JPRB, 1.47774E-06_JPRB, 1.44856E-06_JPRB, & + & 1.41995E-06_JPRB, 1.39191E-06_JPRB, 1.36442E-06_JPRB, 1.33748E-06_JPRB, 1.31107E-06_JPRB, & + & 1.28518E-06_JPRB, 1.25980E-06_JPRB, 1.23492E-06_JPRB, 1.21053E-06_JPRB/) + KAO_MN2( 3, :,12) = (/ & + & 1.73338E-06_JPRB, 1.69915E-06_JPRB, 1.66560E-06_JPRB, 1.63271E-06_JPRB, 1.60046E-06_JPRB, & + & 1.56886E-06_JPRB, 1.53788E-06_JPRB, 1.50751E-06_JPRB, 1.47774E-06_JPRB, 1.44856E-06_JPRB, & + & 1.41995E-06_JPRB, 1.39191E-06_JPRB, 1.36442E-06_JPRB, 1.33748E-06_JPRB, 1.31107E-06_JPRB, & + & 1.28518E-06_JPRB, 1.25980E-06_JPRB, 1.23492E-06_JPRB, 1.21053E-06_JPRB/) + KAO_MN2( 4, :,12) = (/ & + & 1.73338E-06_JPRB, 1.69915E-06_JPRB, 1.66560E-06_JPRB, 1.63271E-06_JPRB, 1.60046E-06_JPRB, & + & 1.56886E-06_JPRB, 1.53788E-06_JPRB, 1.50751E-06_JPRB, 1.47774E-06_JPRB, 1.44856E-06_JPRB, & + & 1.41995E-06_JPRB, 1.39191E-06_JPRB, 1.36442E-06_JPRB, 1.33748E-06_JPRB, 1.31107E-06_JPRB, & + & 1.28518E-06_JPRB, 1.25980E-06_JPRB, 1.23492E-06_JPRB, 1.21053E-06_JPRB/) + KAO_MN2( 5, :,12) = (/ & + & 1.73338E-06_JPRB, 1.69915E-06_JPRB, 1.66560E-06_JPRB, 1.63271E-06_JPRB, 1.60046E-06_JPRB, & + & 1.56886E-06_JPRB, 1.53788E-06_JPRB, 1.50751E-06_JPRB, 1.47774E-06_JPRB, 1.44856E-06_JPRB, & + & 1.41995E-06_JPRB, 1.39191E-06_JPRB, 1.36442E-06_JPRB, 1.33748E-06_JPRB, 1.31107E-06_JPRB, & + & 1.28518E-06_JPRB, 1.25980E-06_JPRB, 1.23492E-06_JPRB, 1.21053E-06_JPRB/) + KAO_MN2( 6, :,12) = (/ & + & 1.73338E-06_JPRB, 1.69915E-06_JPRB, 1.66560E-06_JPRB, 1.63271E-06_JPRB, 1.60046E-06_JPRB, & + & 1.56886E-06_JPRB, 1.53788E-06_JPRB, 1.50751E-06_JPRB, 1.47774E-06_JPRB, 1.44856E-06_JPRB, & + & 1.41995E-06_JPRB, 1.39191E-06_JPRB, 1.36442E-06_JPRB, 1.33748E-06_JPRB, 1.31107E-06_JPRB, & + & 1.28518E-06_JPRB, 1.25980E-06_JPRB, 1.23492E-06_JPRB, 1.21053E-06_JPRB/) + KAO_MN2( 7, :,12) = (/ & + & 1.73338E-06_JPRB, 1.69915E-06_JPRB, 1.66560E-06_JPRB, 1.63271E-06_JPRB, 1.60046E-06_JPRB, & + & 1.56886E-06_JPRB, 1.53788E-06_JPRB, 1.50751E-06_JPRB, 1.47774E-06_JPRB, 1.44856E-06_JPRB, & + & 1.41995E-06_JPRB, 1.39191E-06_JPRB, 1.36442E-06_JPRB, 1.33748E-06_JPRB, 1.31107E-06_JPRB, & + & 1.28518E-06_JPRB, 1.25980E-06_JPRB, 1.23492E-06_JPRB, 1.21053E-06_JPRB/) + KAO_MN2( 8, :,12) = (/ & + & 1.73338E-06_JPRB, 1.69915E-06_JPRB, 1.66560E-06_JPRB, 1.63271E-06_JPRB, 1.60046E-06_JPRB, & + & 1.56886E-06_JPRB, 1.53788E-06_JPRB, 1.50751E-06_JPRB, 1.47774E-06_JPRB, 1.44856E-06_JPRB, & + & 1.41995E-06_JPRB, 1.39191E-06_JPRB, 1.36442E-06_JPRB, 1.33748E-06_JPRB, 1.31107E-06_JPRB, & + & 1.28518E-06_JPRB, 1.25980E-06_JPRB, 1.23492E-06_JPRB, 1.21053E-06_JPRB/) + KAO_MN2( 9, :,12) = (/ & + & 2.04857E-06_JPRB, 1.98353E-06_JPRB, 1.92055E-06_JPRB, 1.85957E-06_JPRB, 1.80053E-06_JPRB, & + & 1.74336E-06_JPRB, 1.68800E-06_JPRB, 1.63441E-06_JPRB, 1.58251E-06_JPRB, 1.53227E-06_JPRB, & + & 1.48362E-06_JPRB, 1.43651E-06_JPRB, 1.39090E-06_JPRB, 1.34674E-06_JPRB, 1.30398E-06_JPRB, & + & 1.26257E-06_JPRB, 1.22249E-06_JPRB, 1.18367E-06_JPRB, 1.14609E-06_JPRB/) + KAO_MN2( 1, :,13) = (/ & + & 1.73511E-06_JPRB, 1.70072E-06_JPRB, 1.66702E-06_JPRB, 1.63398E-06_JPRB, 1.60159E-06_JPRB, & + & 1.56985E-06_JPRB, 1.53874E-06_JPRB, 1.50824E-06_JPRB, 1.47835E-06_JPRB, 1.44905E-06_JPRB, & + & 1.42033E-06_JPRB, 1.39218E-06_JPRB, 1.36459E-06_JPRB, 1.33755E-06_JPRB, 1.31104E-06_JPRB, & + & 1.28505E-06_JPRB, 1.25958E-06_JPRB, 1.23462E-06_JPRB, 1.21015E-06_JPRB/) + KAO_MN2( 2, :,13) = (/ & + & 1.73511E-06_JPRB, 1.70072E-06_JPRB, 1.66702E-06_JPRB, 1.63398E-06_JPRB, 1.60159E-06_JPRB, & + & 1.56985E-06_JPRB, 1.53874E-06_JPRB, 1.50824E-06_JPRB, 1.47835E-06_JPRB, 1.44905E-06_JPRB, & + & 1.42033E-06_JPRB, 1.39218E-06_JPRB, 1.36459E-06_JPRB, 1.33755E-06_JPRB, 1.31104E-06_JPRB, & + & 1.28505E-06_JPRB, 1.25958E-06_JPRB, 1.23462E-06_JPRB, 1.21015E-06_JPRB/) + KAO_MN2( 3, :,13) = (/ & + & 1.73511E-06_JPRB, 1.70072E-06_JPRB, 1.66702E-06_JPRB, 1.63398E-06_JPRB, 1.60159E-06_JPRB, & + & 1.56985E-06_JPRB, 1.53874E-06_JPRB, 1.50824E-06_JPRB, 1.47835E-06_JPRB, 1.44905E-06_JPRB, & + & 1.42033E-06_JPRB, 1.39218E-06_JPRB, 1.36459E-06_JPRB, 1.33755E-06_JPRB, 1.31104E-06_JPRB, & + & 1.28505E-06_JPRB, 1.25958E-06_JPRB, 1.23462E-06_JPRB, 1.21015E-06_JPRB/) + KAO_MN2( 4, :,13) = (/ & + & 1.73511E-06_JPRB, 1.70072E-06_JPRB, 1.66702E-06_JPRB, 1.63398E-06_JPRB, 1.60159E-06_JPRB, & + & 1.56985E-06_JPRB, 1.53874E-06_JPRB, 1.50824E-06_JPRB, 1.47835E-06_JPRB, 1.44905E-06_JPRB, & + & 1.42033E-06_JPRB, 1.39218E-06_JPRB, 1.36459E-06_JPRB, 1.33755E-06_JPRB, 1.31104E-06_JPRB, & + & 1.28505E-06_JPRB, 1.25958E-06_JPRB, 1.23462E-06_JPRB, 1.21015E-06_JPRB/) + KAO_MN2( 5, :,13) = (/ & + & 1.73511E-06_JPRB, 1.70072E-06_JPRB, 1.66702E-06_JPRB, 1.63398E-06_JPRB, 1.60159E-06_JPRB, & + & 1.56985E-06_JPRB, 1.53874E-06_JPRB, 1.50824E-06_JPRB, 1.47835E-06_JPRB, 1.44905E-06_JPRB, & + & 1.42033E-06_JPRB, 1.39218E-06_JPRB, 1.36459E-06_JPRB, 1.33755E-06_JPRB, 1.31104E-06_JPRB, & + & 1.28505E-06_JPRB, 1.25958E-06_JPRB, 1.23462E-06_JPRB, 1.21015E-06_JPRB/) + KAO_MN2( 6, :,13) = (/ & + & 1.73511E-06_JPRB, 1.70072E-06_JPRB, 1.66702E-06_JPRB, 1.63398E-06_JPRB, 1.60159E-06_JPRB, & + & 1.56985E-06_JPRB, 1.53874E-06_JPRB, 1.50824E-06_JPRB, 1.47835E-06_JPRB, 1.44905E-06_JPRB, & + & 1.42033E-06_JPRB, 1.39218E-06_JPRB, 1.36459E-06_JPRB, 1.33755E-06_JPRB, 1.31104E-06_JPRB, & + & 1.28505E-06_JPRB, 1.25958E-06_JPRB, 1.23462E-06_JPRB, 1.21015E-06_JPRB/) + KAO_MN2( 7, :,13) = (/ & + & 1.73511E-06_JPRB, 1.70072E-06_JPRB, 1.66702E-06_JPRB, 1.63398E-06_JPRB, 1.60159E-06_JPRB, & + & 1.56985E-06_JPRB, 1.53874E-06_JPRB, 1.50824E-06_JPRB, 1.47835E-06_JPRB, 1.44905E-06_JPRB, & + & 1.42033E-06_JPRB, 1.39218E-06_JPRB, 1.36459E-06_JPRB, 1.33755E-06_JPRB, 1.31104E-06_JPRB, & + & 1.28505E-06_JPRB, 1.25958E-06_JPRB, 1.23462E-06_JPRB, 1.21015E-06_JPRB/) + KAO_MN2( 8, :,13) = (/ & + & 1.73511E-06_JPRB, 1.70072E-06_JPRB, 1.66702E-06_JPRB, 1.63398E-06_JPRB, 1.60159E-06_JPRB, & + & 1.56985E-06_JPRB, 1.53874E-06_JPRB, 1.50824E-06_JPRB, 1.47835E-06_JPRB, 1.44905E-06_JPRB, & + & 1.42033E-06_JPRB, 1.39218E-06_JPRB, 1.36459E-06_JPRB, 1.33755E-06_JPRB, 1.31104E-06_JPRB, & + & 1.28505E-06_JPRB, 1.25958E-06_JPRB, 1.23462E-06_JPRB, 1.21015E-06_JPRB/) + KAO_MN2( 9, :,13) = (/ & + & 2.13403E-06_JPRB, 2.05906E-06_JPRB, 1.98673E-06_JPRB, 1.91694E-06_JPRB, 1.84961E-06_JPRB, & + & 1.78463E-06_JPRB, 1.72194E-06_JPRB, 1.66145E-06_JPRB, 1.60309E-06_JPRB, 1.54678E-06_JPRB, & + & 1.49244E-06_JPRB, 1.44002E-06_JPRB, 1.38943E-06_JPRB, 1.34062E-06_JPRB, 1.29353E-06_JPRB, & + & 1.24809E-06_JPRB, 1.20425E-06_JPRB, 1.16195E-06_JPRB, 1.12113E-06_JPRB/) + KAO_MN2( 1, :,14) = (/ & + & 1.73398E-06_JPRB, 1.69941E-06_JPRB, 1.66553E-06_JPRB, 1.63233E-06_JPRB, 1.59979E-06_JPRB, & + & 1.56790E-06_JPRB, 1.53664E-06_JPRB, 1.50601E-06_JPRB, 1.47598E-06_JPRB, 1.44656E-06_JPRB, & + & 1.41772E-06_JPRB, 1.38946E-06_JPRB, 1.36176E-06_JPRB, 1.33461E-06_JPRB, 1.30801E-06_JPRB, & + & 1.28193E-06_JPRB, 1.25637E-06_JPRB, 1.23133E-06_JPRB, 1.20678E-06_JPRB/) + KAO_MN2( 2, :,14) = (/ & + & 1.73398E-06_JPRB, 1.69941E-06_JPRB, 1.66553E-06_JPRB, 1.63233E-06_JPRB, 1.59979E-06_JPRB, & + & 1.56790E-06_JPRB, 1.53664E-06_JPRB, 1.50601E-06_JPRB, 1.47598E-06_JPRB, 1.44656E-06_JPRB, & + & 1.41772E-06_JPRB, 1.38946E-06_JPRB, 1.36176E-06_JPRB, 1.33461E-06_JPRB, 1.30801E-06_JPRB, & + & 1.28193E-06_JPRB, 1.25637E-06_JPRB, 1.23133E-06_JPRB, 1.20678E-06_JPRB/) + KAO_MN2( 3, :,14) = (/ & + & 1.73398E-06_JPRB, 1.69941E-06_JPRB, 1.66553E-06_JPRB, 1.63233E-06_JPRB, 1.59979E-06_JPRB, & + & 1.56790E-06_JPRB, 1.53664E-06_JPRB, 1.50601E-06_JPRB, 1.47598E-06_JPRB, 1.44656E-06_JPRB, & + & 1.41772E-06_JPRB, 1.38946E-06_JPRB, 1.36176E-06_JPRB, 1.33461E-06_JPRB, 1.30801E-06_JPRB, & + & 1.28193E-06_JPRB, 1.25637E-06_JPRB, 1.23133E-06_JPRB, 1.20678E-06_JPRB/) + KAO_MN2( 4, :,14) = (/ & + & 1.73398E-06_JPRB, 1.69941E-06_JPRB, 1.66553E-06_JPRB, 1.63233E-06_JPRB, 1.59979E-06_JPRB, & + & 1.56790E-06_JPRB, 1.53664E-06_JPRB, 1.50601E-06_JPRB, 1.47598E-06_JPRB, 1.44656E-06_JPRB, & + & 1.41772E-06_JPRB, 1.38946E-06_JPRB, 1.36176E-06_JPRB, 1.33461E-06_JPRB, 1.30801E-06_JPRB, & + & 1.28193E-06_JPRB, 1.25637E-06_JPRB, 1.23133E-06_JPRB, 1.20678E-06_JPRB/) + KAO_MN2( 5, :,14) = (/ & + & 1.73398E-06_JPRB, 1.69941E-06_JPRB, 1.66553E-06_JPRB, 1.63233E-06_JPRB, 1.59979E-06_JPRB, & + & 1.56790E-06_JPRB, 1.53664E-06_JPRB, 1.50601E-06_JPRB, 1.47598E-06_JPRB, 1.44656E-06_JPRB, & + & 1.41772E-06_JPRB, 1.38946E-06_JPRB, 1.36176E-06_JPRB, 1.33461E-06_JPRB, 1.30801E-06_JPRB, & + & 1.28193E-06_JPRB, 1.25637E-06_JPRB, 1.23133E-06_JPRB, 1.20678E-06_JPRB/) + KAO_MN2( 6, :,14) = (/ & + & 1.73398E-06_JPRB, 1.69941E-06_JPRB, 1.66553E-06_JPRB, 1.63233E-06_JPRB, 1.59979E-06_JPRB, & + & 1.56790E-06_JPRB, 1.53664E-06_JPRB, 1.50601E-06_JPRB, 1.47598E-06_JPRB, 1.44656E-06_JPRB, & + & 1.41772E-06_JPRB, 1.38946E-06_JPRB, 1.36176E-06_JPRB, 1.33461E-06_JPRB, 1.30801E-06_JPRB, & + & 1.28193E-06_JPRB, 1.25637E-06_JPRB, 1.23133E-06_JPRB, 1.20678E-06_JPRB/) + KAO_MN2( 7, :,14) = (/ & + & 1.73398E-06_JPRB, 1.69941E-06_JPRB, 1.66553E-06_JPRB, 1.63233E-06_JPRB, 1.59979E-06_JPRB, & + & 1.56790E-06_JPRB, 1.53664E-06_JPRB, 1.50601E-06_JPRB, 1.47598E-06_JPRB, 1.44656E-06_JPRB, & + & 1.41772E-06_JPRB, 1.38946E-06_JPRB, 1.36176E-06_JPRB, 1.33461E-06_JPRB, 1.30801E-06_JPRB, & + & 1.28193E-06_JPRB, 1.25637E-06_JPRB, 1.23133E-06_JPRB, 1.20678E-06_JPRB/) + KAO_MN2( 8, :,14) = (/ & + & 1.73398E-06_JPRB, 1.69941E-06_JPRB, 1.66553E-06_JPRB, 1.63233E-06_JPRB, 1.59979E-06_JPRB, & + & 1.56790E-06_JPRB, 1.53664E-06_JPRB, 1.50601E-06_JPRB, 1.47598E-06_JPRB, 1.44656E-06_JPRB, & + & 1.41772E-06_JPRB, 1.38946E-06_JPRB, 1.36176E-06_JPRB, 1.33461E-06_JPRB, 1.30801E-06_JPRB, & + & 1.28193E-06_JPRB, 1.25637E-06_JPRB, 1.23133E-06_JPRB, 1.20678E-06_JPRB/) + KAO_MN2( 9, :,14) = (/ & + & 1.83423E-06_JPRB, 1.79123E-06_JPRB, 1.74923E-06_JPRB, 1.70821E-06_JPRB, 1.66816E-06_JPRB, & + & 1.62904E-06_JPRB, 1.59085E-06_JPRB, 1.55354E-06_JPRB, 1.51712E-06_JPRB, 1.48154E-06_JPRB, & + & 1.44681E-06_JPRB, 1.41288E-06_JPRB, 1.37975E-06_JPRB, 1.34740E-06_JPRB, 1.31581E-06_JPRB, & + & 1.28496E-06_JPRB, 1.25483E-06_JPRB, 1.22540E-06_JPRB, 1.19667E-06_JPRB/) + KAO_MN2( 1, :,15) = (/ & + & 1.73231E-06_JPRB, 1.69765E-06_JPRB, 1.66368E-06_JPRB, 1.63039E-06_JPRB, 1.59776E-06_JPRB, & + & 1.56579E-06_JPRB, 1.53445E-06_JPRB, 1.50375E-06_JPRB, 1.47366E-06_JPRB, 1.44417E-06_JPRB, & + & 1.41527E-06_JPRB, 1.38695E-06_JPRB, 1.35919E-06_JPRB, 1.33199E-06_JPRB, 1.30534E-06_JPRB, & + & 1.27922E-06_JPRB, 1.25362E-06_JPRB, 1.22853E-06_JPRB, 1.20395E-06_JPRB/) + KAO_MN2( 2, :,15) = (/ & + & 1.73231E-06_JPRB, 1.69765E-06_JPRB, 1.66368E-06_JPRB, 1.63039E-06_JPRB, 1.59776E-06_JPRB, & + & 1.56579E-06_JPRB, 1.53445E-06_JPRB, 1.50375E-06_JPRB, 1.47366E-06_JPRB, 1.44417E-06_JPRB, & + & 1.41527E-06_JPRB, 1.38695E-06_JPRB, 1.35919E-06_JPRB, 1.33199E-06_JPRB, 1.30534E-06_JPRB, & + & 1.27922E-06_JPRB, 1.25362E-06_JPRB, 1.22853E-06_JPRB, 1.20395E-06_JPRB/) + KAO_MN2( 3, :,15) = (/ & + & 1.73231E-06_JPRB, 1.69765E-06_JPRB, 1.66368E-06_JPRB, 1.63039E-06_JPRB, 1.59776E-06_JPRB, & + & 1.56579E-06_JPRB, 1.53445E-06_JPRB, 1.50375E-06_JPRB, 1.47366E-06_JPRB, 1.44417E-06_JPRB, & + & 1.41527E-06_JPRB, 1.38695E-06_JPRB, 1.35919E-06_JPRB, 1.33199E-06_JPRB, 1.30534E-06_JPRB, & + & 1.27922E-06_JPRB, 1.25362E-06_JPRB, 1.22853E-06_JPRB, 1.20395E-06_JPRB/) + KAO_MN2( 4, :,15) = (/ & + & 1.73231E-06_JPRB, 1.69765E-06_JPRB, 1.66368E-06_JPRB, 1.63039E-06_JPRB, 1.59776E-06_JPRB, & + & 1.56579E-06_JPRB, 1.53445E-06_JPRB, 1.50375E-06_JPRB, 1.47366E-06_JPRB, 1.44417E-06_JPRB, & + & 1.41527E-06_JPRB, 1.38695E-06_JPRB, 1.35919E-06_JPRB, 1.33199E-06_JPRB, 1.30534E-06_JPRB, & + & 1.27922E-06_JPRB, 1.25362E-06_JPRB, 1.22853E-06_JPRB, 1.20395E-06_JPRB/) + KAO_MN2( 5, :,15) = (/ & + & 1.73231E-06_JPRB, 1.69765E-06_JPRB, 1.66368E-06_JPRB, 1.63039E-06_JPRB, 1.59776E-06_JPRB, & + & 1.56579E-06_JPRB, 1.53445E-06_JPRB, 1.50375E-06_JPRB, 1.47366E-06_JPRB, 1.44417E-06_JPRB, & + & 1.41527E-06_JPRB, 1.38695E-06_JPRB, 1.35919E-06_JPRB, 1.33199E-06_JPRB, 1.30534E-06_JPRB, & + & 1.27922E-06_JPRB, 1.25362E-06_JPRB, 1.22853E-06_JPRB, 1.20395E-06_JPRB/) + KAO_MN2( 6, :,15) = (/ & + & 1.73231E-06_JPRB, 1.69765E-06_JPRB, 1.66368E-06_JPRB, 1.63039E-06_JPRB, 1.59776E-06_JPRB, & + & 1.56579E-06_JPRB, 1.53445E-06_JPRB, 1.50375E-06_JPRB, 1.47366E-06_JPRB, 1.44417E-06_JPRB, & + & 1.41527E-06_JPRB, 1.38695E-06_JPRB, 1.35919E-06_JPRB, 1.33199E-06_JPRB, 1.30534E-06_JPRB, & + & 1.27922E-06_JPRB, 1.25362E-06_JPRB, 1.22853E-06_JPRB, 1.20395E-06_JPRB/) + KAO_MN2( 7, :,15) = (/ & + & 1.73231E-06_JPRB, 1.69765E-06_JPRB, 1.66368E-06_JPRB, 1.63039E-06_JPRB, 1.59776E-06_JPRB, & + & 1.56579E-06_JPRB, 1.53445E-06_JPRB, 1.50375E-06_JPRB, 1.47366E-06_JPRB, 1.44417E-06_JPRB, & + & 1.41527E-06_JPRB, 1.38695E-06_JPRB, 1.35919E-06_JPRB, 1.33199E-06_JPRB, 1.30534E-06_JPRB, & + & 1.27922E-06_JPRB, 1.25362E-06_JPRB, 1.22853E-06_JPRB, 1.20395E-06_JPRB/) + KAO_MN2( 8, :,15) = (/ & + & 1.73231E-06_JPRB, 1.69765E-06_JPRB, 1.66368E-06_JPRB, 1.63039E-06_JPRB, 1.59776E-06_JPRB, & + & 1.56579E-06_JPRB, 1.53445E-06_JPRB, 1.50375E-06_JPRB, 1.47366E-06_JPRB, 1.44417E-06_JPRB, & + & 1.41527E-06_JPRB, 1.38695E-06_JPRB, 1.35919E-06_JPRB, 1.33199E-06_JPRB, 1.30534E-06_JPRB, & + & 1.27922E-06_JPRB, 1.25362E-06_JPRB, 1.22853E-06_JPRB, 1.20395E-06_JPRB/) + KAO_MN2( 9, :,15) = (/ & + & 1.71602E-06_JPRB, 1.68499E-06_JPRB, 1.65452E-06_JPRB, 1.62461E-06_JPRB, 1.59523E-06_JPRB, & + & 1.56639E-06_JPRB, 1.53807E-06_JPRB, 1.51026E-06_JPRB, 1.48295E-06_JPRB, 1.45614E-06_JPRB, & + & 1.42981E-06_JPRB, 1.40395E-06_JPRB, 1.37857E-06_JPRB, 1.35364E-06_JPRB, 1.32917E-06_JPRB, & + & 1.30513E-06_JPRB, 1.28153E-06_JPRB, 1.25836E-06_JPRB, 1.23561E-06_JPRB/) + KAO_MN2( 1, :,16) = (/ & + & 1.73310E-06_JPRB, 1.69826E-06_JPRB, 1.66413E-06_JPRB, 1.63069E-06_JPRB, 1.59791E-06_JPRB, & + & 1.56580E-06_JPRB, 1.53433E-06_JPRB, 1.50349E-06_JPRB, 1.47328E-06_JPRB, 1.44367E-06_JPRB, & + & 1.41465E-06_JPRB, 1.38622E-06_JPRB, 1.35836E-06_JPRB, 1.33106E-06_JPRB, 1.30431E-06_JPRB, & + & 1.27810E-06_JPRB, 1.25241E-06_JPRB, 1.22724E-06_JPRB, 1.20257E-06_JPRB/) + KAO_MN2( 2, :,16) = (/ & + & 1.73310E-06_JPRB, 1.69826E-06_JPRB, 1.66413E-06_JPRB, 1.63069E-06_JPRB, 1.59791E-06_JPRB, & + & 1.56580E-06_JPRB, 1.53433E-06_JPRB, 1.50349E-06_JPRB, 1.47328E-06_JPRB, 1.44367E-06_JPRB, & + & 1.41465E-06_JPRB, 1.38622E-06_JPRB, 1.35836E-06_JPRB, 1.33106E-06_JPRB, 1.30431E-06_JPRB, & + & 1.27810E-06_JPRB, 1.25241E-06_JPRB, 1.22724E-06_JPRB, 1.20257E-06_JPRB/) + KAO_MN2( 3, :,16) = (/ & + & 1.73310E-06_JPRB, 1.69826E-06_JPRB, 1.66413E-06_JPRB, 1.63069E-06_JPRB, 1.59791E-06_JPRB, & + & 1.56580E-06_JPRB, 1.53433E-06_JPRB, 1.50349E-06_JPRB, 1.47328E-06_JPRB, 1.44367E-06_JPRB, & + & 1.41465E-06_JPRB, 1.38622E-06_JPRB, 1.35836E-06_JPRB, 1.33106E-06_JPRB, 1.30431E-06_JPRB, & + & 1.27810E-06_JPRB, 1.25241E-06_JPRB, 1.22724E-06_JPRB, 1.20257E-06_JPRB/) + KAO_MN2( 4, :,16) = (/ & + & 1.73310E-06_JPRB, 1.69826E-06_JPRB, 1.66413E-06_JPRB, 1.63069E-06_JPRB, 1.59791E-06_JPRB, & + & 1.56580E-06_JPRB, 1.53433E-06_JPRB, 1.50349E-06_JPRB, 1.47328E-06_JPRB, 1.44367E-06_JPRB, & + & 1.41465E-06_JPRB, 1.38622E-06_JPRB, 1.35836E-06_JPRB, 1.33106E-06_JPRB, 1.30431E-06_JPRB, & + & 1.27810E-06_JPRB, 1.25241E-06_JPRB, 1.22724E-06_JPRB, 1.20257E-06_JPRB/) + KAO_MN2( 5, :,16) = (/ & + & 1.73310E-06_JPRB, 1.69826E-06_JPRB, 1.66413E-06_JPRB, 1.63069E-06_JPRB, 1.59791E-06_JPRB, & + & 1.56580E-06_JPRB, 1.53433E-06_JPRB, 1.50349E-06_JPRB, 1.47328E-06_JPRB, 1.44367E-06_JPRB, & + & 1.41465E-06_JPRB, 1.38622E-06_JPRB, 1.35836E-06_JPRB, 1.33106E-06_JPRB, 1.30431E-06_JPRB, & + & 1.27810E-06_JPRB, 1.25241E-06_JPRB, 1.22724E-06_JPRB, 1.20257E-06_JPRB/) + KAO_MN2( 6, :,16) = (/ & + & 1.73310E-06_JPRB, 1.69826E-06_JPRB, 1.66413E-06_JPRB, 1.63069E-06_JPRB, 1.59791E-06_JPRB, & + & 1.56580E-06_JPRB, 1.53433E-06_JPRB, 1.50349E-06_JPRB, 1.47328E-06_JPRB, 1.44367E-06_JPRB, & + & 1.41465E-06_JPRB, 1.38622E-06_JPRB, 1.35836E-06_JPRB, 1.33106E-06_JPRB, 1.30431E-06_JPRB, & + & 1.27810E-06_JPRB, 1.25241E-06_JPRB, 1.22724E-06_JPRB, 1.20257E-06_JPRB/) + KAO_MN2( 7, :,16) = (/ & + & 1.73310E-06_JPRB, 1.69826E-06_JPRB, 1.66413E-06_JPRB, 1.63069E-06_JPRB, 1.59791E-06_JPRB, & + & 1.56580E-06_JPRB, 1.53433E-06_JPRB, 1.50349E-06_JPRB, 1.47328E-06_JPRB, 1.44367E-06_JPRB, & + & 1.41465E-06_JPRB, 1.38622E-06_JPRB, 1.35836E-06_JPRB, 1.33106E-06_JPRB, 1.30431E-06_JPRB, & + & 1.27810E-06_JPRB, 1.25241E-06_JPRB, 1.22724E-06_JPRB, 1.20257E-06_JPRB/) + KAO_MN2( 8, :,16) = (/ & + & 1.73310E-06_JPRB, 1.69826E-06_JPRB, 1.66413E-06_JPRB, 1.63069E-06_JPRB, 1.59791E-06_JPRB, & + & 1.56580E-06_JPRB, 1.53433E-06_JPRB, 1.50349E-06_JPRB, 1.47328E-06_JPRB, 1.44367E-06_JPRB, & + & 1.41465E-06_JPRB, 1.38622E-06_JPRB, 1.35836E-06_JPRB, 1.33106E-06_JPRB, 1.30431E-06_JPRB, & + & 1.27810E-06_JPRB, 1.25241E-06_JPRB, 1.22724E-06_JPRB, 1.20257E-06_JPRB/) + KAO_MN2( 9, :,16) = (/ & + & 1.79375E-06_JPRB, 1.75599E-06_JPRB, 1.71903E-06_JPRB, 1.68284E-06_JPRB, 1.64741E-06_JPRB, & + & 1.61273E-06_JPRB, 1.57878E-06_JPRB, 1.54554E-06_JPRB, 1.51301E-06_JPRB, 1.48116E-06_JPRB, & + & 1.44998E-06_JPRB, 1.41945E-06_JPRB, 1.38957E-06_JPRB, 1.36032E-06_JPRB, 1.33168E-06_JPRB, & + & 1.30365E-06_JPRB, 1.27620E-06_JPRB, 1.24934E-06_JPRB, 1.22304E-06_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &1.1755E-06_JPRB,6.5398E-07_JPRB,4.3915E-07_JPRB,3.0753E-07_JPRB,1.9677E-07_JPRB,1.4362E-07_JPRB, & + &9.4598E-08_JPRB,1.1848E-07_JPRB,1.4280E-07_JPRB,1.5821E-07_JPRB,1.5816E-07_JPRB,1.5769E-07_JPRB, & + &1.5844E-07_JPRB,1.6016E-07_JPRB,1.6232E-07_JPRB,1.6320E-07_JPRB/) + FORREFO(2,:) = (/ & + &1.0703E-06_JPRB,6.2783E-07_JPRB,4.7122E-07_JPRB,2.6300E-07_JPRB,1.8538E-07_JPRB,1.5076E-07_JPRB, & + &1.9474E-07_JPRB,2.9543E-07_JPRB,2.0093E-07_JPRB,1.5819E-07_JPRB,1.5826E-07_JPRB,1.5737E-07_JPRB, & + &1.5751E-07_JPRB,1.5910E-07_JPRB,1.6181E-07_JPRB,1.6320E-07_JPRB/) + FORREFO(3,:) = (/ & + &1.0470E-06_JPRB,5.8184E-07_JPRB,4.8218E-07_JPRB,2.7771E-07_JPRB,1.9036E-07_JPRB,1.5737E-07_JPRB, & + &1.8633E-07_JPRB,2.5754E-07_JPRB,4.0647E-07_JPRB,1.5839E-07_JPRB,1.5914E-07_JPRB,1.5788E-07_JPRB, & + &1.5731E-07_JPRB,1.5836E-07_JPRB,1.6103E-07_JPRB,1.6320E-07_JPRB/) + FORREFO(4,:) = (/ & + &1.3891E-06_JPRB,5.4901E-07_JPRB,2.8850E-07_JPRB,1.9176E-07_JPRB,1.4549E-07_JPRB,1.3603E-07_JPRB, & + &1.7472E-07_JPRB,2.9796E-07_JPRB,3.2452E-07_JPRB,2.5231E-07_JPRB,2.8195E-07_JPRB,1.5527E-07_JPRB, & + &1.5507E-07_JPRB,1.5442E-07_JPRB,1.5275E-07_JPRB,1.6057E-07_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 1.73980E-03_JPRB, 1.41928E-03_JPRB, 1.15780E-03_JPRB, 9.44496E-04_JPRB, 7.70490E-04_JPRB, & + & 6.28541E-04_JPRB, 5.12744E-04_JPRB, 4.18280E-04_JPRB, 3.41219E-04_JPRB, 2.78356E-04_JPRB/) + SELFREFO(:, 2) = (/ & + & 1.84082E-03_JPRB, 1.50228E-03_JPRB, 1.22600E-03_JPRB, 1.00053E-03_JPRB, 8.16525E-04_JPRB, & + & 6.66359E-04_JPRB, 5.43811E-04_JPRB, 4.43800E-04_JPRB, 3.62182E-04_JPRB, 2.95574E-04_JPRB/) + SELFREFO(:, 3) = (/ & + & 1.92957E-03_JPRB, 1.57727E-03_JPRB, 1.28930E-03_JPRB, 1.05390E-03_JPRB, 8.61484E-04_JPRB, & + & 7.04197E-04_JPRB, 5.75627E-04_JPRB, 4.70530E-04_JPRB, 3.84622E-04_JPRB, 3.14399E-04_JPRB/) + SELFREFO(:, 4) = (/ & + & 2.12958E-03_JPRB, 1.73572E-03_JPRB, 1.41470E-03_JPRB, 1.15305E-03_JPRB, 9.39798E-04_JPRB, & + & 7.65984E-04_JPRB, 6.24317E-04_JPRB, 5.08850E-04_JPRB, 4.14739E-04_JPRB, 3.38034E-04_JPRB/) + SELFREFO(:, 5) = (/ & + & 2.30636E-03_JPRB, 1.88401E-03_JPRB, 1.53900E-03_JPRB, 1.25717E-03_JPRB, 1.02695E-03_JPRB, & + & 8.38891E-04_JPRB, 6.85270E-04_JPRB, 5.59780E-04_JPRB, 4.57270E-04_JPRB, 3.73533E-04_JPRB/) + SELFREFO(:, 6) = (/ & + & 2.47824E-03_JPRB, 2.03278E-03_JPRB, 1.66740E-03_JPRB, 1.36769E-03_JPRB, 1.12185E-03_JPRB, & + & 9.20206E-04_JPRB, 7.54803E-04_JPRB, 6.19130E-04_JPRB, 5.07844E-04_JPRB, 4.16561E-04_JPRB/) + SELFREFO(:, 7) = (/ & + & 2.54196E-03_JPRB, 2.10768E-03_JPRB, 1.74760E-03_JPRB, 1.44904E-03_JPRB, 1.20148E-03_JPRB, & + & 9.96215E-04_JPRB, 8.26019E-04_JPRB, 6.84900E-04_JPRB, 5.67890E-04_JPRB, 4.70870E-04_JPRB/) + SELFREFO(:, 8) = (/ & + & 2.52650E-03_JPRB, 2.11773E-03_JPRB, 1.77510E-03_JPRB, 1.48790E-03_JPRB, 1.24717E-03_JPRB, & + & 1.04539E-03_JPRB, 8.76251E-04_JPRB, 7.34480E-04_JPRB, 6.15646E-04_JPRB, 5.16039E-04_JPRB/) + SELFREFO(:, 9) = (/ & + & 2.82351E-03_JPRB, 2.34652E-03_JPRB, 1.95010E-03_JPRB, 1.62065E-03_JPRB, 1.34686E-03_JPRB, & + & 1.11933E-03_JPRB, 9.30232E-04_JPRB, 7.73080E-04_JPRB, 6.42477E-04_JPRB, 5.33939E-04_JPRB/) + SELFREFO(:,10) = (/ & + & 2.98189E-03_JPRB, 2.46741E-03_JPRB, 2.04170E-03_JPRB, 1.68944E-03_JPRB, 1.39795E-03_JPRB, & + & 1.15676E-03_JPRB, 9.57176E-04_JPRB, 7.92030E-04_JPRB, 6.55377E-04_JPRB, 5.42302E-04_JPRB/) + SELFREFO(:,11) = (/ & + & 2.98239E-03_JPRB, 2.46774E-03_JPRB, 2.04190E-03_JPRB, 1.68954E-03_JPRB, 1.39799E-03_JPRB, & + & 1.15675E-03_JPRB, 9.57137E-04_JPRB, 7.91970E-04_JPRB, 6.55305E-04_JPRB, 5.42224E-04_JPRB/) + SELFREFO(:,12) = (/ & + & 2.97833E-03_JPRB, 2.46461E-03_JPRB, 2.03950E-03_JPRB, 1.68772E-03_JPRB, 1.39661E-03_JPRB, & + & 1.15571E-03_JPRB, 9.56370E-04_JPRB, 7.91410E-04_JPRB, 6.54903E-04_JPRB, 5.41942E-04_JPRB/) + SELFREFO(:,13) = (/ & + & 2.97779E-03_JPRB, 2.46463E-03_JPRB, 2.03990E-03_JPRB, 1.68836E-03_JPRB, 1.39741E-03_JPRB, & + & 1.15659E-03_JPRB, 9.57278E-04_JPRB, 7.92310E-04_JPRB, 6.55771E-04_JPRB, 5.42762E-04_JPRB/) + SELFREFO(:,14) = (/ & + & 2.98326E-03_JPRB, 2.46943E-03_JPRB, 2.04410E-03_JPRB, 1.69203E-03_JPRB, 1.40060E-03_JPRB, & + & 1.15936E-03_JPRB, 9.59673E-04_JPRB, 7.94380E-04_JPRB, 6.57557E-04_JPRB, 5.44301E-04_JPRB/) + SELFREFO(:,15) = (/ & + & 2.99407E-03_JPRB, 2.47825E-03_JPRB, 2.05130E-03_JPRB, 1.69790E-03_JPRB, 1.40539E-03_JPRB, & + & 1.16327E-03_JPRB, 9.62862E-04_JPRB, 7.96980E-04_JPRB, 6.59676E-04_JPRB, 5.46028E-04_JPRB/) + SELFREFO(:,16) = (/ & + & 3.00005E-03_JPRB, 2.48296E-03_JPRB, 2.05500E-03_JPRB, 1.70080E-03_JPRB, 1.40765E-03_JPRB, & + & 1.16503E-03_JPRB, 9.64224E-04_JPRB, 7.98030E-04_JPRB, 6.60481E-04_JPRB, 5.46641E-04_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB15',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB15:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB15 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb16.F90 (revision 6016) @@ -0,0 +1,207 @@ +SUBROUTINE RRTM_KGB16 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 16: 2600-3000 cm-1 (low - H2O,CH4; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO16, ONLY : KAO,KBO ,SELFREFO,FORREFO ,FRACREFAO,FRACREFBO,KAO_D,KBO_D +USE YOMMP0 , ONLY : NPROC, MYPROC + + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB16',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D,KBO_D + CLOSE(NULRAD,ERR=1000) + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB16:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB16:') +ENDIF + +! Planck fraction mapping level: P = 387.6100 mbar, T = 250.17 K + FRACREFAO(:, 1) = (/ & + & 1.1593E-01_JPRB,2.3390E-01_JPRB,1.9120E-01_JPRB,1.3121E-01_JPRB,1.0590E-01_JPRB,8.4852E-02_JPRB, & + & 6.4168E-02_JPRB,4.2537E-02_JPRB,2.3220E-02_JPRB,2.1767E-03_JPRB,1.8203E-03_JPRB,1.3724E-03_JPRB, & + & 9.5452E-04_JPRB,5.5015E-04_JPRB,1.9348E-04_JPRB,2.7344E-05_JPRB/) + FRACREFAO(:, 2) = (/ & + & 2.8101E-01_JPRB,1.9773E-01_JPRB,1.4749E-01_JPRB,1.1399E-01_JPRB,8.8190E-02_JPRB,7.0531E-02_JPRB, & + & 4.6356E-02_JPRB,3.0774E-02_JPRB,1.7332E-02_JPRB,2.0054E-03_JPRB,1.5950E-03_JPRB,1.2760E-03_JPRB, & + & 9.5034E-04_JPRB,5.4992E-04_JPRB,1.9349E-04_JPRB,2.7309E-05_JPRB/) + FRACREFAO(:, 3) = (/ & + & 2.9054E-01_JPRB,2.1263E-01_JPRB,1.4133E-01_JPRB,1.1083E-01_JPRB,8.5107E-02_JPRB,6.5247E-02_JPRB, & + & 4.4542E-02_JPRB,2.7205E-02_JPRB,1.6495E-02_JPRB,1.8453E-03_JPRB,1.5222E-03_JPRB,1.1884E-03_JPRB, & + & 8.1094E-04_JPRB,4.9173E-04_JPRB,1.9344E-04_JPRB,2.7286E-05_JPRB/) + FRACREFAO(:, 4) = (/ & + & 2.9641E-01_JPRB,2.1738E-01_JPRB,1.4228E-01_JPRB,1.0830E-01_JPRB,8.2837E-02_JPRB,6.1359E-02_JPRB, & + & 4.4683E-02_JPRB,2.5027E-02_JPRB,1.6057E-02_JPRB,1.7558E-03_JPRB,1.4193E-03_JPRB,1.0970E-03_JPRB, & + & 7.8281E-04_JPRB,4.3260E-04_JPRB,1.4837E-04_JPRB,2.2958E-05_JPRB/) + FRACREFAO(:, 5) = (/ & + & 2.9553E-01_JPRB,2.2139E-01_JPRB,1.4816E-01_JPRB,1.0601E-01_JPRB,8.0048E-02_JPRB,6.0082E-02_JPRB, & + & 4.3952E-02_JPRB,2.3788E-02_JPRB,1.5734E-02_JPRB,1.6586E-03_JPRB,1.3434E-03_JPRB,1.0281E-03_JPRB, & + & 7.0256E-04_JPRB,4.2577E-04_JPRB,1.2803E-04_JPRB,1.3315E-05_JPRB/) + FRACREFAO(:, 6) = (/ & + & 2.9313E-01_JPRB,2.2476E-01_JPRB,1.5470E-01_JPRB,1.0322E-01_JPRB,7.8904E-02_JPRB,5.8175E-02_JPRB, & + & 4.3097E-02_JPRB,2.3618E-02_JPRB,1.5385E-02_JPRB,1.5942E-03_JPRB,1.2702E-03_JPRB,9.5566E-04_JPRB, & + & 6.5421E-04_JPRB,4.0165E-04_JPRB,1.2805E-04_JPRB,1.3355E-05_JPRB/) + FRACREFAO(:, 7) = (/ & + & 2.9069E-01_JPRB,2.2823E-01_JPRB,1.5995E-01_JPRB,1.0170E-01_JPRB,7.7287E-02_JPRB,5.6780E-02_JPRB, & + & 4.1752E-02_JPRB,2.3899E-02_JPRB,1.4937E-02_JPRB,1.4916E-03_JPRB,1.1909E-03_JPRB,9.1307E-04_JPRB, & + & 6.3518E-04_JPRB,3.9866E-04_JPRB,1.2805E-04_JPRB,1.3298E-05_JPRB/) + FRACREFAO(:, 8) = (/ & + & 2.8446E-01_JPRB,2.2651E-01_JPRB,1.7133E-01_JPRB,1.0299E-01_JPRB,7.4231E-02_JPRB,5.6031E-02_JPRB, & + & 4.1368E-02_JPRB,2.4318E-02_JPRB,1.4135E-02_JPRB,1.4216E-03_JPRB,1.1465E-03_JPRB,8.9800E-04_JPRB, & + & 6.3553E-04_JPRB,3.9536E-04_JPRB,1.2749E-04_JPRB,1.3298E-05_JPRB/) + FRACREFAO(:, 9) = (/ & + & 2.0568E-01_JPRB,2.5049E-01_JPRB,2.0568E-01_JPRB,1.1781E-01_JPRB,7.5579E-02_JPRB,5.8136E-02_JPRB, & + & 4.2397E-02_JPRB,2.6544E-02_JPRB,1.3067E-02_JPRB,1.4061E-03_JPRB,1.1455E-03_JPRB,8.9408E-04_JPRB, & + & 6.3652E-04_JPRB,3.9450E-04_JPRB,1.2841E-04_JPRB,1.3315E-05_JPRB/) + +! Planck fraction mapping level : P=95.58350 mb, T = 215.70 K + FRACREFBO(:) = (/ & + & 1.8111E-01_JPRB,2.2612E-01_JPRB,1.6226E-01_JPRB,1.1872E-01_JPRB,9.9048E-02_JPRB,8.0390E-02_JPRB, & + & 6.1648E-02_JPRB,4.1704E-02_JPRB,2.2976E-02_JPRB,1.9263E-03_JPRB,1.4694E-03_JPRB,1.1498E-03_JPRB, & + & 7.9906E-04_JPRB,4.8310E-04_JPRB,1.6188E-04_JPRB,2.2651E-05_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &5.1629E-06_JPRB,7.7578E-06_JPRB,1.9043E-05_JPRB,1.4802E-04_JPRB,2.2980E-04_JPRB,2.8057E-04_JPRB, & + &3.2824E-04_JPRB,3.4913E-04_JPRB,3.6515E-04_JPRB,3.8271E-04_JPRB,3.7499E-04_JPRB,3.6966E-04_JPRB, & + &3.7424E-04_JPRB,3.8884E-04_JPRB,3.7117E-04_JPRB,4.3710E-04_JPRB/) + FORREFO(2,:) = (/ & + &5.0804E-06_JPRB,1.3466E-05_JPRB,7.2606E-05_JPRB,1.6940E-04_JPRB,2.1022E-04_JPRB,2.5900E-04_JPRB, & + &2.9106E-04_JPRB,3.2261E-04_JPRB,3.2066E-04_JPRB,3.5421E-04_JPRB,3.7128E-04_JPRB,3.8144E-04_JPRB, & + &3.7854E-04_JPRB,3.8347E-04_JPRB,3.8921E-04_JPRB,3.7339E-04_JPRB/) + FORREFO(3,:) = (/ & + &5.4797E-05_JPRB,1.0026E-04_JPRB,1.2422E-04_JPRB,1.6386E-04_JPRB,1.8378E-04_JPRB,1.9616E-04_JPRB, & + &2.0711E-04_JPRB,2.2492E-04_JPRB,2.5240E-04_JPRB,2.6187E-04_JPRB,2.6058E-04_JPRB,2.4892E-04_JPRB, & + &2.6526E-04_JPRB,3.2105E-04_JPRB,3.6903E-04_JPRB,3.7213E-04_JPRB/) + FORREFO(4,:) = (/ & + &4.2782E-05_JPRB,1.4775E-04_JPRB,1.4588E-04_JPRB,1.6964E-04_JPRB,1.6667E-04_JPRB,1.7192E-04_JPRB, & + &1.9057E-04_JPRB,2.0180E-04_JPRB,2.1177E-04_JPRB,2.2326E-04_JPRB,2.3801E-04_JPRB,2.9308E-04_JPRB, & + &3.1130E-04_JPRB,3.1829E-04_JPRB,3.5035E-04_JPRB,3.7782E-04_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 1.27793E-03_JPRB, 1.05944E-03_JPRB, 8.78300E-04_JPRB, 7.28133E-04_JPRB, 6.03641E-04_JPRB, & + & 5.00434E-04_JPRB, 4.14873E-04_JPRB, 3.43940E-04_JPRB, 2.85135E-04_JPRB, 2.36384E-04_JPRB/) + SELFREFO(:, 2) = (/ & + & 1.42785E-03_JPRB, 1.17602E-03_JPRB, 9.68600E-04_JPRB, 7.97765E-04_JPRB, 6.57060E-04_JPRB, & + & 5.41172E-04_JPRB, 4.45724E-04_JPRB, 3.67110E-04_JPRB, 3.02361E-04_JPRB, 2.49033E-04_JPRB/) + SELFREFO(:, 3) = (/ & + & 2.94095E-03_JPRB, 2.27102E-03_JPRB, 1.75370E-03_JPRB, 1.35422E-03_JPRB, 1.04574E-03_JPRB, & + & 8.07525E-04_JPRB, 6.23577E-04_JPRB, 4.81530E-04_JPRB, 3.71841E-04_JPRB, 2.87138E-04_JPRB/) + SELFREFO(:, 4) = (/ & + & 3.94894E-03_JPRB, 3.48184E-03_JPRB, 3.07000E-03_JPRB, 2.70687E-03_JPRB, 2.38669E-03_JPRB, & + & 2.10439E-03_JPRB, 1.85547E-03_JPRB, 1.63600E-03_JPRB, 1.44249E-03_JPRB, 1.27187E-03_JPRB/) + SELFREFO(:, 5) = (/ & + & 4.19971E-03_JPRB, 3.86333E-03_JPRB, 3.55390E-03_JPRB, 3.26925E-03_JPRB, 3.00740E-03_JPRB, & + & 2.76652E-03_JPRB, 2.54494E-03_JPRB, 2.34110E-03_JPRB, 2.15359E-03_JPRB, 1.98110E-03_JPRB/) + SELFREFO(:, 6) = (/ & + & 4.95922E-03_JPRB, 4.57134E-03_JPRB, 4.21380E-03_JPRB, 3.88422E-03_JPRB, 3.58042E-03_JPRB, & + & 3.30038E-03_JPRB, 3.04225E-03_JPRB, 2.80430E-03_JPRB, 2.58496E-03_JPRB, 2.38278E-03_JPRB/) + SELFREFO(:, 7) = (/ & + & 5.27379E-03_JPRB, 4.91005E-03_JPRB, 4.57140E-03_JPRB, 4.25611E-03_JPRB, 3.96256E-03_JPRB, & + & 3.68925E-03_JPRB, 3.43480E-03_JPRB, 3.19790E-03_JPRB, 2.97734E-03_JPRB, 2.77199E-03_JPRB/) + SELFREFO(:, 8) = (/ & + & 5.75341E-03_JPRB, 5.31533E-03_JPRB, 4.91060E-03_JPRB, 4.53669E-03_JPRB, 4.19126E-03_JPRB, & + & 3.87212E-03_JPRB, 3.57729E-03_JPRB, 3.30490E-03_JPRB, 3.05325E-03_JPRB, 2.82077E-03_JPRB/) + SELFREFO(:, 9) = (/ & + & 5.49849E-03_JPRB, 5.14295E-03_JPRB, 4.81040E-03_JPRB, 4.49935E-03_JPRB, 4.20842E-03_JPRB, & + & 3.93629E-03_JPRB, 3.68177E-03_JPRB, 3.44370E-03_JPRB, 3.22102E-03_JPRB, 3.01275E-03_JPRB/) + SELFREFO(:,10) = (/ & + & 6.04962E-03_JPRB, 5.60945E-03_JPRB, 5.20130E-03_JPRB, 4.82285E-03_JPRB, 4.47194E-03_JPRB, & + & 4.14656E-03_JPRB, 3.84485E-03_JPRB, 3.56510E-03_JPRB, 3.30570E-03_JPRB, 3.06518E-03_JPRB/) + SELFREFO(:,11) = (/ & + & 6.40108E-03_JPRB, 5.87551E-03_JPRB, 5.39310E-03_JPRB, 4.95029E-03_JPRB, 4.54385E-03_JPRB, & + & 4.17077E-03_JPRB, 3.82833E-03_JPRB, 3.51400E-03_JPRB, 3.22548E-03_JPRB, 2.96065E-03_JPRB/) + SELFREFO(:,12) = (/ & + & 6.77938E-03_JPRB, 6.15713E-03_JPRB, 5.59200E-03_JPRB, 5.07874E-03_JPRB, 4.61259E-03_JPRB, & + & 4.18922E-03_JPRB, 3.80472E-03_JPRB, 3.45550E-03_JPRB, 3.13834E-03_JPRB, 2.85029E-03_JPRB/) + SELFREFO(:,13) = (/ & + & 6.90020E-03_JPRB, 6.26766E-03_JPRB, 5.69310E-03_JPRB, 5.17121E-03_JPRB, 4.69717E-03_JPRB, & + & 4.26658E-03_JPRB, 3.87546E-03_JPRB, 3.52020E-03_JPRB, 3.19750E-03_JPRB, 2.90439E-03_JPRB/) + SELFREFO(:,14) = (/ & + & 6.92759E-03_JPRB, 6.32882E-03_JPRB, 5.78180E-03_JPRB, 5.28206E-03_JPRB, 4.82552E-03_JPRB, & + & 4.40843E-03_JPRB, 4.02740E-03_JPRB, 3.67930E-03_JPRB, 3.36129E-03_JPRB, 3.07076E-03_JPRB/) + SELFREFO(:,15) = (/ & + & 7.54539E-03_JPRB, 6.81161E-03_JPRB, 6.14920E-03_JPRB, 5.55120E-03_JPRB, 5.01136E-03_JPRB, & + & 4.52402E-03_JPRB, 4.08407E-03_JPRB, 3.68690E-03_JPRB, 3.32836E-03_JPRB, 3.00468E-03_JPRB/) + SELFREFO(:,16) = (/ & + & 7.62039E-03_JPRB, 7.10834E-03_JPRB, 6.63070E-03_JPRB, 6.18515E-03_JPRB, 5.76955E-03_JPRB, & + & 5.38186E-03_JPRB, 5.02023E-03_JPRB, 4.68290E-03_JPRB, 4.36823E-03_JPRB, 4.07471E-03_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB16',1,ZHOOK_HANDLE) +RETURN + +1000 CONTINUE +CALL ABOR1("RRTM_KGB16:ERROR CLOSING FILE RADRRTM") +1001 CONTINUE +CALL ABOR1("RRTM_KGB16:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB16 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb2.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb2.F90 (revision 6016) @@ -0,0 +1,181 @@ +SUBROUTINE RRTM_KGB2 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 2: 250-500 cm-1 (low - H2O; high - H2O) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo May 2013 update to RRTMG v4.85 +! band 2: 350-500 cm-1 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO2 , ONLY : KAO ,KBO ,SELFREFO ,FRACREFAO ,& + & FRACREFBO ,FORREFO ,KAO_D, KBO_D +USE YOMMP0 , ONLY : NPROC, MYPROC + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB2',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB2:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB2:') +ENDIF + + +! Planck fraction mapping level: P = 1053.630 mbar, T = 294.2 K + FRACREFAO(:) = (/ & + & 1.6388E-01_JPRB, 1.5241E-01_JPRB, 1.4290E-01_JPRB, 1.2864E-01_JPRB, & + & 1.1615E-01_JPRB, 1.0047E-01_JPRB, 8.0013E-02_JPRB, 6.0445E-02_JPRB, & + & 4.0530E-02_JPRB, 4.3879E-03_JPRB, 3.5726E-03_JPRB, 2.7669E-03_JPRB, & + & 2.0078E-03_JPRB, 1.2864E-03_JPRB, 4.7630E-04_JPRB, 6.9109E-05_JPRB/) + +! Planck fraction mapping level: P = 3.206e-2 mb, T = 197.92 K + FRACREFBO(:) = (/ & + & 1.4697E-01_JPRB, 1.4826E-01_JPRB, 1.4278E-01_JPRB, 1.3320E-01_JPRB, & + & 1.1965E-01_JPRB, 1.0297E-01_JPRB, 8.4170E-02_JPRB, 6.3282E-02_JPRB, & + & 4.2868E-02_JPRB, 4.6644E-03_JPRB, 3.8619E-03_JPRB, 3.0533E-03_JPRB, & + & 2.2359E-03_JPRB, 1.4226E-03_JPRB, 5.3642E-04_JPRB, 7.6316E-05_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + & 2.8549E-03_JPRB,4.8281E-03_JPRB,6.2570E-03_JPRB,8.2731E-03_JPRB,7.9056E-03_JPRB,7.7840E-03_JPRB, & + & 1.0115E-02_JPRB,9.6599E-03_JPRB,1.0153E-02_JPRB,1.0921E-02_JPRB,1.2408E-02_JPRB,1.3496E-02_JPRB, & + & 1.5059E-02_JPRB,1.4636E-02_JPRB,1.6483E-02_JPRB,1.2394E-02_JPRB/) + FORREFO(2,:) = (/ & + & 3.0036E-03_JPRB,5.1093E-03_JPRB,5.7317E-03_JPRB,9.2246E-03_JPRB,8.9829E-03_JPRB,8.6477E-03_JPRB, & + & 1.1448E-02_JPRB,1.0391E-02_JPRB,1.0211E-02_JPRB,1.2921E-02_JPRB,1.2726E-02_JPRB,1.2426E-02_JPRB, & + & 1.4609E-02_JPRB,1.5783E-02_JPRB,1.6617E-02_JPRB,1.6858E-02_JPRB/) + FORREFO(3,:) = (/ & + & 3.0771E-03_JPRB,5.1206E-03_JPRB,5.8426E-03_JPRB,9.5727E-03_JPRB,1.0338E-02_JPRB,9.3737E-03_JPRB, & + & 1.2805E-02_JPRB,1.1272E-02_JPRB,1.1353E-02_JPRB,1.1837E-02_JPRB,1.1550E-02_JPRB,1.3020E-02_JPRB, & + & 1.3536E-02_JPRB,1.6226E-02_JPRB,1.6039E-02_JPRB,2.2578E-02_JPRB/) + FORREFO(4,:) = (/ & + & 3.3072E-03_JPRB,5.0240E-03_JPRB,6.8474E-03_JPRB,8.2736E-03_JPRB,8.6151E-03_JPRB,8.6762E-03_JPRB, & + & 1.1476E-02_JPRB,1.0246E-02_JPRB,1.0819E-02_JPRB,1.0640E-02_JPRB,1.0545E-02_JPRB,1.0533E-02_JPRB, & + & 1.0496E-02_JPRB,1.0142E-02_JPRB,9.7979E-03_JPRB,1.5255E-02_JPRB/) + + +! The following are parameters related to the reference water vapor +! mixing ratios by REFPARAM(I) = REFH2O(I) / (.002+REFH2O(I)). +! These parameters are used for the Planck function interpolation. +!REFPARAM( :) = (/& +! & 0.903661_JPRB , 0.859386_JPRB , 0.746542_JPRB , 0.580496_JPRB , 0.412889_JPRB ,& +! & 0.275283_JPRB , 0.162745_JPRB , 7.63929E-02_JPRB, 1.82553E-02_JPRB, 3.72432E-03_JPRB, & +! & 2.14946E-03_JPRB, 1.66320E-03_JPRB, 1.59940E-03_JPRB/) + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 7.25695E-01_JPRB, 6.53591E-01_JPRB, 5.88650E-01_JPRB, 5.30162E-01_JPRB, 4.77485E-01_JPRB, & + & 4.30042E-01_JPRB, 3.87313E-01_JPRB, 3.48830E-01_JPRB, 3.14170E-01_JPRB, 2.82954E-01_JPRB/) + SELFREFO(:, 2) = (/ & + & 9.61996E-01_JPRB, 8.77853E-01_JPRB, 8.01070E-01_JPRB, 7.31003E-01_JPRB, 6.67064E-01_JPRB, & + & 6.08718E-01_JPRB, 5.55476E-01_JPRB, 5.06890E-01_JPRB, 4.62554E-01_JPRB, 4.22096E-01_JPRB/) + SELFREFO(:, 3) = (/ & + & 9.72584E-01_JPRB, 9.02658E-01_JPRB, 8.37760E-01_JPRB, 7.77527E-01_JPRB, 7.21626E-01_JPRB, & + & 6.69743E-01_JPRB, 6.21591E-01_JPRB, 5.76900E-01_JPRB, 5.35423E-01_JPRB, 4.96927E-01_JPRB/) + SELFREFO(:, 4) = (/ & + & 1.24790E+00_JPRB, 1.14353E+00_JPRB, 1.04790E+00_JPRB, 9.60263E-01_JPRB, 8.79956E-01_JPRB, & + & 8.06364E-01_JPRB, 7.38927E-01_JPRB, 6.77130E-01_JPRB, 6.20501E-01_JPRB, 5.68608E-01_JPRB/) + SELFREFO(:, 5) = (/ & + & 1.23574E+00_JPRB, 1.12928E+00_JPRB, 1.03200E+00_JPRB, 9.43096E-01_JPRB, 8.61851E-01_JPRB, & + & 7.87605E-01_JPRB, 7.19755E-01_JPRB, 6.57750E-01_JPRB, 6.01087E-01_JPRB, 5.49305E-01_JPRB/) + SELFREFO(:, 6) = (/ & + & 1.20921E+00_JPRB, 1.10660E+00_JPRB, 1.01270E+00_JPRB, 9.26766E-01_JPRB, 8.48124E-01_JPRB, & + & 7.76155E-01_JPRB, 7.10293E-01_JPRB, 6.50020E-01_JPRB, 5.94861E-01_JPRB, 5.44384E-01_JPRB/) + SELFREFO(:, 7) = (/ & + & 1.38112E+00_JPRB, 1.26727E+00_JPRB, 1.16280E+00_JPRB, 1.06694E+00_JPRB, 9.78990E-01_JPRB, & + & 8.98287E-01_JPRB, 8.24236E-01_JPRB, 7.56290E-01_JPRB, 6.93945E-01_JPRB, 6.36739E-01_JPRB/) + SELFREFO(:, 8) = (/ & + & 1.30321E+00_JPRB, 1.20127E+00_JPRB, 1.10730E+00_JPRB, 1.02068E+00_JPRB, 9.40840E-01_JPRB, & + & 8.67243E-01_JPRB, 7.99403E-01_JPRB, 7.36870E-01_JPRB, 6.79229E-01_JPRB, 6.26096E-01_JPRB/) + SELFREFO(:, 9) = (/ & + & 1.26713E+00_JPRB, 1.17927E+00_JPRB, 1.09750E+00_JPRB, 1.02140E+00_JPRB, 9.50575E-01_JPRB, & + & 8.84662E-01_JPRB, 8.23319E-01_JPRB, 7.66230E-01_JPRB, 7.13099E-01_JPRB, 6.63653E-01_JPRB/) + SELFREFO(:,10) = (/ & + & 1.49824E+00_JPRB, 1.37053E+00_JPRB, 1.25370E+00_JPRB, 1.14683E+00_JPRB, 1.04908E+00_JPRB, & + & 9.59651E-01_JPRB, 8.77849E-01_JPRB, 8.03020E-01_JPRB, 7.34569E-01_JPRB, 6.71954E-01_JPRB/) + SELFREFO(:,11) = (/ & + & 1.44786E+00_JPRB, 1.34594E+00_JPRB, 1.25120E+00_JPRB, 1.16313E+00_JPRB, 1.08125E+00_JPRB, & + & 1.00514E+00_JPRB, 9.34392E-01_JPRB, 8.68620E-01_JPRB, 8.07477E-01_JPRB, 7.50639E-01_JPRB/) + SELFREFO(:,12) = (/ & + & 1.38460E+00_JPRB, 1.30437E+00_JPRB, 1.22880E+00_JPRB, 1.15760E+00_JPRB, 1.09053E+00_JPRB, & + & 1.02735E+00_JPRB, 9.67825E-01_JPRB, 9.11750E-01_JPRB, 8.58924E-01_JPRB, 8.09159E-01_JPRB/) + SELFREFO(:,13) = (/ & + & 1.51953E+00_JPRB, 1.42822E+00_JPRB, 1.34240E+00_JPRB, 1.26173E+00_JPRB, 1.18592E+00_JPRB, & + & 1.11465E+00_JPRB, 1.04768E+00_JPRB, 9.84720E-01_JPRB, 9.25548E-01_JPRB, 8.69932E-01_JPRB/) + SELFREFO(:,14) = (/ & + & 1.62608E+00_JPRB, 1.51021E+00_JPRB, 1.40260E+00_JPRB, 1.30266E+00_JPRB, 1.20983E+00_JPRB, & + & 1.12363E+00_JPRB, 1.04356E+00_JPRB, 9.69200E-01_JPRB, 9.00138E-01_JPRB, 8.35998E-01_JPRB/) + SELFREFO(:,15) = (/ & + & 1.65383E+00_JPRB, 1.54808E+00_JPRB, 1.44910E+00_JPRB, 1.35644E+00_JPRB, 1.26971E+00_JPRB, & + & 1.18853E+00_JPRB, 1.11254E+00_JPRB, 1.04140E+00_JPRB, 9.74813E-01_JPRB, 9.12484E-01_JPRB/) + SELFREFO(:,16) = (/ & + & 1.78105E+00_JPRB, 1.61421E+00_JPRB, 1.46300E+00_JPRB, 1.32595E+00_JPRB, 1.20174E+00_JPRB, & + & 1.08917E+00_JPRB, 9.87141E-01_JPRB, 8.94670E-01_JPRB, 8.10861E-01_JPRB, 7.34904E-01_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB2',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB2:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB2 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb3.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb3.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb3.F90 (revision 6016) @@ -0,0 +1,1375 @@ +SUBROUTINE RRTM_KGB3 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 3: 500-630 cm-1 (low - H2O,CO2; high - H2O,CO2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201305 updated to rrtmg_lw_v4.85: +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) +! (high key - h2o,co2; high minor - n2o) +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD +USE YOMMP0 , ONLY : NPROC, MYPROC + +USE YOERRTO3 , ONLY : KAO ,KBO ,SELFREFO ,FRACREFAO ,& + & FRACREFBO ,FORREFO ,KAO_MN2O,KBO_MN2O, KAO_D, KBO_D +!USE YOERRTA3 , ONLY : ETAREF ,H2OREF ,& +! & N2OREF ,CO2REF ,STRRAT + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB3',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD) KAO_D, KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB3:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB3:') +ENDIF + + +! Planck fraction mapping level: P=212.7250 mbar, T = 223.06 K + FRACREFAO(:, 1) = (/ & + & 1.6251E-01_JPRB,1.5572E-01_JPRB,1.4557E-01_JPRB,1.3208E-01_JPRB,1.1582E-01_JPRB,9.6895E-02_JPRB, & + & 7.8720E-02_JPRB,5.8462E-02_JPRB,3.9631E-02_JPRB,4.3001E-03_JPRB,3.5555E-03_JPRB,2.8101E-03_JPRB, & + & 2.0547E-03_JPRB,1.3109E-03_JPRB,4.9403E-04_JPRB,6.9515E-05_JPRB/) + FRACREFAO(:, 2) = (/ & + & 1.6006E-01_JPRB,1.5576E-01_JPRB,1.4609E-01_JPRB,1.3276E-01_JPRB,1.1594E-01_JPRB,9.7336E-02_JPRB, & + & 7.9035E-02_JPRB,5.8696E-02_JPRB,3.9723E-02_JPRB,4.3001E-03_JPRB,3.5555E-03_JPRB,2.8101E-03_JPRB, & + & 2.0547E-03_JPRB,1.3109E-03_JPRB,4.9403E-04_JPRB,6.9515E-05_JPRB/) + FRACREFAO(:, 3) = (/ & + & 1.5952E-01_JPRB,1.5566E-01_JPRB,1.4590E-01_JPRB,1.3294E-01_JPRB,1.1599E-01_JPRB,9.7511E-02_JPRB, & + & 7.9127E-02_JPRB,5.8888E-02_JPRB,3.9874E-02_JPRB,4.3001E-03_JPRB,3.5555E-03_JPRB,2.8102E-03_JPRB, & + & 2.0547E-03_JPRB,1.3109E-03_JPRB,4.9403E-04_JPRB,6.9515E-05_JPRB/) + FRACREFAO(:, 4) = (/ & + & 1.5907E-01_JPRB,1.5541E-01_JPRB,1.4585E-01_JPRB,1.3316E-01_JPRB,1.1596E-01_JPRB,9.7647E-02_JPRB, & + & 7.9243E-02_JPRB,5.9024E-02_JPRB,4.0028E-02_JPRB,4.3112E-03_JPRB,3.5555E-03_JPRB,2.8102E-03_JPRB, & + & 2.0547E-03_JPRB,1.3109E-03_JPRB,4.9403E-04_JPRB,6.9515E-05_JPRB/) + FRACREFAO(:, 5) = (/ & + & 1.5862E-01_JPRB,1.5517E-01_JPRB,1.4588E-01_JPRB,1.3328E-01_JPRB,1.1585E-01_JPRB,9.7840E-02_JPRB, & + & 7.9364E-02_JPRB,5.9174E-02_JPRB,4.0160E-02_JPRB,4.3403E-03_JPRB,3.5900E-03_JPRB,2.8102E-03_JPRB, & + & 2.0547E-03_JPRB,1.3109E-03_JPRB,4.9403E-04_JPRB,6.9515E-05_JPRB/) + FRACREFAO(:, 6) = (/ & + & 1.5830E-01_JPRB,1.5490E-01_JPRB,1.4582E-01_JPRB,1.3331E-01_JPRB,1.1567E-01_JPRB,9.8079E-02_JPRB, & + & 7.9510E-02_JPRB,5.9369E-02_JPRB,4.0326E-02_JPRB,4.3343E-03_JPRB,3.5908E-03_JPRB,2.8527E-03_JPRB, & + & 2.0655E-03_JPRB,1.3109E-03_JPRB,4.9403E-04_JPRB,6.9515E-05_JPRB/) + FRACREFAO(:, 7) = (/ & + & 1.5789E-01_JPRB,1.5435E-01_JPRB,1.4595E-01_JPRB,1.3304E-01_JPRB,1.1566E-01_JPRB,9.8426E-02_JPRB, & + & 7.9704E-02_JPRB,5.9618E-02_JPRB,4.0520E-02_JPRB,4.3812E-03_JPRB,3.6147E-03_JPRB,2.8395E-03_JPRB, & + & 2.1301E-03_JPRB,1.3145E-03_JPRB,4.9403E-04_JPRB,6.9515E-05_JPRB/) + FRACREFAO(:, 8) = (/ & + & 1.5704E-01_JPRB,1.5398E-01_JPRB,1.4564E-01_JPRB,1.3222E-01_JPRB,1.1586E-01_JPRB,9.9230E-02_JPRB, & + & 8.0011E-02_JPRB,6.0149E-02_JPRB,4.0790E-02_JPRB,4.4253E-03_JPRB,3.6534E-03_JPRB,2.9191E-03_JPRB, & + & 2.1373E-03_JPRB,1.3558E-03_JPRB,5.1631E-04_JPRB,7.8794E-05_JPRB/) + FRACREFAO(:, 9) = (/ & + & 1.5270E-01_JPRB,1.5126E-01_JPRB,1.4264E-01_JPRB,1.3106E-01_JPRB,1.1740E-01_JPRB,1.0137E-01_JPRB, & + & 8.3057E-02_JPRB,6.2282E-02_JPRB,4.2301E-02_JPRB,4.6486E-03_JPRB,3.8159E-03_JPRB,3.0472E-03_JPRB, & + & 2.2870E-03_JPRB,1.4818E-03_JPRB,5.6773E-04_JPRB,7.8794E-05_JPRB/) + +! Planck fraction mapping level: p = 95.8 mbar, t = 215.7 k + FRACREFBO(:, 1) = (/ & + & 1.6413E-01_JPRB,1.5665E-01_JPRB,1.4606E-01_JPRB,1.3184E-01_JPRB,1.1517E-01_JPRB,9.6243E-02_JPRB, & + & 7.7982E-02_JPRB,5.8165E-02_JPRB,3.9311E-02_JPRB,4.2586E-03_JPRB,3.5189E-03_JPRB,2.7793E-03_JPRB, & + & 2.0376E-03_JPRB,1.2938E-03_JPRB,4.8853E-04_JPRB,6.8745E-05_JPRB/) + FRACREFBO(:, 2) = (/ & + & 1.6254E-01_JPRB,1.5674E-01_JPRB,1.4652E-01_JPRB,1.3221E-01_JPRB,1.1535E-01_JPRB,9.6439E-02_JPRB, & + & 7.8155E-02_JPRB,5.8254E-02_JPRB,3.9343E-02_JPRB,4.2586E-03_JPRB,3.5189E-03_JPRB,2.7793E-03_JPRB, & + & 2.0376E-03_JPRB,1.2938E-03_JPRB,4.8853E-04_JPRB,6.8745E-05_JPRB/) + FRACREFBO(:, 3) = (/ & + & 1.6177E-01_JPRB,1.5664E-01_JPRB,1.4669E-01_JPRB,1.3242E-01_JPRB,1.1541E-01_JPRB,9.6536E-02_JPRB, & + & 7.8257E-02_JPRB,5.8387E-02_JPRB,3.9431E-02_JPRB,4.2587E-03_JPRB,3.5189E-03_JPRB,2.7793E-03_JPRB, & + & 2.0376E-03_JPRB,1.2938E-03_JPRB,4.8853E-04_JPRB,6.8745E-05_JPRB/) + FRACREFBO(:, 4) = (/ & + & 1.6077E-01_JPRB,1.5679E-01_JPRB,1.4648E-01_JPRB,1.3273E-01_JPRB,1.1546E-01_JPRB,9.6779E-02_JPRB, & + & 7.8371E-02_JPRB,5.8546E-02_JPRB,3.9611E-02_JPRB,4.2772E-03_JPRB,3.5190E-03_JPRB,2.7793E-03_JPRB, & + & 2.0376E-03_JPRB,1.2938E-03_JPRB,4.8853E-04_JPRB,6.8745E-05_JPRB/) + FRACREFBO(:, 5) = (/ & + & 1.6067E-01_JPRB,1.5608E-01_JPRB,1.4247E-01_JPRB,1.2881E-01_JPRB,1.1449E-01_JPRB,9.8802E-02_JPRB, & + & 8.0828E-02_JPRB,6.0977E-02_JPRB,4.1494E-02_JPRB,4.5116E-03_JPRB,3.7290E-03_JPRB,2.9460E-03_JPRB, & + & 2.1948E-03_JPRB,1.3778E-03_JPRB,5.4552E-04_JPRB,7.9969E-05_JPRB/) + + + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different water vapor to CO2 ratios, +! as expressed through the binary species parameter eta, defined as +! eta = h2o/(h20 + (rat) * co2), where rat is the ratio of the integrated +! line strength in the band of co2 to that of h2o. For instance, +! JS=1 refers to dry air (eta = 0), JS = 10 corresponds to eta = 1.0. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + + +! The array KBO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of H2O to CO2. The first index in the array, JS, runs from 1 to 5, +! and corresponds to different H2O to CO2 ratios, as expressed through +! the binary species parameter eta, defined as eta = H2O/(H2O+RAT*CO2), +! where RAT is the ratio of the integrated line strength in the band +! of CO2 to that of H2O. For instance, JS=1 refers to no H2O, +! JS = 2 corresponds to eta = 0.25, etc. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + + KAO_MN2O( 1, :, 1) = (/ & + & 1.28178E-05_JPRB, 1.55472E-05_JPRB, 1.88578E-05_JPRB, 2.28735E-05_JPRB, 2.77442E-05_JPRB, & + & 3.36520E-05_JPRB, 4.08179E-05_JPRB, 4.95098E-05_JPRB, 6.00525E-05_JPRB, 7.28401E-05_JPRB, & + & 8.83508E-05_JPRB, 1.07164E-04_JPRB, 1.29984E-04_JPRB, 1.57663E-04_JPRB, 1.91236E-04_JPRB, & + & 2.31958E-04_JPRB, 2.81352E-04_JPRB, 3.41263E-04_JPRB, 4.13932E-04_JPRB/) + KAO_MN2O( 2, :, 1) = (/ & + & 1.00725E-01_JPRB, 1.04470E-01_JPRB, 1.08355E-01_JPRB, 1.12384E-01_JPRB, 1.16563E-01_JPRB, & + & 1.20898E-01_JPRB, 1.25394E-01_JPRB, 1.30057E-01_JPRB, 1.34893E-01_JPRB, 1.39909E-01_JPRB, & + & 1.45112E-01_JPRB, 1.50508E-01_JPRB, 1.56104E-01_JPRB, 1.61909E-01_JPRB, 1.67930E-01_JPRB, & + & 1.74175E-01_JPRB, 1.80652E-01_JPRB, 1.87369E-01_JPRB, 1.94337E-01_JPRB/) + KAO_MN2O( 3, :, 1) = (/ & + & 1.94143E-01_JPRB, 1.97380E-01_JPRB, 2.00670E-01_JPRB, 2.04016E-01_JPRB, 2.07417E-01_JPRB, & + & 2.10875E-01_JPRB, 2.14390E-01_JPRB, 2.17964E-01_JPRB, 2.21598E-01_JPRB, 2.25292E-01_JPRB, & + & 2.29048E-01_JPRB, 2.32867E-01_JPRB, 2.36749E-01_JPRB, 2.40696E-01_JPRB, 2.44708E-01_JPRB, & + & 2.48788E-01_JPRB, 2.52936E-01_JPRB, 2.57152E-01_JPRB, 2.61439E-01_JPRB/) + KAO_MN2O( 4, :, 1) = (/ & + & 2.98127E-01_JPRB, 3.00016E-01_JPRB, 3.01916E-01_JPRB, 3.03829E-01_JPRB, 3.05754E-01_JPRB, & + & 3.07691E-01_JPRB, 3.09640E-01_JPRB, 3.11601E-01_JPRB, 3.13575E-01_JPRB, 3.15562E-01_JPRB, & + & 3.17561E-01_JPRB, 3.19572E-01_JPRB, 3.21597E-01_JPRB, 3.23634E-01_JPRB, 3.25684E-01_JPRB, & + & 3.27748E-01_JPRB, 3.29824E-01_JPRB, 3.31913E-01_JPRB, 3.34016E-01_JPRB/) + KAO_MN2O( 5, :, 1) = (/ & + & 4.45029E-01_JPRB, 4.45243E-01_JPRB, 4.45458E-01_JPRB, 4.45673E-01_JPRB, 4.45889E-01_JPRB, & + & 4.46104E-01_JPRB, 4.46319E-01_JPRB, 4.46535E-01_JPRB, 4.46750E-01_JPRB, 4.46966E-01_JPRB, & + & 4.47182E-01_JPRB, 4.47398E-01_JPRB, 4.47614E-01_JPRB, 4.47830E-01_JPRB, 4.48046E-01_JPRB, & + & 4.48262E-01_JPRB, 4.48479E-01_JPRB, 4.48695E-01_JPRB, 4.48912E-01_JPRB/) + KAO_MN2O( 6, :, 1) = (/ & + & 7.15677E-01_JPRB, 7.14564E-01_JPRB, 7.13452E-01_JPRB, 7.12342E-01_JPRB, 7.11234E-01_JPRB, & + & 7.10127E-01_JPRB, 7.09022E-01_JPRB, 7.07919E-01_JPRB, 7.06818E-01_JPRB, 7.05718E-01_JPRB, & + & 7.04620E-01_JPRB, 7.03524E-01_JPRB, 7.02429E-01_JPRB, 7.01336E-01_JPRB, 7.00245E-01_JPRB, & + & 6.99156E-01_JPRB, 6.98068E-01_JPRB, 6.96982E-01_JPRB, 6.95898E-01_JPRB/) + KAO_MN2O( 7, :, 1) = (/ & + & 9.89605E-01_JPRB, 9.85128E-01_JPRB, 9.80671E-01_JPRB, 9.76234E-01_JPRB, 9.71817E-01_JPRB, & + & 9.67421E-01_JPRB, 9.63044E-01_JPRB, 9.58687E-01_JPRB, 9.54350E-01_JPRB, 9.50032E-01_JPRB, & + & 9.45734E-01_JPRB, 9.41455E-01_JPRB, 9.37196E-01_JPRB, 9.32956E-01_JPRB, 9.28735E-01_JPRB, & + & 9.24533E-01_JPRB, 9.20350E-01_JPRB, 9.16187E-01_JPRB, 9.12042E-01_JPRB/) + KAO_MN2O( 8, :, 1) = (/ & + & 1.12229E+00_JPRB, 1.11502E+00_JPRB, 1.10779E+00_JPRB, 1.10061E+00_JPRB, 1.09348E+00_JPRB, & + & 1.08639E+00_JPRB, 1.07935E+00_JPRB, 1.07235E+00_JPRB, 1.06540E+00_JPRB, 1.05850E+00_JPRB, & + & 1.05164E+00_JPRB, 1.04482E+00_JPRB, 1.03805E+00_JPRB, 1.03132E+00_JPRB, 1.02464E+00_JPRB, & + & 1.01799E+00_JPRB, 1.01140E+00_JPRB, 1.00484E+00_JPRB, 9.98328E-01_JPRB/) + KAO_MN2O( 9, :, 1) = (/ & + & 7.20959E-01_JPRB, 7.22839E-01_JPRB, 7.24723E-01_JPRB, 7.26612E-01_JPRB, 7.28506E-01_JPRB, & + & 7.30405E-01_JPRB, 7.32309E-01_JPRB, 7.34218E-01_JPRB, 7.36132E-01_JPRB, 7.38051E-01_JPRB, & + & 7.39975E-01_JPRB, 7.41904E-01_JPRB, 7.43838E-01_JPRB, 7.45777E-01_JPRB, 7.47721E-01_JPRB, & + & 7.49670E-01_JPRB, 7.51624E-01_JPRB, 7.53584E-01_JPRB, 7.55548E-01_JPRB/) + KAO_MN2O( 1, :, 2) = (/ & + & 1.62152E-03_JPRB, 1.81627E-03_JPRB, 2.03443E-03_JPRB, 2.27878E-03_JPRB, 2.55248E-03_JPRB, & + & 2.85906E-03_JPRB, 3.20245E-03_JPRB, 3.58710E-03_JPRB, 4.01794E-03_JPRB, 4.50053E-03_JPRB, & + & 5.04109E-03_JPRB, 5.64657E-03_JPRB, 6.32477E-03_JPRB, 7.08444E-03_JPRB, 7.93534E-03_JPRB, & + & 8.88845E-03_JPRB, 9.95603E-03_JPRB, 1.11518E-02_JPRB, 1.24913E-02_JPRB/) + KAO_MN2O( 2, :, 2) = (/ & + & 3.73716E-01_JPRB, 3.72491E-01_JPRB, 3.71271E-01_JPRB, 3.70054E-01_JPRB, 3.68841E-01_JPRB, & + & 3.67633E-01_JPRB, 3.66428E-01_JPRB, 3.65227E-01_JPRB, 3.64031E-01_JPRB, 3.62838E-01_JPRB, & + & 3.61649E-01_JPRB, 3.60464E-01_JPRB, 3.59283E-01_JPRB, 3.58106E-01_JPRB, 3.56932E-01_JPRB, & + & 3.55763E-01_JPRB, 3.54597E-01_JPRB, 3.53435E-01_JPRB, 3.52277E-01_JPRB/) + KAO_MN2O( 3, :, 2) = (/ & + & 5.46240E-01_JPRB, 5.42972E-01_JPRB, 5.39724E-01_JPRB, 5.36495E-01_JPRB, 5.33285E-01_JPRB, & + & 5.30095E-01_JPRB, 5.26923E-01_JPRB, 5.23771E-01_JPRB, 5.20637E-01_JPRB, 5.17523E-01_JPRB, & + & 5.14426E-01_JPRB, 5.11349E-01_JPRB, 5.08290E-01_JPRB, 5.05249E-01_JPRB, 5.02226E-01_JPRB, & + & 4.99221E-01_JPRB, 4.96235E-01_JPRB, 4.93266E-01_JPRB, 4.90315E-01_JPRB/) + KAO_MN2O( 4, :, 2) = (/ & + & 8.35399E-01_JPRB, 8.36766E-01_JPRB, 8.38135E-01_JPRB, 8.39507E-01_JPRB, 8.40880E-01_JPRB, & + & 8.42256E-01_JPRB, 8.43635E-01_JPRB, 8.45015E-01_JPRB, 8.46398E-01_JPRB, 8.47783E-01_JPRB, & + & 8.49170E-01_JPRB, 8.50559E-01_JPRB, 8.51951E-01_JPRB, 8.53345E-01_JPRB, 8.54742E-01_JPRB, & + & 8.56140E-01_JPRB, 8.57541E-01_JPRB, 8.58944E-01_JPRB, 8.60350E-01_JPRB/) + KAO_MN2O( 5, :, 2) = (/ & + & 1.04433E+00_JPRB, 1.04864E+00_JPRB, 1.05297E+00_JPRB, 1.05731E+00_JPRB, 1.06168E+00_JPRB, & + & 1.06606E+00_JPRB, 1.07046E+00_JPRB, 1.07488E+00_JPRB, 1.07932E+00_JPRB, 1.08377E+00_JPRB, & + & 1.08824E+00_JPRB, 1.09274E+00_JPRB, 1.09725E+00_JPRB, 1.10178E+00_JPRB, 1.10632E+00_JPRB, & + & 1.11089E+00_JPRB, 1.11547E+00_JPRB, 1.12008E+00_JPRB, 1.12470E+00_JPRB/) + KAO_MN2O( 6, :, 2) = (/ & + & 1.22341E+00_JPRB, 1.22885E+00_JPRB, 1.23431E+00_JPRB, 1.23980E+00_JPRB, 1.24531E+00_JPRB, & + & 1.25084E+00_JPRB, 1.25640E+00_JPRB, 1.26199E+00_JPRB, 1.26760E+00_JPRB, 1.27323E+00_JPRB, & + & 1.27889E+00_JPRB, 1.28458E+00_JPRB, 1.29029E+00_JPRB, 1.29602E+00_JPRB, 1.30178E+00_JPRB, & + & 1.30757E+00_JPRB, 1.31338E+00_JPRB, 1.31922E+00_JPRB, 1.32508E+00_JPRB/) + KAO_MN2O( 7, :, 2) = (/ & + & 1.67595E+00_JPRB, 1.68296E+00_JPRB, 1.69000E+00_JPRB, 1.69707E+00_JPRB, 1.70417E+00_JPRB, & + & 1.71130E+00_JPRB, 1.71846E+00_JPRB, 1.72565E+00_JPRB, 1.73287E+00_JPRB, 1.74012E+00_JPRB, & + & 1.74740E+00_JPRB, 1.75471E+00_JPRB, 1.76206E+00_JPRB, 1.76943E+00_JPRB, 1.77683E+00_JPRB, & + & 1.78426E+00_JPRB, 1.79173E+00_JPRB, 1.79922E+00_JPRB, 1.80675E+00_JPRB/) + KAO_MN2O( 8, :, 2) = (/ & + & 2.76890E+00_JPRB, 2.76981E+00_JPRB, 2.77072E+00_JPRB, 2.77163E+00_JPRB, 2.77254E+00_JPRB, & + & 2.77345E+00_JPRB, 2.77436E+00_JPRB, 2.77527E+00_JPRB, 2.77618E+00_JPRB, 2.77709E+00_JPRB, & + & 2.77800E+00_JPRB, 2.77891E+00_JPRB, 2.77982E+00_JPRB, 2.78074E+00_JPRB, 2.78165E+00_JPRB, & + & 2.78256E+00_JPRB, 2.78348E+00_JPRB, 2.78439E+00_JPRB, 2.78530E+00_JPRB/) + KAO_MN2O( 9, :, 2) = (/ & + & 8.00944E-01_JPRB, 7.95531E-01_JPRB, 7.90155E-01_JPRB, 7.84815E-01_JPRB, 7.79511E-01_JPRB, & + & 7.74243E-01_JPRB, 7.69011E-01_JPRB, 7.63813E-01_JPRB, 7.58652E-01_JPRB, 7.53525E-01_JPRB, & + & 7.48432E-01_JPRB, 7.43374E-01_JPRB, 7.38350E-01_JPRB, 7.33360E-01_JPRB, 7.28404E-01_JPRB, & + & 7.23482E-01_JPRB, 7.18592E-01_JPRB, 7.13736E-01_JPRB, 7.08912E-01_JPRB/) + KAO_MN2O( 1, :, 3) = (/ & + & 5.26578E-02_JPRB, 5.59000E-02_JPRB, 5.93419E-02_JPRB, 6.29957E-02_JPRB, 6.68744E-02_JPRB, & + & 7.09920E-02_JPRB, 7.53631E-02_JPRB, 8.00034E-02_JPRB, 8.49294E-02_JPRB, 9.01586E-02_JPRB, & + & 9.57099E-02_JPRB, 1.01603E-01_JPRB, 1.07859E-01_JPRB, 1.14500E-01_JPRB, 1.21550E-01_JPRB, & + & 1.29034E-01_JPRB, 1.36979E-01_JPRB, 1.45413E-01_JPRB, 1.54366E-01_JPRB/) + KAO_MN2O( 2, :, 3) = (/ & + & 8.18393E-01_JPRB, 8.20623E-01_JPRB, 8.22860E-01_JPRB, 8.25103E-01_JPRB, 8.27352E-01_JPRB, & + & 8.29608E-01_JPRB, 8.31869E-01_JPRB, 8.34137E-01_JPRB, 8.36410E-01_JPRB, 8.38690E-01_JPRB, & + & 8.40976E-01_JPRB, 8.43269E-01_JPRB, 8.45567E-01_JPRB, 8.47872E-01_JPRB, 8.50183E-01_JPRB, & + & 8.52501E-01_JPRB, 8.54825E-01_JPRB, 8.57155E-01_JPRB, 8.59491E-01_JPRB/) + KAO_MN2O( 3, :, 3) = (/ & + & 1.02454E+00_JPRB, 1.03210E+00_JPRB, 1.03972E+00_JPRB, 1.04740E+00_JPRB, 1.05514E+00_JPRB, & + & 1.06293E+00_JPRB, 1.07077E+00_JPRB, 1.07868E+00_JPRB, 1.08665E+00_JPRB, 1.09467E+00_JPRB, & + & 1.10275E+00_JPRB, 1.11089E+00_JPRB, 1.11910E+00_JPRB, 1.12736E+00_JPRB, 1.13568E+00_JPRB, & + & 1.14407E+00_JPRB, 1.15252E+00_JPRB, 1.16103E+00_JPRB, 1.16960E+00_JPRB/) + KAO_MN2O( 4, :, 3) = (/ & + & 1.11755E+00_JPRB, 1.12348E+00_JPRB, 1.12944E+00_JPRB, 1.13543E+00_JPRB, 1.14146E+00_JPRB, & + & 1.14752E+00_JPRB, 1.15360E+00_JPRB, 1.15972E+00_JPRB, 1.16588E+00_JPRB, 1.17206E+00_JPRB, & + & 1.17828E+00_JPRB, 1.18453E+00_JPRB, 1.19082E+00_JPRB, 1.19714E+00_JPRB, 1.20349E+00_JPRB, & + & 1.20988E+00_JPRB, 1.21630E+00_JPRB, 1.22275E+00_JPRB, 1.22924E+00_JPRB/) + KAO_MN2O( 5, :, 3) = (/ & + & 1.41993E+00_JPRB, 1.42353E+00_JPRB, 1.42713E+00_JPRB, 1.43074E+00_JPRB, 1.43436E+00_JPRB, & + & 1.43799E+00_JPRB, 1.44163E+00_JPRB, 1.44528E+00_JPRB, 1.44894E+00_JPRB, 1.45261E+00_JPRB, & + & 1.45628E+00_JPRB, 1.45997E+00_JPRB, 1.46367E+00_JPRB, 1.46737E+00_JPRB, 1.47108E+00_JPRB, & + & 1.47481E+00_JPRB, 1.47854E+00_JPRB, 1.48228E+00_JPRB, 1.48603E+00_JPRB/) + KAO_MN2O( 6, :, 3) = (/ & + & 1.37725E+00_JPRB, 1.38029E+00_JPRB, 1.38334E+00_JPRB, 1.38640E+00_JPRB, 1.38947E+00_JPRB, & + & 1.39254E+00_JPRB, 1.39562E+00_JPRB, 1.39870E+00_JPRB, 1.40179E+00_JPRB, 1.40489E+00_JPRB, & + & 1.40800E+00_JPRB, 1.41111E+00_JPRB, 1.41423E+00_JPRB, 1.41736E+00_JPRB, 1.42049E+00_JPRB, & + & 1.42363E+00_JPRB, 1.42678E+00_JPRB, 1.42993E+00_JPRB, 1.43309E+00_JPRB/) + KAO_MN2O( 7, :, 3) = (/ & + & 1.34579E+00_JPRB, 1.34584E+00_JPRB, 1.34589E+00_JPRB, 1.34594E+00_JPRB, 1.34599E+00_JPRB, & + & 1.34603E+00_JPRB, 1.34608E+00_JPRB, 1.34613E+00_JPRB, 1.34618E+00_JPRB, 1.34623E+00_JPRB, & + & 1.34627E+00_JPRB, 1.34632E+00_JPRB, 1.34637E+00_JPRB, 1.34642E+00_JPRB, 1.34647E+00_JPRB, & + & 1.34651E+00_JPRB, 1.34656E+00_JPRB, 1.34661E+00_JPRB, 1.34666E+00_JPRB/) + KAO_MN2O( 8, :, 3) = (/ & + & 9.15268E-01_JPRB, 9.12779E-01_JPRB, 9.10298E-01_JPRB, 9.07823E-01_JPRB, 9.05355E-01_JPRB, & + & 9.02893E-01_JPRB, 9.00438E-01_JPRB, 8.97990E-01_JPRB, 8.95549E-01_JPRB, 8.93114E-01_JPRB, & + & 8.90686E-01_JPRB, 8.88264E-01_JPRB, 8.85849E-01_JPRB, 8.83441E-01_JPRB, 8.81039E-01_JPRB, & + & 8.78644E-01_JPRB, 8.76255E-01_JPRB, 8.73873E-01_JPRB, 8.71497E-01_JPRB/) + KAO_MN2O( 9, :, 3) = (/ & + & 1.12514E+00_JPRB, 1.13523E+00_JPRB, 1.14541E+00_JPRB, 1.15568E+00_JPRB, 1.16604E+00_JPRB, & + & 1.17649E+00_JPRB, 1.18704E+00_JPRB, 1.19768E+00_JPRB, 1.20841E+00_JPRB, 1.21925E+00_JPRB, & + & 1.23018E+00_JPRB, 1.24121E+00_JPRB, 1.25233E+00_JPRB, 1.26356E+00_JPRB, 1.27489E+00_JPRB, & + & 1.28632E+00_JPRB, 1.29785E+00_JPRB, 1.30948E+00_JPRB, 1.32122E+00_JPRB/) + KAO_MN2O( 1, :, 4) = (/ & + & 4.65135E-01_JPRB, 4.69677E-01_JPRB, 4.74264E-01_JPRB, 4.78895E-01_JPRB, 4.83572E-01_JPRB, & + & 4.88294E-01_JPRB, 4.93063E-01_JPRB, 4.97878E-01_JPRB, 5.02740E-01_JPRB, 5.07649E-01_JPRB, & + & 5.12607E-01_JPRB, 5.17613E-01_JPRB, 5.22667E-01_JPRB, 5.27771E-01_JPRB, 5.32925E-01_JPRB, & + & 5.38130E-01_JPRB, 5.43385E-01_JPRB, 5.48691E-01_JPRB, 5.54049E-01_JPRB/) + KAO_MN2O( 2, :, 4) = (/ & + & 9.71592E-01_JPRB, 9.74472E-01_JPRB, 9.77360E-01_JPRB, 9.80257E-01_JPRB, 9.83163E-01_JPRB, & + & 9.86077E-01_JPRB, 9.89000E-01_JPRB, 9.91931E-01_JPRB, 9.94871E-01_JPRB, 9.97820E-01_JPRB, & + & 1.00078E+00_JPRB, 1.00374E+00_JPRB, 1.00672E+00_JPRB, 1.00970E+00_JPRB, 1.01270E+00_JPRB, & + & 1.01570E+00_JPRB, 1.01871E+00_JPRB, 1.02173E+00_JPRB, 1.02476E+00_JPRB/) + KAO_MN2O( 3, :, 4) = (/ & + & 1.48090E+00_JPRB, 1.48238E+00_JPRB, 1.48385E+00_JPRB, 1.48532E+00_JPRB, 1.48680E+00_JPRB, & + & 1.48828E+00_JPRB, 1.48976E+00_JPRB, 1.49124E+00_JPRB, 1.49272E+00_JPRB, 1.49420E+00_JPRB, & + & 1.49569E+00_JPRB, 1.49717E+00_JPRB, 1.49866E+00_JPRB, 1.50015E+00_JPRB, 1.50164E+00_JPRB, & + & 1.50313E+00_JPRB, 1.50463E+00_JPRB, 1.50612E+00_JPRB, 1.50762E+00_JPRB/) + KAO_MN2O( 4, :, 4) = (/ & + & 1.50599E+00_JPRB, 1.50541E+00_JPRB, 1.50483E+00_JPRB, 1.50426E+00_JPRB, 1.50368E+00_JPRB, & + & 1.50310E+00_JPRB, 1.50252E+00_JPRB, 1.50195E+00_JPRB, 1.50137E+00_JPRB, 1.50079E+00_JPRB, & + & 1.50022E+00_JPRB, 1.49964E+00_JPRB, 1.49906E+00_JPRB, 1.49849E+00_JPRB, 1.49791E+00_JPRB, & + & 1.49734E+00_JPRB, 1.49676E+00_JPRB, 1.49619E+00_JPRB, 1.49561E+00_JPRB/) + KAO_MN2O( 5, :, 4) = (/ & + & 1.25396E+00_JPRB, 1.25230E+00_JPRB, 1.25065E+00_JPRB, 1.24900E+00_JPRB, 1.24735E+00_JPRB, & + & 1.24570E+00_JPRB, 1.24405E+00_JPRB, 1.24241E+00_JPRB, 1.24077E+00_JPRB, 1.23913E+00_JPRB, & + & 1.23749E+00_JPRB, 1.23586E+00_JPRB, 1.23423E+00_JPRB, 1.23260E+00_JPRB, 1.23097E+00_JPRB, & + & 1.22934E+00_JPRB, 1.22772E+00_JPRB, 1.22610E+00_JPRB, 1.22448E+00_JPRB/) + KAO_MN2O( 6, :, 4) = (/ & + & 1.27104E+00_JPRB, 1.26416E+00_JPRB, 1.25731E+00_JPRB, 1.25050E+00_JPRB, 1.24373E+00_JPRB, & + & 1.23700E+00_JPRB, 1.23030E+00_JPRB, 1.22364E+00_JPRB, 1.21701E+00_JPRB, 1.21043E+00_JPRB, & + & 1.20387E+00_JPRB, 1.19735E+00_JPRB, 1.19087E+00_JPRB, 1.18442E+00_JPRB, 1.17801E+00_JPRB, & + & 1.17163E+00_JPRB, 1.16529E+00_JPRB, 1.15898E+00_JPRB, 1.15270E+00_JPRB/) + KAO_MN2O( 7, :, 4) = (/ & + & 9.57877E-01_JPRB, 9.49712E-01_JPRB, 9.41617E-01_JPRB, 9.33591E-01_JPRB, 9.25633E-01_JPRB, & + & 9.17743E-01_JPRB, 9.09920E-01_JPRB, 9.02164E-01_JPRB, 8.94473E-01_JPRB, 8.86849E-01_JPRB, & + & 8.79289E-01_JPRB, 8.71794E-01_JPRB, 8.64363E-01_JPRB, 8.56995E-01_JPRB, 8.49690E-01_JPRB, & + & 8.42447E-01_JPRB, 8.35266E-01_JPRB, 8.28147E-01_JPRB, 8.21087E-01_JPRB/) + KAO_MN2O( 8, :, 4) = (/ & + & 4.75787E-01_JPRB, 4.77208E-01_JPRB, 4.78633E-01_JPRB, 4.80063E-01_JPRB, 4.81496E-01_JPRB, & + & 4.82934E-01_JPRB, 4.84377E-01_JPRB, 4.85823E-01_JPRB, 4.87274E-01_JPRB, 4.88730E-01_JPRB, & + & 4.90189E-01_JPRB, 4.91653E-01_JPRB, 4.93122E-01_JPRB, 4.94595E-01_JPRB, 4.96072E-01_JPRB, & + & 4.97553E-01_JPRB, 4.99039E-01_JPRB, 5.00530E-01_JPRB, 5.02025E-01_JPRB/) + KAO_MN2O( 9, :, 4) = (/ & + & 2.42533E+00_JPRB, 2.41357E+00_JPRB, 2.40188E+00_JPRB, 2.39024E+00_JPRB, 2.37866E+00_JPRB, & + & 2.36713E+00_JPRB, 2.35566E+00_JPRB, 2.34425E+00_JPRB, 2.33289E+00_JPRB, 2.32158E+00_JPRB, & + & 2.31033E+00_JPRB, 2.29914E+00_JPRB, 2.28800E+00_JPRB, 2.27691E+00_JPRB, 2.26588E+00_JPRB, & + & 2.25490E+00_JPRB, 2.24397E+00_JPRB, 2.23310E+00_JPRB, 2.22228E+00_JPRB/) + KAO_MN2O( 1, :, 5) = (/ & + & 1.53885E+00_JPRB, 1.53590E+00_JPRB, 1.53297E+00_JPRB, 1.53004E+00_JPRB, 1.52711E+00_JPRB, & + & 1.52419E+00_JPRB, 1.52128E+00_JPRB, 1.51837E+00_JPRB, 1.51547E+00_JPRB, 1.51257E+00_JPRB, & + & 1.50968E+00_JPRB, 1.50679E+00_JPRB, 1.50391E+00_JPRB, 1.50104E+00_JPRB, 1.49817E+00_JPRB, & + & 1.49530E+00_JPRB, 1.49245E+00_JPRB, 1.48959E+00_JPRB, 1.48675E+00_JPRB/) + KAO_MN2O( 2, :, 5) = (/ & + & 1.83368E+00_JPRB, 1.83530E+00_JPRB, 1.83692E+00_JPRB, 1.83854E+00_JPRB, 1.84016E+00_JPRB, & + & 1.84178E+00_JPRB, 1.84340E+00_JPRB, 1.84503E+00_JPRB, 1.84665E+00_JPRB, 1.84828E+00_JPRB, & + & 1.84991E+00_JPRB, 1.85154E+00_JPRB, 1.85317E+00_JPRB, 1.85480E+00_JPRB, 1.85644E+00_JPRB, & + & 1.85807E+00_JPRB, 1.85971E+00_JPRB, 1.86135E+00_JPRB, 1.86299E+00_JPRB/) + KAO_MN2O( 3, :, 5) = (/ & + & 1.49593E+00_JPRB, 1.49279E+00_JPRB, 1.48965E+00_JPRB, 1.48652E+00_JPRB, 1.48340E+00_JPRB, & + & 1.48028E+00_JPRB, 1.47717E+00_JPRB, 1.47406E+00_JPRB, 1.47096E+00_JPRB, 1.46787E+00_JPRB, & + & 1.46479E+00_JPRB, 1.46171E+00_JPRB, 1.45863E+00_JPRB, 1.45557E+00_JPRB, 1.45251E+00_JPRB, & + & 1.44946E+00_JPRB, 1.44641E+00_JPRB, 1.44337E+00_JPRB, 1.44033E+00_JPRB/) + KAO_MN2O( 4, :, 5) = (/ & + & 1.40048E+00_JPRB, 1.39228E+00_JPRB, 1.38413E+00_JPRB, 1.37603E+00_JPRB, 1.36798E+00_JPRB, & + & 1.35997E+00_JPRB, 1.35201E+00_JPRB, 1.34410E+00_JPRB, 1.33623E+00_JPRB, 1.32841E+00_JPRB, & + & 1.32064E+00_JPRB, 1.31291E+00_JPRB, 1.30522E+00_JPRB, 1.29758E+00_JPRB, 1.28999E+00_JPRB, & + & 1.28244E+00_JPRB, 1.27493E+00_JPRB, 1.26747E+00_JPRB, 1.26005E+00_JPRB/) + KAO_MN2O( 5, :, 5) = (/ & + & 1.22253E+00_JPRB, 1.21202E+00_JPRB, 1.20160E+00_JPRB, 1.19126E+00_JPRB, 1.18102E+00_JPRB, & + & 1.17087E+00_JPRB, 1.16080E+00_JPRB, 1.15082E+00_JPRB, 1.14092E+00_JPRB, 1.13111E+00_JPRB, & + & 1.12139E+00_JPRB, 1.11174E+00_JPRB, 1.10219E+00_JPRB, 1.09271E+00_JPRB, 1.08331E+00_JPRB, & + & 1.07400E+00_JPRB, 1.06476E+00_JPRB, 1.05561E+00_JPRB, 1.04653E+00_JPRB/) + KAO_MN2O( 6, :, 5) = (/ & + & 1.07930E+00_JPRB, 1.06998E+00_JPRB, 1.06075E+00_JPRB, 1.05159E+00_JPRB, 1.04251E+00_JPRB, & + & 1.03352E+00_JPRB, 1.02459E+00_JPRB, 1.01575E+00_JPRB, 1.00698E+00_JPRB, 9.98291E-01_JPRB, & + & 9.89674E-01_JPRB, 9.81131E-01_JPRB, 9.72663E-01_JPRB, 9.64267E-01_JPRB, 9.55944E-01_JPRB, & + & 9.47692E-01_JPRB, 9.39512E-01_JPRB, 9.31402E-01_JPRB, 9.23363E-01_JPRB/) + KAO_MN2O( 7, :, 5) = (/ & + & 7.87066E-01_JPRB, 7.82767E-01_JPRB, 7.78490E-01_JPRB, 7.74237E-01_JPRB, 7.70008E-01_JPRB, & + & 7.65801E-01_JPRB, 7.61617E-01_JPRB, 7.57457E-01_JPRB, 7.53319E-01_JPRB, 7.49203E-01_JPRB, & + & 7.45110E-01_JPRB, 7.41040E-01_JPRB, 7.36991E-01_JPRB, 7.32965E-01_JPRB, 7.28961E-01_JPRB, & + & 7.24979E-01_JPRB, 7.21018E-01_JPRB, 7.17079E-01_JPRB, 7.13161E-01_JPRB/) + KAO_MN2O( 8, :, 5) = (/ & + & 3.83362E-01_JPRB, 3.84405E-01_JPRB, 3.85452E-01_JPRB, 3.86501E-01_JPRB, 3.87552E-01_JPRB, & + & 3.88607E-01_JPRB, 3.89665E-01_JPRB, 3.90725E-01_JPRB, 3.91788E-01_JPRB, 3.92855E-01_JPRB, & + & 3.93924E-01_JPRB, 3.94996E-01_JPRB, 3.96071E-01_JPRB, 3.97149E-01_JPRB, 3.98229E-01_JPRB, & + & 3.99313E-01_JPRB, 4.00400E-01_JPRB, 4.01489E-01_JPRB, 4.02582E-01_JPRB/) + KAO_MN2O( 9, :, 5) = (/ & + & 8.97278E-01_JPRB, 8.92873E-01_JPRB, 8.88490E-01_JPRB, 8.84128E-01_JPRB, 8.79787E-01_JPRB, & + & 8.75468E-01_JPRB, 8.71170E-01_JPRB, 8.66893E-01_JPRB, 8.62637E-01_JPRB, 8.58402E-01_JPRB, & + & 8.54187E-01_JPRB, 8.49994E-01_JPRB, 8.45821E-01_JPRB, 8.41668E-01_JPRB, 8.37536E-01_JPRB, & + & 8.33424E-01_JPRB, 8.29333E-01_JPRB, 8.25261E-01_JPRB, 8.21209E-01_JPRB/) + KAO_MN2O( 1, :, 6) = (/ & + & 1.83809E+00_JPRB, 1.84036E+00_JPRB, 1.84264E+00_JPRB, 1.84491E+00_JPRB, 1.84720E+00_JPRB, & + & 1.84948E+00_JPRB, 1.85177E+00_JPRB, 1.85406E+00_JPRB, 1.85635E+00_JPRB, 1.85864E+00_JPRB, & + & 1.86094E+00_JPRB, 1.86324E+00_JPRB, 1.86555E+00_JPRB, 1.86785E+00_JPRB, 1.87016E+00_JPRB, & + & 1.87247E+00_JPRB, 1.87479E+00_JPRB, 1.87711E+00_JPRB, 1.87943E+00_JPRB/) + KAO_MN2O( 2, :, 6) = (/ & + & 1.82624E+00_JPRB, 1.81564E+00_JPRB, 1.80510E+00_JPRB, 1.79463E+00_JPRB, 1.78421E+00_JPRB, & + & 1.77386E+00_JPRB, 1.76356E+00_JPRB, 1.75333E+00_JPRB, 1.74315E+00_JPRB, 1.73304E+00_JPRB, & + & 1.72298E+00_JPRB, 1.71298E+00_JPRB, 1.70304E+00_JPRB, 1.69316E+00_JPRB, 1.68333E+00_JPRB, & + & 1.67356E+00_JPRB, 1.66385E+00_JPRB, 1.65419E+00_JPRB, 1.64459E+00_JPRB/) + KAO_MN2O( 3, :, 6) = (/ & + & 1.35442E+00_JPRB, 1.34174E+00_JPRB, 1.32918E+00_JPRB, 1.31673E+00_JPRB, 1.30440E+00_JPRB, & + & 1.29219E+00_JPRB, 1.28010E+00_JPRB, 1.26811E+00_JPRB, 1.25624E+00_JPRB, 1.24448E+00_JPRB, & + & 1.23283E+00_JPRB, 1.22129E+00_JPRB, 1.20985E+00_JPRB, 1.19853E+00_JPRB, 1.18731E+00_JPRB, & + & 1.17619E+00_JPRB, 1.16518E+00_JPRB, 1.15427E+00_JPRB, 1.14347E+00_JPRB/) + KAO_MN2O( 4, :, 6) = (/ & + & 1.10510E+00_JPRB, 1.09473E+00_JPRB, 1.08446E+00_JPRB, 1.07429E+00_JPRB, 1.06420E+00_JPRB, & + & 1.05422E+00_JPRB, 1.04433E+00_JPRB, 1.03453E+00_JPRB, 1.02482E+00_JPRB, 1.01520E+00_JPRB, & + & 1.00568E+00_JPRB, 9.96238E-01_JPRB, 9.86890E-01_JPRB, 9.77629E-01_JPRB, 9.68455E-01_JPRB, & + & 9.59367E-01_JPRB, 9.50365E-01_JPRB, 9.41447E-01_JPRB, 9.32612E-01_JPRB/) + KAO_MN2O( 5, :, 6) = (/ & + & 1.01083E+00_JPRB, 1.00221E+00_JPRB, 9.93656E-01_JPRB, 9.85178E-01_JPRB, 9.76772E-01_JPRB, & + & 9.68437E-01_JPRB, 9.60174E-01_JPRB, 9.51981E-01_JPRB, 9.43859E-01_JPRB, 9.35805E-01_JPRB, & + & 9.27821E-01_JPRB, 9.19904E-01_JPRB, 9.12055E-01_JPRB, 9.04273E-01_JPRB, 8.96557E-01_JPRB, & + & 8.88907E-01_JPRB, 8.81323E-01_JPRB, 8.73803E-01_JPRB, 8.66347E-01_JPRB/) + KAO_MN2O( 6, :, 6) = (/ & + & 5.91415E-01_JPRB, 5.90427E-01_JPRB, 5.89441E-01_JPRB, 5.88457E-01_JPRB, 5.87474E-01_JPRB, & + & 5.86493E-01_JPRB, 5.85514E-01_JPRB, 5.84536E-01_JPRB, 5.83559E-01_JPRB, 5.82585E-01_JPRB, & + & 5.81612E-01_JPRB, 5.80640E-01_JPRB, 5.79671E-01_JPRB, 5.78703E-01_JPRB, 5.77736E-01_JPRB, & + & 5.76771E-01_JPRB, 5.75808E-01_JPRB, 5.74846E-01_JPRB, 5.73886E-01_JPRB/) + KAO_MN2O( 7, :, 6) = (/ & + & 3.68189E-01_JPRB, 3.70029E-01_JPRB, 3.71877E-01_JPRB, 3.73735E-01_JPRB, 3.75603E-01_JPRB, & + & 3.77479E-01_JPRB, 3.79365E-01_JPRB, 3.81260E-01_JPRB, 3.83165E-01_JPRB, 3.85079E-01_JPRB, & + & 3.87003E-01_JPRB, 3.88937E-01_JPRB, 3.90880E-01_JPRB, 3.92833E-01_JPRB, 3.94795E-01_JPRB, & + & 3.96768E-01_JPRB, 3.98750E-01_JPRB, 4.00742E-01_JPRB, 4.02744E-01_JPRB/) + KAO_MN2O( 8, :, 6) = (/ & + & 2.98721E-01_JPRB, 2.99932E-01_JPRB, 3.01149E-01_JPRB, 3.02370E-01_JPRB, 3.03597E-01_JPRB, & + & 3.04828E-01_JPRB, 3.06064E-01_JPRB, 3.07306E-01_JPRB, 3.08552E-01_JPRB, 3.09804E-01_JPRB, & + & 3.11060E-01_JPRB, 3.12322E-01_JPRB, 3.13589E-01_JPRB, 3.14860E-01_JPRB, 3.16138E-01_JPRB, & + & 3.17420E-01_JPRB, 3.18707E-01_JPRB, 3.20000E-01_JPRB, 3.21298E-01_JPRB/) + KAO_MN2O( 9, :, 6) = (/ & + & 3.76116E-01_JPRB, 3.77276E-01_JPRB, 3.78439E-01_JPRB, 3.79606E-01_JPRB, 3.80777E-01_JPRB, & + & 3.81951E-01_JPRB, 3.83129E-01_JPRB, 3.84310E-01_JPRB, 3.85495E-01_JPRB, 3.86684E-01_JPRB, & + & 3.87876E-01_JPRB, 3.89072E-01_JPRB, 3.90272E-01_JPRB, 3.91475E-01_JPRB, 3.92682E-01_JPRB, & + & 3.93893E-01_JPRB, 3.95107E-01_JPRB, 3.96326E-01_JPRB, 3.97548E-01_JPRB/) + KAO_MN2O( 1, :, 7) = (/ & + & 3.22705E+00_JPRB, 3.21966E+00_JPRB, 3.21230E+00_JPRB, 3.20494E+00_JPRB, 3.19761E+00_JPRB, & + & 3.19029E+00_JPRB, 3.18299E+00_JPRB, 3.17571E+00_JPRB, 3.16844E+00_JPRB, 3.16119E+00_JPRB, & + & 3.15395E+00_JPRB, 3.14673E+00_JPRB, 3.13953E+00_JPRB, 3.13235E+00_JPRB, 3.12518E+00_JPRB, & + & 3.11803E+00_JPRB, 3.11089E+00_JPRB, 3.10377E+00_JPRB, 3.09667E+00_JPRB/) + KAO_MN2O( 2, :, 7) = (/ & + & 1.43811E+00_JPRB, 1.42367E+00_JPRB, 1.40938E+00_JPRB, 1.39522E+00_JPRB, 1.38121E+00_JPRB, & + & 1.36735E+00_JPRB, 1.35362E+00_JPRB, 1.34002E+00_JPRB, 1.32657E+00_JPRB, 1.31325E+00_JPRB, & + & 1.30006E+00_JPRB, 1.28701E+00_JPRB, 1.27408E+00_JPRB, 1.26129E+00_JPRB, 1.24862E+00_JPRB, & + & 1.23609E+00_JPRB, 1.22367E+00_JPRB, 1.21139E+00_JPRB, 1.19922E+00_JPRB/) + KAO_MN2O( 3, :, 7) = (/ & + & 1.22586E+00_JPRB, 1.21639E+00_JPRB, 1.20700E+00_JPRB, 1.19767E+00_JPRB, 1.18842E+00_JPRB, & + & 1.17924E+00_JPRB, 1.17014E+00_JPRB, 1.16110E+00_JPRB, 1.15213E+00_JPRB, 1.14323E+00_JPRB, & + & 1.13440E+00_JPRB, 1.12564E+00_JPRB, 1.11695E+00_JPRB, 1.10832E+00_JPRB, 1.09976E+00_JPRB, & + & 1.09127E+00_JPRB, 1.08284E+00_JPRB, 1.07447E+00_JPRB, 1.06618E+00_JPRB/) + KAO_MN2O( 4, :, 7) = (/ & + & 7.94380E-01_JPRB, 7.92795E-01_JPRB, 7.91213E-01_JPRB, 7.89634E-01_JPRB, 7.88059E-01_JPRB, & + & 7.86486E-01_JPRB, 7.84917E-01_JPRB, 7.83351E-01_JPRB, 7.81787E-01_JPRB, 7.80227E-01_JPRB, & + & 7.78671E-01_JPRB, 7.77117E-01_JPRB, 7.75566E-01_JPRB, 7.74019E-01_JPRB, 7.72474E-01_JPRB, & + & 7.70933E-01_JPRB, 7.69394E-01_JPRB, 7.67859E-01_JPRB, 7.66327E-01_JPRB/) + KAO_MN2O( 5, :, 7) = (/ & + & 4.46935E-01_JPRB, 4.49760E-01_JPRB, 4.52602E-01_JPRB, 4.55462E-01_JPRB, 4.58340E-01_JPRB, & + & 4.61237E-01_JPRB, 4.64152E-01_JPRB, 4.67085E-01_JPRB, 4.70037E-01_JPRB, 4.73007E-01_JPRB, & + & 4.75996E-01_JPRB, 4.79004E-01_JPRB, 4.82031E-01_JPRB, 4.85078E-01_JPRB, 4.88143E-01_JPRB, & + & 4.91228E-01_JPRB, 4.94332E-01_JPRB, 4.97456E-01_JPRB, 5.00600E-01_JPRB/) + KAO_MN2O( 6, :, 7) = (/ & + & 4.20211E-01_JPRB, 4.21711E-01_JPRB, 4.23216E-01_JPRB, 4.24726E-01_JPRB, 4.26242E-01_JPRB, & + & 4.27763E-01_JPRB, 4.29290E-01_JPRB, 4.30822E-01_JPRB, 4.32359E-01_JPRB, 4.33902E-01_JPRB, & + & 4.35450E-01_JPRB, 4.37004E-01_JPRB, 4.38564E-01_JPRB, 4.40129E-01_JPRB, 4.41700E-01_JPRB, & + & 4.43276E-01_JPRB, 4.44858E-01_JPRB, 4.46445E-01_JPRB, 4.48038E-01_JPRB/) + KAO_MN2O( 7, :, 7) = (/ & + & 3.42094E-01_JPRB, 3.43589E-01_JPRB, 3.45091E-01_JPRB, 3.46600E-01_JPRB, 3.48115E-01_JPRB, & + & 3.49637E-01_JPRB, 3.51165E-01_JPRB, 3.52700E-01_JPRB, 3.54242E-01_JPRB, 3.55791E-01_JPRB, & + & 3.57346E-01_JPRB, 3.58908E-01_JPRB, 3.60477E-01_JPRB, 3.62053E-01_JPRB, 3.63636E-01_JPRB, & + & 3.65225E-01_JPRB, 3.66822E-01_JPRB, 3.68426E-01_JPRB, 3.70036E-01_JPRB/) + KAO_MN2O( 8, :, 7) = (/ & + & 2.94919E-01_JPRB, 2.97460E-01_JPRB, 3.00022E-01_JPRB, 3.02606E-01_JPRB, 3.05212E-01_JPRB, & + & 3.07841E-01_JPRB, 3.10492E-01_JPRB, 3.13167E-01_JPRB, 3.15864E-01_JPRB, 3.18584E-01_JPRB, & + & 3.21328E-01_JPRB, 3.24096E-01_JPRB, 3.26887E-01_JPRB, 3.29703E-01_JPRB, 3.32543E-01_JPRB, & + & 3.35407E-01_JPRB, 3.38296E-01_JPRB, 3.41210E-01_JPRB, 3.44148E-01_JPRB/) + KAO_MN2O( 9, :, 7) = (/ & + & 2.97441E-01_JPRB, 2.99207E-01_JPRB, 3.00984E-01_JPRB, 3.02772E-01_JPRB, 3.04570E-01_JPRB, & + & 3.06379E-01_JPRB, 3.08199E-01_JPRB, 3.10029E-01_JPRB, 3.11870E-01_JPRB, 3.13723E-01_JPRB, & + & 3.15586E-01_JPRB, 3.17460E-01_JPRB, 3.19345E-01_JPRB, 3.21242E-01_JPRB, 3.23150E-01_JPRB, & + & 3.25069E-01_JPRB, 3.27000E-01_JPRB, 3.28942E-01_JPRB, 3.30895E-01_JPRB/) + KAO_MN2O( 1, :, 8) = (/ & + & 2.14641E+00_JPRB, 2.12585E+00_JPRB, 2.10549E+00_JPRB, 2.08532E+00_JPRB, 2.06534E+00_JPRB, & + & 2.04556E+00_JPRB, 2.02596E+00_JPRB, 2.00656E+00_JPRB, 1.98733E+00_JPRB, 1.96830E+00_JPRB, & + & 1.94944E+00_JPRB, 1.93077E+00_JPRB, 1.91227E+00_JPRB, 1.89395E+00_JPRB, 1.87581E+00_JPRB, & + & 1.85784E+00_JPRB, 1.84004E+00_JPRB, 1.82242E+00_JPRB, 1.80496E+00_JPRB/) + KAO_MN2O( 2, :, 8) = (/ & + & 8.83687E-01_JPRB, 8.83170E-01_JPRB, 8.82654E-01_JPRB, 8.82137E-01_JPRB, 8.81621E-01_JPRB, & + & 8.81106E-01_JPRB, 8.80590E-01_JPRB, 8.80075E-01_JPRB, 8.79560E-01_JPRB, 8.79046E-01_JPRB, & + & 8.78531E-01_JPRB, 8.78017E-01_JPRB, 8.77504E-01_JPRB, 8.76990E-01_JPRB, 8.76477E-01_JPRB, & + & 8.75965E-01_JPRB, 8.75452E-01_JPRB, 8.74940E-01_JPRB, 8.74428E-01_JPRB/) + KAO_MN2O( 3, :, 8) = (/ & + & 4.49840E-01_JPRB, 4.52683E-01_JPRB, 4.55543E-01_JPRB, 4.58421E-01_JPRB, 4.61318E-01_JPRB, & + & 4.64233E-01_JPRB, 4.67166E-01_JPRB, 4.70118E-01_JPRB, 4.73088E-01_JPRB, 4.76078E-01_JPRB, & + & 4.79086E-01_JPRB, 4.82113E-01_JPRB, 4.85159E-01_JPRB, 4.88225E-01_JPRB, 4.91310E-01_JPRB, & + & 4.94414E-01_JPRB, 4.97538E-01_JPRB, 5.00682E-01_JPRB, 5.03845E-01_JPRB/) + KAO_MN2O( 4, :, 8) = (/ & + & 3.92292E-01_JPRB, 3.93574E-01_JPRB, 3.94861E-01_JPRB, 3.96151E-01_JPRB, 3.97446E-01_JPRB, & + & 3.98746E-01_JPRB, 4.00049E-01_JPRB, 4.01357E-01_JPRB, 4.02669E-01_JPRB, 4.03985E-01_JPRB, & + & 4.05306E-01_JPRB, 4.06630E-01_JPRB, 4.07960E-01_JPRB, 4.09293E-01_JPRB, 4.10631E-01_JPRB, & + & 4.11973E-01_JPRB, 4.13320E-01_JPRB, 4.14671E-01_JPRB, 4.16027E-01_JPRB/) + KAO_MN2O( 5, :, 8) = (/ & + & 3.38920E-01_JPRB, 3.41151E-01_JPRB, 3.43397E-01_JPRB, 3.45658E-01_JPRB, 3.47934E-01_JPRB, & + & 3.50225E-01_JPRB, 3.52531E-01_JPRB, 3.54852E-01_JPRB, 3.57189E-01_JPRB, 3.59541E-01_JPRB, & + & 3.61908E-01_JPRB, 3.64291E-01_JPRB, 3.66689E-01_JPRB, 3.69104E-01_JPRB, 3.71534E-01_JPRB, & + & 3.73980E-01_JPRB, 3.76443E-01_JPRB, 3.78921E-01_JPRB, 3.81416E-01_JPRB/) + KAO_MN2O( 6, :, 8) = (/ & + & 3.01673E-01_JPRB, 3.04752E-01_JPRB, 3.07863E-01_JPRB, 3.11005E-01_JPRB, 3.14180E-01_JPRB, & + & 3.17387E-01_JPRB, 3.20626E-01_JPRB, 3.23899E-01_JPRB, 3.27205E-01_JPRB, 3.30545E-01_JPRB, & + & 3.33919E-01_JPRB, 3.37328E-01_JPRB, 3.40771E-01_JPRB, 3.44249E-01_JPRB, 3.47763E-01_JPRB, & + & 3.51313E-01_JPRB, 3.54899E-01_JPRB, 3.58521E-01_JPRB, 3.62181E-01_JPRB/) + KAO_MN2O( 7, :, 8) = (/ & + & 2.99381E-01_JPRB, 3.02431E-01_JPRB, 3.05512E-01_JPRB, 3.08624E-01_JPRB, 3.11768E-01_JPRB, & + & 3.14945E-01_JPRB, 3.18153E-01_JPRB, 3.21394E-01_JPRB, 3.24668E-01_JPRB, 3.27976E-01_JPRB, & + & 3.31317E-01_JPRB, 3.34693E-01_JPRB, 3.38102E-01_JPRB, 3.41547E-01_JPRB, 3.45026E-01_JPRB, & + & 3.48541E-01_JPRB, 3.52092E-01_JPRB, 3.55679E-01_JPRB, 3.59302E-01_JPRB/) + KAO_MN2O( 8, :, 8) = (/ & + & 2.87559E-01_JPRB, 2.89153E-01_JPRB, 2.90756E-01_JPRB, 2.92367E-01_JPRB, 2.93987E-01_JPRB, & + & 2.95617E-01_JPRB, 2.97255E-01_JPRB, 2.98902E-01_JPRB, 3.00559E-01_JPRB, 3.02225E-01_JPRB, & + & 3.03899E-01_JPRB, 3.05584E-01_JPRB, 3.07277E-01_JPRB, 3.08980E-01_JPRB, 3.10693E-01_JPRB, & + & 3.12414E-01_JPRB, 3.14146E-01_JPRB, 3.15887E-01_JPRB, 3.17638E-01_JPRB/) + KAO_MN2O( 9, :, 8) = (/ & + & 2.96238E-01_JPRB, 2.97588E-01_JPRB, 2.98945E-01_JPRB, 3.00309E-01_JPRB, 3.01678E-01_JPRB, & + & 3.03054E-01_JPRB, 3.04436E-01_JPRB, 3.05824E-01_JPRB, 3.07219E-01_JPRB, 3.08620E-01_JPRB, & + & 3.10027E-01_JPRB, 3.11441E-01_JPRB, 3.12861E-01_JPRB, 3.14288E-01_JPRB, 3.15721E-01_JPRB, & + & 3.17161E-01_JPRB, 3.18607E-01_JPRB, 3.20060E-01_JPRB, 3.21520E-01_JPRB/) + KAO_MN2O( 1, :, 9) = (/ & + & 1.56483E+00_JPRB, 1.55792E+00_JPRB, 1.55105E+00_JPRB, 1.54420E+00_JPRB, 1.53739E+00_JPRB, & + & 1.53060E+00_JPRB, 1.52384E+00_JPRB, 1.51712E+00_JPRB, 1.51042E+00_JPRB, 1.50376E+00_JPRB, & + & 1.49712E+00_JPRB, 1.49051E+00_JPRB, 1.48393E+00_JPRB, 1.47738E+00_JPRB, 1.47086E+00_JPRB, & + & 1.46437E+00_JPRB, 1.45791E+00_JPRB, 1.45147E+00_JPRB, 1.44507E+00_JPRB/) + KAO_MN2O( 2, :, 9) = (/ & + & 4.09526E-01_JPRB, 4.10301E-01_JPRB, 4.11078E-01_JPRB, 4.11857E-01_JPRB, 4.12637E-01_JPRB, & + & 4.13418E-01_JPRB, 4.14201E-01_JPRB, 4.14986E-01_JPRB, 4.15771E-01_JPRB, 4.16559E-01_JPRB, & + & 4.17348E-01_JPRB, 4.18138E-01_JPRB, 4.18930E-01_JPRB, 4.19723E-01_JPRB, 4.20518E-01_JPRB, & + & 4.21315E-01_JPRB, 4.22112E-01_JPRB, 4.22912E-01_JPRB, 4.23713E-01_JPRB/) + KAO_MN2O( 3, :, 9) = (/ & + & 3.35672E-01_JPRB, 3.38982E-01_JPRB, 3.42326E-01_JPRB, 3.45702E-01_JPRB, 3.49111E-01_JPRB, & + & 3.52554E-01_JPRB, 3.56031E-01_JPRB, 3.59543E-01_JPRB, 3.63089E-01_JPRB, 3.66670E-01_JPRB, & + & 3.70286E-01_JPRB, 3.73938E-01_JPRB, 3.77626E-01_JPRB, 3.81350E-01_JPRB, 3.85111E-01_JPRB, & + & 3.88909E-01_JPRB, 3.92745E-01_JPRB, 3.96618E-01_JPRB, 4.00530E-01_JPRB/) + KAO_MN2O( 4, :, 9) = (/ & + & 3.19130E-01_JPRB, 3.23028E-01_JPRB, 3.26973E-01_JPRB, 3.30966E-01_JPRB, 3.35008E-01_JPRB, & + & 3.39100E-01_JPRB, 3.43241E-01_JPRB, 3.47433E-01_JPRB, 3.51676E-01_JPRB, 3.55971E-01_JPRB, & + & 3.60319E-01_JPRB, 3.64719E-01_JPRB, 3.69173E-01_JPRB, 3.73682E-01_JPRB, 3.78246E-01_JPRB, & + & 3.82865E-01_JPRB, 3.87541E-01_JPRB, 3.92274E-01_JPRB, 3.97065E-01_JPRB/) + KAO_MN2O( 5, :, 9) = (/ & + & 3.04385E-01_JPRB, 3.07155E-01_JPRB, 3.09949E-01_JPRB, 3.12770E-01_JPRB, 3.15616E-01_JPRB, & + & 3.18488E-01_JPRB, 3.21386E-01_JPRB, 3.24310E-01_JPRB, 3.27261E-01_JPRB, 3.30239E-01_JPRB, & + & 3.33244E-01_JPRB, 3.36276E-01_JPRB, 3.39336E-01_JPRB, 3.42424E-01_JPRB, 3.45540E-01_JPRB, & + & 3.48684E-01_JPRB, 3.51857E-01_JPRB, 3.55059E-01_JPRB, 3.58289E-01_JPRB/) + KAO_MN2O( 6, :, 9) = (/ & + & 2.98789E-01_JPRB, 3.00996E-01_JPRB, 3.03220E-01_JPRB, 3.05460E-01_JPRB, 3.07717E-01_JPRB, & + & 3.09990E-01_JPRB, 3.12281E-01_JPRB, 3.14588E-01_JPRB, 3.16912E-01_JPRB, 3.19253E-01_JPRB, & + & 3.21612E-01_JPRB, 3.23988E-01_JPRB, 3.26382E-01_JPRB, 3.28793E-01_JPRB, 3.31222E-01_JPRB, & + & 3.33669E-01_JPRB, 3.36134E-01_JPRB, 3.38618E-01_JPRB, 3.41119E-01_JPRB/) + KAO_MN2O( 7, :, 9) = (/ & + & 3.08712E-01_JPRB, 3.10491E-01_JPRB, 3.12281E-01_JPRB, 3.14080E-01_JPRB, 3.15890E-01_JPRB, & + & 3.17710E-01_JPRB, 3.19541E-01_JPRB, 3.21382E-01_JPRB, 3.23234E-01_JPRB, 3.25097E-01_JPRB, & + & 3.26970E-01_JPRB, 3.28854E-01_JPRB, 3.30749E-01_JPRB, 3.32655E-01_JPRB, 3.34572E-01_JPRB, & + & 3.36500E-01_JPRB, 3.38439E-01_JPRB, 3.40390E-01_JPRB, 3.42351E-01_JPRB/) + KAO_MN2O( 8, :, 9) = (/ & + & 3.10571E-01_JPRB, 3.12262E-01_JPRB, 3.13961E-01_JPRB, 3.15670E-01_JPRB, 3.17388E-01_JPRB, & + & 3.19115E-01_JPRB, 3.20852E-01_JPRB, 3.22598E-01_JPRB, 3.24354E-01_JPRB, 3.26120E-01_JPRB, & + & 3.27895E-01_JPRB, 3.29679E-01_JPRB, 3.31474E-01_JPRB, 3.33278E-01_JPRB, 3.35092E-01_JPRB, & + & 3.36915E-01_JPRB, 3.38749E-01_JPRB, 3.40593E-01_JPRB, 3.42447E-01_JPRB/) + KAO_MN2O( 9, :, 9) = (/ & + & 3.16436E-01_JPRB, 3.18200E-01_JPRB, 3.19974E-01_JPRB, 3.21759E-01_JPRB, 3.23553E-01_JPRB, & + & 3.25357E-01_JPRB, 3.27172E-01_JPRB, 3.28996E-01_JPRB, 3.30831E-01_JPRB, 3.32675E-01_JPRB, & + & 3.34530E-01_JPRB, 3.36396E-01_JPRB, 3.38272E-01_JPRB, 3.40158E-01_JPRB, 3.42055E-01_JPRB, & + & 3.43962E-01_JPRB, 3.45880E-01_JPRB, 3.47809E-01_JPRB, 3.49749E-01_JPRB/) + KAO_MN2O( 1, :,10) = (/ & + & 7.68616E-01_JPRB, 7.63263E-01_JPRB, 7.57948E-01_JPRB, 7.52669E-01_JPRB, 7.47428E-01_JPRB, & + & 7.42223E-01_JPRB, 7.37054E-01_JPRB, 7.31921E-01_JPRB, 7.26824E-01_JPRB, 7.21762E-01_JPRB, & + & 7.16736E-01_JPRB, 7.11744E-01_JPRB, 7.06788E-01_JPRB, 7.01866E-01_JPRB, 6.96978E-01_JPRB, & + & 6.92124E-01_JPRB, 6.87304E-01_JPRB, 6.82517E-01_JPRB, 6.77764E-01_JPRB/) + KAO_MN2O( 2, :,10) = (/ & + & 4.97271E-01_JPRB, 5.10054E-01_JPRB, 5.23165E-01_JPRB, 5.36614E-01_JPRB, 5.50408E-01_JPRB, & + & 5.64556E-01_JPRB, 5.79069E-01_JPRB, 5.93954E-01_JPRB, 6.09222E-01_JPRB, 6.24883E-01_JPRB, & + & 6.40946E-01_JPRB, 6.57422E-01_JPRB, 6.74321E-01_JPRB, 6.91655E-01_JPRB, 7.09435E-01_JPRB, & + & 7.27671E-01_JPRB, 7.46377E-01_JPRB, 7.65563E-01_JPRB, 7.85242E-01_JPRB/) + KAO_MN2O( 3, :,10) = (/ & + & 2.44443E-01_JPRB, 2.47096E-01_JPRB, 2.49778E-01_JPRB, 2.52489E-01_JPRB, 2.55229E-01_JPRB, & + & 2.57999E-01_JPRB, 2.60799E-01_JPRB, 2.63630E-01_JPRB, 2.66491E-01_JPRB, 2.69383E-01_JPRB, & + & 2.72307E-01_JPRB, 2.75262E-01_JPRB, 2.78250E-01_JPRB, 2.81269E-01_JPRB, 2.84322E-01_JPRB, & + & 2.87408E-01_JPRB, 2.90527E-01_JPRB, 2.93680E-01_JPRB, 2.96868E-01_JPRB/) + KAO_MN2O( 4, :,10) = (/ & + & 2.01964E-01_JPRB, 2.02869E-01_JPRB, 2.03777E-01_JPRB, 2.04690E-01_JPRB, 2.05606E-01_JPRB, & + & 2.06527E-01_JPRB, 2.07452E-01_JPRB, 2.08381E-01_JPRB, 2.09314E-01_JPRB, 2.10251E-01_JPRB, & + & 2.11193E-01_JPRB, 2.12139E-01_JPRB, 2.13089E-01_JPRB, 2.14043E-01_JPRB, 2.15002E-01_JPRB, & + & 2.15964E-01_JPRB, 2.16932E-01_JPRB, 2.17903E-01_JPRB, 2.18879E-01_JPRB/) + KAO_MN2O( 5, :,10) = (/ & + & 2.56972E-01_JPRB, 2.56837E-01_JPRB, 2.56702E-01_JPRB, 2.56567E-01_JPRB, 2.56432E-01_JPRB, & + & 2.56297E-01_JPRB, 2.56162E-01_JPRB, 2.56027E-01_JPRB, 2.55893E-01_JPRB, 2.55758E-01_JPRB, & + & 2.55624E-01_JPRB, 2.55489E-01_JPRB, 2.55355E-01_JPRB, 2.55220E-01_JPRB, 2.55086E-01_JPRB, & + & 2.54952E-01_JPRB, 2.54818E-01_JPRB, 2.54684E-01_JPRB, 2.54550E-01_JPRB/) + KAO_MN2O( 6, :,10) = (/ & + & 2.57322E-01_JPRB, 2.57187E-01_JPRB, 2.57052E-01_JPRB, 2.56917E-01_JPRB, 2.56782E-01_JPRB, & + & 2.56647E-01_JPRB, 2.56512E-01_JPRB, 2.56377E-01_JPRB, 2.56243E-01_JPRB, 2.56108E-01_JPRB, & + & 2.55974E-01_JPRB, 2.55839E-01_JPRB, 2.55705E-01_JPRB, 2.55570E-01_JPRB, 2.55436E-01_JPRB, & + & 2.55302E-01_JPRB, 2.55168E-01_JPRB, 2.55034E-01_JPRB, 2.54900E-01_JPRB/) + KAO_MN2O( 7, :,10) = (/ & + & 2.56551E-01_JPRB, 2.56421E-01_JPRB, 2.56291E-01_JPRB, 2.56161E-01_JPRB, 2.56030E-01_JPRB, & + & 2.55900E-01_JPRB, 2.55770E-01_JPRB, 2.55640E-01_JPRB, 2.55511E-01_JPRB, 2.55381E-01_JPRB, & + & 2.55251E-01_JPRB, 2.55121E-01_JPRB, 2.54992E-01_JPRB, 2.54862E-01_JPRB, 2.54733E-01_JPRB, & + & 2.54603E-01_JPRB, 2.54474E-01_JPRB, 2.54345E-01_JPRB, 2.54215E-01_JPRB/) + KAO_MN2O( 8, :,10) = (/ & + & 2.73629E-01_JPRB, 2.73460E-01_JPRB, 2.73291E-01_JPRB, 2.73122E-01_JPRB, 2.72953E-01_JPRB, & + & 2.72784E-01_JPRB, 2.72615E-01_JPRB, 2.72447E-01_JPRB, 2.72279E-01_JPRB, 2.72110E-01_JPRB, & + & 2.71942E-01_JPRB, 2.71774E-01_JPRB, 2.71606E-01_JPRB, 2.71438E-01_JPRB, 2.71270E-01_JPRB, & + & 2.71102E-01_JPRB, 2.70935E-01_JPRB, 2.70767E-01_JPRB, 2.70600E-01_JPRB/) + KAO_MN2O( 9, :,10) = (/ & + & 2.57294E-01_JPRB, 2.57149E-01_JPRB, 2.57004E-01_JPRB, 2.56860E-01_JPRB, 2.56715E-01_JPRB, & + & 2.56570E-01_JPRB, 2.56426E-01_JPRB, 2.56282E-01_JPRB, 2.56137E-01_JPRB, 2.55993E-01_JPRB, & + & 2.55849E-01_JPRB, 2.55705E-01_JPRB, 2.55561E-01_JPRB, 2.55417E-01_JPRB, 2.55273E-01_JPRB, & + & 2.55129E-01_JPRB, 2.54986E-01_JPRB, 2.54842E-01_JPRB, 2.54698E-01_JPRB/) + KAO_MN2O( 1, :,11) = (/ & + & 6.91062E-01_JPRB, 6.84151E-01_JPRB, 6.77309E-01_JPRB, 6.70535E-01_JPRB, 6.63829E-01_JPRB, & + & 6.57190E-01_JPRB, 6.50617E-01_JPRB, 6.44111E-01_JPRB, 6.37669E-01_JPRB, 6.31292E-01_JPRB, & + & 6.24978E-01_JPRB, 6.18728E-01_JPRB, 6.12540E-01_JPRB, 6.06414E-01_JPRB, 6.00349E-01_JPRB, & + & 5.94345E-01_JPRB, 5.88401E-01_JPRB, 5.82517E-01_JPRB, 5.76691E-01_JPRB/) + KAO_MN2O( 2, :,11) = (/ & + & 1.98698E-01_JPRB, 2.01182E-01_JPRB, 2.03698E-01_JPRB, 2.06244E-01_JPRB, 2.08823E-01_JPRB, & + & 2.11433E-01_JPRB, 2.14077E-01_JPRB, 2.16753E-01_JPRB, 2.19463E-01_JPRB, 2.22207E-01_JPRB, & + & 2.24985E-01_JPRB, 2.27798E-01_JPRB, 2.30646E-01_JPRB, 2.33529E-01_JPRB, 2.36449E-01_JPRB, & + & 2.39405E-01_JPRB, 2.42398E-01_JPRB, 2.45429E-01_JPRB, 2.48497E-01_JPRB/) + KAO_MN2O( 3, :,11) = (/ & + & 2.11950E-01_JPRB, 2.13560E-01_JPRB, 2.15184E-01_JPRB, 2.16819E-01_JPRB, 2.18467E-01_JPRB, & + & 2.20127E-01_JPRB, 2.21800E-01_JPRB, 2.23486E-01_JPRB, 2.25185E-01_JPRB, 2.26896E-01_JPRB, & + & 2.28621E-01_JPRB, 2.30358E-01_JPRB, 2.32109E-01_JPRB, 2.33873E-01_JPRB, 2.35651E-01_JPRB, & + & 2.37442E-01_JPRB, 2.39247E-01_JPRB, 2.41065E-01_JPRB, 2.42897E-01_JPRB/) + KAO_MN2O( 4, :,11) = (/ & + & 3.14210E-01_JPRB, 3.13143E-01_JPRB, 3.12080E-01_JPRB, 3.11021E-01_JPRB, 3.09965E-01_JPRB, & + & 3.08913E-01_JPRB, 3.07864E-01_JPRB, 3.06819E-01_JPRB, 3.05777E-01_JPRB, 3.04739E-01_JPRB, & + & 3.03705E-01_JPRB, 3.02674E-01_JPRB, 3.01646E-01_JPRB, 3.00622E-01_JPRB, 2.99602E-01_JPRB, & + & 2.98584E-01_JPRB, 2.97571E-01_JPRB, 2.96561E-01_JPRB, 2.95554E-01_JPRB/) + KAO_MN2O( 5, :,11) = (/ & + & 3.13536E-01_JPRB, 3.12459E-01_JPRB, 3.11386E-01_JPRB, 3.10316E-01_JPRB, 3.09250E-01_JPRB, & + & 3.08188E-01_JPRB, 3.07129E-01_JPRB, 3.06074E-01_JPRB, 3.05022E-01_JPRB, 3.03974E-01_JPRB, & + & 3.02930E-01_JPRB, 3.01889E-01_JPRB, 3.00852E-01_JPRB, 2.99819E-01_JPRB, 2.98789E-01_JPRB, & + & 2.97762E-01_JPRB, 2.96739E-01_JPRB, 2.95720E-01_JPRB, 2.94704E-01_JPRB/) + KAO_MN2O( 6, :,11) = (/ & + & 3.13215E-01_JPRB, 3.12123E-01_JPRB, 3.11034E-01_JPRB, 3.09949E-01_JPRB, 3.08867E-01_JPRB, & + & 3.07790E-01_JPRB, 3.06716E-01_JPRB, 3.05646E-01_JPRB, 3.04579E-01_JPRB, 3.03517E-01_JPRB, & + & 3.02458E-01_JPRB, 3.01403E-01_JPRB, 3.00351E-01_JPRB, 2.99303E-01_JPRB, 2.98259E-01_JPRB, & + & 2.97219E-01_JPRB, 2.96182E-01_JPRB, 2.95148E-01_JPRB, 2.94119E-01_JPRB/) + KAO_MN2O( 7, :,11) = (/ & + & 3.14236E-01_JPRB, 3.13123E-01_JPRB, 3.12014E-01_JPRB, 3.10908E-01_JPRB, 3.09806E-01_JPRB, & + & 3.08709E-01_JPRB, 3.07615E-01_JPRB, 3.06525E-01_JPRB, 3.05439E-01_JPRB, 3.04357E-01_JPRB, & + & 3.03278E-01_JPRB, 3.02204E-01_JPRB, 3.01133E-01_JPRB, 3.00066E-01_JPRB, 2.99003E-01_JPRB, & + & 2.97944E-01_JPRB, 2.96888E-01_JPRB, 2.95836E-01_JPRB, 2.94788E-01_JPRB/) + KAO_MN2O( 8, :,11) = (/ & + & 2.97453E-01_JPRB, 2.96420E-01_JPRB, 2.95391E-01_JPRB, 2.94366E-01_JPRB, 2.93344E-01_JPRB, & + & 2.92325E-01_JPRB, 2.91311E-01_JPRB, 2.90299E-01_JPRB, 2.89291E-01_JPRB, 2.88287E-01_JPRB, & + & 2.87286E-01_JPRB, 2.86289E-01_JPRB, 2.85295E-01_JPRB, 2.84304E-01_JPRB, 2.83317E-01_JPRB, & + & 2.82334E-01_JPRB, 2.81354E-01_JPRB, 2.80377E-01_JPRB, 2.79404E-01_JPRB/) + KAO_MN2O( 9, :,11) = (/ & + & 3.12694E-01_JPRB, 3.11622E-01_JPRB, 3.10554E-01_JPRB, 3.09489E-01_JPRB, 3.08428E-01_JPRB, & + & 3.07370E-01_JPRB, 3.06316E-01_JPRB, 3.05266E-01_JPRB, 3.04220E-01_JPRB, 3.03177E-01_JPRB, & + & 3.02137E-01_JPRB, 3.01101E-01_JPRB, 3.00069E-01_JPRB, 2.99040E-01_JPRB, 2.98015E-01_JPRB, & + & 2.96993E-01_JPRB, 2.95975E-01_JPRB, 2.94960E-01_JPRB, 2.93949E-01_JPRB/) + KAO_MN2O( 1, :,12) = (/ & + & 5.30796E-01_JPRB, 5.50444E-01_JPRB, 5.70818E-01_JPRB, 5.91947E-01_JPRB, 6.13857E-01_JPRB, & + & 6.36579E-01_JPRB, 6.60142E-01_JPRB, 6.84577E-01_JPRB, 7.09916E-01_JPRB, 7.36194E-01_JPRB, & + & 7.63444E-01_JPRB, 7.91702E-01_JPRB, 8.21007E-01_JPRB, 8.51396E-01_JPRB, 8.82910E-01_JPRB, & + & 9.15591E-01_JPRB, 9.49481E-01_JPRB, 9.84626E-01_JPRB, 1.02107E+00_JPRB/) + KAO_MN2O( 2, :,12) = (/ & + & 1.38469E-01_JPRB, 1.40959E-01_JPRB, 1.43493E-01_JPRB, 1.46073E-01_JPRB, 1.48699E-01_JPRB, & + & 1.51373E-01_JPRB, 1.54094E-01_JPRB, 1.56865E-01_JPRB, 1.59685E-01_JPRB, 1.62556E-01_JPRB, & + & 1.65478E-01_JPRB, 1.68454E-01_JPRB, 1.71482E-01_JPRB, 1.74565E-01_JPRB, 1.77704E-01_JPRB, & + & 1.80899E-01_JPRB, 1.84151E-01_JPRB, 1.87462E-01_JPRB, 1.90833E-01_JPRB/) + KAO_MN2O( 3, :,12) = (/ & + & 1.50741E-01_JPRB, 1.50855E-01_JPRB, 1.50969E-01_JPRB, 1.51084E-01_JPRB, 1.51198E-01_JPRB, & + & 1.51313E-01_JPRB, 1.51427E-01_JPRB, 1.51542E-01_JPRB, 1.51657E-01_JPRB, 1.51772E-01_JPRB, & + & 1.51887E-01_JPRB, 1.52002E-01_JPRB, 1.52117E-01_JPRB, 1.52233E-01_JPRB, 1.52348E-01_JPRB, & + & 1.52463E-01_JPRB, 1.52579E-01_JPRB, 1.52695E-01_JPRB, 1.52810E-01_JPRB/) + KAO_MN2O( 4, :,12) = (/ & + & 1.80444E-01_JPRB, 1.79944E-01_JPRB, 1.79445E-01_JPRB, 1.78948E-01_JPRB, 1.78452E-01_JPRB, & + & 1.77958E-01_JPRB, 1.77465E-01_JPRB, 1.76973E-01_JPRB, 1.76483E-01_JPRB, 1.75994E-01_JPRB, & + & 1.75506E-01_JPRB, 1.75020E-01_JPRB, 1.74535E-01_JPRB, 1.74051E-01_JPRB, 1.73569E-01_JPRB, & + & 1.73088E-01_JPRB, 1.72609E-01_JPRB, 1.72131E-01_JPRB, 1.71654E-01_JPRB/) + KAO_MN2O( 5, :,12) = (/ & + & 1.80595E-01_JPRB, 1.80033E-01_JPRB, 1.79474E-01_JPRB, 1.78916E-01_JPRB, 1.78359E-01_JPRB, & + & 1.77805E-01_JPRB, 1.77252E-01_JPRB, 1.76701E-01_JPRB, 1.76152E-01_JPRB, 1.75604E-01_JPRB, & + & 1.75058E-01_JPRB, 1.74514E-01_JPRB, 1.73971E-01_JPRB, 1.73430E-01_JPRB, 1.72891E-01_JPRB, & + & 1.72354E-01_JPRB, 1.71818E-01_JPRB, 1.71284E-01_JPRB, 1.70751E-01_JPRB/) + KAO_MN2O( 6, :,12) = (/ & + & 1.79904E-01_JPRB, 1.79254E-01_JPRB, 1.78607E-01_JPRB, 1.77962E-01_JPRB, 1.77320E-01_JPRB, & + & 1.76680E-01_JPRB, 1.76042E-01_JPRB, 1.75406E-01_JPRB, 1.74773E-01_JPRB, 1.74142E-01_JPRB, & + & 1.73513E-01_JPRB, 1.72887E-01_JPRB, 1.72262E-01_JPRB, 1.71640E-01_JPRB, 1.71021E-01_JPRB, & + & 1.70403E-01_JPRB, 1.69788E-01_JPRB, 1.69175E-01_JPRB, 1.68564E-01_JPRB/) + KAO_MN2O( 7, :,12) = (/ & + & 1.78712E-01_JPRB, 1.77868E-01_JPRB, 1.77027E-01_JPRB, 1.76190E-01_JPRB, 1.75357E-01_JPRB, & + & 1.74528E-01_JPRB, 1.73703E-01_JPRB, 1.72882E-01_JPRB, 1.72064E-01_JPRB, 1.71251E-01_JPRB, & + & 1.70441E-01_JPRB, 1.69636E-01_JPRB, 1.68834E-01_JPRB, 1.68036E-01_JPRB, 1.67241E-01_JPRB, & + & 1.66451E-01_JPRB, 1.65664E-01_JPRB, 1.64881E-01_JPRB, 1.64101E-01_JPRB/) + KAO_MN2O( 8, :,12) = (/ & + & 1.72346E-01_JPRB, 1.70873E-01_JPRB, 1.69413E-01_JPRB, 1.67965E-01_JPRB, 1.66530E-01_JPRB, & + & 1.65107E-01_JPRB, 1.63696E-01_JPRB, 1.62297E-01_JPRB, 1.60910E-01_JPRB, 1.59535E-01_JPRB, & + & 1.58171E-01_JPRB, 1.56819E-01_JPRB, 1.55479E-01_JPRB, 1.54150E-01_JPRB, 1.52833E-01_JPRB, & + & 1.51527E-01_JPRB, 1.50232E-01_JPRB, 1.48948E-01_JPRB, 1.47675E-01_JPRB/) + KAO_MN2O( 9, :,12) = (/ & + & 1.80517E-01_JPRB, 1.79951E-01_JPRB, 1.79386E-01_JPRB, 1.78823E-01_JPRB, 1.78262E-01_JPRB, & + & 1.77702E-01_JPRB, 1.77144E-01_JPRB, 1.76588E-01_JPRB, 1.76034E-01_JPRB, 1.75481E-01_JPRB, & + & 1.74931E-01_JPRB, 1.74382E-01_JPRB, 1.73834E-01_JPRB, 1.73289E-01_JPRB, 1.72745E-01_JPRB, & + & 1.72202E-01_JPRB, 1.71662E-01_JPRB, 1.71123E-01_JPRB, 1.70586E-01_JPRB/) + KAO_MN2O( 1, :,13) = (/ & + & 2.41966E-01_JPRB, 2.50534E-01_JPRB, 2.59406E-01_JPRB, 2.68591E-01_JPRB, 2.78102E-01_JPRB, & + & 2.87950E-01_JPRB, 2.98146E-01_JPRB, 3.08704E-01_JPRB, 3.19635E-01_JPRB, 3.30953E-01_JPRB, & + & 3.42672E-01_JPRB, 3.54806E-01_JPRB, 3.67370E-01_JPRB, 3.80379E-01_JPRB, 3.93848E-01_JPRB, & + & 4.07794E-01_JPRB, 4.22234E-01_JPRB, 4.37186E-01_JPRB, 4.52667E-01_JPRB/) + KAO_MN2O( 2, :,13) = (/ & + & 1.54385E-01_JPRB, 1.54015E-01_JPRB, 1.53646E-01_JPRB, 1.53279E-01_JPRB, 1.52912E-01_JPRB, & + & 1.52545E-01_JPRB, 1.52180E-01_JPRB, 1.51816E-01_JPRB, 1.51452E-01_JPRB, 1.51089E-01_JPRB, & + & 1.50728E-01_JPRB, 1.50367E-01_JPRB, 1.50007E-01_JPRB, 1.49647E-01_JPRB, 1.49289E-01_JPRB, & + & 1.48932E-01_JPRB, 1.48575E-01_JPRB, 1.48219E-01_JPRB, 1.47864E-01_JPRB/) + KAO_MN2O( 3, :,13) = (/ & + & 2.00518E-01_JPRB, 1.94901E-01_JPRB, 1.89442E-01_JPRB, 1.84136E-01_JPRB, 1.78978E-01_JPRB, & + & 1.73965E-01_JPRB, 1.69092E-01_JPRB, 1.64356E-01_JPRB, 1.59752E-01_JPRB, 1.55278E-01_JPRB, & + & 1.50928E-01_JPRB, 1.46701E-01_JPRB, 1.42592E-01_JPRB, 1.38598E-01_JPRB, 1.34715E-01_JPRB, & + & 1.30942E-01_JPRB, 1.27274E-01_JPRB, 1.23709E-01_JPRB, 1.20244E-01_JPRB/) + KAO_MN2O( 4, :,13) = (/ & + & 2.03974E-01_JPRB, 1.98258E-01_JPRB, 1.92703E-01_JPRB, 1.87302E-01_JPRB, 1.82054E-01_JPRB, & + & 1.76952E-01_JPRB, 1.71993E-01_JPRB, 1.67173E-01_JPRB, 1.62489E-01_JPRB, 1.57935E-01_JPRB, & + & 1.53509E-01_JPRB, 1.49207E-01_JPRB, 1.45026E-01_JPRB, 1.40962E-01_JPRB, 1.37012E-01_JPRB, & + & 1.33172E-01_JPRB, 1.29440E-01_JPRB, 1.25813E-01_JPRB, 1.22287E-01_JPRB/) + KAO_MN2O( 5, :,13) = (/ & + & 2.09410E-01_JPRB, 2.03543E-01_JPRB, 1.97841E-01_JPRB, 1.92298E-01_JPRB, 1.86911E-01_JPRB, & + & 1.81674E-01_JPRB, 1.76585E-01_JPRB, 1.71637E-01_JPRB, 1.66829E-01_JPRB, 1.62155E-01_JPRB, & + & 1.57612E-01_JPRB, 1.53196E-01_JPRB, 1.48904E-01_JPRB, 1.44733E-01_JPRB, 1.40678E-01_JPRB, & + & 1.36736E-01_JPRB, 1.32906E-01_JPRB, 1.29182E-01_JPRB, 1.25563E-01_JPRB/) + KAO_MN2O( 6, :,13) = (/ & + & 2.19808E-01_JPRB, 2.13643E-01_JPRB, 2.07651E-01_JPRB, 2.01827E-01_JPRB, 1.96166E-01_JPRB, & + & 1.90664E-01_JPRB, 1.85317E-01_JPRB, 1.80119E-01_JPRB, 1.75067E-01_JPRB, 1.70157E-01_JPRB, & + & 1.65385E-01_JPRB, 1.60746E-01_JPRB, 1.56238E-01_JPRB, 1.51856E-01_JPRB, 1.47596E-01_JPRB, & + & 1.43457E-01_JPRB, 1.39433E-01_JPRB, 1.35523E-01_JPRB, 1.31722E-01_JPRB/) + KAO_MN2O( 7, :,13) = (/ & + & 2.47074E-01_JPRB, 2.40127E-01_JPRB, 2.33375E-01_JPRB, 2.26813E-01_JPRB, 2.20436E-01_JPRB, & + & 2.14238E-01_JPRB, 2.08215E-01_JPRB, 2.02360E-01_JPRB, 1.96671E-01_JPRB, 1.91141E-01_JPRB, & + & 1.85767E-01_JPRB, 1.80544E-01_JPRB, 1.75467E-01_JPRB, 1.70534E-01_JPRB, 1.65739E-01_JPRB, & + & 1.61079E-01_JPRB, 1.56550E-01_JPRB, 1.52148E-01_JPRB, 1.47870E-01_JPRB/) + KAO_MN2O( 8, :,13) = (/ & + & 2.55282E-01_JPRB, 2.48105E-01_JPRB, 2.41130E-01_JPRB, 2.34350E-01_JPRB, 2.27762E-01_JPRB, & + & 2.21358E-01_JPRB, 2.15135E-01_JPRB, 2.09086E-01_JPRB, 2.03208E-01_JPRB, 1.97495E-01_JPRB, & + & 1.91942E-01_JPRB, 1.86546E-01_JPRB, 1.81301E-01_JPRB, 1.76204E-01_JPRB, 1.71250E-01_JPRB, & + & 1.66435E-01_JPRB, 1.61756E-01_JPRB, 1.57208E-01_JPRB, 1.52788E-01_JPRB/) + KAO_MN2O( 9, :,13) = (/ & + & 2.09991E-01_JPRB, 2.04103E-01_JPRB, 1.98380E-01_JPRB, 1.92818E-01_JPRB, 1.87411E-01_JPRB, & + & 1.82156E-01_JPRB, 1.77048E-01_JPRB, 1.72084E-01_JPRB, 1.67259E-01_JPRB, 1.62569E-01_JPRB, & + & 1.58010E-01_JPRB, 1.53580E-01_JPRB, 1.49273E-01_JPRB, 1.45087E-01_JPRB, 1.41019E-01_JPRB, & + & 1.37065E-01_JPRB, 1.33222E-01_JPRB, 1.29486E-01_JPRB, 1.25855E-01_JPRB/) + KAO_MN2O( 1, :,14) = (/ & + & 9.08340E-02_JPRB, 9.50421E-02_JPRB, 9.94452E-02_JPRB, 1.04052E-01_JPRB, 1.08873E-01_JPRB, & + & 1.13917E-01_JPRB, 1.19194E-01_JPRB, 1.24716E-01_JPRB, 1.30494E-01_JPRB, 1.36540E-01_JPRB, & + & 1.42865E-01_JPRB, 1.49484E-01_JPRB, 1.56409E-01_JPRB, 1.63655E-01_JPRB, 1.71237E-01_JPRB, & + & 1.79170E-01_JPRB, 1.87471E-01_JPRB, 1.96156E-01_JPRB, 2.05243E-01_JPRB/) + KAO_MN2O( 2, :,14) = (/ & + & 3.36945E-02_JPRB, 3.45144E-02_JPRB, 3.53542E-02_JPRB, 3.62144E-02_JPRB, 3.70956E-02_JPRB, & + & 3.79982E-02_JPRB, 3.89228E-02_JPRB, 3.98698E-02_JPRB, 4.08399E-02_JPRB, 4.18336E-02_JPRB, & + & 4.28515E-02_JPRB, 4.38942E-02_JPRB, 4.49622E-02_JPRB, 4.60562E-02_JPRB, 4.71769E-02_JPRB, & + & 4.83248E-02_JPRB, 4.95006E-02_JPRB, 5.07051E-02_JPRB, 5.19388E-02_JPRB/) + KAO_MN2O( 3, :,14) = (/ & + & 9.11678E-02_JPRB, 8.85761E-02_JPRB, 8.60580E-02_JPRB, 8.36116E-02_JPRB, 8.12347E-02_JPRB, & + & 7.89253E-02_JPRB, 7.66817E-02_JPRB, 7.45017E-02_JPRB, 7.23838E-02_JPRB, 7.03261E-02_JPRB, & + & 6.83269E-02_JPRB, 6.63845E-02_JPRB, 6.44973E-02_JPRB, 6.26638E-02_JPRB, 6.08824E-02_JPRB, & + & 5.91516E-02_JPRB, 5.74700E-02_JPRB, 5.58363E-02_JPRB, 5.42490E-02_JPRB/) + KAO_MN2O( 4, :,14) = (/ & + & 8.43999E-02_JPRB, 8.20004E-02_JPRB, 7.96692E-02_JPRB, 7.74042E-02_JPRB, 7.52037E-02_JPRB, & + & 7.30656E-02_JPRB, 7.09884E-02_JPRB, 6.89702E-02_JPRB, 6.70094E-02_JPRB, 6.51044E-02_JPRB, & + & 6.32535E-02_JPRB, 6.14552E-02_JPRB, 5.97081E-02_JPRB, 5.80106E-02_JPRB, 5.63614E-02_JPRB, & + & 5.47590E-02_JPRB, 5.32022E-02_JPRB, 5.16897E-02_JPRB, 5.02202E-02_JPRB/) + KAO_MN2O( 5, :,14) = (/ & + & 7.41279E-02_JPRB, 7.20196E-02_JPRB, 6.99712E-02_JPRB, 6.79811E-02_JPRB, 6.60476E-02_JPRB, & + & 6.41691E-02_JPRB, 6.23440E-02_JPRB, 6.05708E-02_JPRB, 5.88481E-02_JPRB, 5.71743E-02_JPRB, & + & 5.55482E-02_JPRB, 5.39683E-02_JPRB, 5.24334E-02_JPRB, 5.09421E-02_JPRB, 4.94932E-02_JPRB, & + & 4.80855E-02_JPRB, 4.67179E-02_JPRB, 4.53891E-02_JPRB, 4.40982E-02_JPRB/) + KAO_MN2O( 6, :,14) = (/ & + & 5.66805E-02_JPRB, 5.50676E-02_JPRB, 5.35006E-02_JPRB, 5.19782E-02_JPRB, 5.04991E-02_JPRB, & + & 4.90621E-02_JPRB, 4.76659E-02_JPRB, 4.63096E-02_JPRB, 4.49918E-02_JPRB, 4.37115E-02_JPRB, & + & 4.24676E-02_JPRB, 4.12592E-02_JPRB, 4.00851E-02_JPRB, 3.89444E-02_JPRB, 3.78362E-02_JPRB, & + & 3.67595E-02_JPRB, 3.57135E-02_JPRB, 3.46972E-02_JPRB, 3.37099E-02_JPRB/) + KAO_MN2O( 7, :,14) = (/ & + & 1.23018E-02_JPRB, 1.19517E-02_JPRB, 1.16116E-02_JPRB, 1.12811E-02_JPRB, 1.09601E-02_JPRB, & + & 1.06482E-02_JPRB, 1.03452E-02_JPRB, 1.00508E-02_JPRB, 9.76474E-03_JPRB, 9.48685E-03_JPRB, & + & 9.21687E-03_JPRB, 8.95458E-03_JPRB, 8.69974E-03_JPRB, 8.45216E-03_JPRB, 8.21163E-03_JPRB, & + & 7.97794E-03_JPRB, 7.75091E-03_JPRB, 7.53033E-03_JPRB, 7.31603E-03_JPRB/) + KAO_MN2O( 8, :,14) = (/ & + & 3.22403E-07_JPRB, 3.75986E-07_JPRB, 4.38475E-07_JPRB, 5.11349E-07_JPRB, 5.96335E-07_JPRB, & + & 6.95446E-07_JPRB, 8.11028E-07_JPRB, 9.45821E-07_JPRB, 1.10302E-06_JPRB, 1.28634E-06_JPRB, & + & 1.50012E-06_JPRB, 1.74944E-06_JPRB, 2.04020E-06_JPRB, 2.37928E-06_JPRB, 2.77472E-06_JPRB, & + & 3.23587E-06_JPRB, 3.77367E-06_JPRB, 4.40085E-06_JPRB, 5.13227E-06_JPRB/) + KAO_MN2O( 9, :,14) = (/ & + & 7.33052E-02_JPRB, 7.12199E-02_JPRB, 6.91939E-02_JPRB, 6.72255E-02_JPRB, 6.53131E-02_JPRB, & + & 6.34551E-02_JPRB, 6.16500E-02_JPRB, 5.98963E-02_JPRB, 5.81924E-02_JPRB, 5.65370E-02_JPRB, & + & 5.49287E-02_JPRB, 5.33661E-02_JPRB, 5.18480E-02_JPRB, 5.03730E-02_JPRB, 4.89401E-02_JPRB, & + & 4.75479E-02_JPRB, 4.61953E-02_JPRB, 4.48811E-02_JPRB, 4.36044E-02_JPRB/) + KAO_MN2O( 1, :,15) = (/ & + & 8.80247E-02_JPRB, 9.01793E-02_JPRB, 9.23868E-02_JPRB, 9.46482E-02_JPRB, 9.69650E-02_JPRB, & + & 9.93385E-02_JPRB, 1.01770E-01_JPRB, 1.04261E-01_JPRB, 1.06813E-01_JPRB, 1.09428E-01_JPRB, & + & 1.12107E-01_JPRB, 1.14851E-01_JPRB, 1.17662E-01_JPRB, 1.20542E-01_JPRB, 1.23493E-01_JPRB, & + & 1.26516E-01_JPRB, 1.29613E-01_JPRB, 1.32785E-01_JPRB, 1.36036E-01_JPRB/) + KAO_MN2O( 2, :,15) = (/ & + & 3.89107E-07_JPRB, 4.53768E-07_JPRB, 5.29173E-07_JPRB, 6.17109E-07_JPRB, 7.19658E-07_JPRB, & + & 8.39248E-07_JPRB, 9.78710E-07_JPRB, 1.14135E-06_JPRB, 1.33101E-06_JPRB, 1.55220E-06_JPRB, & + & 1.81013E-06_JPRB, 2.11094E-06_JPRB, 2.46172E-06_JPRB, 2.87080E-06_JPRB, 3.34786E-06_JPRB, & + & 3.90420E-06_JPRB, 4.55298E-06_JPRB, 5.30958E-06_JPRB, 6.19190E-06_JPRB/) + KAO_MN2O( 3, :,15) = (/ & + & 3.86537E-07_JPRB, 4.50763E-07_JPRB, 5.25662E-07_JPRB, 6.13006E-07_JPRB, 7.14863E-07_JPRB, & + & 8.33644E-07_JPRB, 9.72162E-07_JPRB, 1.13370E-06_JPRB, 1.32207E-06_JPRB, 1.54175E-06_JPRB, & + & 1.79792E-06_JPRB, 2.09666E-06_JPRB, 2.44504E-06_JPRB, 2.85131E-06_JPRB, 3.32508E-06_JPRB, & + & 3.87758E-06_JPRB, 4.52188E-06_JPRB, 5.27323E-06_JPRB, 6.14943E-06_JPRB/) + KAO_MN2O( 4, :,15) = (/ & + & 3.81913E-07_JPRB, 4.45369E-07_JPRB, 5.19369E-07_JPRB, 6.05664E-07_JPRB, 7.06297E-07_JPRB, & + & 8.23651E-07_JPRB, 9.60503E-07_JPRB, 1.12009E-06_JPRB, 1.30620E-06_JPRB, 1.52323E-06_JPRB, & + & 1.77632E-06_JPRB, 2.07147E-06_JPRB, 2.41565E-06_JPRB, 2.81701E-06_JPRB, 3.28507E-06_JPRB, & + & 3.83090E-06_JPRB, 4.46741E-06_JPRB, 5.20969E-06_JPRB, 6.07529E-06_JPRB/) + KAO_MN2O( 5, :,15) = (/ & + & 3.77265E-07_JPRB, 4.39951E-07_JPRB, 5.13053E-07_JPRB, 5.98303E-07_JPRB, 6.97717E-07_JPRB, & + & 8.13650E-07_JPRB, 9.48846E-07_JPRB, 1.10651E-06_JPRB, 1.29036E-06_JPRB, 1.50477E-06_JPRB, & + & 1.75480E-06_JPRB, 2.04638E-06_JPRB, 2.38641E-06_JPRB, 2.78294E-06_JPRB, 3.24535E-06_JPRB, & + & 3.78460E-06_JPRB, 4.41345E-06_JPRB, 5.14679E-06_JPRB, 6.00198E-06_JPRB/) + KAO_MN2O( 6, :,15) = (/ & + & 3.77877E-07_JPRB, 4.40670E-07_JPRB, 5.13897E-07_JPRB, 5.99292E-07_JPRB, 6.98878E-07_JPRB, & + & 8.15012E-07_JPRB, 9.50444E-07_JPRB, 1.10838E-06_JPRB, 1.29256E-06_JPRB, 1.50735E-06_JPRB, & + & 1.75783E-06_JPRB, 2.04993E-06_JPRB, 2.39057E-06_JPRB, 2.78782E-06_JPRB, 3.25107E-06_JPRB, & + & 3.79131E-06_JPRB, 4.42132E-06_JPRB, 5.15602E-06_JPRB, 6.01280E-06_JPRB/) + KAO_MN2O( 7, :,15) = (/ & + & 3.80495E-07_JPRB, 4.43726E-07_JPRB, 5.17465E-07_JPRB, 6.03458E-07_JPRB, 7.03741E-07_JPRB, & + & 8.20689E-07_JPRB, 9.57072E-07_JPRB, 1.11612E-06_JPRB, 1.30160E-06_JPRB, 1.51790E-06_JPRB, & + & 1.77014E-06_JPRB, 2.06430E-06_JPRB, 2.40735E-06_JPRB, 2.80741E-06_JPRB, 3.27394E-06_JPRB, & + & 3.81801E-06_JPRB, 4.45249E-06_JPRB, 5.19241E-06_JPRB, 6.05528E-06_JPRB/) + KAO_MN2O( 8, :,15) = (/ & + & 3.87881E-07_JPRB, 4.52329E-07_JPRB, 5.27486E-07_JPRB, 6.15129E-07_JPRB, 7.17335E-07_JPRB, & + & 8.36523E-07_JPRB, 9.75515E-07_JPRB, 1.13760E-06_JPRB, 1.32662E-06_JPRB, 1.54704E-06_JPRB, & + & 1.80409E-06_JPRB, 2.10384E-06_JPRB, 2.45340E-06_JPRB, 2.86105E-06_JPRB, 3.33642E-06_JPRB, & + & 3.89078E-06_JPRB, 4.53725E-06_JPRB, 5.29112E-06_JPRB, 6.17026E-06_JPRB/) + KAO_MN2O( 9, :,15) = (/ & + & 3.77265E-07_JPRB, 4.39951E-07_JPRB, 5.13053E-07_JPRB, 5.98303E-07_JPRB, 6.97717E-07_JPRB, & + & 8.13650E-07_JPRB, 9.48846E-07_JPRB, 1.10651E-06_JPRB, 1.29036E-06_JPRB, 1.50477E-06_JPRB, & + & 1.75480E-06_JPRB, 2.04638E-06_JPRB, 2.38641E-06_JPRB, 2.78294E-06_JPRB, 3.24535E-06_JPRB, & + & 3.78460E-06_JPRB, 4.41345E-06_JPRB, 5.14679E-06_JPRB, 6.00198E-06_JPRB/) + KAO_MN2O( 1, :,16) = (/ & + & 8.84606E-02_JPRB, 9.05971E-02_JPRB, 9.27852E-02_JPRB, 9.50261E-02_JPRB, 9.73212E-02_JPRB, & + & 9.96717E-02_JPRB, 1.02079E-01_JPRB, 1.04544E-01_JPRB, 1.07069E-01_JPRB, 1.09655E-01_JPRB, & + & 1.12304E-01_JPRB, 1.15016E-01_JPRB, 1.17794E-01_JPRB, 1.20639E-01_JPRB, 1.23553E-01_JPRB, & + & 1.26537E-01_JPRB, 1.29593E-01_JPRB, 1.32723E-01_JPRB, 1.35928E-01_JPRB/) + KAO_MN2O( 2, :,16) = (/ & + & 8.13898E-07_JPRB, 9.49130E-07_JPRB, 1.10683E-06_JPRB, 1.29073E-06_JPRB, 1.50519E-06_JPRB, & + & 1.75528E-06_JPRB, 2.04693E-06_JPRB, 2.38703E-06_JPRB, 2.78364E-06_JPRB, 3.24615E-06_JPRB, & + & 3.78551E-06_JPRB, 4.41449E-06_JPRB, 5.14796E-06_JPRB, 6.00331E-06_JPRB, 7.00078E-06_JPRB, & + & 8.16398E-06_JPRB, 9.52045E-06_JPRB, 1.11023E-05_JPRB, 1.29470E-05_JPRB/) + KAO_MN2O( 3, :,16) = (/ & + & 8.32666E-07_JPRB, 9.71021E-07_JPRB, 1.13237E-06_JPRB, 1.32052E-06_JPRB, 1.53994E-06_JPRB, & + & 1.79581E-06_JPRB, 2.09420E-06_JPRB, 2.44217E-06_JPRB, 2.84796E-06_JPRB, 3.32117E-06_JPRB, & + & 3.87302E-06_JPRB, 4.51656E-06_JPRB, 5.26703E-06_JPRB, 6.14219E-06_JPRB, 7.16277E-06_JPRB, & + & 8.35294E-06_JPRB, 9.74086E-06_JPRB, 1.13594E-05_JPRB, 1.32468E-05_JPRB/) + KAO_MN2O( 4, :,16) = (/ & + & 8.70348E-07_JPRB, 1.01496E-06_JPRB, 1.18360E-06_JPRB, 1.38026E-06_JPRB, 1.60959E-06_JPRB, & + & 1.87703E-06_JPRB, 2.18890E-06_JPRB, 2.55259E-06_JPRB, 2.97671E-06_JPRB, 3.47130E-06_JPRB, & + & 4.04807E-06_JPRB, 4.72067E-06_JPRB, 5.50502E-06_JPRB, 6.41970E-06_JPRB, 7.48635E-06_JPRB, & + & 8.73023E-06_JPRB, 1.01808E-05_JPRB, 1.18724E-05_JPRB, 1.38450E-05_JPRB/) + KAO_MN2O( 5, :,16) = (/ & + & 9.07957E-07_JPRB, 1.05882E-06_JPRB, 1.23475E-06_JPRB, 1.43991E-06_JPRB, 1.67916E-06_JPRB, & + & 1.95816E-06_JPRB, 2.28352E-06_JPRB, 2.66294E-06_JPRB, 3.10541E-06_JPRB, 3.62139E-06_JPRB, & + & 4.22310E-06_JPRB, 4.92480E-06_JPRB, 5.74308E-06_JPRB, 6.69733E-06_JPRB, 7.81013E-06_JPRB, & + & 9.10784E-06_JPRB, 1.06212E-05_JPRB, 1.23859E-05_JPRB, 1.44439E-05_JPRB/) + KAO_MN2O( 6, :,16) = (/ & + & 8.59072E-04_JPRB, 9.19773E-04_JPRB, 9.84764E-04_JPRB, 1.05435E-03_JPRB, 1.12885E-03_JPRB, & + & 1.20861E-03_JPRB, 1.29401E-03_JPRB, 1.38544E-03_JPRB, 1.48334E-03_JPRB, 1.58815E-03_JPRB, & + & 1.70037E-03_JPRB, 1.82052E-03_JPRB, 1.94915E-03_JPRB, 2.08688E-03_JPRB, 2.23434E-03_JPRB, & + & 2.39222E-03_JPRB, 2.56125E-03_JPRB, 2.74223E-03_JPRB, 2.93599E-03_JPRB/) + KAO_MN2O( 7, :,16) = (/ & + & 9.17294E-07_JPRB, 1.06971E-06_JPRB, 1.24746E-06_JPRB, 1.45474E-06_JPRB, 1.69646E-06_JPRB, & + & 1.97835E-06_JPRB, 2.30708E-06_JPRB, 2.69043E-06_JPRB, 3.13748E-06_JPRB, 3.65880E-06_JPRB, & + & 4.26676E-06_JPRB, 4.97574E-06_JPRB, 5.80251E-06_JPRB, 6.76667E-06_JPRB, 7.89104E-06_JPRB, & + & 9.20223E-06_JPRB, 1.07313E-05_JPRB, 1.25144E-05_JPRB, 1.45939E-05_JPRB/) + KAO_MN2O( 8, :,16) = (/ & + & 9.17341E-07_JPRB, 1.06977E-06_JPRB, 1.24752E-06_JPRB, 1.45480E-06_JPRB, 1.69653E-06_JPRB, & + & 1.97843E-06_JPRB, 2.30716E-06_JPRB, 2.69051E-06_JPRB, 3.13757E-06_JPRB, 3.65890E-06_JPRB, & + & 4.26686E-06_JPRB, 4.97584E-06_JPRB, 5.80261E-06_JPRB, 6.76677E-06_JPRB, 7.89113E-06_JPRB, & + & 9.20231E-06_JPRB, 1.07314E-05_JPRB, 1.25145E-05_JPRB, 1.45939E-05_JPRB/) + KAO_MN2O( 9, :,16) = (/ & + & 9.07957E-07_JPRB, 1.05882E-06_JPRB, 1.23475E-06_JPRB, 1.43991E-06_JPRB, 1.67916E-06_JPRB, & + & 1.95816E-06_JPRB, 2.28352E-06_JPRB, 2.66294E-06_JPRB, 3.10541E-06_JPRB, 3.62139E-06_JPRB, & + & 4.22310E-06_JPRB, 4.92480E-06_JPRB, 5.74308E-06_JPRB, 6.69733E-06_JPRB, 7.81013E-06_JPRB, & + & 9.10784E-06_JPRB, 1.06212E-05_JPRB, 1.23859E-05_JPRB, 1.44439E-05_JPRB/) + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amounts ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 to +! that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + + KBO_MN2O( 1, :, 1) = (/ & + & 7.72009E-08_JPRB, 1.15883E-07_JPRB, 1.73947E-07_JPRB, 2.61104E-07_JPRB, 3.91932E-07_JPRB, & + & 5.88311E-07_JPRB, 8.83088E-07_JPRB, 1.32556E-06_JPRB, 1.98975E-06_JPRB, 2.98672E-06_JPRB, & + & 4.48324E-06_JPRB, 6.72960E-06_JPRB, 1.01015E-05_JPRB, 1.51629E-05_JPRB, 2.27604E-05_JPRB, & + & 3.41646E-05_JPRB, 5.12831E-05_JPRB, 7.69787E-05_JPRB, 1.15549E-04_JPRB/) + KBO_MN2O( 2, :, 1) = (/ & + & 1.29932E-05_JPRB, 1.78207E-05_JPRB, 2.44419E-05_JPRB, 3.35232E-05_JPRB, 4.59786E-05_JPRB, & + & 6.30617E-05_JPRB, 8.64920E-05_JPRB, 1.18628E-04_JPRB, 1.62703E-04_JPRB, 2.23155E-04_JPRB, & + & 3.06067E-04_JPRB, 4.19784E-04_JPRB, 5.75753E-04_JPRB, 7.89671E-04_JPRB, 1.08307E-03_JPRB, & + & 1.48548E-03_JPRB, 2.03740E-03_JPRB, 2.79439E-03_JPRB, 3.83262E-03_JPRB/) + KBO_MN2O( 3, :, 1) = (/ & + & 6.44518E-05_JPRB, 8.10996E-05_JPRB, 1.02047E-04_JPRB, 1.28406E-04_JPRB, 1.61573E-04_JPRB, & + & 2.03307E-04_JPRB, 2.55821E-04_JPRB, 3.21899E-04_JPRB, 4.05045E-04_JPRB, 5.09667E-04_JPRB, & + & 6.41313E-04_JPRB, 8.06964E-04_JPRB, 1.01540E-03_JPRB, 1.27768E-03_JPRB, 1.60770E-03_JPRB, & + & 2.02296E-03_JPRB, 2.54549E-03_JPRB, 3.20298E-03_JPRB, 4.03031E-03_JPRB/) + KBO_MN2O( 4, :, 1) = (/ & + & 3.23454E-04_JPRB, 3.82112E-04_JPRB, 4.51408E-04_JPRB, 5.33270E-04_JPRB, 6.29978E-04_JPRB, & + & 7.44223E-04_JPRB, 8.79187E-04_JPRB, 1.03863E-03_JPRB, 1.22698E-03_JPRB, 1.44949E-03_JPRB, & + & 1.71235E-03_JPRB, 2.02289E-03_JPRB, 2.38974E-03_JPRB, 2.82311E-03_JPRB, 3.33508E-03_JPRB, & + & 3.93989E-03_JPRB, 4.65439E-03_JPRB, 5.49845E-03_JPRB, 6.49558E-03_JPRB/) + KBO_MN2O( 5, :, 1) = (/ & + & 1.45978E-04_JPRB, 1.75646E-04_JPRB, 2.11344E-04_JPRB, 2.54296E-04_JPRB, 3.05978E-04_JPRB, & + & 3.68163E-04_JPRB, 4.42986E-04_JPRB, 5.33017E-04_JPRB, 6.41344E-04_JPRB, 7.71687E-04_JPRB, & + & 9.28522E-04_JPRB, 1.11723E-03_JPRB, 1.34429E-03_JPRB, 1.61750E-03_JPRB, 1.94623E-03_JPRB, & + & 2.34177E-03_JPRB, 2.81770E-03_JPRB, 3.39035E-03_JPRB, 4.07939E-03_JPRB/) + KBO_MN2O( 1, :, 2) = (/ & + & 1.94527E-04_JPRB, 2.38609E-04_JPRB, 2.92680E-04_JPRB, 3.59005E-04_JPRB, 4.40360E-04_JPRB, & + & 5.40150E-04_JPRB, 6.62554E-04_JPRB, 8.12697E-04_JPRB, 9.96864E-04_JPRB, 1.22276E-03_JPRB, & + & 1.49986E-03_JPRB, 1.83974E-03_JPRB, 2.25665E-03_JPRB, 2.76803E-03_JPRB, 3.39530E-03_JPRB, & + & 4.16472E-03_JPRB, 5.10849E-03_JPRB, 6.26613E-03_JPRB, 7.68611E-03_JPRB/) + KBO_MN2O( 2, :, 2) = (/ & + & 7.49615E-04_JPRB, 8.82716E-04_JPRB, 1.03945E-03_JPRB, 1.22401E-03_JPRB, 1.44135E-03_JPRB, & + & 1.69727E-03_JPRB, 1.99863E-03_JPRB, 2.35351E-03_JPRB, 2.77139E-03_JPRB, 3.26347E-03_JPRB, & + & 3.84293E-03_JPRB, 4.52528E-03_JPRB, 5.32878E-03_JPRB, 6.27495E-03_JPRB, 7.38911E-03_JPRB, & + & 8.70111E-03_JPRB, 1.02461E-02_JPRB, 1.20653E-02_JPRB, 1.42076E-02_JPRB/) + KBO_MN2O( 3, :, 2) = (/ & + & 1.39162E-03_JPRB, 1.59859E-03_JPRB, 1.83634E-03_JPRB, 2.10946E-03_JPRB, 2.42319E-03_JPRB, & + & 2.78358E-03_JPRB, 3.19758E-03_JPRB, 3.67314E-03_JPRB, 4.21944E-03_JPRB, 4.84698E-03_JPRB, & + & 5.56786E-03_JPRB, 6.39595E-03_JPRB, 7.34720E-03_JPRB, 8.43992E-03_JPRB, 9.69516E-03_JPRB, & + & 1.11371E-02_JPRB, 1.27935E-02_JPRB, 1.46962E-02_JPRB, 1.68819E-02_JPRB/) + KBO_MN2O( 4, :, 2) = (/ & + & 2.42354E-03_JPRB, 2.73623E-03_JPRB, 3.08926E-03_JPRB, 3.48783E-03_JPRB, 3.93783E-03_JPRB, & + & 4.44589E-03_JPRB, 5.01950E-03_JPRB, 5.66712E-03_JPRB, 6.39829E-03_JPRB, 7.22379E-03_JPRB, & + & 8.15581E-03_JPRB, 9.20807E-03_JPRB, 1.03961E-02_JPRB, 1.17374E-02_JPRB, 1.32517E-02_JPRB, & + & 1.49615E-02_JPRB, 1.68918E-02_JPRB, 1.90712E-02_JPRB, 2.15318E-02_JPRB/) + KBO_MN2O( 5, :, 2) = (/ & + & 1.39908E-03_JPRB, 1.59133E-03_JPRB, 1.81000E-03_JPRB, 2.05872E-03_JPRB, 2.34161E-03_JPRB, & + & 2.66338E-03_JPRB, 3.02937E-03_JPRB, 3.44564E-03_JPRB, 3.91912E-03_JPRB, 4.45766E-03_JPRB, & + & 5.07021E-03_JPRB, 5.76693E-03_JPRB, 6.55938E-03_JPRB, 7.46073E-03_JPRB, 8.48594E-03_JPRB, & + & 9.65202E-03_JPRB, 1.09783E-02_JPRB, 1.24869E-02_JPRB, 1.42028E-02_JPRB/) + KBO_MN2O( 1, :, 3) = (/ & + & 8.74797E-03_JPRB, 9.66828E-03_JPRB, 1.06854E-02_JPRB, 1.18095E-02_JPRB, 1.30519E-02_JPRB, & + & 1.44250E-02_JPRB, 1.59426E-02_JPRB, 1.76198E-02_JPRB, 1.94735E-02_JPRB, 2.15221E-02_JPRB, & + & 2.37863E-02_JPRB, 2.62887E-02_JPRB, 2.90544E-02_JPRB, 3.21110E-02_JPRB, 3.54891E-02_JPRB, & + & 3.92227E-02_JPRB, 4.33491E-02_JPRB, 4.79095E-02_JPRB, 5.29497E-02_JPRB/) + KBO_MN2O( 2, :, 3) = (/ & + & 1.43974E-02_JPRB, 1.56118E-02_JPRB, 1.69286E-02_JPRB, 1.83564E-02_JPRB, 1.99047E-02_JPRB, & + & 2.15836E-02_JPRB, 2.34041E-02_JPRB, 2.53781E-02_JPRB, 2.75187E-02_JPRB, 2.98397E-02_JPRB, & + & 3.23566E-02_JPRB, 3.50857E-02_JPRB, 3.80451E-02_JPRB, 4.12540E-02_JPRB, 4.47336E-02_JPRB, & + & 4.85067E-02_JPRB, 5.25980E-02_JPRB, 5.70344E-02_JPRB, 6.18450E-02_JPRB/) + KBO_MN2O( 3, :, 3) = (/ & + & 1.83051E-02_JPRB, 1.96851E-02_JPRB, 2.11692E-02_JPRB, 2.27651E-02_JPRB, 2.44813E-02_JPRB, & + & 2.63270E-02_JPRB, 2.83117E-02_JPRB, 3.04461E-02_JPRB, 3.27414E-02_JPRB, 3.52097E-02_JPRB, & + & 3.78642E-02_JPRB, 4.07187E-02_JPRB, 4.37884E-02_JPRB, 4.70896E-02_JPRB, 5.06396E-02_JPRB, & + & 5.44573E-02_JPRB, 5.85628E-02_JPRB, 6.29777E-02_JPRB, 6.77256E-02_JPRB/) + KBO_MN2O( 4, :, 3) = (/ & + & 2.81258E-02_JPRB, 2.97806E-02_JPRB, 3.15328E-02_JPRB, 3.33880E-02_JPRB, 3.53524E-02_JPRB, & + & 3.74324E-02_JPRB, 3.96348E-02_JPRB, 4.19667E-02_JPRB, 4.44358E-02_JPRB, 4.70502E-02_JPRB, & + & 4.98185E-02_JPRB, 5.27496E-02_JPRB, 5.58531E-02_JPRB, 5.91393E-02_JPRB, 6.26187E-02_JPRB, & + & 6.63030E-02_JPRB, 7.02039E-02_JPRB, 7.43344E-02_JPRB, 7.87079E-02_JPRB/) + KBO_MN2O( 5, :, 3) = (/ & + & 8.82958E-03_JPRB, 9.53842E-03_JPRB, 1.03042E-02_JPRB, 1.11314E-02_JPRB, 1.20250E-02_JPRB, & + & 1.29904E-02_JPRB, 1.40333E-02_JPRB, 1.51599E-02_JPRB, 1.63769E-02_JPRB, 1.76917E-02_JPRB, & + & 1.91120E-02_JPRB, 2.06463E-02_JPRB, 2.23038E-02_JPRB, 2.40944E-02_JPRB, 2.60287E-02_JPRB, & + & 2.81183E-02_JPRB, 3.03757E-02_JPRB, 3.28142E-02_JPRB, 3.54486E-02_JPRB/) + KBO_MN2O( 1, :, 4) = (/ & + & 1.18673E-01_JPRB, 1.22983E-01_JPRB, 1.27449E-01_JPRB, 1.32077E-01_JPRB, 1.36874E-01_JPRB, & + & 1.41845E-01_JPRB, 1.46996E-01_JPRB, 1.52334E-01_JPRB, 1.57866E-01_JPRB, 1.63599E-01_JPRB, & + & 1.69541E-01_JPRB, 1.75698E-01_JPRB, 1.82078E-01_JPRB, 1.88691E-01_JPRB, 1.95543E-01_JPRB, & + & 2.02645E-01_JPRB, 2.10004E-01_JPRB, 2.17631E-01_JPRB, 2.25534E-01_JPRB/) + KBO_MN2O( 2, :, 4) = (/ & + & 1.32161E-01_JPRB, 1.36550E-01_JPRB, 1.41084E-01_JPRB, 1.45769E-01_JPRB, 1.50610E-01_JPRB, & + & 1.55611E-01_JPRB, 1.60779E-01_JPRB, 1.66118E-01_JPRB, 1.71634E-01_JPRB, 1.77334E-01_JPRB, & + & 1.83223E-01_JPRB, 1.89307E-01_JPRB, 1.95594E-01_JPRB, 2.02089E-01_JPRB, 2.08800E-01_JPRB, & + & 2.15734E-01_JPRB, 2.22898E-01_JPRB, 2.30300E-01_JPRB, 2.37947E-01_JPRB/) + KBO_MN2O( 3, :, 4) = (/ & + & 1.44384E-01_JPRB, 1.48820E-01_JPRB, 1.53392E-01_JPRB, 1.58104E-01_JPRB, 1.62962E-01_JPRB, & + & 1.67968E-01_JPRB, 1.73128E-01_JPRB, 1.78447E-01_JPRB, 1.83929E-01_JPRB, 1.89580E-01_JPRB, & + & 1.95404E-01_JPRB, 2.01407E-01_JPRB, 2.07594E-01_JPRB, 2.13972E-01_JPRB, 2.20546E-01_JPRB, & + & 2.27321E-01_JPRB, 2.34305E-01_JPRB, 2.41503E-01_JPRB, 2.48922E-01_JPRB/) + KBO_MN2O( 4, :, 4) = (/ & + & 1.58026E-01_JPRB, 1.62626E-01_JPRB, 1.67360E-01_JPRB, 1.72232E-01_JPRB, 1.77245E-01_JPRB, & + & 1.82405E-01_JPRB, 1.87714E-01_JPRB, 1.93179E-01_JPRB, 1.98802E-01_JPRB, 2.04589E-01_JPRB, & + & 2.10544E-01_JPRB, 2.16673E-01_JPRB, 2.22980E-01_JPRB, 2.29471E-01_JPRB, 2.36151E-01_JPRB, & + & 2.43025E-01_JPRB, 2.50100E-01_JPRB, 2.57380E-01_JPRB, 2.64872E-01_JPRB/) + KBO_MN2O( 5, :, 4) = (/ & + & 4.04885E-02_JPRB, 4.16064E-02_JPRB, 4.27551E-02_JPRB, 4.39355E-02_JPRB, 4.51485E-02_JPRB, & + & 4.63950E-02_JPRB, 4.76759E-02_JPRB, 4.89921E-02_JPRB, 5.03448E-02_JPRB, 5.17347E-02_JPRB, & + & 5.31630E-02_JPRB, 5.46308E-02_JPRB, 5.61391E-02_JPRB, 5.76890E-02_JPRB, 5.92817E-02_JPRB, & + & 6.09184E-02_JPRB, 6.26003E-02_JPRB, 6.43286E-02_JPRB, 6.61047E-02_JPRB/) + KBO_MN2O( 1, :, 5) = (/ & + & 3.97757E-01_JPRB, 4.01082E-01_JPRB, 4.04434E-01_JPRB, 4.07814E-01_JPRB, 4.11223E-01_JPRB, & + & 4.14659E-01_JPRB, 4.18125E-01_JPRB, 4.21620E-01_JPRB, 4.25144E-01_JPRB, 4.28697E-01_JPRB, & + & 4.32280E-01_JPRB, 4.35893E-01_JPRB, 4.39536E-01_JPRB, 4.43209E-01_JPRB, 4.46913E-01_JPRB, & + & 4.50649E-01_JPRB, 4.54415E-01_JPRB, 4.58213E-01_JPRB, 4.62043E-01_JPRB/) + KBO_MN2O( 2, :, 5) = (/ & + & 3.99425E-01_JPRB, 4.02035E-01_JPRB, 4.04662E-01_JPRB, 4.07306E-01_JPRB, 4.09968E-01_JPRB, & + & 4.12647E-01_JPRB, 4.15343E-01_JPRB, 4.18057E-01_JPRB, 4.20789E-01_JPRB, 4.23539E-01_JPRB, & + & 4.26307E-01_JPRB, 4.29092E-01_JPRB, 4.31896E-01_JPRB, 4.34719E-01_JPRB, 4.37559E-01_JPRB, & + & 4.40419E-01_JPRB, 4.43296E-01_JPRB, 4.46193E-01_JPRB, 4.49109E-01_JPRB/) + KBO_MN2O( 3, :, 5) = (/ & + & 4.00527E-01_JPRB, 4.02848E-01_JPRB, 4.05182E-01_JPRB, 4.07530E-01_JPRB, 4.09892E-01_JPRB, & + & 4.12267E-01_JPRB, 4.14656E-01_JPRB, 4.17058E-01_JPRB, 4.19475E-01_JPRB, 4.21906E-01_JPRB, & + & 4.24351E-01_JPRB, 4.26809E-01_JPRB, 4.29283E-01_JPRB, 4.31770E-01_JPRB, 4.34272E-01_JPRB, & + & 4.36788E-01_JPRB, 4.39319E-01_JPRB, 4.41865E-01_JPRB, 4.44426E-01_JPRB/) + KBO_MN2O( 4, :, 5) = (/ & + & 4.11455E-01_JPRB, 4.13077E-01_JPRB, 4.14705E-01_JPRB, 4.16340E-01_JPRB, 4.17981E-01_JPRB, & + & 4.19629E-01_JPRB, 4.21283E-01_JPRB, 4.22944E-01_JPRB, 4.24611E-01_JPRB, 4.26285E-01_JPRB, & + & 4.27966E-01_JPRB, 4.29653E-01_JPRB, 4.31346E-01_JPRB, 4.33047E-01_JPRB, 4.34754E-01_JPRB, & + & 4.36468E-01_JPRB, 4.38188E-01_JPRB, 4.39916E-01_JPRB, 4.41650E-01_JPRB/) + KBO_MN2O( 5, :, 5) = (/ & + & 8.65576E-02_JPRB, 8.83622E-02_JPRB, 9.02044E-02_JPRB, 9.20850E-02_JPRB, 9.40049E-02_JPRB, & + & 9.59647E-02_JPRB, 9.79655E-02_JPRB, 1.00008E-01_JPRB, 1.02093E-01_JPRB, 1.04221E-01_JPRB, & + & 1.06394E-01_JPRB, 1.08612E-01_JPRB, 1.10877E-01_JPRB, 1.13188E-01_JPRB, 1.15548E-01_JPRB, & + & 1.17957E-01_JPRB, 1.20417E-01_JPRB, 1.22927E-01_JPRB, 1.25490E-01_JPRB/) + KBO_MN2O( 1, :, 6) = (/ & + & 6.98675E-01_JPRB, 7.00999E-01_JPRB, 7.03331E-01_JPRB, 7.05671E-01_JPRB, 7.08019E-01_JPRB, & + & 7.10375E-01_JPRB, 7.12738E-01_JPRB, 7.15110E-01_JPRB, 7.17489E-01_JPRB, 7.19876E-01_JPRB, & + & 7.22271E-01_JPRB, 7.24674E-01_JPRB, 7.27085E-01_JPRB, 7.29504E-01_JPRB, 7.31931E-01_JPRB, & + & 7.34366E-01_JPRB, 7.36809E-01_JPRB, 7.39261E-01_JPRB, 7.41720E-01_JPRB/) + KBO_MN2O( 2, :, 6) = (/ & + & 6.98858E-01_JPRB, 7.01424E-01_JPRB, 7.03999E-01_JPRB, 7.06583E-01_JPRB, 7.09177E-01_JPRB, & + & 7.11780E-01_JPRB, 7.14393E-01_JPRB, 7.17016E-01_JPRB, 7.19648E-01_JPRB, 7.22289E-01_JPRB, & + & 7.24941E-01_JPRB, 7.27602E-01_JPRB, 7.30273E-01_JPRB, 7.32954E-01_JPRB, 7.35644E-01_JPRB, & + & 7.38345E-01_JPRB, 7.41055E-01_JPRB, 7.43775E-01_JPRB, 7.46506E-01_JPRB/) + KBO_MN2O( 3, :, 6) = (/ & + & 7.08151E-01_JPRB, 7.10727E-01_JPRB, 7.13311E-01_JPRB, 7.15905E-01_JPRB, 7.18508E-01_JPRB, & + & 7.21121E-01_JPRB, 7.23743E-01_JPRB, 7.26375E-01_JPRB, 7.29017E-01_JPRB, 7.31668E-01_JPRB, & + & 7.34329E-01_JPRB, 7.36999E-01_JPRB, 7.39679E-01_JPRB, 7.42369E-01_JPRB, 7.45068E-01_JPRB, & + & 7.47778E-01_JPRB, 7.50497E-01_JPRB, 7.53226E-01_JPRB, 7.55965E-01_JPRB/) + KBO_MN2O( 4, :, 6) = (/ & + & 7.22269E-01_JPRB, 7.24981E-01_JPRB, 7.27704E-01_JPRB, 7.30437E-01_JPRB, 7.33180E-01_JPRB, & + & 7.35933E-01_JPRB, 7.38697E-01_JPRB, 7.41471E-01_JPRB, 7.44256E-01_JPRB, 7.47051E-01_JPRB, & + & 7.49856E-01_JPRB, 7.52672E-01_JPRB, 7.55499E-01_JPRB, 7.58336E-01_JPRB, 7.61184E-01_JPRB, & + & 7.64043E-01_JPRB, 7.66912E-01_JPRB, 7.69792E-01_JPRB, 7.72683E-01_JPRB/) + KBO_MN2O( 5, :, 6) = (/ & + & 1.75877E-01_JPRB, 1.78578E-01_JPRB, 1.81321E-01_JPRB, 1.84107E-01_JPRB, 1.86935E-01_JPRB, & + & 1.89806E-01_JPRB, 1.92722E-01_JPRB, 1.95682E-01_JPRB, 1.98688E-01_JPRB, 2.01740E-01_JPRB, & + & 2.04839E-01_JPRB, 2.07986E-01_JPRB, 2.11181E-01_JPRB, 2.14425E-01_JPRB, 2.17719E-01_JPRB, & + & 2.21063E-01_JPRB, 2.24459E-01_JPRB, 2.27907E-01_JPRB, 2.31408E-01_JPRB/) + KBO_MN2O( 1, :, 7) = (/ & + & 1.82985E+00_JPRB, 1.83684E+00_JPRB, 1.84386E+00_JPRB, 1.85091E+00_JPRB, 1.85798E+00_JPRB, & + & 1.86508E+00_JPRB, 1.87221E+00_JPRB, 1.87937E+00_JPRB, 1.88655E+00_JPRB, 1.89376E+00_JPRB, & + & 1.90100E+00_JPRB, 1.90827E+00_JPRB, 1.91556E+00_JPRB, 1.92288E+00_JPRB, 1.93023E+00_JPRB, & + & 1.93761E+00_JPRB, 1.94502E+00_JPRB, 1.95245E+00_JPRB, 1.95991E+00_JPRB/) + KBO_MN2O( 2, :, 7) = (/ & + & 1.83229E+00_JPRB, 1.83943E+00_JPRB, 1.84659E+00_JPRB, 1.85379E+00_JPRB, 1.86100E+00_JPRB, & + & 1.86825E+00_JPRB, 1.87553E+00_JPRB, 1.88283E+00_JPRB, 1.89016E+00_JPRB, 1.89753E+00_JPRB, & + & 1.90492E+00_JPRB, 1.91233E+00_JPRB, 1.91978E+00_JPRB, 1.92726E+00_JPRB, 1.93476E+00_JPRB, & + & 1.94230E+00_JPRB, 1.94986E+00_JPRB, 1.95746E+00_JPRB, 1.96508E+00_JPRB/) + KBO_MN2O( 3, :, 7) = (/ & + & 1.84946E+00_JPRB, 1.85707E+00_JPRB, 1.86471E+00_JPRB, 1.87238E+00_JPRB, 1.88008E+00_JPRB, & + & 1.88781E+00_JPRB, 1.89558E+00_JPRB, 1.90338E+00_JPRB, 1.91120E+00_JPRB, 1.91907E+00_JPRB, & + & 1.92696E+00_JPRB, 1.93489E+00_JPRB, 1.94285E+00_JPRB, 1.95084E+00_JPRB, 1.95886E+00_JPRB, & + & 1.96692E+00_JPRB, 1.97501E+00_JPRB, 1.98313E+00_JPRB, 1.99129E+00_JPRB/) + KBO_MN2O( 4, :, 7) = (/ & + & 1.88354E+00_JPRB, 1.89167E+00_JPRB, 1.89983E+00_JPRB, 1.90803E+00_JPRB, 1.91626E+00_JPRB, & + & 1.92453E+00_JPRB, 1.93283E+00_JPRB, 1.94117E+00_JPRB, 1.94955E+00_JPRB, 1.95796E+00_JPRB, & + & 1.96641E+00_JPRB, 1.97489E+00_JPRB, 1.98341E+00_JPRB, 1.99197E+00_JPRB, 2.00056E+00_JPRB, & + & 2.00920E+00_JPRB, 2.01787E+00_JPRB, 2.02657E+00_JPRB, 2.03532E+00_JPRB/) + KBO_MN2O( 5, :, 7) = (/ & + & 3.35154E-01_JPRB, 3.43258E-01_JPRB, 3.51557E-01_JPRB, 3.60058E-01_JPRB, 3.68764E-01_JPRB, & + & 3.77680E-01_JPRB, 3.86812E-01_JPRB, 3.96164E-01_JPRB, 4.05743E-01_JPRB, 4.15553E-01_JPRB, & + & 4.25601E-01_JPRB, 4.35892E-01_JPRB, 4.46431E-01_JPRB, 4.57225E-01_JPRB, 4.68280E-01_JPRB, & + & 4.79603E-01_JPRB, 4.91199E-01_JPRB, 5.03075E-01_JPRB, 5.15239E-01_JPRB/) + KBO_MN2O( 1, :, 8) = (/ & + & 4.46843E+00_JPRB, 4.49793E+00_JPRB, 4.52763E+00_JPRB, 4.55752E+00_JPRB, 4.58761E+00_JPRB, & + & 4.61790E+00_JPRB, 4.64839E+00_JPRB, 4.67908E+00_JPRB, 4.70997E+00_JPRB, 4.74106E+00_JPRB, & + & 4.77236E+00_JPRB, 4.80387E+00_JPRB, 4.83559E+00_JPRB, 4.86751E+00_JPRB, 4.89965E+00_JPRB, & + & 4.93200E+00_JPRB, 4.96456E+00_JPRB, 4.99733E+00_JPRB, 5.03033E+00_JPRB/) + KBO_MN2O( 2, :, 8) = (/ & + & 4.44347E+00_JPRB, 4.47278E+00_JPRB, 4.50228E+00_JPRB, 4.53198E+00_JPRB, 4.56188E+00_JPRB, & + & 4.59197E+00_JPRB, 4.62227E+00_JPRB, 4.65276E+00_JPRB, 4.68345E+00_JPRB, 4.71435E+00_JPRB, & + & 4.74544E+00_JPRB, 4.77675E+00_JPRB, 4.80826E+00_JPRB, 4.83998E+00_JPRB, 4.87191E+00_JPRB, & + & 4.90405E+00_JPRB, 4.93640E+00_JPRB, 4.96896E+00_JPRB, 5.00174E+00_JPRB/) + KBO_MN2O( 3, :, 8) = (/ & + & 4.43138E+00_JPRB, 4.46017E+00_JPRB, 4.48916E+00_JPRB, 4.51834E+00_JPRB, 4.54770E+00_JPRB, & + & 4.57725E+00_JPRB, 4.60700E+00_JPRB, 4.63694E+00_JPRB, 4.66708E+00_JPRB, 4.69741E+00_JPRB, & + & 4.72793E+00_JPRB, 4.75866E+00_JPRB, 4.78958E+00_JPRB, 4.82071E+00_JPRB, 4.85204E+00_JPRB, & + & 4.88357E+00_JPRB, 4.91531E+00_JPRB, 4.94725E+00_JPRB, 4.97941E+00_JPRB/) + KBO_MN2O( 4, :, 8) = (/ & + & 4.47437E+00_JPRB, 4.50396E+00_JPRB, 4.53375E+00_JPRB, 4.56374E+00_JPRB, 4.59392E+00_JPRB, & + & 4.62431E+00_JPRB, 4.65490E+00_JPRB, 4.68569E+00_JPRB, 4.71668E+00_JPRB, 4.74788E+00_JPRB, & + & 4.77928E+00_JPRB, 4.81089E+00_JPRB, 4.84271E+00_JPRB, 4.87474E+00_JPRB, 4.90698E+00_JPRB, & + & 4.93944E+00_JPRB, 4.97211E+00_JPRB, 5.00500E+00_JPRB, 5.03810E+00_JPRB/) + KBO_MN2O( 5, :, 8) = (/ & + & 8.82838E-01_JPRB, 8.92257E-01_JPRB, 9.01777E-01_JPRB, 9.11398E-01_JPRB, 9.21122E-01_JPRB, & + & 9.30950E-01_JPRB, 9.40883E-01_JPRB, 9.50921E-01_JPRB, 9.61067E-01_JPRB, 9.71321E-01_JPRB, & + & 9.81685E-01_JPRB, 9.92159E-01_JPRB, 1.00274E+00_JPRB, 1.01344E+00_JPRB, 1.02426E+00_JPRB, & + & 1.03518E+00_JPRB, 1.04623E+00_JPRB, 1.05739E+00_JPRB, 1.06867E+00_JPRB/) + KBO_MN2O( 1, :, 9) = (/ & + & 7.92826E+00_JPRB, 7.83168E+00_JPRB, 7.73628E+00_JPRB, 7.64204E+00_JPRB, 7.54895E+00_JPRB, & + & 7.45699E+00_JPRB, 7.36616E+00_JPRB, 7.27643E+00_JPRB, 7.18779E+00_JPRB, 7.10023E+00_JPRB, & + & 7.01374E+00_JPRB, 6.92831E+00_JPRB, 6.84391E+00_JPRB, 6.76054E+00_JPRB, 6.67819E+00_JPRB, & + & 6.59684E+00_JPRB, 6.51648E+00_JPRB, 6.43710E+00_JPRB, 6.35869E+00_JPRB/) + KBO_MN2O( 2, :, 9) = (/ & + & 7.89244E+00_JPRB, 7.79570E+00_JPRB, 7.70014E+00_JPRB, 7.60576E+00_JPRB, 7.51253E+00_JPRB, & + & 7.42045E+00_JPRB, 7.32949E+00_JPRB, 7.23965E+00_JPRB, 7.15091E+00_JPRB, 7.06325E+00_JPRB, & + & 6.97668E+00_JPRB, 6.89116E+00_JPRB, 6.80669E+00_JPRB, 6.72326E+00_JPRB, 6.64085E+00_JPRB, & + & 6.55945E+00_JPRB, 6.47904E+00_JPRB, 6.39963E+00_JPRB, 6.32118E+00_JPRB/) + KBO_MN2O( 3, :, 9) = (/ & + & 7.79799E+00_JPRB, 7.70076E+00_JPRB, 7.60474E+00_JPRB, 7.50991E+00_JPRB, 7.41627E+00_JPRB, & + & 7.32379E+00_JPRB, 7.23247E+00_JPRB, 7.14229E+00_JPRB, 7.05323E+00_JPRB, 6.96528E+00_JPRB, & + & 6.87843E+00_JPRB, 6.79266E+00_JPRB, 6.70797E+00_JPRB, 6.62432E+00_JPRB, 6.54172E+00_JPRB, & + & 6.46015E+00_JPRB, 6.37960E+00_JPRB, 6.30005E+00_JPRB, 6.22150E+00_JPRB/) + KBO_MN2O( 4, :, 9) = (/ & + & 7.53750E+00_JPRB, 7.43715E+00_JPRB, 7.33814E+00_JPRB, 7.24045E+00_JPRB, 7.14406E+00_JPRB, & + & 7.04895E+00_JPRB, 6.95510E+00_JPRB, 6.86251E+00_JPRB, 6.77115E+00_JPRB, 6.68101E+00_JPRB, & + & 6.59206E+00_JPRB, 6.50430E+00_JPRB, 6.41771E+00_JPRB, 6.33227E+00_JPRB, 6.24797E+00_JPRB, & + & 6.16479E+00_JPRB, 6.08272E+00_JPRB, 6.00174E+00_JPRB, 5.92184E+00_JPRB/) + KBO_MN2O( 5, :, 9) = (/ & + & 5.06319E+00_JPRB, 5.08595E+00_JPRB, 5.10881E+00_JPRB, 5.13177E+00_JPRB, 5.15483E+00_JPRB, & + & 5.17800E+00_JPRB, 5.20127E+00_JPRB, 5.22464E+00_JPRB, 5.24813E+00_JPRB, 5.27171E+00_JPRB, & + & 5.29540E+00_JPRB, 5.31920E+00_JPRB, 5.34311E+00_JPRB, 5.36712E+00_JPRB, 5.39124E+00_JPRB, & + & 5.41547E+00_JPRB, 5.43981E+00_JPRB, 5.46426E+00_JPRB, 5.48882E+00_JPRB/) + KBO_MN2O( 1, :,10) = (/ & + & 1.05265E+00_JPRB, 1.03986E+00_JPRB, 1.02723E+00_JPRB, 1.01475E+00_JPRB, 1.00243E+00_JPRB, & + & 9.90250E-01_JPRB, 9.78220E-01_JPRB, 9.66338E-01_JPRB, 9.54599E-01_JPRB, 9.43003E-01_JPRB, & + & 9.31548E-01_JPRB, 9.20232E-01_JPRB, 9.09054E-01_JPRB, 8.98011E-01_JPRB, 8.87102E-01_JPRB, & + & 8.76326E-01_JPRB, 8.65681E-01_JPRB, 8.55165E-01_JPRB, 8.44777E-01_JPRB/) + KBO_MN2O( 2, :,10) = (/ & + & 1.05246E+00_JPRB, 1.03973E+00_JPRB, 1.02714E+00_JPRB, 1.01471E+00_JPRB, 1.00243E+00_JPRB, & + & 9.90303E-01_JPRB, 9.78319E-01_JPRB, 9.66480E-01_JPRB, 9.54784E-01_JPRB, 9.43230E-01_JPRB, & + & 9.31815E-01_JPRB, 9.20539E-01_JPRB, 9.09399E-01_JPRB, 8.98394E-01_JPRB, 8.87522E-01_JPRB, & + & 8.76782E-01_JPRB, 8.66171E-01_JPRB, 8.55690E-01_JPRB, 8.45335E-01_JPRB/) + KBO_MN2O( 3, :,10) = (/ & + & 1.05236E+00_JPRB, 1.03963E+00_JPRB, 1.02704E+00_JPRB, 1.01461E+00_JPRB, 1.00233E+00_JPRB, & + & 9.90203E-01_JPRB, 9.78219E-01_JPRB, 9.66380E-01_JPRB, 9.54684E-01_JPRB, 9.43130E-01_JPRB, & + & 9.31715E-01_JPRB, 9.20439E-01_JPRB, 9.09300E-01_JPRB, 8.98295E-01_JPRB, 8.87423E-01_JPRB, & + & 8.76683E-01_JPRB, 8.66073E-01_JPRB, 8.55591E-01_JPRB, 8.45236E-01_JPRB/) + KBO_MN2O( 4, :,10) = (/ & + & 9.30836E-01_JPRB, 9.21099E-01_JPRB, 9.11464E-01_JPRB, 9.01930E-01_JPRB, 8.92495E-01_JPRB, & + & 8.83159E-01_JPRB, 8.73921E-01_JPRB, 8.64779E-01_JPRB, 8.55733E-01_JPRB, 8.46781E-01_JPRB, & + & 8.37923E-01_JPRB, 8.29158E-01_JPRB, 8.20485E-01_JPRB, 8.11902E-01_JPRB, 8.03409E-01_JPRB, & + & 7.95005E-01_JPRB, 7.86689E-01_JPRB, 7.78460E-01_JPRB, 7.70316E-01_JPRB/) + KBO_MN2O( 5, :,10) = (/ & + & 1.65786E+01_JPRB, 1.66541E+01_JPRB, 1.67299E+01_JPRB, 1.68062E+01_JPRB, 1.68827E+01_JPRB, & + & 1.69596E+01_JPRB, 1.70369E+01_JPRB, 1.71145E+01_JPRB, 1.71925E+01_JPRB, 1.72708E+01_JPRB, & + & 1.73495E+01_JPRB, 1.74285E+01_JPRB, 1.75079E+01_JPRB, 1.75877E+01_JPRB, 1.76678E+01_JPRB, & + & 1.77483E+01_JPRB, 1.78291E+01_JPRB, 1.79103E+01_JPRB, 1.79919E+01_JPRB/) + KBO_MN2O( 1, :,11) = (/ & + & 1.74239E-01_JPRB, 1.77873E-01_JPRB, 1.81583E-01_JPRB, 1.85370E-01_JPRB, 1.89236E-01_JPRB, & + & 1.93182E-01_JPRB, 1.97211E-01_JPRB, 2.01324E-01_JPRB, 2.05523E-01_JPRB, 2.09809E-01_JPRB, & + & 2.14185E-01_JPRB, 2.18652E-01_JPRB, 2.23212E-01_JPRB, 2.27867E-01_JPRB, 2.32620E-01_JPRB, & + & 2.37471E-01_JPRB, 2.42424E-01_JPRB, 2.47479E-01_JPRB, 2.52641E-01_JPRB/) + KBO_MN2O( 2, :,11) = (/ & + & 1.74114E-01_JPRB, 1.77756E-01_JPRB, 1.81475E-01_JPRB, 1.85271E-01_JPRB, 1.89147E-01_JPRB, & + & 1.93104E-01_JPRB, 1.97144E-01_JPRB, 2.01268E-01_JPRB, 2.05479E-01_JPRB, 2.09778E-01_JPRB, & + & 2.14166E-01_JPRB, 2.18647E-01_JPRB, 2.23221E-01_JPRB, 2.27890E-01_JPRB, 2.32658E-01_JPRB, & + & 2.37525E-01_JPRB, 2.42494E-01_JPRB, 2.47567E-01_JPRB, 2.52746E-01_JPRB/) + KBO_MN2O( 3, :,11) = (/ & + & 1.74142E-01_JPRB, 1.77780E-01_JPRB, 1.81494E-01_JPRB, 1.85286E-01_JPRB, 1.89157E-01_JPRB, & + & 1.93108E-01_JPRB, 1.97143E-01_JPRB, 2.01261E-01_JPRB, 2.05466E-01_JPRB, 2.09759E-01_JPRB, & + & 2.14141E-01_JPRB, 2.18615E-01_JPRB, 2.23182E-01_JPRB, 2.27845E-01_JPRB, 2.32605E-01_JPRB, & + & 2.37464E-01_JPRB, 2.42425E-01_JPRB, 2.47490E-01_JPRB, 2.52661E-01_JPRB/) + KBO_MN2O( 4, :,11) = (/ & + & 1.74074E-01_JPRB, 1.77716E-01_JPRB, 1.81435E-01_JPRB, 1.85231E-01_JPRB, 1.89107E-01_JPRB, & + & 1.93064E-01_JPRB, 1.97104E-01_JPRB, 2.01229E-01_JPRB, 2.05439E-01_JPRB, 2.09738E-01_JPRB, & + & 2.14127E-01_JPRB, 2.18607E-01_JPRB, 2.23181E-01_JPRB, 2.27852E-01_JPRB, 2.32619E-01_JPRB, & + & 2.37487E-01_JPRB, 2.42456E-01_JPRB, 2.47529E-01_JPRB, 2.52709E-01_JPRB/) + KBO_MN2O( 5, :,11) = (/ & + & 2.31905E+01_JPRB, 2.33011E+01_JPRB, 2.34123E+01_JPRB, 2.35240E+01_JPRB, 2.36362E+01_JPRB, & + & 2.37489E+01_JPRB, 2.38622E+01_JPRB, 2.39760E+01_JPRB, 2.40904E+01_JPRB, 2.42053E+01_JPRB, & + & 2.43208E+01_JPRB, 2.44368E+01_JPRB, 2.45533E+01_JPRB, 2.46705E+01_JPRB, 2.47881E+01_JPRB, & + & 2.49064E+01_JPRB, 2.50252E+01_JPRB, 2.51446E+01_JPRB, 2.52645E+01_JPRB/) + KBO_MN2O( 1, :,12) = (/ & + & 1.60269E-01_JPRB, 1.62873E-01_JPRB, 1.65519E-01_JPRB, 1.68208E-01_JPRB, 1.70940E-01_JPRB, & + & 1.73717E-01_JPRB, 1.76540E-01_JPRB, 1.79408E-01_JPRB, 1.82322E-01_JPRB, 1.85284E-01_JPRB, & + & 1.88295E-01_JPRB, 1.91354E-01_JPRB, 1.94462E-01_JPRB, 1.97622E-01_JPRB, 2.00832E-01_JPRB, & + & 2.04095E-01_JPRB, 2.07411E-01_JPRB, 2.10780E-01_JPRB, 2.14205E-01_JPRB/) + KBO_MN2O( 2, :,12) = (/ & + & 1.60497E-01_JPRB, 1.63096E-01_JPRB, 1.65738E-01_JPRB, 1.68422E-01_JPRB, 1.71150E-01_JPRB, & + & 1.73922E-01_JPRB, 1.76738E-01_JPRB, 1.79601E-01_JPRB, 1.82510E-01_JPRB, 1.85466E-01_JPRB, & + & 1.88469E-01_JPRB, 1.91522E-01_JPRB, 1.94624E-01_JPRB, 1.97776E-01_JPRB, 2.00979E-01_JPRB, & + & 2.04234E-01_JPRB, 2.07542E-01_JPRB, 2.10903E-01_JPRB, 2.14319E-01_JPRB/) + KBO_MN2O( 3, :,12) = (/ & + & 1.60407E-01_JPRB, 1.63006E-01_JPRB, 1.65648E-01_JPRB, 1.68332E-01_JPRB, 1.71060E-01_JPRB, & + & 1.73832E-01_JPRB, 1.76649E-01_JPRB, 1.79511E-01_JPRB, 1.82420E-01_JPRB, 1.85376E-01_JPRB, & + & 1.88380E-01_JPRB, 1.91433E-01_JPRB, 1.94535E-01_JPRB, 1.97687E-01_JPRB, 2.00891E-01_JPRB, & + & 2.04146E-01_JPRB, 2.07454E-01_JPRB, 2.10816E-01_JPRB, 2.14232E-01_JPRB/) + KBO_MN2O( 4, :,12) = (/ & + & 1.60475E-01_JPRB, 1.63070E-01_JPRB, 1.65706E-01_JPRB, 1.68386E-01_JPRB, 1.71109E-01_JPRB, & + & 1.73876E-01_JPRB, 1.76687E-01_JPRB, 1.79544E-01_JPRB, 1.82448E-01_JPRB, 1.85398E-01_JPRB, & + & 1.88396E-01_JPRB, 1.91442E-01_JPRB, 1.94538E-01_JPRB, 1.97684E-01_JPRB, 2.00881E-01_JPRB, & + & 2.04129E-01_JPRB, 2.07430E-01_JPRB, 2.10784E-01_JPRB, 2.14192E-01_JPRB/) + KBO_MN2O( 5, :,12) = (/ & + & 3.25743E+01_JPRB, 3.27992E+01_JPRB, 3.30256E+01_JPRB, 3.32536E+01_JPRB, 3.34832E+01_JPRB, & + & 3.37143E+01_JPRB, 3.39471E+01_JPRB, 3.41815E+01_JPRB, 3.44174E+01_JPRB, 3.46550E+01_JPRB, & + & 3.48943E+01_JPRB, 3.51352E+01_JPRB, 3.53778E+01_JPRB, 3.56220E+01_JPRB, 3.58679E+01_JPRB, & + & 3.61156E+01_JPRB, 3.63649E+01_JPRB, 3.66159E+01_JPRB, 3.68687E+01_JPRB/) + KBO_MN2O( 1, :,13) = (/ & + & 2.01846E-01_JPRB, 2.03110E-01_JPRB, 2.04381E-01_JPRB, 2.05660E-01_JPRB, 2.06947E-01_JPRB, & + & 2.08242E-01_JPRB, 2.09546E-01_JPRB, 2.10857E-01_JPRB, 2.12177E-01_JPRB, 2.13505E-01_JPRB, & + & 2.14841E-01_JPRB, 2.16186E-01_JPRB, 2.17539E-01_JPRB, 2.18900E-01_JPRB, 2.20270E-01_JPRB, & + & 2.21649E-01_JPRB, 2.23036E-01_JPRB, 2.24432E-01_JPRB, 2.25837E-01_JPRB/) + KBO_MN2O( 2, :,13) = (/ & + & 2.01756E-01_JPRB, 2.03020E-01_JPRB, 2.04291E-01_JPRB, 2.05570E-01_JPRB, 2.06857E-01_JPRB, & + & 2.08152E-01_JPRB, 2.09456E-01_JPRB, 2.10767E-01_JPRB, 2.12087E-01_JPRB, 2.13415E-01_JPRB, & + & 2.14751E-01_JPRB, 2.16096E-01_JPRB, 2.17449E-01_JPRB, 2.18810E-01_JPRB, 2.20181E-01_JPRB, & + & 2.21559E-01_JPRB, 2.22946E-01_JPRB, 2.24342E-01_JPRB, 2.25747E-01_JPRB/) + KBO_MN2O( 3, :,13) = (/ & + & 2.01836E-01_JPRB, 2.03100E-01_JPRB, 2.04371E-01_JPRB, 2.05650E-01_JPRB, 2.06937E-01_JPRB, & + & 2.08232E-01_JPRB, 2.09536E-01_JPRB, 2.10847E-01_JPRB, 2.12167E-01_JPRB, 2.13495E-01_JPRB, & + & 2.14831E-01_JPRB, 2.16176E-01_JPRB, 2.17529E-01_JPRB, 2.18890E-01_JPRB, 2.20260E-01_JPRB, & + & 2.21639E-01_JPRB, 2.23026E-01_JPRB, 2.24422E-01_JPRB, 2.25827E-01_JPRB/) + KBO_MN2O( 4, :,13) = (/ & + & 2.01845E-01_JPRB, 2.03103E-01_JPRB, 2.04370E-01_JPRB, 2.05644E-01_JPRB, 2.06926E-01_JPRB, & + & 2.08217E-01_JPRB, 2.09515E-01_JPRB, 2.10822E-01_JPRB, 2.12136E-01_JPRB, 2.13459E-01_JPRB, & + & 2.14790E-01_JPRB, 2.16129E-01_JPRB, 2.17477E-01_JPRB, 2.18833E-01_JPRB, 2.20198E-01_JPRB, & + & 2.21571E-01_JPRB, 2.22952E-01_JPRB, 2.24343E-01_JPRB, 2.25741E-01_JPRB/) + KBO_MN2O( 5, :,13) = (/ & + & 5.34154E+01_JPRB, 5.31954E+01_JPRB, 5.29763E+01_JPRB, 5.27582E+01_JPRB, 5.25409E+01_JPRB, & + & 5.23245E+01_JPRB, 5.21090E+01_JPRB, 5.18943E+01_JPRB, 5.16806E+01_JPRB, 5.14677E+01_JPRB, & + & 5.12558E+01_JPRB, 5.10446E+01_JPRB, 5.08344E+01_JPRB, 5.06250E+01_JPRB, 5.04165E+01_JPRB, & + & 5.02089E+01_JPRB, 5.00021E+01_JPRB, 4.97961E+01_JPRB, 4.95910E+01_JPRB/) + KBO_MN2O( 1, :,14) = (/ & + & 2.87818E-02_JPRB, 3.17868E-02_JPRB, 3.51056E-02_JPRB, 3.87708E-02_JPRB, 4.28187E-02_JPRB, & + & 4.72893E-02_JPRB, 5.22266E-02_JPRB, 5.76794E-02_JPRB, 6.37015E-02_JPRB, 7.03523E-02_JPRB, & + & 7.76976E-02_JPRB, 8.58097E-02_JPRB, 9.47688E-02_JPRB, 1.04663E-01_JPRB, 1.15591E-01_JPRB, & + & 1.27659E-01_JPRB, 1.40988E-01_JPRB, 1.55708E-01_JPRB, 1.71965E-01_JPRB/) + KBO_MN2O( 2, :,14) = (/ & + & 2.88500E-02_JPRB, 3.18494E-02_JPRB, 3.51606E-02_JPRB, 3.88161E-02_JPRB, 4.28517E-02_JPRB, & + & 4.73068E-02_JPRB, 5.22251E-02_JPRB, 5.76547E-02_JPRB, 6.36488E-02_JPRB, 7.02661E-02_JPRB, & + & 7.75714E-02_JPRB, 8.56362E-02_JPRB, 9.45395E-02_JPRB, 1.04368E-01_JPRB, 1.15219E-01_JPRB, & + & 1.27198E-01_JPRB, 1.40422E-01_JPRB, 1.55021E-01_JPRB, 1.71138E-01_JPRB/) + KBO_MN2O( 3, :,14) = (/ & + & 2.88036E-02_JPRB, 3.18109E-02_JPRB, 3.51322E-02_JPRB, 3.88002E-02_JPRB, 4.28512E-02_JPRB, & + & 4.73252E-02_JPRB, 5.22663E-02_JPRB, 5.77232E-02_JPRB, 6.37499E-02_JPRB, 7.04058E-02_JPRB, & + & 7.77567E-02_JPRB, 8.58751E-02_JPRB, 9.48410E-02_JPRB, 1.04743E-01_JPRB, 1.15679E-01_JPRB, & + & 1.27757E-01_JPRB, 1.41095E-01_JPRB, 1.55827E-01_JPRB, 1.72096E-01_JPRB/) + KBO_MN2O( 4, :,14) = (/ & + & 2.87750E-02_JPRB, 3.17783E-02_JPRB, 3.50951E-02_JPRB, 3.87580E-02_JPRB, 4.28033E-02_JPRB, & + & 4.72708E-02_JPRB, 5.22046E-02_JPRB, 5.76533E-02_JPRB, 6.36707E-02_JPRB, 7.03162E-02_JPRB, & + & 7.76553E-02_JPRB, 8.57604E-02_JPRB, 9.47114E-02_JPRB, 1.04597E-01_JPRB, 1.15514E-01_JPRB, & + & 1.27570E-01_JPRB, 1.40885E-01_JPRB, 1.55589E-01_JPRB, 1.71829E-01_JPRB/) + KBO_MN2O( 5, :,14) = (/ & + & 1.11848E+02_JPRB, 1.09489E+02_JPRB, 1.07179E+02_JPRB, 1.04918E+02_JPRB, 1.02705E+02_JPRB, & + & 1.00538E+02_JPRB, 9.84175E+01_JPRB, 9.63414E+01_JPRB, 9.43091E+01_JPRB, 9.23196E+01_JPRB, & + & 9.03722E+01_JPRB, 8.84658E+01_JPRB, 8.65996E+01_JPRB, 8.47728E+01_JPRB, 8.29845E+01_JPRB, & + & 8.12339E+01_JPRB, 7.95203E+01_JPRB, 7.78428E+01_JPRB, 7.62007E+01_JPRB/) + KBO_MN2O( 1, :,15) = (/ & + & 1.52234E-02_JPRB, 1.69256E-02_JPRB, 1.88181E-02_JPRB, 2.09222E-02_JPRB, 2.32617E-02_JPRB, & + & 2.58626E-02_JPRB, 2.87545E-02_JPRB, 3.19696E-02_JPRB, 3.55443E-02_JPRB, 3.95187E-02_JPRB, & + & 4.39374E-02_JPRB, 4.88503E-02_JPRB, 5.43124E-02_JPRB, 6.03854E-02_JPRB, 6.71373E-02_JPRB, & + & 7.46443E-02_JPRB, 8.29906E-02_JPRB, 9.22701E-02_JPRB, 1.02587E-01_JPRB/) + KBO_MN2O( 2, :,15) = (/ & + & 1.52234E-02_JPRB, 1.69256E-02_JPRB, 1.88181E-02_JPRB, 2.09222E-02_JPRB, 2.32617E-02_JPRB, & + & 2.58626E-02_JPRB, 2.87545E-02_JPRB, 3.19696E-02_JPRB, 3.55443E-02_JPRB, 3.95187E-02_JPRB, & + & 4.39374E-02_JPRB, 4.88503E-02_JPRB, 5.43124E-02_JPRB, 6.03854E-02_JPRB, 6.71373E-02_JPRB, & + & 7.46443E-02_JPRB, 8.29906E-02_JPRB, 9.22701E-02_JPRB, 1.02587E-01_JPRB/) + KBO_MN2O( 3, :,15) = (/ & + & 1.52076E-02_JPRB, 1.69049E-02_JPRB, 1.87916E-02_JPRB, 2.08890E-02_JPRB, 2.32203E-02_JPRB, & + & 2.58119E-02_JPRB, 2.86928E-02_JPRB, 3.18951E-02_JPRB, 3.54549E-02_JPRB, 3.94120E-02_JPRB, & + & 4.38107E-02_JPRB, 4.87003E-02_JPRB, 5.41357E-02_JPRB, 6.01777E-02_JPRB, 6.68940E-02_JPRB, & + & 7.43600E-02_JPRB, 8.26593E-02_JPRB, 9.18847E-02_JPRB, 1.02140E-01_JPRB/) + KBO_MN2O( 4, :,15) = (/ & + & 1.52422E-02_JPRB, 1.69488E-02_JPRB, 1.88464E-02_JPRB, 2.09565E-02_JPRB, 2.33028E-02_JPRB, & + & 2.59118E-02_JPRB, 2.88129E-02_JPRB, 3.20389E-02_JPRB, 3.56260E-02_JPRB, 3.96148E-02_JPRB, & + & 4.40501E-02_JPRB, 4.89821E-02_JPRB, 5.44662E-02_JPRB, 6.05643E-02_JPRB, 6.73452E-02_JPRB, & + & 7.48853E-02_JPRB, 8.32696E-02_JPRB, 9.25927E-02_JPRB, 1.02959E-01_JPRB/) + KBO_MN2O( 5, :,15) = (/ & + & 6.94782E+01_JPRB, 6.73469E+01_JPRB, 6.52810E+01_JPRB, 6.32785E+01_JPRB, 6.13373E+01_JPRB, & + & 5.94558E+01_JPRB, 5.76319E+01_JPRB, 5.58640E+01_JPRB, 5.41503E+01_JPRB, 5.24892E+01_JPRB, & + & 5.08791E+01_JPRB, 4.93183E+01_JPRB, 4.78055E+01_JPRB, 4.63390E+01_JPRB, 4.49175E+01_JPRB, & + & 4.35396E+01_JPRB, 4.22040E+01_JPRB, 4.09094E+01_JPRB, 3.96544E+01_JPRB/) + KBO_MN2O( 1, :,16) = (/ & + & 1.08257E-02_JPRB, 1.15188E-02_JPRB, 1.22563E-02_JPRB, 1.30410E-02_JPRB, 1.38759E-02_JPRB, & + & 1.47643E-02_JPRB, 1.57096E-02_JPRB, 1.67154E-02_JPRB, 1.77857E-02_JPRB, 1.89244E-02_JPRB, & + & 2.01360E-02_JPRB, 2.14252E-02_JPRB, 2.27970E-02_JPRB, 2.42565E-02_JPRB, 2.58096E-02_JPRB, & + & 2.74620E-02_JPRB, 2.92203E-02_JPRB, 3.10911E-02_JPRB, 3.30817E-02_JPRB/) + KBO_MN2O( 2, :,16) = (/ & + & 1.08257E-02_JPRB, 1.15188E-02_JPRB, 1.22563E-02_JPRB, 1.30410E-02_JPRB, 1.38759E-02_JPRB, & + & 1.47643E-02_JPRB, 1.57096E-02_JPRB, 1.67154E-02_JPRB, 1.77857E-02_JPRB, 1.89244E-02_JPRB, & + & 2.01360E-02_JPRB, 2.14252E-02_JPRB, 2.27970E-02_JPRB, 2.42565E-02_JPRB, 2.58096E-02_JPRB, & + & 2.74620E-02_JPRB, 2.92203E-02_JPRB, 3.10911E-02_JPRB, 3.30817E-02_JPRB/) + KBO_MN2O( 3, :,16) = (/ & + & 1.08257E-02_JPRB, 1.15188E-02_JPRB, 1.22563E-02_JPRB, 1.30410E-02_JPRB, 1.38759E-02_JPRB, & + & 1.47643E-02_JPRB, 1.57096E-02_JPRB, 1.67154E-02_JPRB, 1.77857E-02_JPRB, 1.89244E-02_JPRB, & + & 2.01360E-02_JPRB, 2.14252E-02_JPRB, 2.27970E-02_JPRB, 2.42565E-02_JPRB, 2.58096E-02_JPRB, & + & 2.74620E-02_JPRB, 2.92203E-02_JPRB, 3.10911E-02_JPRB, 3.30817E-02_JPRB/) + KBO_MN2O( 4, :,16) = (/ & + & 1.08263E-02_JPRB, 1.15191E-02_JPRB, 1.22562E-02_JPRB, 1.30404E-02_JPRB, 1.38749E-02_JPRB, & + & 1.47627E-02_JPRB, 1.57073E-02_JPRB, 1.67124E-02_JPRB, 1.77818E-02_JPRB, 1.89196E-02_JPRB, & + & 2.01302E-02_JPRB, 2.14183E-02_JPRB, 2.27888E-02_JPRB, 2.42470E-02_JPRB, 2.57986E-02_JPRB, & + & 2.74494E-02_JPRB, 2.92058E-02_JPRB, 3.10746E-02_JPRB, 3.30630E-02_JPRB/) + KBO_MN2O( 5, :,16) = (/ & + & 4.53450E-08_JPRB, 5.75193E-08_JPRB, 7.29620E-08_JPRB, 9.25509E-08_JPRB, 1.17399E-07_JPRB, & + & 1.48918E-07_JPRB, 1.88900E-07_JPRB, 2.39616E-07_JPRB, 3.03948E-07_JPRB, 3.85551E-07_JPRB, & + & 4.89064E-07_JPRB, 6.20369E-07_JPRB, 7.86925E-07_JPRB, 9.98199E-07_JPRB, 1.26619E-06_JPRB, & + & 1.60614E-06_JPRB, 2.03736E-06_JPRB, 2.58435E-06_JPRB, 3.27819E-06_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &9.0039E-04_JPRB,1.1081E-03_JPRB,1.0732E-03_JPRB,1.1881E-03_JPRB,1.2488E-03_JPRB,1.3170E-03_JPRB, & + &1.3317E-03_JPRB,1.3168E-03_JPRB,1.3369E-03_JPRB,1.4228E-03_JPRB,1.5385E-03_JPRB,1.7376E-03_JPRB, & + &1.7122E-03_JPRB,1.9002E-03_JPRB,1.8881E-03_JPRB,2.1595E-03_JPRB/) + FORREFO(2,:) = (/ & + &1.2726E-03_JPRB,1.3680E-03_JPRB,1.2494E-03_JPRB,1.2049E-03_JPRB,1.2048E-03_JPRB,1.1256E-03_JPRB, & + &1.1170E-03_JPRB,1.0697E-03_JPRB,1.1177E-03_JPRB,1.1883E-03_JPRB,1.2219E-03_JPRB,1.2179E-03_JPRB, & + &1.5692E-03_JPRB,1.9103E-03_JPRB,2.0219E-03_JPRB,1.6937E-03_JPRB/) + FORREFO(3,:) = (/ & + &1.5527E-03_JPRB,1.6477E-03_JPRB,1.4973E-03_JPRB,1.3400E-03_JPRB,1.0820E-03_JPRB,9.3315E-04_JPRB, & + &8.8132E-04_JPRB,8.1508E-04_JPRB,8.3559E-04_JPRB,7.6492E-04_JPRB,8.2343E-04_JPRB,7.1274E-04_JPRB, & + &6.6011E-04_JPRB,6.7179E-04_JPRB,6.7039E-04_JPRB,6.7021E-04_JPRB/) + FORREFO(4,:) = (/ & + &1.6763E-03_JPRB,1.6066E-03_JPRB,1.3927E-03_JPRB,1.2087E-03_JPRB,9.8463E-04_JPRB,8.8414E-04_JPRB, & + &8.0976E-04_JPRB,7.8758E-04_JPRB,7.7376E-04_JPRB,7.5785E-04_JPRB,7.4152E-04_JPRB,7.3814E-04_JPRB, & + &7.4278E-04_JPRB,7.1745E-04_JPRB,6.7216E-04_JPRB,6.4097E-04_JPRB/) + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 5.11926E-01_JPRB, 4.32863E-01_JPRB, 3.66010E-01_JPRB, 3.09482E-01_JPRB, 2.61685E-01_JPRB, & + & 2.21269E-01_JPRB, 1.87096E-01_JPRB, 1.58200E-01_JPRB, 1.33767E-01_JPRB, 1.13108E-01_JPRB/) + SELFREFO(:, 2) = (/ & + & 5.02863E-01_JPRB, 4.35008E-01_JPRB, 3.76310E-01_JPRB, 3.25532E-01_JPRB, 2.81606E-01_JPRB, & + & 2.43607E-01_JPRB, 2.10736E-01_JPRB, 1.82300E-01_JPRB, 1.57701E-01_JPRB, 1.36422E-01_JPRB/) + SELFREFO(:, 3) = (/ & + & 4.57628E-01_JPRB, 3.99663E-01_JPRB, 3.49040E-01_JPRB, 3.04829E-01_JPRB, 2.66218E-01_JPRB, & + & 2.32498E-01_JPRB, 2.03049E-01_JPRB, 1.77330E-01_JPRB, 1.54869E-01_JPRB, 1.35252E-01_JPRB/) + SELFREFO(:, 4) = (/ & + & 4.28634E-01_JPRB, 3.81736E-01_JPRB, 3.39970E-01_JPRB, 3.02773E-01_JPRB, 2.69647E-01_JPRB, & + & 2.40144E-01_JPRB, 2.13870E-01_JPRB, 1.90470E-01_JPRB, 1.69630E-01_JPRB, 1.51071E-01_JPRB/) + SELFREFO(:, 5) = (/ & + & 4.21002E-01_JPRB, 3.77493E-01_JPRB, 3.38480E-01_JPRB, 3.03499E-01_JPRB, 2.72133E-01_JPRB, & + & 2.44009E-01_JPRB, 2.18792E-01_JPRB, 1.96180E-01_JPRB, 1.75905E-01_JPRB, 1.57726E-01_JPRB/) + SELFREFO(:, 6) = (/ & + & 3.97517E-01_JPRB, 3.61167E-01_JPRB, 3.28140E-01_JPRB, 2.98133E-01_JPRB, 2.70871E-01_JPRB, & + & 2.46101E-01_JPRB, 2.23597E-01_JPRB, 2.03150E-01_JPRB, 1.84573E-01_JPRB, 1.67695E-01_JPRB/) + SELFREFO(:, 7) = (/ & + & 3.92114E-01_JPRB, 3.57554E-01_JPRB, 3.26040E-01_JPRB, 2.97304E-01_JPRB, 2.71100E-01_JPRB, & + & 2.47206E-01_JPRB, 2.25418E-01_JPRB, 2.05550E-01_JPRB, 1.87433E-01_JPRB, 1.70913E-01_JPRB/) + SELFREFO(:, 8) = (/ & + & 3.79555E-01_JPRB, 3.47264E-01_JPRB, 3.17720E-01_JPRB, 2.90690E-01_JPRB, 2.65959E-01_JPRB, & + & 2.43332E-01_JPRB, 2.22631E-01_JPRB, 2.03690E-01_JPRB, 1.86361E-01_JPRB, 1.70506E-01_JPRB/) + SELFREFO(:, 9) = (/ & + & 3.92644E-01_JPRB, 3.58048E-01_JPRB, 3.26500E-01_JPRB, 2.97732E-01_JPRB, 2.71498E-01_JPRB, & + & 2.47576E-01_JPRB, 2.25762E-01_JPRB, 2.05870E-01_JPRB, 1.87731E-01_JPRB, 1.71190E-01_JPRB/) + SELFREFO(:,10) = (/ & + & 4.06542E-01_JPRB, 3.71200E-01_JPRB, 3.38930E-01_JPRB, 3.09465E-01_JPRB, 2.82562E-01_JPRB, & + & 2.57998E-01_JPRB, 2.35569E-01_JPRB, 2.15090E-01_JPRB, 1.96391E-01_JPRB, 1.79318E-01_JPRB/) + SELFREFO(:,11) = (/ & + & 4.09672E-01_JPRB, 3.76237E-01_JPRB, 3.45530E-01_JPRB, 3.17329E-01_JPRB, 2.91430E-01_JPRB, & + & 2.67645E-01_JPRB, 2.45801E-01_JPRB, 2.25740E-01_JPRB, 2.07316E-01_JPRB, 1.90396E-01_JPRB/) + SELFREFO(:,12) = (/ & + & 3.85140E-01_JPRB, 3.61989E-01_JPRB, 3.40230E-01_JPRB, 3.19779E-01_JPRB, 3.00557E-01_JPRB, & + & 2.82490E-01_JPRB, 2.65510E-01_JPRB, 2.49550E-01_JPRB, 2.34549E-01_JPRB, 2.20451E-01_JPRB/) + SELFREFO(:,13) = (/ & + & 4.87349E-01_JPRB, 4.42192E-01_JPRB, 4.01220E-01_JPRB, 3.64044E-01_JPRB, 3.30313E-01_JPRB, & + & 2.99707E-01_JPRB, 2.71937E-01_JPRB, 2.46740E-01_JPRB, 2.23878E-01_JPRB, 2.03134E-01_JPRB/) + SELFREFO(:,14) = (/ & + & 5.64339E-01_JPRB, 5.06194E-01_JPRB, 4.54040E-01_JPRB, 4.07259E-01_JPRB, 3.65298E-01_JPRB, & + & 3.27661E-01_JPRB, 2.93901E-01_JPRB, 2.63620E-01_JPRB, 2.36459E-01_JPRB, 2.12096E-01_JPRB/) + SELFREFO(:,15) = (/ & + & 5.91123E-01_JPRB, 5.26420E-01_JPRB, 4.68800E-01_JPRB, 4.17486E-01_JPRB, 3.71790E-01_JPRB, & + & 3.31095E-01_JPRB, 2.94854E-01_JPRB, 2.62580E-01_JPRB, 2.33839E-01_JPRB, 2.08243E-01_JPRB/) + SELFREFO(:,16) = (/ & + & 5.04590E-01_JPRB, 4.65235E-01_JPRB, 4.28950E-01_JPRB, 3.95495E-01_JPRB, 3.64649E-01_JPRB, & + & 3.36209E-01_JPRB, 3.09987E-01_JPRB, 2.85810E-01_JPRB, 2.63519E-01_JPRB, 2.42966E-01_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB3',1,ZHOOK_HANDLE) +RETURN + +END SUBROUTINE RRTM_KGB3 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb4.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb4.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb4.F90 (revision 6016) @@ -0,0 +1,229 @@ +SUBROUTINE RRTM_KGB4 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 4: 630-700 cm-1 (low - H2O,CO2; high - O3,CO2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD +USE YOMMP0 , ONLY : NPROC, MYPROC + +USE YOERRTO4 , ONLY : KAO ,KBO ,SELFREFO ,FORREFO, FRACREFAO ,FRACREFBO, & + & KAO_D, KBO_D + + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB4',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB4:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB4:') +ENDIF + + +! Planck fraction mapping level : P = 142.5940 mbar, T = 215.70 K + FRACREFAO(:, 1) = (/ & + & 1.5572E-01_JPRB,1.4925E-01_JPRB,1.4107E-01_JPRB,1.3126E-01_JPRB,1.1791E-01_JPRB,1.0173E-01_JPRB, & + & 8.2949E-02_JPRB,6.2393E-02_JPRB,4.2146E-02_JPRB,4.5907E-03_JPRB,3.7965E-03_JPRB,2.9744E-03_JPRB, & + & 2.2074E-03_JPRB,1.4063E-03_JPRB,5.3012E-04_JPRB,7.4595E-05_JPRB/) + FRACREFAO(:, 2) = (/ & + & 1.5572E-01_JPRB,1.4925E-01_JPRB,1.4107E-01_JPRB,1.3126E-01_JPRB,1.1791E-01_JPRB,1.0173E-01_JPRB, & + & 8.2949E-02_JPRB,6.2392E-02_JPRB,4.2146E-02_JPRB,4.5906E-03_JPRB,3.7965E-03_JPRB,2.9745E-03_JPRB, & + & 2.2074E-03_JPRB,1.4063E-03_JPRB,5.3012E-04_JPRB,7.4595E-05_JPRB/) + FRACREFAO(:, 3) = (/ & + & 1.5572E-01_JPRB,1.4925E-01_JPRB,1.4107E-01_JPRB,1.3126E-01_JPRB,1.1791E-01_JPRB,1.0173E-01_JPRB, & + & 8.2949E-02_JPRB,6.2393E-02_JPRB,4.2146E-02_JPRB,4.5907E-03_JPRB,3.7965E-03_JPRB,2.9745E-03_JPRB, & + & 2.2074E-03_JPRB,1.4063E-03_JPRB,5.3012E-04_JPRB,7.4595E-05_JPRB/) + FRACREFAO(:, 4) = (/ & + & 1.5572E-01_JPRB,1.4925E-01_JPRB,1.4107E-01_JPRB,1.3126E-01_JPRB,1.1791E-01_JPRB,1.0173E-01_JPRB, & + & 8.2949E-02_JPRB,6.2393E-02_JPRB,4.2146E-02_JPRB,4.5907E-03_JPRB,3.7964E-03_JPRB,2.9744E-03_JPRB, & + & 2.2074E-03_JPRB,1.4063E-03_JPRB,5.3012E-04_JPRB,7.4595E-05_JPRB/) + FRACREFAO(:, 5) = (/ & + & 1.5572E-01_JPRB,1.4925E-01_JPRB,1.4107E-01_JPRB,1.3126E-01_JPRB,1.1791E-01_JPRB,1.0173E-01_JPRB, & + & 8.2949E-02_JPRB,6.2393E-02_JPRB,4.2146E-02_JPRB,4.5907E-03_JPRB,3.7965E-03_JPRB,2.9744E-03_JPRB, & + & 2.2074E-03_JPRB,1.4063E-03_JPRB,5.3012E-04_JPRB,7.4595E-05_JPRB/) + FRACREFAO(:, 6) = (/ & + & 1.5572E-01_JPRB,1.4925E-01_JPRB,1.4107E-01_JPRB,1.3126E-01_JPRB,1.1791E-01_JPRB,1.0173E-01_JPRB, & + & 8.2949E-02_JPRB,6.2393E-02_JPRB,4.2146E-02_JPRB,4.5907E-03_JPRB,3.7965E-03_JPRB,2.9744E-03_JPRB, & + & 2.2074E-03_JPRB,1.4063E-03_JPRB,5.3012E-04_JPRB,7.4595E-05_JPRB/) + FRACREFAO(:, 7) = (/ & + & 1.5572E-01_JPRB,1.4926E-01_JPRB,1.4107E-01_JPRB,1.3126E-01_JPRB,1.1791E-01_JPRB,1.0173E-01_JPRB, & + & 8.2949E-02_JPRB,6.2393E-02_JPRB,4.2146E-02_JPRB,4.5908E-03_JPRB,3.7964E-03_JPRB,2.9745E-03_JPRB, & + & 2.2074E-03_JPRB,1.4063E-03_JPRB,5.3012E-04_JPRB,7.4595E-05_JPRB/) + FRACREFAO(:, 8) = (/ & + & 1.5571E-01_JPRB,1.4926E-01_JPRB,1.4107E-01_JPRB,1.3125E-01_JPRB,1.1791E-01_JPRB,1.0173E-01_JPRB, & + & 8.2949E-02_JPRB,6.2393E-02_JPRB,4.2146E-02_JPRB,4.5907E-03_JPRB,3.7964E-03_JPRB,2.9744E-03_JPRB, & + & 2.2074E-03_JPRB,1.4063E-03_JPRB,5.3012E-04_JPRB,7.4595E-05_JPRB/) + FRACREFAO(:, 9) = (/ & + & 1.5952E-01_JPRB,1.5155E-01_JPRB,1.4217E-01_JPRB,1.3077E-01_JPRB,1.1667E-01_JPRB,1.0048E-01_JPRB, & + & 8.1511E-02_JPRB,6.1076E-02_JPRB,4.1111E-02_JPRB,4.4432E-03_JPRB,3.6910E-03_JPRB,2.9076E-03_JPRB, & + & 2.1329E-03_JPRB,1.3566E-03_JPRB,5.2235E-04_JPRB,7.9935E-05_JPRB/) + +! Planck fraction mapping level : P = 95.58350 mb, T = 215.70 K + FRACREFBO(:, 1) = (/ & + & 1.5558E-01_JPRB,1.4931E-01_JPRB,1.4104E-01_JPRB,1.3124E-01_JPRB,1.1793E-01_JPRB,1.0160E-01_JPRB, & + & 8.3142E-02_JPRB,6.2403E-02_JPRB,4.2170E-02_JPRB,4.5935E-03_JPRB,3.7976E-03_JPRB,2.9986E-03_JPRB, & + & 2.1890E-03_JPRB,1.4061E-03_JPRB,5.3005E-04_JPRB,7.4587E-05_JPRB/) + FRACREFBO(:, 2) = (/ & + & 1.5558E-01_JPRB,1.4932E-01_JPRB,1.4104E-01_JPRB,1.3124E-01_JPRB,1.1792E-01_JPRB,1.0159E-01_JPRB, & + & 8.3142E-02_JPRB,6.2403E-02_JPRB,4.2170E-02_JPRB,4.5935E-03_JPRB,3.7976E-03_JPRB,2.9986E-03_JPRB, & + & 2.1890E-03_JPRB,1.4061E-03_JPRB,5.3005E-04_JPRB,7.4587E-05_JPRB/) + FRACREFBO(:, 3) = (/ & + & 1.5558E-01_JPRB,1.4933E-01_JPRB,1.4103E-01_JPRB,1.3124E-01_JPRB,1.1792E-01_JPRB,1.0159E-01_JPRB, & + & 8.3142E-02_JPRB,6.2403E-02_JPRB,4.2170E-02_JPRB,4.5935E-03_JPRB,3.7976E-03_JPRB,2.9986E-03_JPRB, & + & 2.1890E-03_JPRB,1.4061E-03_JPRB,5.3005E-04_JPRB,7.4587E-05_JPRB/) + FRACREFBO(:, 4) = (/ & + & 1.5569E-01_JPRB,1.4926E-01_JPRB,1.4102E-01_JPRB,1.3122E-01_JPRB,1.1791E-01_JPRB,1.0159E-01_JPRB, & + & 8.3141E-02_JPRB,6.2403E-02_JPRB,4.2170E-02_JPRB,4.5935E-03_JPRB,3.7976E-03_JPRB,2.9986E-03_JPRB, & + & 2.1890E-03_JPRB,1.4061E-03_JPRB,5.3005E-04_JPRB,7.4587E-05_JPRB/) + FRACREFBO(:, 5) = (/ & + & 1.5947E-01_JPRB,1.5132E-01_JPRB,1.4195E-01_JPRB,1.3061E-01_JPRB,1.1680E-01_JPRB,1.0054E-01_JPRB, & + & 8.1785E-02_JPRB,6.1212E-02_JPRB,4.1276E-02_JPRB,4.4424E-03_JPRB,3.6628E-03_JPRB,2.8943E-03_JPRB, & + & 2.1134E-03_JPRB,1.3457E-03_JPRB,5.1024E-04_JPRB,7.3998E-05_JPRB/) + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 9 and corresponds to different water vapor to CO2 ratios, +! as expressed through the binary species parameter eta, defined as +! eta = h2o/(h20 + (rat) * co2), where rat is the ratio of the integrated +! line strength in the band of co2 to that of h2o. For instance, +! JS=1 refers to dry air (eta = 0), JS = 9 corresponds to eta = 1.0. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, +! JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + + +! The array KBO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of O3 to CO2. The first index in the array, JS, runs from 1 to 6, +! and corresponds to different O3 to CO2 ratios, as expressed through +! the binary species parameter eta, defined as eta = O3/(O3+RAT*H2O), +! where RAT is the ratio of the integrated line strength in the band +! of CO2 to that of O3. For instance, JS=1 refers to no O3 (eta = 0) +! and JS = 5 corresponds to eta = 1.0. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + + + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &3.3839E-04_JPRB,2.4739E-04_JPRB,2.2846E-04_JPRB,2.3376E-04_JPRB,2.2622E-04_JPRB,2.3188E-04_JPRB, & + &2.2990E-04_JPRB,2.2532E-04_JPRB,2.1233E-04_JPRB,2.0593E-04_JPRB,2.0716E-04_JPRB,2.0809E-04_JPRB, & + &2.0889E-04_JPRB,2.0932E-04_JPRB,2.0944E-04_JPRB,2.0945E-04_JPRB/) + FORREFO(2,:) = (/ & + &3.4391E-04_JPRB,2.6022E-04_JPRB,2.3449E-04_JPRB,2.4544E-04_JPRB,2.3831E-04_JPRB,2.3014E-04_JPRB, & + &2.3729E-04_JPRB,2.2726E-04_JPRB,2.1892E-04_JPRB,1.9223E-04_JPRB,2.1291E-04_JPRB,2.1406E-04_JPRB, & + &2.1491E-04_JPRB,2.1548E-04_JPRB,2.1562E-04_JPRB,2.1567E-04_JPRB/) + FORREFO(3,:) = (/ & + &3.4219E-04_JPRB,2.7334E-04_JPRB,2.3727E-04_JPRB,2.4515E-04_JPRB,2.5272E-04_JPRB,2.4212E-04_JPRB, & + &2.3824E-04_JPRB,2.3615E-04_JPRB,2.2724E-04_JPRB,2.2381E-04_JPRB,1.9634E-04_JPRB,2.1625E-04_JPRB, & + &2.1963E-04_JPRB,2.2032E-04_JPRB,2.2057E-04_JPRB,2.2058E-04_JPRB/) + FORREFO(4,:) = (/ & + &3.1684E-04_JPRB,2.4823E-04_JPRB,2.4890E-04_JPRB,2.4577E-04_JPRB,2.4106E-04_JPRB,2.4353E-04_JPRB, & + &2.4038E-04_JPRB,2.3932E-04_JPRB,2.3604E-04_JPRB,2.3773E-04_JPRB,2.4243E-04_JPRB,2.2597E-04_JPRB, & + &2.2879E-04_JPRB,2.2440E-04_JPRB,2.1104E-04_JPRB,2.1460E-04_JPRB/) + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 2.62922E-01_JPRB, 2.29106E-01_JPRB, 1.99640E-01_JPRB, 1.73964E-01_JPRB, 1.51589E-01_JPRB, & + & 1.32093E-01_JPRB, 1.15104E-01_JPRB, 1.00300E-01_JPRB, 8.74000E-02_JPRB, 7.61592E-02_JPRB/) + SELFREFO(:, 2) = (/ & + & 2.45448E-01_JPRB, 2.13212E-01_JPRB, 1.85210E-01_JPRB, 1.60886E-01_JPRB, 1.39756E-01_JPRB, & + & 1.21401E-01_JPRB, 1.05457E-01_JPRB, 9.16070E-02_JPRB, 7.95759E-02_JPRB, 6.91249E-02_JPRB/) + SELFREFO(:, 3) = (/ & + & 2.41595E-01_JPRB, 2.09697E-01_JPRB, 1.82010E-01_JPRB, 1.57979E-01_JPRB, 1.37121E-01_JPRB, & + & 1.19016E-01_JPRB, 1.03302E-01_JPRB, 8.96630E-02_JPRB, 7.78246E-02_JPRB, 6.75492E-02_JPRB/) + SELFREFO(:, 4) = (/ & + & 2.44818E-01_JPRB, 2.12172E-01_JPRB, 1.83880E-01_JPRB, 1.59360E-01_JPRB, 1.38110E-01_JPRB, & + & 1.19694E-01_JPRB, 1.03733E-01_JPRB, 8.99010E-02_JPRB, 7.79131E-02_JPRB, 6.75238E-02_JPRB/) + SELFREFO(:, 5) = (/ & + & 2.43458E-01_JPRB, 2.10983E-01_JPRB, 1.82840E-01_JPRB, 1.58451E-01_JPRB, 1.37315E-01_JPRB, & + & 1.18998E-01_JPRB, 1.03125E-01_JPRB, 8.93690E-02_JPRB, 7.74480E-02_JPRB, 6.71171E-02_JPRB/) + SELFREFO(:, 6) = (/ & + & 2.40186E-01_JPRB, 2.08745E-01_JPRB, 1.81420E-01_JPRB, 1.57672E-01_JPRB, 1.37032E-01_JPRB, & + & 1.19095E-01_JPRB, 1.03505E-01_JPRB, 8.99560E-02_JPRB, 7.81806E-02_JPRB, 6.79467E-02_JPRB/) + SELFREFO(:, 7) = (/ & + & 2.42752E-01_JPRB, 2.10579E-01_JPRB, 1.82670E-01_JPRB, 1.58460E-01_JPRB, 1.37459E-01_JPRB, & + & 1.19240E-01_JPRB, 1.03437E-01_JPRB, 8.97280E-02_JPRB, 7.78359E-02_JPRB, 6.75200E-02_JPRB/) + SELFREFO(:, 8) = (/ & + & 2.39620E-01_JPRB, 2.08166E-01_JPRB, 1.80840E-01_JPRB, 1.57101E-01_JPRB, 1.36479E-01_JPRB, & + & 1.18563E-01_JPRB, 1.03000E-01_JPRB, 8.94790E-02_JPRB, 7.77332E-02_JPRB, 6.75292E-02_JPRB/) + SELFREFO(:, 9) = (/ & + & 2.38856E-01_JPRB, 2.07166E-01_JPRB, 1.79680E-01_JPRB, 1.55841E-01_JPRB, 1.35165E-01_JPRB, & + & 1.17232E-01_JPRB, 1.01678E-01_JPRB, 8.81880E-02_JPRB, 7.64877E-02_JPRB, 6.63397E-02_JPRB/) + SELFREFO(:,10) = (/ & + & 2.29821E-01_JPRB, 2.00586E-01_JPRB, 1.75070E-01_JPRB, 1.52800E-01_JPRB, 1.33363E-01_JPRB, & + & 1.16398E-01_JPRB, 1.01591E-01_JPRB, 8.86680E-02_JPRB, 7.73887E-02_JPRB, 6.75443E-02_JPRB/) + SELFREFO(:,11) = (/ & + & 2.39945E-01_JPRB, 2.08186E-01_JPRB, 1.80630E-01_JPRB, 1.56722E-01_JPRB, 1.35978E-01_JPRB, & + & 1.17980E-01_JPRB, 1.02364E-01_JPRB, 8.88150E-02_JPRB, 7.70594E-02_JPRB, 6.68598E-02_JPRB/) + SELFREFO(:,12) = (/ & + & 2.40271E-01_JPRB, 2.08465E-01_JPRB, 1.80870E-01_JPRB, 1.56927E-01_JPRB, 1.36154E-01_JPRB, & + & 1.18131E-01_JPRB, 1.02494E-01_JPRB, 8.89260E-02_JPRB, 7.71545E-02_JPRB, 6.69412E-02_JPRB/) + SELFREFO(:,13) = (/ & + & 2.40503E-01_JPRB, 2.08670E-01_JPRB, 1.81050E-01_JPRB, 1.57086E-01_JPRB, 1.36294E-01_JPRB, & + & 1.18254E-01_JPRB, 1.02602E-01_JPRB, 8.90210E-02_JPRB, 7.72380E-02_JPRB, 6.70147E-02_JPRB/) + SELFREFO(:,14) = (/ & + & 2.40670E-01_JPRB, 2.08811E-01_JPRB, 1.81170E-01_JPRB, 1.57188E-01_JPRB, 1.36380E-01_JPRB, & + & 1.18327E-01_JPRB, 1.02663E-01_JPRB, 8.90730E-02_JPRB, 7.72819E-02_JPRB, 6.70517E-02_JPRB/) + SELFREFO(:,15) = (/ & + & 2.40711E-01_JPRB, 2.08846E-01_JPRB, 1.81200E-01_JPRB, 1.57213E-01_JPRB, 1.36402E-01_JPRB, & + & 1.18346E-01_JPRB, 1.02679E-01_JPRB, 8.90870E-02_JPRB, 7.72939E-02_JPRB, 6.70621E-02_JPRB/) + SELFREFO(:,16) = (/ & + & 2.40727E-01_JPRB, 2.08859E-01_JPRB, 1.81210E-01_JPRB, 1.57221E-01_JPRB, 1.36408E-01_JPRB, & + & 1.18350E-01_JPRB, 1.02682E-01_JPRB, 8.90890E-02_JPRB, 7.72952E-02_JPRB, 6.70627E-02_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB4',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB4:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB4 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb5.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb5.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb5.F90 (revision 6016) @@ -0,0 +1,972 @@ +SUBROUTINE RRTM_KGB5 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 5: 700-820 cm-1 (low - H2O,CO2; high - O3,CO2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO5 , ONLY : KAO ,KBO ,SELFREFO ,FORREFO, FRACREFAO ,& + & FRACREFBO, CCL4O , KAO_MO3, KAO_D, KBO_D + +USE YOMMP0 , ONLY : NPROC, MYPROC + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB5',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB5:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB5:') +ENDIF + + +! Planck fraction mapping level : P = 473.42 mb, T = 259.83 + FRACREFAO(:, 1) = (/ & + & 1.4111E-01_JPRB,1.4222E-01_JPRB,1.3802E-01_JPRB,1.3101E-01_JPRB,1.2244E-01_JPRB,1.0691E-01_JPRB, & + & 8.8703E-02_JPRB,6.7130E-02_JPRB,4.5509E-02_JPRB,4.9866E-03_JPRB,4.1214E-03_JPRB,3.2557E-03_JPRB, & + & 2.3805E-03_JPRB,1.5450E-03_JPRB,5.8423E-04_JPRB,8.2275E-05_JPRB/) + FRACREFAO(:, 2) = (/ & + & 1.4152E-01_JPRB,1.4271E-01_JPRB,1.3784E-01_JPRB,1.3075E-01_JPRB,1.2215E-01_JPRB,1.0674E-01_JPRB, & + & 8.8686E-02_JPRB,6.7135E-02_JPRB,4.5508E-02_JPRB,4.9866E-03_JPRB,4.1214E-03_JPRB,3.2558E-03_JPRB, & + & 2.3805E-03_JPRB,1.5450E-03_JPRB,5.8423E-04_JPRB,8.2275E-05_JPRB/) + FRACREFAO(:, 3) = (/ & + & 1.4159E-01_JPRB,1.4300E-01_JPRB,1.3781E-01_JPRB,1.3094E-01_JPRB,1.2192E-01_JPRB,1.0661E-01_JPRB, & + & 8.8529E-02_JPRB,6.7127E-02_JPRB,4.5511E-02_JPRB,4.9877E-03_JPRB,4.1214E-03_JPRB,3.2558E-03_JPRB, & + & 2.3805E-03_JPRB,1.5450E-03_JPRB,5.8423E-04_JPRB,8.2275E-05_JPRB/) + FRACREFAO(:, 4) = (/ & + & 1.4162E-01_JPRB,1.4337E-01_JPRB,1.3774E-01_JPRB,1.3122E-01_JPRB,1.2172E-01_JPRB,1.0641E-01_JPRB, & + & 8.8384E-02_JPRB,6.7056E-02_JPRB,4.5514E-02_JPRB,4.9880E-03_JPRB,4.1214E-03_JPRB,3.2557E-03_JPRB, & + & 2.3805E-03_JPRB,1.5450E-03_JPRB,5.8423E-04_JPRB,8.2275E-05_JPRB/) + FRACREFAO(:, 5) = (/ & + & 1.4161E-01_JPRB,1.4370E-01_JPRB,1.3770E-01_JPRB,1.3143E-01_JPRB,1.2173E-01_JPRB,1.0613E-01_JPRB, & + & 8.8357E-02_JPRB,6.6874E-02_JPRB,4.5509E-02_JPRB,4.9883E-03_JPRB,4.1214E-03_JPRB,3.2558E-03_JPRB, & + & 2.3804E-03_JPRB,1.5450E-03_JPRB,5.8423E-04_JPRB,8.2275E-05_JPRB/) + FRACREFAO(:, 6) = (/ & + & 1.4154E-01_JPRB,1.4405E-01_JPRB,1.3771E-01_JPRB,1.3169E-01_JPRB,1.2166E-01_JPRB,1.0603E-01_JPRB, & + & 8.8193E-02_JPRB,6.6705E-02_JPRB,4.5469E-02_JPRB,4.9902E-03_JPRB,4.1214E-03_JPRB,3.2558E-03_JPRB, & + & 2.3804E-03_JPRB,1.5450E-03_JPRB,5.8423E-04_JPRB,8.2275E-05_JPRB/) + FRACREFAO(:, 7) = (/ & + & 1.4126E-01_JPRB,1.4440E-01_JPRB,1.3790E-01_JPRB,1.3214E-01_JPRB,1.2153E-01_JPRB,1.0603E-01_JPRB, & + & 8.7908E-02_JPRB,6.6612E-02_JPRB,4.5269E-02_JPRB,4.9900E-03_JPRB,4.1256E-03_JPRB,3.2558E-03_JPRB, & + & 2.3804E-03_JPRB,1.5451E-03_JPRB,5.8423E-04_JPRB,8.2275E-05_JPRB/) + FRACREFAO(:, 8) = (/ & + & 1.4076E-01_JPRB,1.4415E-01_JPRB,1.3885E-01_JPRB,1.3286E-01_JPRB,1.2147E-01_JPRB,1.0612E-01_JPRB, & + & 8.7579E-02_JPRB,6.6280E-02_JPRB,4.4977E-02_JPRB,4.9782E-03_JPRB,4.1200E-03_JPRB,3.2620E-03_JPRB, & + & 2.3820E-03_JPRB,1.5452E-03_JPRB,5.8423E-04_JPRB,8.2275E-05_JPRB/) + FRACREFAO(:, 9) = (/ & + & 1.4205E-01_JPRB,1.4496E-01_JPRB,1.4337E-01_JPRB,1.3504E-01_JPRB,1.2260E-01_JPRB,1.0428E-01_JPRB, & + & 8.4946E-02_JPRB,6.3625E-02_JPRB,4.2951E-02_JPRB,4.7313E-03_JPRB,3.9157E-03_JPRB,3.0879E-03_JPRB, & + & 2.2666E-03_JPRB,1.5193E-03_JPRB,5.7469E-04_JPRB,8.1674E-05_JPRB/) + +! Planck fraction mapping level : P = 0.2369280 mbar, T = 253.60 K + FRACREFBO(:, 1) = (/ & + & 1.4075E-01_JPRB,1.4196E-01_JPRB,1.3833E-01_JPRB,1.3345E-01_JPRB,1.2234E-01_JPRB,1.0718E-01_JPRB, & + & 8.8004E-02_JPRB,6.6308E-02_JPRB,4.5028E-02_JPRB,4.9029E-03_JPRB,4.0377E-03_JPRB,3.1870E-03_JPRB, & + & 2.3503E-03_JPRB,1.5146E-03_JPRB,5.7165E-04_JPRB,8.2371E-05_JPRB/) + FRACREFBO(:, 2) = (/ & + & 1.4081E-01_JPRB,1.4225E-01_JPRB,1.3890E-01_JPRB,1.3410E-01_JPRB,1.2254E-01_JPRB,1.0680E-01_JPRB, & + & 8.7391E-02_JPRB,6.5819E-02_JPRB,4.4725E-02_JPRB,4.9121E-03_JPRB,4.0420E-03_JPRB,3.1869E-03_JPRB, & + & 2.3504E-03_JPRB,1.5146E-03_JPRB,5.7165E-04_JPRB,8.2371E-05_JPRB/) + FRACREFBO(:, 3) = (/ & + & 1.4087E-01_JPRB,1.4227E-01_JPRB,1.3920E-01_JPRB,1.3395E-01_JPRB,1.2270E-01_JPRB,1.0694E-01_JPRB, & + & 8.7229E-02_JPRB,6.5653E-02_JPRB,4.4554E-02_JPRB,4.8797E-03_JPRB,4.0460E-03_JPRB,3.1939E-03_JPRB, & + & 2.3505E-03_JPRB,1.5146E-03_JPRB,5.7165E-04_JPRB,8.1910E-05_JPRB/) + FRACREFBO(:, 4) = (/ & + & 1.4089E-01_JPRB,1.4238E-01_JPRB,1.3956E-01_JPRB,1.3379E-01_JPRB,1.2284E-01_JPRB,1.0688E-01_JPRB, & + & 8.7192E-02_JPRB,6.5490E-02_JPRB,4.4390E-02_JPRB,4.8395E-03_JPRB,4.0173E-03_JPRB,3.2070E-03_JPRB, & + & 2.3559E-03_JPRB,1.5146E-03_JPRB,5.7165E-04_JPRB,8.2371E-05_JPRB/) + FRACREFBO(:, 5) = (/ & + & 1.4091E-01_JPRB,1.4417E-01_JPRB,1.4194E-01_JPRB,1.3457E-01_JPRB,1.2167E-01_JPRB,1.0551E-01_JPRB, & + & 8.6450E-02_JPRB,6.4889E-02_JPRB,4.3584E-02_JPRB,4.7551E-03_JPRB,3.9509E-03_JPRB,3.1374E-03_JPRB, & + & 2.3226E-03_JPRB,1.4942E-03_JPRB,5.7545E-04_JPRB,8.0887E-05_JPRB/) + + + +CCL4O( :) = (/& + & 26.1407_JPRB, 53.9776_JPRB, 63.8085_JPRB, 36.1701_JPRB,& + & 15.4099_JPRB, 10.23116_JPRB, 4.82948_JPRB, 5.03836_JPRB,& + & 1.75558_JPRB, 0.0_JPRB , 0.0_JPRB , 0.0_JPRB ,& + & 0.0_JPRB , 0.0_JPRB , 0.0_JPRB , 0.0_JPRB /) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 9 and corresponds to different water vapor to CO2 ratios, +! as expressed through the binary species parameter eta, defined as +! eta = h2o/(h20 + (rat) * co2), where rat is the ratio of the integrated +! line strength in the band of co2 to that of h2o. For instance, +! JS=1 refers to dry air (eta = 0), JS = 9 corresponds to eta = 1.0. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, +! JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + + +! The array KB contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of O3 to CO2. The first index in the array, JS, runs from 1 to 5, +! and corresponds to different O3 to CO2 ratios, as expressed through +! the binary species parameter eta, defined as eta = O3/(O3+RAT*CO2), +! where RAT is the ratio of the integrated line strength in the band +! of co2 to that of O3. For instance, JS=1 refers to no O3 (eta = 0) +! and JS = 5 corresponds to eta = 1.0. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + + + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + + KAO_MO3( 1, :, 1) = (/ & + & 9.31040E-03_JPRB, 1.01286E-02_JPRB, 1.10186E-02_JPRB, 1.19869E-02_JPRB, 1.30403E-02_JPRB, & + & 1.41862E-02_JPRB, 1.54328E-02_JPRB, 1.67890E-02_JPRB, 1.82644E-02_JPRB, 1.98694E-02_JPRB, & + & 2.16154E-02_JPRB, 2.35149E-02_JPRB, 2.55813E-02_JPRB, 2.78293E-02_JPRB, 3.02749E-02_JPRB, & + & 3.29353E-02_JPRB, 3.58295E-02_JPRB, 3.89781E-02_JPRB, 4.24034E-02_JPRB/) + KAO_MO3( 2, :, 1) = (/ & + & 1.11200E-02_JPRB, 1.20461E-02_JPRB, 1.30493E-02_JPRB, 1.41360E-02_JPRB, 1.53133E-02_JPRB, & + & 1.65886E-02_JPRB, 1.79701E-02_JPRB, 1.94666E-02_JPRB, 2.10878E-02_JPRB, 2.28440E-02_JPRB, & + & 2.47465E-02_JPRB, 2.68074E-02_JPRB, 2.90399E-02_JPRB, 3.14583E-02_JPRB, 3.40782E-02_JPRB, & + & 3.69162E-02_JPRB, 3.99907E-02_JPRB, 4.33211E-02_JPRB, 4.69289E-02_JPRB/) + KAO_MO3( 3, :, 1) = (/ & + & 1.21630E-02_JPRB, 1.31401E-02_JPRB, 1.41956E-02_JPRB, 1.53359E-02_JPRB, 1.65679E-02_JPRB, & + & 1.78988E-02_JPRB, 1.93366E-02_JPRB, 2.08899E-02_JPRB, 2.25680E-02_JPRB, 2.43808E-02_JPRB, & + & 2.63394E-02_JPRB, 2.84552E-02_JPRB, 3.07410E-02_JPRB, 3.32104E-02_JPRB, 3.58782E-02_JPRB, & + & 3.87603E-02_JPRB, 4.18739E-02_JPRB, 4.52377E-02_JPRB, 4.88716E-02_JPRB/) + KAO_MO3( 4, :, 1) = (/ & + & 1.26231E-02_JPRB, 1.36243E-02_JPRB, 1.47049E-02_JPRB, 1.58713E-02_JPRB, 1.71301E-02_JPRB, & + & 1.84888E-02_JPRB, 1.99553E-02_JPRB, 2.15380E-02_JPRB, 2.32463E-02_JPRB, 2.50901E-02_JPRB, & + & 2.70801E-02_JPRB, 2.92280E-02_JPRB, 3.15463E-02_JPRB, 3.40484E-02_JPRB, 3.67489E-02_JPRB, & + & 3.96637E-02_JPRB, 4.28097E-02_JPRB, 4.62051E-02_JPRB, 4.98699E-02_JPRB/) + KAO_MO3( 5, :, 1) = (/ & + & 1.33345E-02_JPRB, 1.43736E-02_JPRB, 1.54938E-02_JPRB, 1.67012E-02_JPRB, 1.80027E-02_JPRB, & + & 1.94057E-02_JPRB, 2.09180E-02_JPRB, 2.25481E-02_JPRB, 2.43053E-02_JPRB, 2.61994E-02_JPRB, & + & 2.82411E-02_JPRB, 3.04419E-02_JPRB, 3.28142E-02_JPRB, 3.53714E-02_JPRB, 3.81279E-02_JPRB, & + & 4.10992E-02_JPRB, 4.43021E-02_JPRB, 4.77545E-02_JPRB, 5.14760E-02_JPRB/) + KAO_MO3( 6, :, 1) = (/ & + & 1.43294E-02_JPRB, 1.54133E-02_JPRB, 1.65791E-02_JPRB, 1.78331E-02_JPRB, 1.91819E-02_JPRB, & + & 2.06328E-02_JPRB, 2.21935E-02_JPRB, 2.38721E-02_JPRB, 2.56778E-02_JPRB, 2.76200E-02_JPRB, & + & 2.97091E-02_JPRB, 3.19562E-02_JPRB, 3.43733E-02_JPRB, 3.69732E-02_JPRB, 3.97698E-02_JPRB, & + & 4.27779E-02_JPRB, 4.60136E-02_JPRB, 4.94939E-02_JPRB, 5.32375E-02_JPRB/) + KAO_MO3( 7, :, 1) = (/ & + & 1.48298E-02_JPRB, 1.59503E-02_JPRB, 1.71554E-02_JPRB, 1.84517E-02_JPRB, 1.98458E-02_JPRB, & + & 2.13453E-02_JPRB, 2.29581E-02_JPRB, 2.46928E-02_JPRB, 2.65585E-02_JPRB, 2.85652E-02_JPRB, & + & 3.07235E-02_JPRB, 3.30449E-02_JPRB, 3.55417E-02_JPRB, 3.82272E-02_JPRB, 4.11155E-02_JPRB, & + & 4.42221E-02_JPRB, 4.75634E-02_JPRB, 5.11572E-02_JPRB, 5.50225E-02_JPRB/) + KAO_MO3( 8, :, 1) = (/ & + & 1.41792E-02_JPRB, 1.53141E-02_JPRB, 1.65398E-02_JPRB, 1.78637E-02_JPRB, 1.92935E-02_JPRB, & + & 2.08378E-02_JPRB, 2.25057E-02_JPRB, 2.43071E-02_JPRB, 2.62526E-02_JPRB, 2.83539E-02_JPRB, & + & 3.06234E-02_JPRB, 3.30745E-02_JPRB, 3.57218E-02_JPRB, 3.85810E-02_JPRB, 4.16690E-02_JPRB, & + & 4.50042E-02_JPRB, 4.86064E-02_JPRB, 5.24969E-02_JPRB, 5.66988E-02_JPRB/) + KAO_MO3( 9, :, 1) = (/ & + & 8.82784E-03_JPRB, 9.48321E-03_JPRB, 1.01872E-02_JPRB, 1.09435E-02_JPRB, 1.17560E-02_JPRB, & + & 1.26287E-02_JPRB, 1.35662E-02_JPRB, 1.45734E-02_JPRB, 1.56553E-02_JPRB, 1.68175E-02_JPRB, & + & 1.80660E-02_JPRB, 1.94072E-02_JPRB, 2.08480E-02_JPRB, 2.23958E-02_JPRB, 2.40584E-02_JPRB, & + & 2.58445E-02_JPRB, 2.77631E-02_JPRB, 2.98242E-02_JPRB, 3.20383E-02_JPRB/) + KAO_MO3( 1, :, 2) = (/ & + & 4.28238E-02_JPRB, 4.51015E-02_JPRB, 4.75003E-02_JPRB, 5.00266E-02_JPRB, 5.26873E-02_JPRB, & + & 5.54896E-02_JPRB, 5.84409E-02_JPRB, 6.15491E-02_JPRB, 6.48227E-02_JPRB, 6.82704E-02_JPRB, & + & 7.19014E-02_JPRB, 7.57256E-02_JPRB, 7.97532E-02_JPRB, 8.39949E-02_JPRB, 8.84623E-02_JPRB, & + & 9.31673E-02_JPRB, 9.81225E-02_JPRB, 1.03341E-01_JPRB, 1.08838E-01_JPRB/) + KAO_MO3( 2, :, 2) = (/ & + & 4.83672E-02_JPRB, 5.07219E-02_JPRB, 5.31911E-02_JPRB, 5.57806E-02_JPRB, 5.84962E-02_JPRB, & + & 6.13440E-02_JPRB, 6.43303E-02_JPRB, 6.74621E-02_JPRB, 7.07464E-02_JPRB, 7.41905E-02_JPRB, & + & 7.78023E-02_JPRB, 8.15899E-02_JPRB, 8.55619E-02_JPRB, 8.97273E-02_JPRB, 9.40955E-02_JPRB, & + & 9.86763E-02_JPRB, 1.03480E-01_JPRB, 1.08518E-01_JPRB, 1.13801E-01_JPRB/) + KAO_MO3( 3, :, 2) = (/ & + & 5.24315E-02_JPRB, 5.48650E-02_JPRB, 5.74115E-02_JPRB, 6.00762E-02_JPRB, 6.28645E-02_JPRB, & + & 6.57822E-02_JPRB, 6.88354E-02_JPRB, 7.20302E-02_JPRB, 7.53734E-02_JPRB, 7.88717E-02_JPRB, & + & 8.25324E-02_JPRB, 8.63630E-02_JPRB, 9.03714E-02_JPRB, 9.45658E-02_JPRB, 9.89549E-02_JPRB, & + & 1.03548E-01_JPRB, 1.08354E-01_JPRB, 1.13383E-01_JPRB, 1.18645E-01_JPRB/) + KAO_MO3( 4, :, 2) = (/ & + & 5.65191E-02_JPRB, 5.90383E-02_JPRB, 6.16699E-02_JPRB, 6.44187E-02_JPRB, 6.72901E-02_JPRB, & + & 7.02894E-02_JPRB, 7.34224E-02_JPRB, 7.66951E-02_JPRB, 8.01137E-02_JPRB, 8.36846E-02_JPRB, & + & 8.74147E-02_JPRB, 9.13111E-02_JPRB, 9.53812E-02_JPRB, 9.96326E-02_JPRB, 1.04074E-01_JPRB, & + & 1.08712E-01_JPRB, 1.13558E-01_JPRB, 1.18620E-01_JPRB, 1.23907E-01_JPRB/) + KAO_MO3( 5, :, 2) = (/ & + & 6.03171E-02_JPRB, 6.29114E-02_JPRB, 6.56172E-02_JPRB, 6.84394E-02_JPRB, 7.13830E-02_JPRB, & + & 7.44532E-02_JPRB, 7.76555E-02_JPRB, 8.09955E-02_JPRB, 8.44791E-02_JPRB, 8.81125E-02_JPRB, & + & 9.19023E-02_JPRB, 9.58550E-02_JPRB, 9.99778E-02_JPRB, 1.04278E-01_JPRB, 1.08763E-01_JPRB, & + & 1.13441E-01_JPRB, 1.18320E-01_JPRB, 1.23409E-01_JPRB, 1.28717E-01_JPRB/) + KAO_MO3( 6, :, 2) = (/ & + & 6.51092E-02_JPRB, 6.77827E-02_JPRB, 7.05660E-02_JPRB, 7.34635E-02_JPRB, 7.64801E-02_JPRB, & + & 7.96204E-02_JPRB, 8.28898E-02_JPRB, 8.62934E-02_JPRB, 8.98367E-02_JPRB, 9.35255E-02_JPRB, & + & 9.73658E-02_JPRB, 1.01364E-01_JPRB, 1.05526E-01_JPRB, 1.09859E-01_JPRB, 1.14370E-01_JPRB, & + & 1.19066E-01_JPRB, 1.23955E-01_JPRB, 1.29045E-01_JPRB, 1.34344E-01_JPRB/) + KAO_MO3( 7, :, 2) = (/ & + & 7.09653E-02_JPRB, 7.37378E-02_JPRB, 7.66187E-02_JPRB, 7.96121E-02_JPRB, 8.27225E-02_JPRB, & + & 8.59543E-02_JPRB, 8.93125E-02_JPRB, 9.28018E-02_JPRB, 9.64275E-02_JPRB, 1.00195E-01_JPRB, & + & 1.04109E-01_JPRB, 1.08177E-01_JPRB, 1.12403E-01_JPRB, 1.16795E-01_JPRB, 1.21358E-01_JPRB, & + & 1.26099E-01_JPRB, 1.31026E-01_JPRB, 1.36145E-01_JPRB, 1.41464E-01_JPRB/) + KAO_MO3( 8, :, 2) = (/ & + & 7.69193E-02_JPRB, 7.97926E-02_JPRB, 8.27733E-02_JPRB, 8.58653E-02_JPRB, 8.90728E-02_JPRB, & + & 9.24002E-02_JPRB, 9.58518E-02_JPRB, 9.94324E-02_JPRB, 1.03147E-01_JPRB, 1.07000E-01_JPRB, & + & 1.10997E-01_JPRB, 1.15143E-01_JPRB, 1.19444E-01_JPRB, 1.23906E-01_JPRB, 1.28535E-01_JPRB, & + & 1.33336E-01_JPRB, 1.38317E-01_JPRB, 1.43484E-01_JPRB, 1.48844E-01_JPRB/) + KAO_MO3( 9, :, 2) = (/ & + & 4.57962E-02_JPRB, 4.76027E-02_JPRB, 4.94805E-02_JPRB, 5.14323E-02_JPRB, 5.34611E-02_JPRB, & + & 5.55700E-02_JPRB, 5.77620E-02_JPRB, 6.00405E-02_JPRB, 6.24089E-02_JPRB, 6.48707E-02_JPRB, & + & 6.74296E-02_JPRB, 7.00895E-02_JPRB, 7.28542E-02_JPRB, 7.57281E-02_JPRB, 7.87153E-02_JPRB, & + & 8.18203E-02_JPRB, 8.50478E-02_JPRB, 8.84027E-02_JPRB, 9.18898E-02_JPRB/) + KAO_MO3( 1, :, 3) = (/ & + & 1.12607E-01_JPRB, 1.16047E-01_JPRB, 1.19591E-01_JPRB, 1.23244E-01_JPRB, 1.27009E-01_JPRB, & + & 1.30888E-01_JPRB, 1.34886E-01_JPRB, 1.39006E-01_JPRB, 1.43252E-01_JPRB, 1.47628E-01_JPRB, & + & 1.52137E-01_JPRB, 1.56785E-01_JPRB, 1.61574E-01_JPRB, 1.66509E-01_JPRB, 1.71595E-01_JPRB, & + & 1.76836E-01_JPRB, 1.82238E-01_JPRB, 1.87804E-01_JPRB, 1.93541E-01_JPRB/) + KAO_MO3( 2, :, 3) = (/ & + & 1.14531E-01_JPRB, 1.17850E-01_JPRB, 1.21266E-01_JPRB, 1.24781E-01_JPRB, 1.28397E-01_JPRB, & + & 1.32119E-01_JPRB, 1.35948E-01_JPRB, 1.39888E-01_JPRB, 1.43943E-01_JPRB, 1.48115E-01_JPRB, & + & 1.52407E-01_JPRB, 1.56825E-01_JPRB, 1.61370E-01_JPRB, 1.66047E-01_JPRB, 1.70860E-01_JPRB, & + & 1.75812E-01_JPRB, 1.80907E-01_JPRB, 1.86150E-01_JPRB, 1.91546E-01_JPRB/) + KAO_MO3( 3, :, 3) = (/ & + & 1.13986E-01_JPRB, 1.17222E-01_JPRB, 1.20551E-01_JPRB, 1.23974E-01_JPRB, 1.27494E-01_JPRB, & + & 1.31114E-01_JPRB, 1.34837E-01_JPRB, 1.38666E-01_JPRB, 1.42604E-01_JPRB, 1.46653E-01_JPRB, & + & 1.50817E-01_JPRB, 1.55099E-01_JPRB, 1.59503E-01_JPRB, 1.64032E-01_JPRB, 1.68690E-01_JPRB, & + & 1.73480E-01_JPRB, 1.78406E-01_JPRB, 1.83472E-01_JPRB, 1.88682E-01_JPRB/) + KAO_MO3( 4, :, 3) = (/ & + & 1.13713E-01_JPRB, 1.16892E-01_JPRB, 1.20160E-01_JPRB, 1.23519E-01_JPRB, 1.26972E-01_JPRB, & + & 1.30522E-01_JPRB, 1.34171E-01_JPRB, 1.37922E-01_JPRB, 1.41778E-01_JPRB, 1.45742E-01_JPRB, & + & 1.49817E-01_JPRB, 1.54005E-01_JPRB, 1.58311E-01_JPRB, 1.62737E-01_JPRB, 1.67287E-01_JPRB, & + & 1.71964E-01_JPRB, 1.76771E-01_JPRB, 1.81714E-01_JPRB, 1.86794E-01_JPRB/) + KAO_MO3( 5, :, 3) = (/ & + & 1.12321E-01_JPRB, 1.15413E-01_JPRB, 1.18591E-01_JPRB, 1.21856E-01_JPRB, 1.25211E-01_JPRB, & + & 1.28658E-01_JPRB, 1.32200E-01_JPRB, 1.35840E-01_JPRB, 1.39580E-01_JPRB, 1.43423E-01_JPRB, & + & 1.47372E-01_JPRB, 1.51429E-01_JPRB, 1.55599E-01_JPRB, 1.59883E-01_JPRB, 1.64284E-01_JPRB, & + & 1.68808E-01_JPRB, 1.73455E-01_JPRB, 1.78231E-01_JPRB, 1.83138E-01_JPRB/) + KAO_MO3( 6, :, 3) = (/ & + & 1.14158E-01_JPRB, 1.17218E-01_JPRB, 1.20360E-01_JPRB, 1.23586E-01_JPRB, 1.26899E-01_JPRB, & + & 1.30300E-01_JPRB, 1.33793E-01_JPRB, 1.37379E-01_JPRB, 1.41061E-01_JPRB, 1.44842E-01_JPRB, & + & 1.48724E-01_JPRB, 1.52711E-01_JPRB, 1.56804E-01_JPRB, 1.61007E-01_JPRB, 1.65322E-01_JPRB, & + & 1.69754E-01_JPRB, 1.74304E-01_JPRB, 1.78976E-01_JPRB, 1.83773E-01_JPRB/) + KAO_MO3( 7, :, 3) = (/ & + & 1.21015E-01_JPRB, 1.23989E-01_JPRB, 1.27036E-01_JPRB, 1.30157E-01_JPRB, 1.33355E-01_JPRB, & + & 1.36632E-01_JPRB, 1.39990E-01_JPRB, 1.43429E-01_JPRB, 1.46954E-01_JPRB, 1.50565E-01_JPRB, & + & 1.54264E-01_JPRB, 1.58055E-01_JPRB, 1.61939E-01_JPRB, 1.65918E-01_JPRB, 1.69995E-01_JPRB, & + & 1.74172E-01_JPRB, 1.78452E-01_JPRB, 1.82836E-01_JPRB, 1.87329E-01_JPRB/) + KAO_MO3( 8, :, 3) = (/ & + & 1.33952E-01_JPRB, 1.36939E-01_JPRB, 1.39992E-01_JPRB, 1.43114E-01_JPRB, 1.46305E-01_JPRB, & + & 1.49567E-01_JPRB, 1.52902E-01_JPRB, 1.56311E-01_JPRB, 1.59797E-01_JPRB, 1.63360E-01_JPRB, & + & 1.67002E-01_JPRB, 1.70726E-01_JPRB, 1.74533E-01_JPRB, 1.78424E-01_JPRB, 1.82403E-01_JPRB, & + & 1.86470E-01_JPRB, 1.90627E-01_JPRB, 1.94878E-01_JPRB, 1.99223E-01_JPRB/) + KAO_MO3( 9, :, 3) = (/ & + & 1.01003E-01_JPRB, 1.03713E-01_JPRB, 1.06495E-01_JPRB, 1.09352E-01_JPRB, 1.12285E-01_JPRB, & + & 1.15297E-01_JPRB, 1.18390E-01_JPRB, 1.21566E-01_JPRB, 1.24827E-01_JPRB, 1.28176E-01_JPRB, & + & 1.31614E-01_JPRB, 1.35145E-01_JPRB, 1.38770E-01_JPRB, 1.42493E-01_JPRB, 1.46315E-01_JPRB, & + & 1.50240E-01_JPRB, 1.54271E-01_JPRB, 1.58409E-01_JPRB, 1.62659E-01_JPRB/) + KAO_MO3( 1, :, 4) = (/ & + & 2.35597E-01_JPRB, 2.37975E-01_JPRB, 2.40376E-01_JPRB, 2.42802E-01_JPRB, 2.45253E-01_JPRB, & + & 2.47728E-01_JPRB, 2.50228E-01_JPRB, 2.52753E-01_JPRB, 2.55304E-01_JPRB, 2.57881E-01_JPRB, & + & 2.60483E-01_JPRB, 2.63112E-01_JPRB, 2.65767E-01_JPRB, 2.68450E-01_JPRB, 2.71159E-01_JPRB, & + & 2.73895E-01_JPRB, 2.76660E-01_JPRB, 2.79452E-01_JPRB, 2.82272E-01_JPRB/) + KAO_MO3( 2, :, 4) = (/ & + & 2.27965E-01_JPRB, 2.30334E-01_JPRB, 2.32728E-01_JPRB, 2.35146E-01_JPRB, 2.37590E-01_JPRB, & + & 2.40059E-01_JPRB, 2.42554E-01_JPRB, 2.45075E-01_JPRB, 2.47621E-01_JPRB, 2.50195E-01_JPRB, & + & 2.52795E-01_JPRB, 2.55422E-01_JPRB, 2.58077E-01_JPRB, 2.60759E-01_JPRB, 2.63468E-01_JPRB, & + & 2.66206E-01_JPRB, 2.68973E-01_JPRB, 2.71768E-01_JPRB, 2.74593E-01_JPRB/) + KAO_MO3( 3, :, 4) = (/ & + & 2.25956E-01_JPRB, 2.28277E-01_JPRB, 2.30622E-01_JPRB, 2.32991E-01_JPRB, 2.35384E-01_JPRB, & + & 2.37802E-01_JPRB, 2.40244E-01_JPRB, 2.42712E-01_JPRB, 2.45205E-01_JPRB, 2.47724E-01_JPRB, & + & 2.50268E-01_JPRB, 2.52839E-01_JPRB, 2.55436E-01_JPRB, 2.58060E-01_JPRB, 2.60711E-01_JPRB, & + & 2.63389E-01_JPRB, 2.66094E-01_JPRB, 2.68827E-01_JPRB, 2.71589E-01_JPRB/) + KAO_MO3( 4, :, 4) = (/ & + & 2.28371E-01_JPRB, 2.30595E-01_JPRB, 2.32840E-01_JPRB, 2.35107E-01_JPRB, 2.37397E-01_JPRB, & + & 2.39708E-01_JPRB, 2.42042E-01_JPRB, 2.44399E-01_JPRB, 2.46779E-01_JPRB, 2.49182E-01_JPRB, & + & 2.51608E-01_JPRB, 2.54058E-01_JPRB, 2.56532E-01_JPRB, 2.59030E-01_JPRB, 2.61552E-01_JPRB, & + & 2.64099E-01_JPRB, 2.66671E-01_JPRB, 2.69267E-01_JPRB, 2.71889E-01_JPRB/) + KAO_MO3( 5, :, 4) = (/ & + & 2.42563E-01_JPRB, 2.44620E-01_JPRB, 2.46695E-01_JPRB, 2.48787E-01_JPRB, 2.50897E-01_JPRB, & + & 2.53024E-01_JPRB, 2.55170E-01_JPRB, 2.57334E-01_JPRB, 2.59516E-01_JPRB, 2.61717E-01_JPRB, & + & 2.63936E-01_JPRB, 2.66174E-01_JPRB, 2.68431E-01_JPRB, 2.70708E-01_JPRB, 2.73003E-01_JPRB, & + & 2.75318E-01_JPRB, 2.77653E-01_JPRB, 2.80008E-01_JPRB, 2.82382E-01_JPRB/) + KAO_MO3( 6, :, 4) = (/ & + & 2.54052E-01_JPRB, 2.56017E-01_JPRB, 2.57997E-01_JPRB, 2.59992E-01_JPRB, 2.62003E-01_JPRB, & + & 2.64029E-01_JPRB, 2.66071E-01_JPRB, 2.68129E-01_JPRB, 2.70203E-01_JPRB, 2.72293E-01_JPRB, & + & 2.74398E-01_JPRB, 2.76521E-01_JPRB, 2.78659E-01_JPRB, 2.80814E-01_JPRB, 2.82986E-01_JPRB, & + & 2.85175E-01_JPRB, 2.87380E-01_JPRB, 2.89603E-01_JPRB, 2.91842E-01_JPRB/) + KAO_MO3( 7, :, 4) = (/ & + & 2.54061E-01_JPRB, 2.55982E-01_JPRB, 2.57917E-01_JPRB, 2.59867E-01_JPRB, 2.61832E-01_JPRB, & + & 2.63811E-01_JPRB, 2.65806E-01_JPRB, 2.67815E-01_JPRB, 2.69840E-01_JPRB, 2.71880E-01_JPRB, & + & 2.73936E-01_JPRB, 2.76007E-01_JPRB, 2.78093E-01_JPRB, 2.80196E-01_JPRB, 2.82314E-01_JPRB, & + & 2.84449E-01_JPRB, 2.86599E-01_JPRB, 2.88766E-01_JPRB, 2.90949E-01_JPRB/) + KAO_MO3( 8, :, 4) = (/ & + & 2.72482E-01_JPRB, 2.73916E-01_JPRB, 2.75358E-01_JPRB, 2.76807E-01_JPRB, 2.78264E-01_JPRB, & + & 2.79729E-01_JPRB, 2.81201E-01_JPRB, 2.82681E-01_JPRB, 2.84169E-01_JPRB, 2.85665E-01_JPRB, & + & 2.87168E-01_JPRB, 2.88680E-01_JPRB, 2.90199E-01_JPRB, 2.91726E-01_JPRB, 2.93262E-01_JPRB, & + & 2.94805E-01_JPRB, 2.96357E-01_JPRB, 2.97917E-01_JPRB, 2.99485E-01_JPRB/) + KAO_MO3( 9, :, 4) = (/ & + & 1.93414E-01_JPRB, 1.95498E-01_JPRB, 1.97605E-01_JPRB, 1.99734E-01_JPRB, 2.01886E-01_JPRB, & + & 2.04062E-01_JPRB, 2.06261E-01_JPRB, 2.08483E-01_JPRB, 2.10730E-01_JPRB, 2.13001E-01_JPRB, & + & 2.15296E-01_JPRB, 2.17616E-01_JPRB, 2.19961E-01_JPRB, 2.22331E-01_JPRB, 2.24727E-01_JPRB, & + & 2.27148E-01_JPRB, 2.29596E-01_JPRB, 2.32070E-01_JPRB, 2.34571E-01_JPRB/) + KAO_MO3( 1, :, 5) = (/ & + & 5.30785E-01_JPRB, 5.30477E-01_JPRB, 5.30169E-01_JPRB, 5.29861E-01_JPRB, 5.29553E-01_JPRB, & + & 5.29246E-01_JPRB, 5.28938E-01_JPRB, 5.28631E-01_JPRB, 5.28324E-01_JPRB, 5.28017E-01_JPRB, & + & 5.27711E-01_JPRB, 5.27404E-01_JPRB, 5.27098E-01_JPRB, 5.26792E-01_JPRB, 5.26486E-01_JPRB, & + & 5.26180E-01_JPRB, 5.25875E-01_JPRB, 5.25569E-01_JPRB, 5.25264E-01_JPRB/) + KAO_MO3( 2, :, 5) = (/ & + & 5.33406E-01_JPRB, 5.32997E-01_JPRB, 5.32587E-01_JPRB, 5.32178E-01_JPRB, 5.31769E-01_JPRB, & + & 5.31360E-01_JPRB, 5.30952E-01_JPRB, 5.30544E-01_JPRB, 5.30137E-01_JPRB, 5.29729E-01_JPRB, & + & 5.29322E-01_JPRB, 5.28916E-01_JPRB, 5.28509E-01_JPRB, 5.28103E-01_JPRB, 5.27697E-01_JPRB, & + & 5.27292E-01_JPRB, 5.26887E-01_JPRB, 5.26482E-01_JPRB, 5.26077E-01_JPRB/) + KAO_MO3( 3, :, 5) = (/ & + & 5.39814E-01_JPRB, 5.39234E-01_JPRB, 5.38655E-01_JPRB, 5.38077E-01_JPRB, 5.37499E-01_JPRB, & + & 5.36922E-01_JPRB, 5.36345E-01_JPRB, 5.35769E-01_JPRB, 5.35194E-01_JPRB, 5.34620E-01_JPRB, & + & 5.34045E-01_JPRB, 5.33472E-01_JPRB, 5.32899E-01_JPRB, 5.32327E-01_JPRB, 5.31756E-01_JPRB, & + & 5.31185E-01_JPRB, 5.30614E-01_JPRB, 5.30045E-01_JPRB, 5.29475E-01_JPRB/) + KAO_MO3( 4, :, 5) = (/ & + & 5.39054E-01_JPRB, 5.38348E-01_JPRB, 5.37643E-01_JPRB, 5.36938E-01_JPRB, 5.36235E-01_JPRB, & + & 5.35532E-01_JPRB, 5.34831E-01_JPRB, 5.34130E-01_JPRB, 5.33431E-01_JPRB, 5.32732E-01_JPRB, & + & 5.32034E-01_JPRB, 5.31337E-01_JPRB, 5.30641E-01_JPRB, 5.29946E-01_JPRB, 5.29252E-01_JPRB, & + & 5.28559E-01_JPRB, 5.27866E-01_JPRB, 5.27175E-01_JPRB, 5.26484E-01_JPRB/) + KAO_MO3( 5, :, 5) = (/ & + & 5.29240E-01_JPRB, 5.28475E-01_JPRB, 5.27711E-01_JPRB, 5.26949E-01_JPRB, 5.26187E-01_JPRB, & + & 5.25427E-01_JPRB, 5.24668E-01_JPRB, 5.23909E-01_JPRB, 5.23152E-01_JPRB, 5.22396E-01_JPRB, & + & 5.21641E-01_JPRB, 5.20888E-01_JPRB, 5.20135E-01_JPRB, 5.19383E-01_JPRB, 5.18633E-01_JPRB, & + & 5.17883E-01_JPRB, 5.17135E-01_JPRB, 5.16388E-01_JPRB, 5.15642E-01_JPRB/) + KAO_MO3( 6, :, 5) = (/ & + & 5.21746E-01_JPRB, 5.20815E-01_JPRB, 5.19886E-01_JPRB, 5.18958E-01_JPRB, 5.18032E-01_JPRB, & + & 5.17107E-01_JPRB, 5.16184E-01_JPRB, 5.15263E-01_JPRB, 5.14343E-01_JPRB, 5.13425E-01_JPRB, & + & 5.12509E-01_JPRB, 5.11594E-01_JPRB, 5.10681E-01_JPRB, 5.09770E-01_JPRB, 5.08860E-01_JPRB, & + & 5.07952E-01_JPRB, 5.07045E-01_JPRB, 5.06140E-01_JPRB, 5.05237E-01_JPRB/) + KAO_MO3( 7, :, 5) = (/ & + & 5.26752E-01_JPRB, 5.25550E-01_JPRB, 5.24352E-01_JPRB, 5.23156E-01_JPRB, 5.21963E-01_JPRB, & + & 5.20772E-01_JPRB, 5.19584E-01_JPRB, 5.18399E-01_JPRB, 5.17217E-01_JPRB, 5.16038E-01_JPRB, & + & 5.14861E-01_JPRB, 5.13686E-01_JPRB, 5.12515E-01_JPRB, 5.11346E-01_JPRB, 5.10180E-01_JPRB, & + & 5.09016E-01_JPRB, 5.07855E-01_JPRB, 5.06697E-01_JPRB, 5.05541E-01_JPRB/) + KAO_MO3( 8, :, 5) = (/ & + & 5.23581E-01_JPRB, 5.22513E-01_JPRB, 5.21446E-01_JPRB, 5.20382E-01_JPRB, 5.19320E-01_JPRB, & + & 5.18260E-01_JPRB, 5.17203E-01_JPRB, 5.16147E-01_JPRB, 5.15094E-01_JPRB, 5.14042E-01_JPRB, & + & 5.12993E-01_JPRB, 5.11946E-01_JPRB, 5.10901E-01_JPRB, 5.09859E-01_JPRB, 5.08818E-01_JPRB, & + & 5.07780E-01_JPRB, 5.06743E-01_JPRB, 5.05709E-01_JPRB, 5.04677E-01_JPRB/) + KAO_MO3( 9, :, 5) = (/ & + & 3.80393E-01_JPRB, 3.80680E-01_JPRB, 3.80967E-01_JPRB, 3.81254E-01_JPRB, 3.81542E-01_JPRB, & + & 3.81829E-01_JPRB, 3.82117E-01_JPRB, 3.82405E-01_JPRB, 3.82693E-01_JPRB, 3.82982E-01_JPRB, & + & 3.83271E-01_JPRB, 3.83559E-01_JPRB, 3.83849E-01_JPRB, 3.84138E-01_JPRB, 3.84428E-01_JPRB, & + & 3.84717E-01_JPRB, 3.85007E-01_JPRB, 3.85298E-01_JPRB, 3.85588E-01_JPRB/) + KAO_MO3( 1, :, 6) = (/ & + & 6.14818E-01_JPRB, 6.10664E-01_JPRB, 6.06539E-01_JPRB, 6.02441E-01_JPRB, 5.98372E-01_JPRB, & + & 5.94330E-01_JPRB, 5.90315E-01_JPRB, 5.86327E-01_JPRB, 5.82366E-01_JPRB, 5.78432E-01_JPRB, & + & 5.74524E-01_JPRB, 5.70643E-01_JPRB, 5.66788E-01_JPRB, 5.62959E-01_JPRB, 5.59156E-01_JPRB, & + & 5.55379E-01_JPRB, 5.51627E-01_JPRB, 5.47901E-01_JPRB, 5.44199E-01_JPRB/) + KAO_MO3( 2, :, 6) = (/ & + & 6.10199E-01_JPRB, 6.06143E-01_JPRB, 6.02114E-01_JPRB, 5.98112E-01_JPRB, 5.94136E-01_JPRB, & + & 5.90187E-01_JPRB, 5.86264E-01_JPRB, 5.82367E-01_JPRB, 5.78496E-01_JPRB, 5.74651E-01_JPRB, & + & 5.70831E-01_JPRB, 5.67037E-01_JPRB, 5.63268E-01_JPRB, 5.59524E-01_JPRB, 5.55805E-01_JPRB, & + & 5.52110E-01_JPRB, 5.48440E-01_JPRB, 5.44795E-01_JPRB, 5.41174E-01_JPRB/) + KAO_MO3( 3, :, 6) = (/ & + & 6.02949E-01_JPRB, 5.99057E-01_JPRB, 5.95190E-01_JPRB, 5.91348E-01_JPRB, 5.87531E-01_JPRB, & + & 5.83739E-01_JPRB, 5.79971E-01_JPRB, 5.76227E-01_JPRB, 5.72508E-01_JPRB, 5.68812E-01_JPRB, & + & 5.65140E-01_JPRB, 5.61493E-01_JPRB, 5.57868E-01_JPRB, 5.54267E-01_JPRB, 5.50690E-01_JPRB, & + & 5.47135E-01_JPRB, 5.43603E-01_JPRB, 5.40094E-01_JPRB, 5.36608E-01_JPRB/) + KAO_MO3( 4, :, 6) = (/ & + & 6.05047E-01_JPRB, 6.01155E-01_JPRB, 5.97289E-01_JPRB, 5.93448E-01_JPRB, 5.89631E-01_JPRB, & + & 5.85838E-01_JPRB, 5.82071E-01_JPRB, 5.78327E-01_JPRB, 5.74607E-01_JPRB, 5.70912E-01_JPRB, & + & 5.67240E-01_JPRB, 5.63592E-01_JPRB, 5.59967E-01_JPRB, 5.56365E-01_JPRB, 5.52787E-01_JPRB, & + & 5.49232E-01_JPRB, 5.45699E-01_JPRB, 5.42190E-01_JPRB, 5.38703E-01_JPRB/) + KAO_MO3( 5, :, 6) = (/ & + & 6.03593E-01_JPRB, 5.99867E-01_JPRB, 5.96164E-01_JPRB, 5.92483E-01_JPRB, 5.88825E-01_JPRB, & + & 5.85190E-01_JPRB, 5.81577E-01_JPRB, 5.77987E-01_JPRB, 5.74419E-01_JPRB, 5.70872E-01_JPRB, & + & 5.67348E-01_JPRB, 5.63846E-01_JPRB, 5.60365E-01_JPRB, 5.56905E-01_JPRB, 5.53467E-01_JPRB, & + & 5.50050E-01_JPRB, 5.46654E-01_JPRB, 5.43279E-01_JPRB, 5.39926E-01_JPRB/) + KAO_MO3( 6, :, 6) = (/ & + & 6.03940E-01_JPRB, 6.00224E-01_JPRB, 5.96531E-01_JPRB, 5.92861E-01_JPRB, 5.89213E-01_JPRB, & + & 5.85588E-01_JPRB, 5.81985E-01_JPRB, 5.78404E-01_JPRB, 5.74845E-01_JPRB, 5.71308E-01_JPRB, & + & 5.67793E-01_JPRB, 5.64299E-01_JPRB, 5.60827E-01_JPRB, 5.57377E-01_JPRB, 5.53947E-01_JPRB, & + & 5.50539E-01_JPRB, 5.47151E-01_JPRB, 5.43785E-01_JPRB, 5.40439E-01_JPRB/) + KAO_MO3( 7, :, 6) = (/ & + & 6.06242E-01_JPRB, 6.02257E-01_JPRB, 5.98299E-01_JPRB, 5.94367E-01_JPRB, 5.90461E-01_JPRB, & + & 5.86580E-01_JPRB, 5.82725E-01_JPRB, 5.78895E-01_JPRB, 5.75090E-01_JPRB, 5.71311E-01_JPRB, & + & 5.67556E-01_JPRB, 5.63826E-01_JPRB, 5.60120E-01_JPRB, 5.56439E-01_JPRB, 5.52782E-01_JPRB, & + & 5.49149E-01_JPRB, 5.45540E-01_JPRB, 5.41954E-01_JPRB, 5.38393E-01_JPRB/) + KAO_MO3( 8, :, 6) = (/ & + & 6.11929E-01_JPRB, 6.07173E-01_JPRB, 6.02454E-01_JPRB, 5.97773E-01_JPRB, 5.93127E-01_JPRB, & + & 5.88518E-01_JPRB, 5.83944E-01_JPRB, 5.79406E-01_JPRB, 5.74903E-01_JPRB, 5.70436E-01_JPRB, & + & 5.66002E-01_JPRB, 5.61604E-01_JPRB, 5.57239E-01_JPRB, 5.52909E-01_JPRB, 5.48612E-01_JPRB, & + & 5.44349E-01_JPRB, 5.40118E-01_JPRB, 5.35921E-01_JPRB, 5.31756E-01_JPRB/) + KAO_MO3( 9, :, 6) = (/ & + & 6.21189E-01_JPRB, 6.17338E-01_JPRB, 6.13511E-01_JPRB, 6.09707E-01_JPRB, 6.05927E-01_JPRB, & + & 6.02170E-01_JPRB, 5.98437E-01_JPRB, 5.94726E-01_JPRB, 5.91039E-01_JPRB, 5.87375E-01_JPRB, & + & 5.83733E-01_JPRB, 5.80114E-01_JPRB, 5.76517E-01_JPRB, 5.72943E-01_JPRB, 5.69390E-01_JPRB, & + & 5.65860E-01_JPRB, 5.62352E-01_JPRB, 5.58865E-01_JPRB, 5.55400E-01_JPRB/) + KAO_MO3( 1, :, 7) = (/ & + & 7.41310E-01_JPRB, 7.30108E-01_JPRB, 7.19075E-01_JPRB, 7.08209E-01_JPRB, 6.97507E-01_JPRB, & + & 6.86967E-01_JPRB, 6.76586E-01_JPRB, 6.66362E-01_JPRB, 6.56292E-01_JPRB, 6.46374E-01_JPRB, & + & 6.36607E-01_JPRB, 6.26987E-01_JPRB, 6.17512E-01_JPRB, 6.08181E-01_JPRB, 5.98990E-01_JPRB, & + & 5.89939E-01_JPRB, 5.81024E-01_JPRB, 5.72244E-01_JPRB, 5.63597E-01_JPRB/) + KAO_MO3( 2, :, 7) = (/ & + & 7.38780E-01_JPRB, 7.27631E-01_JPRB, 7.16651E-01_JPRB, 7.05836E-01_JPRB, 6.95185E-01_JPRB, & + & 6.84695E-01_JPRB, 6.74362E-01_JPRB, 6.64186E-01_JPRB, 6.54163E-01_JPRB, 6.44292E-01_JPRB, & + & 6.34569E-01_JPRB, 6.24993E-01_JPRB, 6.15562E-01_JPRB, 6.06273E-01_JPRB, 5.97124E-01_JPRB, & + & 5.88113E-01_JPRB, 5.79238E-01_JPRB, 5.70498E-01_JPRB, 5.61889E-01_JPRB/) + KAO_MO3( 3, :, 7) = (/ & + & 7.33846E-01_JPRB, 7.22799E-01_JPRB, 7.11919E-01_JPRB, 7.01203E-01_JPRB, 6.90648E-01_JPRB, & + & 6.80252E-01_JPRB, 6.70012E-01_JPRB, 6.59927E-01_JPRB, 6.49993E-01_JPRB, 6.40209E-01_JPRB, & + & 6.30572E-01_JPRB, 6.21080E-01_JPRB, 6.11731E-01_JPRB, 6.02523E-01_JPRB, 5.93453E-01_JPRB, & + & 5.84520E-01_JPRB, 5.75721E-01_JPRB, 5.67055E-01_JPRB, 5.58519E-01_JPRB/) + KAO_MO3( 4, :, 7) = (/ & + & 7.21218E-01_JPRB, 7.10492E-01_JPRB, 6.99926E-01_JPRB, 6.89517E-01_JPRB, 6.79262E-01_JPRB, & + & 6.69160E-01_JPRB, 6.59209E-01_JPRB, 6.49405E-01_JPRB, 6.39747E-01_JPRB, 6.30233E-01_JPRB, & + & 6.20860E-01_JPRB, 6.11627E-01_JPRB, 6.02531E-01_JPRB, 5.93570E-01_JPRB, 5.84743E-01_JPRB, & + & 5.76047E-01_JPRB, 5.67480E-01_JPRB, 5.59040E-01_JPRB, 5.50726E-01_JPRB/) + KAO_MO3( 5, :, 7) = (/ & + & 7.10588E-01_JPRB, 7.00014E-01_JPRB, 6.89596E-01_JPRB, 6.79334E-01_JPRB, 6.69225E-01_JPRB, & + & 6.59266E-01_JPRB, 6.49455E-01_JPRB, 6.39790E-01_JPRB, 6.30269E-01_JPRB, 6.20889E-01_JPRB, & + & 6.11650E-01_JPRB, 6.02547E-01_JPRB, 5.93581E-01_JPRB, 5.84747E-01_JPRB, 5.76045E-01_JPRB, & + & 5.67473E-01_JPRB, 5.59028E-01_JPRB, 5.50709E-01_JPRB, 5.42513E-01_JPRB/) + KAO_MO3( 6, :, 7) = (/ & + & 6.98166E-01_JPRB, 6.87706E-01_JPRB, 6.77402E-01_JPRB, 6.67253E-01_JPRB, 6.57256E-01_JPRB, & + & 6.47408E-01_JPRB, 6.37708E-01_JPRB, 6.28154E-01_JPRB, 6.18742E-01_JPRB, 6.09472E-01_JPRB, & + & 6.00340E-01_JPRB, 5.91346E-01_JPRB, 5.82486E-01_JPRB, 5.73758E-01_JPRB, 5.65162E-01_JPRB, & + & 5.56694E-01_JPRB, 5.48353E-01_JPRB, 5.40138E-01_JPRB, 5.32045E-01_JPRB/) + KAO_MO3( 7, :, 7) = (/ & + & 6.76974E-01_JPRB, 6.67034E-01_JPRB, 6.57240E-01_JPRB, 6.47590E-01_JPRB, 6.38081E-01_JPRB, & + & 6.28712E-01_JPRB, 6.19481E-01_JPRB, 6.10385E-01_JPRB, 6.01422E-01_JPRB, 5.92592E-01_JPRB, & + & 5.83891E-01_JPRB, 5.75317E-01_JPRB, 5.66870E-01_JPRB, 5.58547E-01_JPRB, 5.50345E-01_JPRB, & + & 5.42265E-01_JPRB, 5.34303E-01_JPRB, 5.26457E-01_JPRB, 5.18727E-01_JPRB/) + KAO_MO3( 8, :, 7) = (/ & + & 6.30061E-01_JPRB, 6.21017E-01_JPRB, 6.12102E-01_JPRB, 6.03316E-01_JPRB, 5.94656E-01_JPRB, & + & 5.86120E-01_JPRB, 5.77706E-01_JPRB, 5.69414E-01_JPRB, 5.61240E-01_JPRB, 5.53184E-01_JPRB, & + & 5.45243E-01_JPRB, 5.37416E-01_JPRB, 5.29702E-01_JPRB, 5.22098E-01_JPRB, 5.14604E-01_JPRB, & + & 5.07217E-01_JPRB, 4.99936E-01_JPRB, 4.92760E-01_JPRB, 4.85687E-01_JPRB/) + KAO_MO3( 9, :, 7) = (/ & + & 8.97633E-01_JPRB, 8.87307E-01_JPRB, 8.77100E-01_JPRB, 8.67010E-01_JPRB, 8.57036E-01_JPRB, & + & 8.47176E-01_JPRB, 8.37431E-01_JPRB, 8.27797E-01_JPRB, 8.18274E-01_JPRB, 8.08861E-01_JPRB, & + & 7.99555E-01_JPRB, 7.90357E-01_JPRB, 7.81265E-01_JPRB, 7.72278E-01_JPRB, 7.63393E-01_JPRB, & + & 7.54611E-01_JPRB, 7.45930E-01_JPRB, 7.37349E-01_JPRB, 7.28867E-01_JPRB/) + KAO_MO3( 1, :, 8) = (/ & + & 4.87356E-01_JPRB, 4.80743E-01_JPRB, 4.74220E-01_JPRB, 4.67785E-01_JPRB, 4.61437E-01_JPRB, & + & 4.55176E-01_JPRB, 4.49000E-01_JPRB, 4.42907E-01_JPRB, 4.36897E-01_JPRB, 4.30969E-01_JPRB, & + & 4.25121E-01_JPRB, 4.19353E-01_JPRB, 4.13663E-01_JPRB, 4.08049E-01_JPRB, 4.02513E-01_JPRB, & + & 3.97051E-01_JPRB, 3.91663E-01_JPRB, 3.86349E-01_JPRB, 3.81106E-01_JPRB/) + KAO_MO3( 2, :, 8) = (/ & + & 4.86776E-01_JPRB, 4.80157E-01_JPRB, 4.73627E-01_JPRB, 4.67187E-01_JPRB, 4.60834E-01_JPRB, & + & 4.54567E-01_JPRB, 4.48386E-01_JPRB, 4.42289E-01_JPRB, 4.36274E-01_JPRB, 4.30342E-01_JPRB, & + & 4.24490E-01_JPRB, 4.18718E-01_JPRB, 4.13024E-01_JPRB, 4.07407E-01_JPRB, 4.01867E-01_JPRB, & + & 3.96403E-01_JPRB, 3.91012E-01_JPRB, 3.85695E-01_JPRB, 3.80450E-01_JPRB/) + KAO_MO3( 3, :, 8) = (/ & + & 4.86111E-01_JPRB, 4.79496E-01_JPRB, 4.72972E-01_JPRB, 4.66536E-01_JPRB, 4.60188E-01_JPRB, & + & 4.53926E-01_JPRB, 4.47750E-01_JPRB, 4.41657E-01_JPRB, 4.35648E-01_JPRB, 4.29720E-01_JPRB, & + & 4.23873E-01_JPRB, 4.18105E-01_JPRB, 4.12416E-01_JPRB, 4.06804E-01_JPRB, 4.01269E-01_JPRB, & + & 3.95809E-01_JPRB, 3.90423E-01_JPRB, 3.85111E-01_JPRB, 3.79871E-01_JPRB/) + KAO_MO3( 4, :, 8) = (/ & + & 4.85501E-01_JPRB, 4.78880E-01_JPRB, 4.72350E-01_JPRB, 4.65908E-01_JPRB, 4.59554E-01_JPRB, & + & 4.53288E-01_JPRB, 4.47106E-01_JPRB, 4.41009E-01_JPRB, 4.34995E-01_JPRB, 4.29063E-01_JPRB, & + & 4.23211E-01_JPRB, 4.17440E-01_JPRB, 4.11747E-01_JPRB, 4.06132E-01_JPRB, 4.00594E-01_JPRB, & + & 3.95131E-01_JPRB, 3.89743E-01_JPRB, 3.84428E-01_JPRB, 3.79185E-01_JPRB/) + KAO_MO3( 5, :, 8) = (/ & + & 4.83679E-01_JPRB, 4.77140E-01_JPRB, 4.70691E-01_JPRB, 4.64328E-01_JPRB, 4.58051E-01_JPRB, & + & 4.51859E-01_JPRB, 4.45751E-01_JPRB, 4.39726E-01_JPRB, 4.33781E-01_JPRB, 4.27918E-01_JPRB, & + & 4.22133E-01_JPRB, 4.16427E-01_JPRB, 4.10798E-01_JPRB, 4.05245E-01_JPRB, 3.99767E-01_JPRB, & + & 3.94363E-01_JPRB, 3.89032E-01_JPRB, 3.83773E-01_JPRB, 3.78585E-01_JPRB/) + KAO_MO3( 6, :, 8) = (/ & + & 4.72120E-01_JPRB, 4.65834E-01_JPRB, 4.59630E-01_JPRB, 4.53510E-01_JPRB, 4.47471E-01_JPRB, & + & 4.41513E-01_JPRB, 4.35633E-01_JPRB, 4.29833E-01_JPRB, 4.24109E-01_JPRB, 4.18461E-01_JPRB, & + & 4.12889E-01_JPRB, 4.07391E-01_JPRB, 4.01966E-01_JPRB, 3.96614E-01_JPRB, 3.91332E-01_JPRB, & + & 3.86122E-01_JPRB, 3.80980E-01_JPRB, 3.75907E-01_JPRB, 3.70901E-01_JPRB/) + KAO_MO3( 7, :, 8) = (/ & + & 4.58683E-01_JPRB, 4.52758E-01_JPRB, 4.46909E-01_JPRB, 4.41135E-01_JPRB, 4.35437E-01_JPRB, & + & 4.29812E-01_JPRB, 4.24259E-01_JPRB, 4.18779E-01_JPRB, 4.13369E-01_JPRB, 4.08029E-01_JPRB, & + & 4.02758E-01_JPRB, 3.97555E-01_JPRB, 3.92419E-01_JPRB, 3.87350E-01_JPRB, 3.82346E-01_JPRB, & + & 3.77406E-01_JPRB, 3.72531E-01_JPRB, 3.67719E-01_JPRB, 3.62968E-01_JPRB/) + KAO_MO3( 8, :, 8) = (/ & + & 4.56091E-01_JPRB, 4.50481E-01_JPRB, 4.44940E-01_JPRB, 4.39467E-01_JPRB, 4.34062E-01_JPRB, & + & 4.28722E-01_JPRB, 4.23449E-01_JPRB, 4.18240E-01_JPRB, 4.13096E-01_JPRB, 4.08015E-01_JPRB, & + & 4.02996E-01_JPRB, 3.98039E-01_JPRB, 3.93143E-01_JPRB, 3.88307E-01_JPRB, 3.83531E-01_JPRB, & + & 3.78813E-01_JPRB, 3.74154E-01_JPRB, 3.69552E-01_JPRB, 3.65006E-01_JPRB/) + KAO_MO3( 9, :, 8) = (/ & + & 9.11213E-01_JPRB, 9.03270E-01_JPRB, 8.95396E-01_JPRB, 8.87591E-01_JPRB, 8.79855E-01_JPRB, & + & 8.72185E-01_JPRB, 8.64583E-01_JPRB, 8.57046E-01_JPRB, 8.49576E-01_JPRB, 8.42170E-01_JPRB, & + & 8.34829E-01_JPRB, 8.27552E-01_JPRB, 8.20339E-01_JPRB, 8.13188E-01_JPRB, 8.06100E-01_JPRB, & + & 7.99073E-01_JPRB, 7.92108E-01_JPRB, 7.85204E-01_JPRB, 7.78359E-01_JPRB/) + KAO_MO3( 1, :, 9) = (/ & + & 5.56194E-01_JPRB, 5.48595E-01_JPRB, 5.41100E-01_JPRB, 5.33707E-01_JPRB, 5.26415E-01_JPRB, & + & 5.19223E-01_JPRB, 5.12129E-01_JPRB, 5.05132E-01_JPRB, 4.98231E-01_JPRB, 4.91424E-01_JPRB, & + & 4.84710E-01_JPRB, 4.78087E-01_JPRB, 4.71556E-01_JPRB, 4.65113E-01_JPRB, 4.58758E-01_JPRB, & + & 4.52491E-01_JPRB, 4.46309E-01_JPRB, 4.40211E-01_JPRB, 4.34197E-01_JPRB/) + KAO_MO3( 2, :, 9) = (/ & + & 5.56174E-01_JPRB, 5.48575E-01_JPRB, 5.41079E-01_JPRB, 5.33687E-01_JPRB, 5.26395E-01_JPRB, & + & 5.19203E-01_JPRB, 5.12109E-01_JPRB, 5.05112E-01_JPRB, 4.98211E-01_JPRB, 4.91404E-01_JPRB, & + & 4.84690E-01_JPRB, 4.78068E-01_JPRB, 4.71536E-01_JPRB, 4.65093E-01_JPRB, 4.58739E-01_JPRB, & + & 4.52471E-01_JPRB, 4.46289E-01_JPRB, 4.40191E-01_JPRB, 4.34177E-01_JPRB/) + KAO_MO3( 3, :, 9) = (/ & + & 5.55996E-01_JPRB, 5.48403E-01_JPRB, 5.40913E-01_JPRB, 5.33526E-01_JPRB, 5.26239E-01_JPRB, & + & 5.19052E-01_JPRB, 5.11963E-01_JPRB, 5.04971E-01_JPRB, 4.98074E-01_JPRB, 4.91272E-01_JPRB, & + & 4.84562E-01_JPRB, 4.77944E-01_JPRB, 4.71417E-01_JPRB, 4.64978E-01_JPRB, 4.58628E-01_JPRB, & + & 4.52364E-01_JPRB, 4.46186E-01_JPRB, 4.40092E-01_JPRB, 4.34081E-01_JPRB/) + KAO_MO3( 4, :, 9) = (/ & + & 5.55859E-01_JPRB, 5.48271E-01_JPRB, 5.40786E-01_JPRB, 5.33404E-01_JPRB, 5.26123E-01_JPRB, & + & 5.18941E-01_JPRB, 5.11856E-01_JPRB, 5.04869E-01_JPRB, 4.97977E-01_JPRB, 4.91179E-01_JPRB, & + & 4.84474E-01_JPRB, 4.77861E-01_JPRB, 4.71337E-01_JPRB, 4.64903E-01_JPRB, 4.58557E-01_JPRB, & + & 4.52297E-01_JPRB, 4.46123E-01_JPRB, 4.40033E-01_JPRB, 4.34026E-01_JPRB/) + KAO_MO3( 5, :, 9) = (/ & + & 5.54550E-01_JPRB, 5.46921E-01_JPRB, 5.39397E-01_JPRB, 5.31976E-01_JPRB, 5.24657E-01_JPRB, & + & 5.17439E-01_JPRB, 5.10320E-01_JPRB, 5.03300E-01_JPRB, 4.96376E-01_JPRB, 4.89547E-01_JPRB, & + & 4.82812E-01_JPRB, 4.76170E-01_JPRB, 4.69619E-01_JPRB, 4.63158E-01_JPRB, 4.56786E-01_JPRB, & + & 4.50502E-01_JPRB, 4.44304E-01_JPRB, 4.38192E-01_JPRB, 4.32163E-01_JPRB/) + KAO_MO3( 6, :, 9) = (/ & + & 5.53514E-01_JPRB, 5.45883E-01_JPRB, 5.38358E-01_JPRB, 5.30937E-01_JPRB, 5.23618E-01_JPRB, & + & 5.16399E-01_JPRB, 5.09280E-01_JPRB, 5.02260E-01_JPRB, 4.95336E-01_JPRB, 4.88507E-01_JPRB, & + & 4.81773E-01_JPRB, 4.75132E-01_JPRB, 4.68582E-01_JPRB, 4.62122E-01_JPRB, 4.55752E-01_JPRB, & + & 4.49469E-01_JPRB, 4.43273E-01_JPRB, 4.37162E-01_JPRB, 4.31136E-01_JPRB/) + KAO_MO3( 7, :, 9) = (/ & + & 5.49865E-01_JPRB, 5.42303E-01_JPRB, 5.34846E-01_JPRB, 5.27491E-01_JPRB, 5.20237E-01_JPRB, & + & 5.13084E-01_JPRB, 5.06028E-01_JPRB, 4.99070E-01_JPRB, 4.92207E-01_JPRB, 4.85438E-01_JPRB, & + & 4.78763E-01_JPRB, 4.72179E-01_JPRB, 4.65686E-01_JPRB, 4.59282E-01_JPRB, 4.52967E-01_JPRB, & + & 4.46738E-01_JPRB, 4.40595E-01_JPRB, 4.34536E-01_JPRB, 4.28561E-01_JPRB/) + KAO_MO3( 8, :, 9) = (/ & + & 5.25435E-01_JPRB, 5.18437E-01_JPRB, 5.11533E-01_JPRB, 5.04721E-01_JPRB, 4.97999E-01_JPRB, & + & 4.91367E-01_JPRB, 4.84823E-01_JPRB, 4.78366E-01_JPRB, 4.71996E-01_JPRB, 4.65710E-01_JPRB, & + & 4.59508E-01_JPRB, 4.53388E-01_JPRB, 4.47350E-01_JPRB, 4.41393E-01_JPRB, 4.35515E-01_JPRB, & + & 4.29715E-01_JPRB, 4.23992E-01_JPRB, 4.18345E-01_JPRB, 4.12774E-01_JPRB/) + KAO_MO3( 9, :, 9) = (/ & + & 3.48228E-01_JPRB, 3.45949E-01_JPRB, 3.43686E-01_JPRB, 3.41437E-01_JPRB, 3.39203E-01_JPRB, & + & 3.36983E-01_JPRB, 3.34778E-01_JPRB, 3.32588E-01_JPRB, 3.30412E-01_JPRB, 3.28250E-01_JPRB, & + & 3.26102E-01_JPRB, 3.23968E-01_JPRB, 3.21848E-01_JPRB, 3.19742E-01_JPRB, 3.17650E-01_JPRB, & + & 3.15572E-01_JPRB, 3.13507E-01_JPRB, 3.11456E-01_JPRB, 3.09418E-01_JPRB/) + KAO_MO3( 1, :,10) = (/ & + & 8.34107E-01_JPRB, 8.27276E-01_JPRB, 8.20501E-01_JPRB, 8.13781E-01_JPRB, 8.07117E-01_JPRB, & + & 8.00507E-01_JPRB, 7.93951E-01_JPRB, 7.87449E-01_JPRB, 7.81000E-01_JPRB, 7.74604E-01_JPRB, & + & 7.68260E-01_JPRB, 7.61968E-01_JPRB, 7.55728E-01_JPRB, 7.49539E-01_JPRB, 7.43400E-01_JPRB, & + & 7.37312E-01_JPRB, 7.31274E-01_JPRB, 7.25285E-01_JPRB, 7.19345E-01_JPRB/) + KAO_MO3( 2, :,10) = (/ & + & 8.32838E-01_JPRB, 8.26022E-01_JPRB, 8.19263E-01_JPRB, 8.12558E-01_JPRB, 8.05908E-01_JPRB, & + & 7.99313E-01_JPRB, 7.92772E-01_JPRB, 7.86284E-01_JPRB, 7.79849E-01_JPRB, 7.73467E-01_JPRB, & + & 7.67137E-01_JPRB, 7.60859E-01_JPRB, 7.54633E-01_JPRB, 7.48457E-01_JPRB, 7.42332E-01_JPRB, & + & 7.36257E-01_JPRB, 7.30232E-01_JPRB, 7.24256E-01_JPRB, 7.18329E-01_JPRB/) + KAO_MO3( 3, :,10) = (/ & + & 8.31167E-01_JPRB, 8.24361E-01_JPRB, 8.17611E-01_JPRB, 8.10916E-01_JPRB, 8.04276E-01_JPRB, & + & 7.97691E-01_JPRB, 7.91159E-01_JPRB, 7.84681E-01_JPRB, 7.78256E-01_JPRB, 7.71883E-01_JPRB, & + & 7.65563E-01_JPRB, 7.59294E-01_JPRB, 7.53077E-01_JPRB, 7.46910E-01_JPRB, 7.40795E-01_JPRB, & + & 7.34729E-01_JPRB, 7.28713E-01_JPRB, 7.22746E-01_JPRB, 7.16828E-01_JPRB/) + KAO_MO3( 4, :,10) = (/ & + & 8.29026E-01_JPRB, 8.22246E-01_JPRB, 8.15521E-01_JPRB, 8.08851E-01_JPRB, 8.02236E-01_JPRB, & + & 7.95675E-01_JPRB, 7.89167E-01_JPRB, 7.82713E-01_JPRB, 7.76312E-01_JPRB, 7.69962E-01_JPRB, & + & 7.63665E-01_JPRB, 7.57419E-01_JPRB, 7.51225E-01_JPRB, 7.45081E-01_JPRB, 7.38987E-01_JPRB, & + & 7.32943E-01_JPRB, 7.26949E-01_JPRB, 7.21003E-01_JPRB, 7.15107E-01_JPRB/) + KAO_MO3( 5, :,10) = (/ & + & 8.26226E-01_JPRB, 8.19471E-01_JPRB, 8.12771E-01_JPRB, 8.06126E-01_JPRB, 7.99536E-01_JPRB, & + & 7.92999E-01_JPRB, 7.86515E-01_JPRB, 7.80085E-01_JPRB, 7.73707E-01_JPRB, 7.67382E-01_JPRB, & + & 7.61108E-01_JPRB, 7.54885E-01_JPRB, 7.48714E-01_JPRB, 7.42592E-01_JPRB, 7.36521E-01_JPRB, & + & 7.30500E-01_JPRB, 7.24527E-01_JPRB, 7.18604E-01_JPRB, 7.12729E-01_JPRB/) + KAO_MO3( 6, :,10) = (/ & + & 8.33246E-01_JPRB, 8.26510E-01_JPRB, 8.19828E-01_JPRB, 8.13200E-01_JPRB, 8.06626E-01_JPRB, & + & 8.00105E-01_JPRB, 7.93637E-01_JPRB, 7.87221E-01_JPRB, 7.80856E-01_JPRB, 7.74544E-01_JPRB, & + & 7.68282E-01_JPRB, 7.62071E-01_JPRB, 7.55910E-01_JPRB, 7.49799E-01_JPRB, 7.43737E-01_JPRB, & + & 7.37725E-01_JPRB, 7.31760E-01_JPRB, 7.25845E-01_JPRB, 7.19977E-01_JPRB/) + KAO_MO3( 7, :,10) = (/ & + & 8.45693E-01_JPRB, 8.38967E-01_JPRB, 8.32295E-01_JPRB, 8.25675E-01_JPRB, 8.19108E-01_JPRB, & + & 8.12594E-01_JPRB, 8.06131E-01_JPRB, 7.99719E-01_JPRB, 7.93359E-01_JPRB, 7.87049E-01_JPRB, & + & 7.80789E-01_JPRB, 7.74579E-01_JPRB, 7.68419E-01_JPRB, 7.62307E-01_JPRB, 7.56244E-01_JPRB, & + & 7.50230E-01_JPRB, 7.44263E-01_JPRB, 7.38343E-01_JPRB, 7.32471E-01_JPRB/) + KAO_MO3( 8, :,10) = (/ & + & 8.32139E-01_JPRB, 8.25565E-01_JPRB, 8.19044E-01_JPRB, 8.12574E-01_JPRB, 8.06156E-01_JPRB, & + & 7.99788E-01_JPRB, 7.93470E-01_JPRB, 7.87202E-01_JPRB, 7.80984E-01_JPRB, 7.74815E-01_JPRB, & + & 7.68694E-01_JPRB, 7.62622E-01_JPRB, 7.56598E-01_JPRB, 7.50622E-01_JPRB, 7.44692E-01_JPRB, & + & 7.38810E-01_JPRB, 7.32974E-01_JPRB, 7.27184E-01_JPRB, 7.21440E-01_JPRB/) + KAO_MO3( 9, :,10) = (/ & + & 2.34258E-01_JPRB, 2.35247E-01_JPRB, 2.36239E-01_JPRB, 2.37236E-01_JPRB, 2.38237E-01_JPRB, & + & 2.39242E-01_JPRB, 2.40252E-01_JPRB, 2.41265E-01_JPRB, 2.42283E-01_JPRB, 2.43306E-01_JPRB, & + & 2.44332E-01_JPRB, 2.45363E-01_JPRB, 2.46398E-01_JPRB, 2.47438E-01_JPRB, 2.48482E-01_JPRB, & + & 2.49531E-01_JPRB, 2.50583E-01_JPRB, 2.51641E-01_JPRB, 2.52702E-01_JPRB/) + KAO_MO3( 1, :,11) = (/ & + & 8.31308E-01_JPRB, 8.22153E-01_JPRB, 8.13098E-01_JPRB, 8.04143E-01_JPRB, 7.95287E-01_JPRB, & + & 7.86528E-01_JPRB, 7.77866E-01_JPRB, 7.69299E-01_JPRB, 7.60827E-01_JPRB, 7.52448E-01_JPRB, & + & 7.44161E-01_JPRB, 7.35965E-01_JPRB, 7.27860E-01_JPRB, 7.19844E-01_JPRB, 7.11916E-01_JPRB, & + & 7.04075E-01_JPRB, 6.96321E-01_JPRB, 6.88652E-01_JPRB, 6.81068E-01_JPRB/) + KAO_MO3( 2, :,11) = (/ & + & 8.31577E-01_JPRB, 8.22400E-01_JPRB, 8.13324E-01_JPRB, 8.04349E-01_JPRB, 7.95472E-01_JPRB, & + & 7.86693E-01_JPRB, 7.78011E-01_JPRB, 7.69425E-01_JPRB, 7.60934E-01_JPRB, 7.52537E-01_JPRB, & + & 7.44232E-01_JPRB, 7.36019E-01_JPRB, 7.27896E-01_JPRB, 7.19863E-01_JPRB, 7.11919E-01_JPRB, & + & 7.04062E-01_JPRB, 6.96292E-01_JPRB, 6.88608E-01_JPRB, 6.81009E-01_JPRB/) + KAO_MO3( 3, :,11) = (/ & + & 8.31578E-01_JPRB, 8.22422E-01_JPRB, 8.13368E-01_JPRB, 8.04413E-01_JPRB, 7.95557E-01_JPRB, & + & 7.86798E-01_JPRB, 7.78136E-01_JPRB, 7.69569E-01_JPRB, 7.61097E-01_JPRB, 7.52717E-01_JPRB, & + & 7.44430E-01_JPRB, 7.36235E-01_JPRB, 7.28129E-01_JPRB, 7.20113E-01_JPRB, 7.12185E-01_JPRB, & + & 7.04344E-01_JPRB, 6.96589E-01_JPRB, 6.88920E-01_JPRB, 6.81336E-01_JPRB/) + KAO_MO3( 4, :,11) = (/ & + & 8.31261E-01_JPRB, 8.22111E-01_JPRB, 8.13062E-01_JPRB, 8.04112E-01_JPRB, 7.95261E-01_JPRB, & + & 7.86507E-01_JPRB, 7.77850E-01_JPRB, 7.69288E-01_JPRB, 7.60820E-01_JPRB, 7.52445E-01_JPRB, & + & 7.44163E-01_JPRB, 7.35971E-01_JPRB, 7.27870E-01_JPRB, 7.19858E-01_JPRB, 7.11935E-01_JPRB, & + & 7.04098E-01_JPRB, 6.96348E-01_JPRB, 6.88683E-01_JPRB, 6.81102E-01_JPRB/) + KAO_MO3( 5, :,11) = (/ & + & 8.31565E-01_JPRB, 8.22404E-01_JPRB, 8.13344E-01_JPRB, 8.04384E-01_JPRB, 7.95523E-01_JPRB, & + & 7.86760E-01_JPRB, 7.78092E-01_JPRB, 7.69521E-01_JPRB, 7.61044E-01_JPRB, 7.52660E-01_JPRB, & + & 7.44368E-01_JPRB, 7.36168E-01_JPRB, 7.28058E-01_JPRB, 7.20038E-01_JPRB, 7.12106E-01_JPRB, & + & 7.04261E-01_JPRB, 6.96503E-01_JPRB, 6.88830E-01_JPRB, 6.81242E-01_JPRB/) + KAO_MO3( 6, :,11) = (/ & + & 8.17636E-01_JPRB, 8.08497E-01_JPRB, 7.99461E-01_JPRB, 7.90525E-01_JPRB, 7.81690E-01_JPRB, & + & 7.72953E-01_JPRB, 7.64314E-01_JPRB, 7.55771E-01_JPRB, 7.47324E-01_JPRB, 7.38971E-01_JPRB, & + & 7.30712E-01_JPRB, 7.22545E-01_JPRB, 7.14469E-01_JPRB, 7.06483E-01_JPRB, 6.98587E-01_JPRB, & + & 6.90779E-01_JPRB, 6.83058E-01_JPRB, 6.75424E-01_JPRB, 6.67875E-01_JPRB/) + KAO_MO3( 7, :,11) = (/ & + & 7.95247E-01_JPRB, 7.86140E-01_JPRB, 7.77137E-01_JPRB, 7.68238E-01_JPRB, 7.59440E-01_JPRB, & + & 7.50743E-01_JPRB, 7.42145E-01_JPRB, 7.33646E-01_JPRB, 7.25245E-01_JPRB, 7.16939E-01_JPRB, & + & 7.08729E-01_JPRB, 7.00612E-01_JPRB, 6.92589E-01_JPRB, 6.84658E-01_JPRB, 6.76817E-01_JPRB, & + & 6.69066E-01_JPRB, 6.61404E-01_JPRB, 6.53830E-01_JPRB, 6.46342E-01_JPRB/) + KAO_MO3( 8, :,11) = (/ & + & 7.63069E-01_JPRB, 7.54006E-01_JPRB, 7.45051E-01_JPRB, 7.36202E-01_JPRB, 7.27458E-01_JPRB, & + & 7.18818E-01_JPRB, 7.10281E-01_JPRB, 7.01845E-01_JPRB, 6.93509E-01_JPRB, 6.85272E-01_JPRB, & + & 6.77133E-01_JPRB, 6.69091E-01_JPRB, 6.61144E-01_JPRB, 6.53292E-01_JPRB, 6.45533E-01_JPRB, & + & 6.37866E-01_JPRB, 6.30290E-01_JPRB, 6.22804E-01_JPRB, 6.15407E-01_JPRB/) + KAO_MO3( 9, :,11) = (/ & + & 2.03255E-01_JPRB, 2.03004E-01_JPRB, 2.02753E-01_JPRB, 2.02502E-01_JPRB, 2.02252E-01_JPRB, & + & 2.02001E-01_JPRB, 2.01752E-01_JPRB, 2.01502E-01_JPRB, 2.01253E-01_JPRB, 2.01004E-01_JPRB, & + & 2.00755E-01_JPRB, 2.00507E-01_JPRB, 2.00259E-01_JPRB, 2.00011E-01_JPRB, 1.99764E-01_JPRB, & + & 1.99517E-01_JPRB, 1.99270E-01_JPRB, 1.99024E-01_JPRB, 1.98777E-01_JPRB/) + KAO_MO3( 1, :,12) = (/ & + & 4.13201E-01_JPRB, 4.05258E-01_JPRB, 3.97468E-01_JPRB, 3.89828E-01_JPRB, 3.82334E-01_JPRB, & + & 3.74985E-01_JPRB, 3.67777E-01_JPRB, 3.60707E-01_JPRB, 3.53774E-01_JPRB, 3.46973E-01_JPRB, & + & 3.40303E-01_JPRB, 3.33762E-01_JPRB, 3.27346E-01_JPRB, 3.21054E-01_JPRB, 3.14882E-01_JPRB, & + & 3.08829E-01_JPRB, 3.02893E-01_JPRB, 2.97071E-01_JPRB, 2.91360E-01_JPRB/) + KAO_MO3( 2, :,12) = (/ & + & 4.12835E-01_JPRB, 4.04897E-01_JPRB, 3.97112E-01_JPRB, 3.89477E-01_JPRB, 3.81988E-01_JPRB, & + & 3.74644E-01_JPRB, 3.67440E-01_JPRB, 3.60376E-01_JPRB, 3.53447E-01_JPRB, 3.46651E-01_JPRB, & + & 3.39986E-01_JPRB, 3.33449E-01_JPRB, 3.27038E-01_JPRB, 3.20750E-01_JPRB, 3.14582E-01_JPRB, & + & 3.08534E-01_JPRB, 3.02602E-01_JPRB, 2.96784E-01_JPRB, 2.91077E-01_JPRB/) + KAO_MO3( 3, :,12) = (/ & + & 4.13023E-01_JPRB, 4.05079E-01_JPRB, 3.97289E-01_JPRB, 3.89648E-01_JPRB, 3.82155E-01_JPRB, & + & 3.74805E-01_JPRB, 3.67597E-01_JPRB, 3.60527E-01_JPRB, 3.53594E-01_JPRB, 3.46793E-01_JPRB, & + & 3.40124E-01_JPRB, 3.33583E-01_JPRB, 3.27167E-01_JPRB, 3.20875E-01_JPRB, 3.14704E-01_JPRB, & + & 3.08652E-01_JPRB, 3.02716E-01_JPRB, 2.96894E-01_JPRB, 2.91184E-01_JPRB/) + KAO_MO3( 4, :,12) = (/ & + & 4.13397E-01_JPRB, 4.05437E-01_JPRB, 3.97630E-01_JPRB, 3.89973E-01_JPRB, 3.82463E-01_JPRB, & + & 3.75099E-01_JPRB, 3.67876E-01_JPRB, 3.60792E-01_JPRB, 3.53844E-01_JPRB, 3.47031E-01_JPRB, & + & 3.40348E-01_JPRB, 3.33794E-01_JPRB, 3.27367E-01_JPRB, 3.21063E-01_JPRB, 3.14880E-01_JPRB, & + & 3.08817E-01_JPRB, 3.02870E-01_JPRB, 2.97038E-01_JPRB, 2.91318E-01_JPRB/) + KAO_MO3( 5, :,12) = (/ & + & 4.13043E-01_JPRB, 4.05106E-01_JPRB, 3.97321E-01_JPRB, 3.89686E-01_JPRB, 3.82198E-01_JPRB, & + & 3.74854E-01_JPRB, 3.67651E-01_JPRB, 3.60586E-01_JPRB, 3.53657E-01_JPRB, 3.46861E-01_JPRB, & + & 3.40195E-01_JPRB, 3.33658E-01_JPRB, 3.27246E-01_JPRB, 3.20958E-01_JPRB, 3.14790E-01_JPRB, & + & 3.08741E-01_JPRB, 3.02808E-01_JPRB, 2.96990E-01_JPRB, 2.91283E-01_JPRB/) + KAO_MO3( 6, :,12) = (/ & + & 4.13151E-01_JPRB, 4.05202E-01_JPRB, 3.97406E-01_JPRB, 3.89760E-01_JPRB, 3.82261E-01_JPRB, & + & 3.74906E-01_JPRB, 3.67693E-01_JPRB, 3.60619E-01_JPRB, 3.53680E-01_JPRB, 3.46876E-01_JPRB, & + & 3.40202E-01_JPRB, 3.33656E-01_JPRB, 3.27237E-01_JPRB, 3.20941E-01_JPRB, 3.14766E-01_JPRB, & + & 3.08710E-01_JPRB, 3.02770E-01_JPRB, 2.96945E-01_JPRB, 2.91232E-01_JPRB/) + KAO_MO3( 7, :,12) = (/ & + & 4.13052E-01_JPRB, 4.05109E-01_JPRB, 3.97319E-01_JPRB, 3.89678E-01_JPRB, 3.82185E-01_JPRB, & + & 3.74835E-01_JPRB, 3.67627E-01_JPRB, 3.60557E-01_JPRB, 3.53624E-01_JPRB, 3.46823E-01_JPRB, & + & 3.40154E-01_JPRB, 3.33612E-01_JPRB, 3.27197E-01_JPRB, 3.20905E-01_JPRB, 3.14734E-01_JPRB, & + & 3.08681E-01_JPRB, 3.02745E-01_JPRB, 2.96923E-01_JPRB, 2.91213E-01_JPRB/) + KAO_MO3( 8, :,12) = (/ & + & 4.13152E-01_JPRB, 4.05209E-01_JPRB, 3.97418E-01_JPRB, 3.89778E-01_JPRB, 3.82284E-01_JPRB, & + & 3.74935E-01_JPRB, 3.67727E-01_JPRB, 3.60657E-01_JPRB, 3.53723E-01_JPRB, 3.46923E-01_JPRB, & + & 3.40253E-01_JPRB, 3.33712E-01_JPRB, 3.27296E-01_JPRB, 3.21004E-01_JPRB, 3.14833E-01_JPRB, & + & 3.08780E-01_JPRB, 3.02844E-01_JPRB, 2.97021E-01_JPRB, 2.91311E-01_JPRB/) + KAO_MO3( 9, :,12) = (/ & + & 1.31008E-01_JPRB, 1.30607E-01_JPRB, 1.30208E-01_JPRB, 1.29810E-01_JPRB, 1.29413E-01_JPRB, & + & 1.29017E-01_JPRB, 1.28623E-01_JPRB, 1.28229E-01_JPRB, 1.27837E-01_JPRB, 1.27446E-01_JPRB, & + & 1.27056E-01_JPRB, 1.26668E-01_JPRB, 1.26280E-01_JPRB, 1.25894E-01_JPRB, 1.25509E-01_JPRB, & + & 1.25125E-01_JPRB, 1.24743E-01_JPRB, 1.24361E-01_JPRB, 1.23981E-01_JPRB/) + KAO_MO3( 1, :,13) = (/ & + & 4.66826E-01_JPRB, 4.71437E-01_JPRB, 4.76094E-01_JPRB, 4.80798E-01_JPRB, 4.85547E-01_JPRB, & + & 4.90344E-01_JPRB, 4.95187E-01_JPRB, 5.00079E-01_JPRB, 5.05019E-01_JPRB, 5.10008E-01_JPRB, & + & 5.15046E-01_JPRB, 5.20134E-01_JPRB, 5.25272E-01_JPRB, 5.30461E-01_JPRB, 5.35701E-01_JPRB, & + & 5.40993E-01_JPRB, 5.46338E-01_JPRB, 5.51735E-01_JPRB, 5.57185E-01_JPRB/) + KAO_MO3( 2, :,13) = (/ & + & 4.66579E-01_JPRB, 4.71199E-01_JPRB, 4.75865E-01_JPRB, 4.80577E-01_JPRB, 4.85336E-01_JPRB, & + & 4.90141E-01_JPRB, 4.94995E-01_JPRB, 4.99896E-01_JPRB, 5.04846E-01_JPRB, 5.09845E-01_JPRB, & + & 5.14893E-01_JPRB, 5.19992E-01_JPRB, 5.25141E-01_JPRB, 5.30340E-01_JPRB, 5.35592E-01_JPRB, & + & 5.40895E-01_JPRB, 5.46251E-01_JPRB, 5.51660E-01_JPRB, 5.57122E-01_JPRB/) + KAO_MO3( 3, :,13) = (/ & + & 4.66956E-01_JPRB, 4.71567E-01_JPRB, 4.76224E-01_JPRB, 4.80927E-01_JPRB, 4.85677E-01_JPRB, & + & 4.90474E-01_JPRB, 4.95318E-01_JPRB, 5.00209E-01_JPRB, 5.05149E-01_JPRB, 5.10138E-01_JPRB, & + & 5.15176E-01_JPRB, 5.20264E-01_JPRB, 5.25402E-01_JPRB, 5.30591E-01_JPRB, 5.35831E-01_JPRB, & + & 5.41123E-01_JPRB, 5.46467E-01_JPRB, 5.51864E-01_JPRB, 5.57314E-01_JPRB/) + KAO_MO3( 4, :,13) = (/ & + & 4.66456E-01_JPRB, 4.71080E-01_JPRB, 4.75750E-01_JPRB, 4.80467E-01_JPRB, 4.85230E-01_JPRB, & + & 4.90040E-01_JPRB, 4.94898E-01_JPRB, 4.99804E-01_JPRB, 5.04759E-01_JPRB, 5.09763E-01_JPRB, & + & 5.14817E-01_JPRB, 5.19920E-01_JPRB, 5.25075E-01_JPRB, 5.30280E-01_JPRB, 5.35537E-01_JPRB, & + & 5.40846E-01_JPRB, 5.46208E-01_JPRB, 5.51622E-01_JPRB, 5.57091E-01_JPRB/) + KAO_MO3( 5, :,13) = (/ & + & 4.66853E-01_JPRB, 4.71456E-01_JPRB, 4.76104E-01_JPRB, 4.80798E-01_JPRB, 4.85539E-01_JPRB, & + & 4.90326E-01_JPRB, 4.95160E-01_JPRB, 5.00042E-01_JPRB, 5.04973E-01_JPRB, 5.09952E-01_JPRB, & + & 5.14979E-01_JPRB, 5.20057E-01_JPRB, 5.25185E-01_JPRB, 5.30363E-01_JPRB, 5.35592E-01_JPRB, & + & 5.40873E-01_JPRB, 5.46205E-01_JPRB, 5.51591E-01_JPRB, 5.57029E-01_JPRB/) + KAO_MO3( 6, :,13) = (/ & + & 4.66832E-01_JPRB, 4.71448E-01_JPRB, 4.76110E-01_JPRB, 4.80817E-01_JPRB, 4.85571E-01_JPRB, & + & 4.90372E-01_JPRB, 4.95221E-01_JPRB, 5.00118E-01_JPRB, 5.05063E-01_JPRB, 5.10056E-01_JPRB, & + & 5.15100E-01_JPRB, 5.20193E-01_JPRB, 5.25336E-01_JPRB, 5.30531E-01_JPRB, 5.35776E-01_JPRB, & + & 5.41074E-01_JPRB, 5.46424E-01_JPRB, 5.51826E-01_JPRB, 5.57283E-01_JPRB/) + KAO_MO3( 7, :,13) = (/ & + & 4.66679E-01_JPRB, 4.71299E-01_JPRB, 4.75965E-01_JPRB, 4.80677E-01_JPRB, 4.85436E-01_JPRB, & + & 4.90241E-01_JPRB, 4.95095E-01_JPRB, 4.99996E-01_JPRB, 5.04946E-01_JPRB, 5.09945E-01_JPRB, & + & 5.14993E-01_JPRB, 5.20092E-01_JPRB, 5.25240E-01_JPRB, 5.30440E-01_JPRB, 5.35692E-01_JPRB, & + & 5.40995E-01_JPRB, 5.46351E-01_JPRB, 5.51759E-01_JPRB, 5.57222E-01_JPRB/) + KAO_MO3( 8, :,13) = (/ & + & 4.66982E-01_JPRB, 4.71598E-01_JPRB, 4.76260E-01_JPRB, 4.80967E-01_JPRB, 4.85721E-01_JPRB, & + & 4.90522E-01_JPRB, 4.95371E-01_JPRB, 5.00268E-01_JPRB, 5.05213E-01_JPRB, 5.10206E-01_JPRB, & + & 5.15250E-01_JPRB, 5.20343E-01_JPRB, 5.25486E-01_JPRB, 5.30680E-01_JPRB, 5.35926E-01_JPRB, & + & 5.41223E-01_JPRB, 5.46573E-01_JPRB, 5.51976E-01_JPRB, 5.57432E-01_JPRB/) + KAO_MO3( 9, :,13) = (/ & + & 1.13709E-01_JPRB, 1.13141E-01_JPRB, 1.12576E-01_JPRB, 1.12013E-01_JPRB, 1.11453E-01_JPRB, & + & 1.10897E-01_JPRB, 1.10342E-01_JPRB, 1.09791E-01_JPRB, 1.09242E-01_JPRB, 1.08696E-01_JPRB, & + & 1.08153E-01_JPRB, 1.07613E-01_JPRB, 1.07075E-01_JPRB, 1.06540E-01_JPRB, 1.06007E-01_JPRB, & + & 1.05478E-01_JPRB, 1.04951E-01_JPRB, 1.04426E-01_JPRB, 1.03904E-01_JPRB/) + KAO_MO3( 1, :,14) = (/ & + & 5.67608E-01_JPRB, 5.55796E-01_JPRB, 5.44230E-01_JPRB, 5.32904E-01_JPRB, 5.21814E-01_JPRB, & + & 5.10955E-01_JPRB, 5.00322E-01_JPRB, 4.89910E-01_JPRB, 4.79714E-01_JPRB, 4.69731E-01_JPRB, & + & 4.59956E-01_JPRB, 4.50384E-01_JPRB, 4.41011E-01_JPRB, 4.31834E-01_JPRB, 4.22847E-01_JPRB, & + & 4.14048E-01_JPRB, 4.05431E-01_JPRB, 3.96994E-01_JPRB, 3.88732E-01_JPRB/) + KAO_MO3( 2, :,14) = (/ & + & 5.67766E-01_JPRB, 5.55948E-01_JPRB, 5.44376E-01_JPRB, 5.33045E-01_JPRB, 5.21950E-01_JPRB, & + & 5.11086E-01_JPRB, 5.00448E-01_JPRB, 4.90031E-01_JPRB, 4.79831E-01_JPRB, 4.69844E-01_JPRB, & + & 4.60064E-01_JPRB, 4.50488E-01_JPRB, 4.41111E-01_JPRB, 4.31930E-01_JPRB, 4.22939E-01_JPRB, & + & 4.14136E-01_JPRB, 4.05516E-01_JPRB, 3.97075E-01_JPRB, 3.88810E-01_JPRB/) + KAO_MO3( 3, :,14) = (/ & + & 5.67460E-01_JPRB, 5.55647E-01_JPRB, 5.44080E-01_JPRB, 5.32754E-01_JPRB, 5.21664E-01_JPRB, & + & 5.10805E-01_JPRB, 5.00172E-01_JPRB, 4.89760E-01_JPRB, 4.79564E-01_JPRB, 4.69582E-01_JPRB, & + & 4.59806E-01_JPRB, 4.50235E-01_JPRB, 4.40862E-01_JPRB, 4.31685E-01_JPRB, 4.22699E-01_JPRB, & + & 4.13900E-01_JPRB, 4.05284E-01_JPRB, 3.96847E-01_JPRB, 3.88586E-01_JPRB/) + KAO_MO3( 4, :,14) = (/ & + & 5.67925E-01_JPRB, 5.56107E-01_JPRB, 5.44536E-01_JPRB, 5.33205E-01_JPRB, 5.22110E-01_JPRB, & + & 5.11246E-01_JPRB, 5.00608E-01_JPRB, 4.90191E-01_JPRB, 4.79991E-01_JPRB, 4.70004E-01_JPRB, & + & 4.60224E-01_JPRB, 4.50647E-01_JPRB, 4.41270E-01_JPRB, 4.32088E-01_JPRB, 4.23097E-01_JPRB, & + & 4.14293E-01_JPRB, 4.05673E-01_JPRB, 3.97231E-01_JPRB, 3.88966E-01_JPRB/) + KAO_MO3( 5, :,14) = (/ & + & 5.67520E-01_JPRB, 5.55733E-01_JPRB, 5.44190E-01_JPRB, 5.32887E-01_JPRB, 5.21818E-01_JPRB, & + & 5.10980E-01_JPRB, 5.00366E-01_JPRB, 4.89974E-01_JPRB, 4.79797E-01_JPRB, 4.69831E-01_JPRB, & + & 4.60072E-01_JPRB, 4.50516E-01_JPRB, 4.41159E-01_JPRB, 4.31996E-01_JPRB, 4.23023E-01_JPRB, & + & 4.14236E-01_JPRB, 4.05633E-01_JPRB, 3.97207E-01_JPRB, 3.88957E-01_JPRB/) + KAO_MO3( 6, :,14) = (/ & + & 5.67549E-01_JPRB, 5.55749E-01_JPRB, 5.44195E-01_JPRB, 5.32880E-01_JPRB, 5.21801E-01_JPRB, & + & 5.10952E-01_JPRB, 5.00329E-01_JPRB, 4.89927E-01_JPRB, 4.79740E-01_JPRB, 4.69766E-01_JPRB, & + & 4.59999E-01_JPRB, 4.50435E-01_JPRB, 4.41070E-01_JPRB, 4.31900E-01_JPRB, 4.22920E-01_JPRB, & + & 4.14127E-01_JPRB, 4.05517E-01_JPRB, 3.97086E-01_JPRB, 3.88830E-01_JPRB/) + KAO_MO3( 7, :,14) = (/ & + & 5.67727E-01_JPRB, 5.55909E-01_JPRB, 5.44337E-01_JPRB, 5.33005E-01_JPRB, 5.21910E-01_JPRB, & + & 5.11046E-01_JPRB, 5.00408E-01_JPRB, 4.89991E-01_JPRB, 4.79791E-01_JPRB, 4.69804E-01_JPRB, & + & 4.60024E-01_JPRB, 4.50448E-01_JPRB, 4.41071E-01_JPRB, 4.31890E-01_JPRB, 4.22900E-01_JPRB, & + & 4.14096E-01_JPRB, 4.05476E-01_JPRB, 3.97036E-01_JPRB, 3.88771E-01_JPRB/) + KAO_MO3( 8, :,14) = (/ & + & 5.67795E-01_JPRB, 5.55965E-01_JPRB, 5.44381E-01_JPRB, 5.33039E-01_JPRB, 5.21933E-01_JPRB, & + & 5.11058E-01_JPRB, 5.00410E-01_JPRB, 4.89984E-01_JPRB, 4.79775E-01_JPRB, 4.69779E-01_JPRB, & + & 4.59991E-01_JPRB, 4.50407E-01_JPRB, 4.41023E-01_JPRB, 4.31834E-01_JPRB, 4.22836E-01_JPRB, & + & 4.14026E-01_JPRB, 4.05400E-01_JPRB, 3.96953E-01_JPRB, 3.88683E-01_JPRB/) + KAO_MO3( 9, :,14) = (/ & + & 1.32957E-01_JPRB, 1.31737E-01_JPRB, 1.30528E-01_JPRB, 1.29330E-01_JPRB, 1.28143E-01_JPRB, & + & 1.26967E-01_JPRB, 1.25802E-01_JPRB, 1.24648E-01_JPRB, 1.23504E-01_JPRB, 1.22370E-01_JPRB, & + & 1.21247E-01_JPRB, 1.20135E-01_JPRB, 1.19032E-01_JPRB, 1.17940E-01_JPRB, 1.16857E-01_JPRB, & + & 1.15785E-01_JPRB, 1.14722E-01_JPRB, 1.13669E-01_JPRB, 1.12626E-01_JPRB/) + KAO_MO3( 1, :,15) = (/ & + & 1.51281E-01_JPRB, 1.53439E-01_JPRB, 1.55628E-01_JPRB, 1.57848E-01_JPRB, 1.60100E-01_JPRB, & + & 1.62384E-01_JPRB, 1.64700E-01_JPRB, 1.67049E-01_JPRB, 1.69432E-01_JPRB, 1.71849E-01_JPRB, & + & 1.74301E-01_JPRB, 1.76787E-01_JPRB, 1.79309E-01_JPRB, 1.81866E-01_JPRB, 1.84461E-01_JPRB, & + & 1.87092E-01_JPRB, 1.89761E-01_JPRB, 1.92468E-01_JPRB, 1.95213E-01_JPRB/) + KAO_MO3( 2, :,15) = (/ & + & 1.51431E-01_JPRB, 1.53589E-01_JPRB, 1.55778E-01_JPRB, 1.57998E-01_JPRB, 1.60250E-01_JPRB, & + & 1.62534E-01_JPRB, 1.64850E-01_JPRB, 1.67199E-01_JPRB, 1.69582E-01_JPRB, 1.71999E-01_JPRB, & + & 1.74450E-01_JPRB, 1.76937E-01_JPRB, 1.79458E-01_JPRB, 1.82016E-01_JPRB, 1.84610E-01_JPRB, & + & 1.87241E-01_JPRB, 1.89909E-01_JPRB, 1.92616E-01_JPRB, 1.95361E-01_JPRB/) + KAO_MO3( 3, :,15) = (/ & + & 1.51299E-01_JPRB, 1.53461E-01_JPRB, 1.55654E-01_JPRB, 1.57878E-01_JPRB, 1.60134E-01_JPRB, & + & 1.62422E-01_JPRB, 1.64744E-01_JPRB, 1.67098E-01_JPRB, 1.69486E-01_JPRB, 1.71908E-01_JPRB, & + & 1.74364E-01_JPRB, 1.76856E-01_JPRB, 1.79383E-01_JPRB, 1.81947E-01_JPRB, 1.84547E-01_JPRB, & + & 1.87184E-01_JPRB, 1.89859E-01_JPRB, 1.92572E-01_JPRB, 1.95324E-01_JPRB/) + KAO_MO3( 4, :,15) = (/ & + & 1.51281E-01_JPRB, 1.53439E-01_JPRB, 1.55628E-01_JPRB, 1.57848E-01_JPRB, 1.60100E-01_JPRB, & + & 1.62384E-01_JPRB, 1.64700E-01_JPRB, 1.67049E-01_JPRB, 1.69432E-01_JPRB, 1.71849E-01_JPRB, & + & 1.74301E-01_JPRB, 1.76787E-01_JPRB, 1.79309E-01_JPRB, 1.81866E-01_JPRB, 1.84461E-01_JPRB, & + & 1.87092E-01_JPRB, 1.89761E-01_JPRB, 1.92468E-01_JPRB, 1.95213E-01_JPRB/) + KAO_MO3( 5, :,15) = (/ & + & 1.51281E-01_JPRB, 1.53439E-01_JPRB, 1.55628E-01_JPRB, 1.57848E-01_JPRB, 1.60100E-01_JPRB, & + & 1.62384E-01_JPRB, 1.64700E-01_JPRB, 1.67049E-01_JPRB, 1.69432E-01_JPRB, 1.71849E-01_JPRB, & + & 1.74301E-01_JPRB, 1.76787E-01_JPRB, 1.79309E-01_JPRB, 1.81866E-01_JPRB, 1.84461E-01_JPRB, & + & 1.87092E-01_JPRB, 1.89761E-01_JPRB, 1.92468E-01_JPRB, 1.95213E-01_JPRB/) + KAO_MO3( 6, :,15) = (/ & + & 1.51299E-01_JPRB, 1.53461E-01_JPRB, 1.55654E-01_JPRB, 1.57878E-01_JPRB, 1.60134E-01_JPRB, & + & 1.62422E-01_JPRB, 1.64744E-01_JPRB, 1.67098E-01_JPRB, 1.69486E-01_JPRB, 1.71908E-01_JPRB, & + & 1.74364E-01_JPRB, 1.76856E-01_JPRB, 1.79383E-01_JPRB, 1.81947E-01_JPRB, 1.84547E-01_JPRB, & + & 1.87184E-01_JPRB, 1.89859E-01_JPRB, 1.92572E-01_JPRB, 1.95324E-01_JPRB/) + KAO_MO3( 7, :,15) = (/ & + & 1.51299E-01_JPRB, 1.53461E-01_JPRB, 1.55654E-01_JPRB, 1.57878E-01_JPRB, 1.60134E-01_JPRB, & + & 1.62422E-01_JPRB, 1.64744E-01_JPRB, 1.67098E-01_JPRB, 1.69486E-01_JPRB, 1.71908E-01_JPRB, & + & 1.74364E-01_JPRB, 1.76856E-01_JPRB, 1.79383E-01_JPRB, 1.81947E-01_JPRB, 1.84547E-01_JPRB, & + & 1.87184E-01_JPRB, 1.89859E-01_JPRB, 1.92572E-01_JPRB, 1.95324E-01_JPRB/) + KAO_MO3( 8, :,15) = (/ & + & 1.51281E-01_JPRB, 1.53439E-01_JPRB, 1.55628E-01_JPRB, 1.57848E-01_JPRB, 1.60100E-01_JPRB, & + & 1.62384E-01_JPRB, 1.64700E-01_JPRB, 1.67049E-01_JPRB, 1.69432E-01_JPRB, 1.71849E-01_JPRB, & + & 1.74301E-01_JPRB, 1.76787E-01_JPRB, 1.79309E-01_JPRB, 1.81866E-01_JPRB, 1.84461E-01_JPRB, & + & 1.87092E-01_JPRB, 1.89761E-01_JPRB, 1.92468E-01_JPRB, 1.95213E-01_JPRB/) + KAO_MO3( 9, :,15) = (/ & + & 2.44180E-01_JPRB, 2.35686E-01_JPRB, 2.27487E-01_JPRB, 2.19574E-01_JPRB, 2.11935E-01_JPRB, & + & 2.04563E-01_JPRB, 1.97447E-01_JPRB, 1.90578E-01_JPRB, 1.83949E-01_JPRB, 1.77550E-01_JPRB, & + & 1.71373E-01_JPRB, 1.65412E-01_JPRB, 1.59658E-01_JPRB, 1.54104E-01_JPRB, 1.48743E-01_JPRB, & + & 1.43569E-01_JPRB, 1.38574E-01_JPRB, 1.33754E-01_JPRB, 1.29101E-01_JPRB/) + KAO_MO3( 1, :,16) = (/ & + & 1.02934E-01_JPRB, 1.04369E-01_JPRB, 1.05825E-01_JPRB, 1.07300E-01_JPRB, 1.08797E-01_JPRB, & + & 1.10314E-01_JPRB, 1.11852E-01_JPRB, 1.13412E-01_JPRB, 1.14993E-01_JPRB, 1.16597E-01_JPRB, & + & 1.18223E-01_JPRB, 1.19871E-01_JPRB, 1.21543E-01_JPRB, 1.23238E-01_JPRB, 1.24956E-01_JPRB, & + & 1.26699E-01_JPRB, 1.28466E-01_JPRB, 1.30257E-01_JPRB, 1.32073E-01_JPRB/) + KAO_MO3( 2, :,16) = (/ & + & 1.02934E-01_JPRB, 1.04369E-01_JPRB, 1.05825E-01_JPRB, 1.07300E-01_JPRB, 1.08797E-01_JPRB, & + & 1.10314E-01_JPRB, 1.11852E-01_JPRB, 1.13412E-01_JPRB, 1.14993E-01_JPRB, 1.16597E-01_JPRB, & + & 1.18223E-01_JPRB, 1.19871E-01_JPRB, 1.21543E-01_JPRB, 1.23238E-01_JPRB, 1.24956E-01_JPRB, & + & 1.26699E-01_JPRB, 1.28466E-01_JPRB, 1.30257E-01_JPRB, 1.32073E-01_JPRB/) + KAO_MO3( 3, :,16) = (/ & + & 1.02934E-01_JPRB, 1.04369E-01_JPRB, 1.05825E-01_JPRB, 1.07300E-01_JPRB, 1.08797E-01_JPRB, & + & 1.10314E-01_JPRB, 1.11852E-01_JPRB, 1.13412E-01_JPRB, 1.14993E-01_JPRB, 1.16597E-01_JPRB, & + & 1.18223E-01_JPRB, 1.19871E-01_JPRB, 1.21543E-01_JPRB, 1.23238E-01_JPRB, 1.24956E-01_JPRB, & + & 1.26699E-01_JPRB, 1.28466E-01_JPRB, 1.30257E-01_JPRB, 1.32073E-01_JPRB/) + KAO_MO3( 4, :,16) = (/ & + & 1.02934E-01_JPRB, 1.04369E-01_JPRB, 1.05825E-01_JPRB, 1.07300E-01_JPRB, 1.08797E-01_JPRB, & + & 1.10314E-01_JPRB, 1.11852E-01_JPRB, 1.13412E-01_JPRB, 1.14993E-01_JPRB, 1.16597E-01_JPRB, & + & 1.18223E-01_JPRB, 1.19871E-01_JPRB, 1.21543E-01_JPRB, 1.23238E-01_JPRB, 1.24956E-01_JPRB, & + & 1.26699E-01_JPRB, 1.28466E-01_JPRB, 1.30257E-01_JPRB, 1.32073E-01_JPRB/) + KAO_MO3( 5, :,16) = (/ & + & 1.02934E-01_JPRB, 1.04369E-01_JPRB, 1.05825E-01_JPRB, 1.07300E-01_JPRB, 1.08797E-01_JPRB, & + & 1.10314E-01_JPRB, 1.11852E-01_JPRB, 1.13412E-01_JPRB, 1.14993E-01_JPRB, 1.16597E-01_JPRB, & + & 1.18223E-01_JPRB, 1.19871E-01_JPRB, 1.21543E-01_JPRB, 1.23238E-01_JPRB, 1.24956E-01_JPRB, & + & 1.26699E-01_JPRB, 1.28466E-01_JPRB, 1.30257E-01_JPRB, 1.32073E-01_JPRB/) + KAO_MO3( 6, :,16) = (/ & + & 1.02934E-01_JPRB, 1.04369E-01_JPRB, 1.05825E-01_JPRB, 1.07300E-01_JPRB, 1.08797E-01_JPRB, & + & 1.10314E-01_JPRB, 1.11852E-01_JPRB, 1.13412E-01_JPRB, 1.14993E-01_JPRB, 1.16597E-01_JPRB, & + & 1.18223E-01_JPRB, 1.19871E-01_JPRB, 1.21543E-01_JPRB, 1.23238E-01_JPRB, 1.24956E-01_JPRB, & + & 1.26699E-01_JPRB, 1.28466E-01_JPRB, 1.30257E-01_JPRB, 1.32073E-01_JPRB/) + KAO_MO3( 7, :,16) = (/ & + & 1.02934E-01_JPRB, 1.04369E-01_JPRB, 1.05825E-01_JPRB, 1.07300E-01_JPRB, 1.08797E-01_JPRB, & + & 1.10314E-01_JPRB, 1.11852E-01_JPRB, 1.13412E-01_JPRB, 1.14993E-01_JPRB, 1.16597E-01_JPRB, & + & 1.18223E-01_JPRB, 1.19871E-01_JPRB, 1.21543E-01_JPRB, 1.23238E-01_JPRB, 1.24956E-01_JPRB, & + & 1.26699E-01_JPRB, 1.28466E-01_JPRB, 1.30257E-01_JPRB, 1.32073E-01_JPRB/) + KAO_MO3( 8, :,16) = (/ & + & 1.02934E-01_JPRB, 1.04369E-01_JPRB, 1.05825E-01_JPRB, 1.07300E-01_JPRB, 1.08797E-01_JPRB, & + & 1.10314E-01_JPRB, 1.11852E-01_JPRB, 1.13412E-01_JPRB, 1.14993E-01_JPRB, 1.16597E-01_JPRB, & + & 1.18223E-01_JPRB, 1.19871E-01_JPRB, 1.21543E-01_JPRB, 1.23238E-01_JPRB, 1.24956E-01_JPRB, & + & 1.26699E-01_JPRB, 1.28466E-01_JPRB, 1.30257E-01_JPRB, 1.32073E-01_JPRB/) + KAO_MO3( 9, :,16) = (/ & + & 3.91531E-01_JPRB, 3.78978E-01_JPRB, 3.66827E-01_JPRB, 3.55067E-01_JPRB, 3.43683E-01_JPRB, & + & 3.32664E-01_JPRB, 3.21999E-01_JPRB, 3.11675E-01_JPRB, 3.01683E-01_JPRB, 2.92011E-01_JPRB, & + & 2.82648E-01_JPRB, 2.73586E-01_JPRB, 2.64815E-01_JPRB, 2.56325E-01_JPRB, 2.48107E-01_JPRB, & + & 2.40152E-01_JPRB, 2.32453E-01_JPRB, 2.25000E-01_JPRB, 2.17787E-01_JPRB/) + + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &1.0689E-05_JPRB,1.6987E-05_JPRB,1.8993E-05_JPRB,3.4470E-05_JPRB,4.0873E-05_JPRB,4.8275E-05_JPRB, & + &6.1178E-05_JPRB,6.4035E-05_JPRB,6.6253E-05_JPRB,7.8914E-05_JPRB,8.1640E-05_JPRB,7.9738E-05_JPRB, & + &7.8492E-05_JPRB,9.1565E-05_JPRB,1.0262E-04_JPRB,1.0368E-04_JPRB/) + FORREFO(2,:) = (/ & + &1.1194E-05_JPRB,1.6128E-05_JPRB,1.7213E-05_JPRB,2.6845E-05_JPRB,4.1361E-05_JPRB,5.1508E-05_JPRB, & + &6.8245E-05_JPRB,7.4063E-05_JPRB,7.6273E-05_JPRB,8.4061E-05_JPRB,8.2492E-05_JPRB,8.1720E-05_JPRB, & + &7.7626E-05_JPRB,1.0096E-04_JPRB,1.0519E-04_JPRB,1.0631E-04_JPRB/) + FORREFO(3,:) = (/ & + &1.0891E-05_JPRB,1.4933E-05_JPRB,1.7964E-05_JPRB,2.2577E-05_JPRB,4.4290E-05_JPRB,5.4675E-05_JPRB, & + &7.2494E-05_JPRB,7.8410E-05_JPRB,7.6948E-05_JPRB,7.5742E-05_JPRB,7.7654E-05_JPRB,8.2760E-05_JPRB, & + &7.8443E-05_JPRB,9.8384E-05_JPRB,1.0634E-04_JPRB,1.0838E-04_JPRB/) + FORREFO(4,:) = (/ & + &1.1316E-05_JPRB,1.5470E-05_JPRB,2.1246E-05_JPRB,3.3349E-05_JPRB,4.8704E-05_JPRB,5.6424E-05_JPRB, & + &5.8569E-05_JPRB,5.8780E-05_JPRB,6.0358E-05_JPRB,6.1586E-05_JPRB,6.4281E-05_JPRB,6.9333E-05_JPRB, & + &7.2763E-05_JPRB,7.2675E-05_JPRB,7.3754E-05_JPRB,1.0131E-04_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + SELFREFO(:, 1) = (/ & + & 1.27686E-01_JPRB, 1.09347E-01_JPRB, 9.36410E-02_JPRB, 8.01912E-02_JPRB, 6.86732E-02_JPRB, & + & 5.88096E-02_JPRB, 5.03627E-02_JPRB, 4.31290E-02_JPRB, 3.69343E-02_JPRB, 3.16294E-02_JPRB/) + SELFREFO(:, 2) = (/ & + & 1.40051E-01_JPRB, 1.20785E-01_JPRB, 1.04170E-01_JPRB, 8.98402E-02_JPRB, 7.74816E-02_JPRB, & + & 6.68231E-02_JPRB, 5.76308E-02_JPRB, 4.97030E-02_JPRB, 4.28658E-02_JPRB, 3.69691E-02_JPRB/) + SELFREFO(:, 3) = (/ & + & 1.42322E-01_JPRB, 1.22872E-01_JPRB, 1.06080E-01_JPRB, 9.15829E-02_JPRB, 7.90671E-02_JPRB, & + & 6.82616E-02_JPRB, 5.89329E-02_JPRB, 5.08790E-02_JPRB, 4.39258E-02_JPRB, 3.79228E-02_JPRB/) + SELFREFO(:, 4) = (/ & + & 1.53244E-01_JPRB, 1.33057E-01_JPRB, 1.15530E-01_JPRB, 1.00311E-01_JPRB, 8.70977E-02_JPRB, & + & 7.56244E-02_JPRB, 6.56626E-02_JPRB, 5.70130E-02_JPRB, 4.95028E-02_JPRB, 4.29819E-02_JPRB/) + SELFREFO(:, 5) = (/ & + & 1.71011E-01_JPRB, 1.46680E-01_JPRB, 1.25810E-01_JPRB, 1.07910E-01_JPRB, 9.25563E-02_JPRB, & + & 7.93874E-02_JPRB, 6.80922E-02_JPRB, 5.84040E-02_JPRB, 5.00943E-02_JPRB, 4.29669E-02_JPRB/) + SELFREFO(:, 6) = (/ & + & 1.76012E-01_JPRB, 1.51010E-01_JPRB, 1.29560E-01_JPRB, 1.11157E-01_JPRB, 9.53672E-02_JPRB, & + & 8.18207E-02_JPRB, 7.01984E-02_JPRB, 6.02270E-02_JPRB, 5.16720E-02_JPRB, 4.43322E-02_JPRB/) + SELFREFO(:, 7) = (/ & + & 1.85600E-01_JPRB, 1.59051E-01_JPRB, 1.36300E-01_JPRB, 1.16803E-01_JPRB, 1.00095E-01_JPRB, & + & 8.57776E-02_JPRB, 7.35077E-02_JPRB, 6.29930E-02_JPRB, 5.39823E-02_JPRB, 4.62606E-02_JPRB/) + SELFREFO(:, 8) = (/ & + & 1.88931E-01_JPRB, 1.61727E-01_JPRB, 1.38440E-01_JPRB, 1.18506E-01_JPRB, 1.01442E-01_JPRB, & + & 8.68356E-02_JPRB, 7.43321E-02_JPRB, 6.36290E-02_JPRB, 5.44670E-02_JPRB, 4.66243E-02_JPRB/) + SELFREFO(:, 9) = (/ & + & 1.91122E-01_JPRB, 1.63407E-01_JPRB, 1.39710E-01_JPRB, 1.19450E-01_JPRB, 1.02128E-01_JPRB, & + & 8.73176E-02_JPRB, 7.46552E-02_JPRB, 6.38290E-02_JPRB, 5.45728E-02_JPRB, 4.66589E-02_JPRB/) + SELFREFO(:,10) = (/ & + & 1.91334E-01_JPRB, 1.64872E-01_JPRB, 1.42070E-01_JPRB, 1.22421E-01_JPRB, 1.05490E-01_JPRB, & + & 9.09008E-02_JPRB, 7.83291E-02_JPRB, 6.74960E-02_JPRB, 5.81612E-02_JPRB, 5.01174E-02_JPRB/) + SELFREFO(:,11) = (/ & + & 1.89858E-01_JPRB, 1.63934E-01_JPRB, 1.41550E-01_JPRB, 1.22222E-01_JPRB, 1.05534E-01_JPRB, & + & 9.11237E-02_JPRB, 7.86814E-02_JPRB, 6.79380E-02_JPRB, 5.86615E-02_JPRB, 5.06517E-02_JPRB/) + SELFREFO(:,12) = (/ & + & 1.89783E-01_JPRB, 1.63757E-01_JPRB, 1.41300E-01_JPRB, 1.21923E-01_JPRB, 1.05203E-01_JPRB, & + & 9.07760E-02_JPRB, 7.83274E-02_JPRB, 6.75860E-02_JPRB, 5.83176E-02_JPRB, 5.03202E-02_JPRB/) + SELFREFO(:,13) = (/ & + & 1.87534E-01_JPRB, 1.62016E-01_JPRB, 1.39970E-01_JPRB, 1.20924E-01_JPRB, 1.04470E-01_JPRB, & + & 9.02541E-02_JPRB, 7.79730E-02_JPRB, 6.73630E-02_JPRB, 5.81967E-02_JPRB, 5.02778E-02_JPRB/) + SELFREFO(:,14) = (/ & + & 1.99128E-01_JPRB, 1.71410E-01_JPRB, 1.47550E-01_JPRB, 1.27011E-01_JPRB, 1.09332E-01_JPRB, & + & 9.41131E-02_JPRB, 8.10128E-02_JPRB, 6.97360E-02_JPRB, 6.00289E-02_JPRB, 5.16731E-02_JPRB/) + SELFREFO(:,15) = (/ & + & 1.99460E-01_JPRB, 1.72342E-01_JPRB, 1.48910E-01_JPRB, 1.28664E-01_JPRB, 1.11171E-01_JPRB, & + & 9.60560E-02_JPRB, 8.29962E-02_JPRB, 7.17120E-02_JPRB, 6.19620E-02_JPRB, 5.35376E-02_JPRB/) + SELFREFO(:,16) = (/ & + & 1.99906E-01_JPRB, 1.72737E-01_JPRB, 1.49260E-01_JPRB, 1.28974E-01_JPRB, 1.11445E-01_JPRB, & + & 9.62982E-02_JPRB, 8.32102E-02_JPRB, 7.19010E-02_JPRB, 6.21288E-02_JPRB, 5.36848E-02_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB5',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB5:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB5 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb6.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb6.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb6.F90 (revision 6016) @@ -0,0 +1,255 @@ +SUBROUTINE RRTM_KGB6 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 6: 820-980 cm-1 (low - H2O; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO6 , ONLY : KAO ,KAO_MCO2, SELFREFO, FORREFO ,FRACREFAO ,CFC11ADJO ,& + & CFC12O, KAO_D +USE YOMMP0 , ONLY : NPROC, MYPROC + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB6',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D + KAO = REAL(KAO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB6:') +ENDIF + + +! Planck fraction mapping level : P = 473.4280 mb, T = 259.83 K +FRACREFAO(:) = (/ & + & 1.4353E-01_JPRB,1.4774E-01_JPRB,1.4467E-01_JPRB,1.3785E-01_JPRB,1.2376E-01_JPRB,1.0214E-01_JPRB, & + & 8.1984E-02_JPRB,6.1152E-02_JPRB,4.0987E-02_JPRB,4.5067E-03_JPRB,4.0020E-03_JPRB,3.1772E-03_JPRB, & + & 2.3458E-03_JPRB,1.5025E-03_JPRB,5.7415E-04_JPRB,8.2970E-05_JPRB/) + +! Minor gas mapping level: +! lower - co2, p = 706.2720 mb, t = 294.2 k +! upper - cfc11, cfc12 + + +! CFC11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band. +CFC11ADJO( :) = (/& + & 0.0_JPRB, 0.0_JPRB, 36.7627_JPRB, 150.757_JPRB, & + & 81.4109_JPRB, 74.9112_JPRB, 56.9325_JPRB, 49.3226_JPRB, & + & 57.1074_JPRB, 66.1202_JPRB, 109.557_JPRB, 89.0562_JPRB, & + & 149.865_JPRB, 196.140_JPRB, 258.393_JPRB, 80.9923_JPRB/) + +CFC12O( :) = (/& + & 62.8368_JPRB, 43.2626_JPRB, 26.7549_JPRB, 22.2487_JPRB,& + & 23.5029_JPRB, 34.8323_JPRB, 26.2335_JPRB, 23.2306_JPRB,& + & 18.4062_JPRB, 13.9534_JPRB, 22.6268_JPRB, 24.2604_JPRB,& + & 30.0088_JPRB, 26.3634_JPRB, 15.8237_JPRB, 57.5050_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + + KAO_MCO2(:, 1) = (/ & + & 1.45661E-05_JPRB, 1.73337E-05_JPRB, 2.06273E-05_JPRB, 2.45466E-05_JPRB, 2.92105E-05_JPRB, & + & 3.47607E-05_JPRB, 4.13654E-05_JPRB, 4.92251E-05_JPRB, 5.85781E-05_JPRB, 6.97083E-05_JPRB, & + & 8.29533E-05_JPRB, 9.87149E-05_JPRB, 1.17471E-04_JPRB, 1.39792E-04_JPRB, 1.66353E-04_JPRB, & + & 1.97961E-04_JPRB, 2.35574E-04_JPRB, 2.80335E-04_JPRB, 3.33600E-04_JPRB/) + KAO_MCO2(:, 2) = (/ & + & 9.96332E-06_JPRB, 1.21229E-05_JPRB, 1.47506E-05_JPRB, 1.79478E-05_JPRB, 2.18381E-05_JPRB, & + & 2.65716E-05_JPRB, 3.23310E-05_JPRB, 3.93389E-05_JPRB, 4.78658E-05_JPRB, 5.82408E-05_JPRB, & + & 7.08647E-05_JPRB, 8.62250E-05_JPRB, 1.04914E-04_JPRB, 1.27655E-04_JPRB, 1.55325E-04_JPRB, & + & 1.88992E-04_JPRB, 2.29957E-04_JPRB, 2.79801E-04_JPRB, 3.40448E-04_JPRB/) + KAO_MCO2(:, 3) = (/ & + & 1.14968E-05_JPRB, 1.39890E-05_JPRB, 1.70215E-05_JPRB, 2.07115E-05_JPRB, 2.52013E-05_JPRB, & + & 3.06644E-05_JPRB, 3.73118E-05_JPRB, 4.54002E-05_JPRB, 5.52420E-05_JPRB, 6.72173E-05_JPRB, & + & 8.17887E-05_JPRB, 9.95188E-05_JPRB, 1.21092E-04_JPRB, 1.47343E-04_JPRB, 1.79283E-04_JPRB, & + & 2.18148E-04_JPRB, 2.65438E-04_JPRB, 3.22980E-04_JPRB, 3.92995E-04_JPRB/) + KAO_MCO2(:, 4) = (/ & + & 1.02186E-05_JPRB, 1.23232E-05_JPRB, 1.48613E-05_JPRB, 1.79222E-05_JPRB, 2.16134E-05_JPRB, & + & 2.60649E-05_JPRB, 3.14332E-05_JPRB, 3.79071E-05_JPRB, 4.57145E-05_JPRB, 5.51297E-05_JPRB, & + & 6.64843E-05_JPRB, 8.01773E-05_JPRB, 9.66905E-05_JPRB, 1.16605E-04_JPRB, 1.40621E-04_JPRB, & + & 1.69583E-04_JPRB, 2.04510E-04_JPRB, 2.46631E-04_JPRB, 2.97426E-04_JPRB/) + KAO_MCO2(:, 5) = (/ & + & 1.03469E-05_JPRB, 1.24680E-05_JPRB, 1.50239E-05_JPRB, 1.81037E-05_JPRB, 2.18149E-05_JPRB, & + & 2.62869E-05_JPRB, 3.16756E-05_JPRB, 3.81690E-05_JPRB, 4.59935E-05_JPRB, 5.54220E-05_JPRB, & + & 6.67833E-05_JPRB, 8.04737E-05_JPRB, 9.69704E-05_JPRB, 1.16849E-04_JPRB, 1.40803E-04_JPRB, & + & 1.69667E-04_JPRB, 2.04448E-04_JPRB, 2.46359E-04_JPRB, 2.96861E-04_JPRB/) + KAO_MCO2(:, 6) = (/ & + & 1.71660E-05_JPRB, 2.07334E-05_JPRB, 2.50420E-05_JPRB, 3.02461E-05_JPRB, 3.65317E-05_JPRB, & + & 4.41235E-05_JPRB, 5.32930E-05_JPRB, 6.43680E-05_JPRB, 7.77446E-05_JPRB, 9.39010E-05_JPRB, & + & 1.13415E-04_JPRB, 1.36984E-04_JPRB, 1.65451E-04_JPRB, 1.99835E-04_JPRB, 2.41363E-04_JPRB, & + & 2.91522E-04_JPRB, 3.52104E-04_JPRB, 4.25276E-04_JPRB, 5.13654E-04_JPRB/) + KAO_MCO2(:, 7) = (/ & + & 4.78803E-05_JPRB, 5.79395E-05_JPRB, 7.01119E-05_JPRB, 8.48418E-05_JPRB, 1.02666E-04_JPRB, & + & 1.24235E-04_JPRB, 1.50336E-04_JPRB, 1.81920E-04_JPRB, 2.20139E-04_JPRB, 2.66388E-04_JPRB, & + & 3.22354E-04_JPRB, 3.90077E-04_JPRB, 4.72028E-04_JPRB, 5.71197E-04_JPRB, 6.91199E-04_JPRB, & + & 8.36413E-04_JPRB, 1.01214E-03_JPRB, 1.22477E-03_JPRB, 1.48209E-03_JPRB/) + KAO_MCO2(:, 8) = (/ & + & 1.27954E-04_JPRB, 1.55281E-04_JPRB, 1.88445E-04_JPRB, 2.28692E-04_JPRB, 2.77534E-04_JPRB, & + & 3.36808E-04_JPRB, 4.08741E-04_JPRB, 4.96037E-04_JPRB, 6.01977E-04_JPRB, 7.30542E-04_JPRB, & + & 8.86566E-04_JPRB, 1.07591E-03_JPRB, 1.30570E-03_JPRB, 1.58456E-03_JPRB, 1.92298E-03_JPRB, & + & 2.33367E-03_JPRB, 2.83208E-03_JPRB, 3.43694E-03_JPRB, 4.17097E-03_JPRB/) + KAO_MCO2(:, 9) = (/ & + & 2.93792E-05_JPRB, 3.55109E-05_JPRB, 4.29223E-05_JPRB, 5.18805E-05_JPRB, 6.27083E-05_JPRB, & + & 7.57960E-05_JPRB, 9.16151E-05_JPRB, 1.10736E-04_JPRB, 1.33847E-04_JPRB, 1.61782E-04_JPRB, & + & 1.95547E-04_JPRB, 2.36359E-04_JPRB, 2.85689E-04_JPRB, 3.45315E-04_JPRB, 4.17384E-04_JPRB, & + & 5.04495E-04_JPRB, 6.09787E-04_JPRB, 7.37054E-04_JPRB, 8.90882E-04_JPRB/) + KAO_MCO2(:,10) = (/ & + & 5.08569E-05_JPRB, 6.24700E-05_JPRB, 7.67350E-05_JPRB, 9.42574E-05_JPRB, 1.15781E-04_JPRB, & + & 1.42220E-04_JPRB, 1.74695E-04_JPRB, 2.14587E-04_JPRB, 2.63588E-04_JPRB, 3.23778E-04_JPRB, & + & 3.97712E-04_JPRB, 4.88530E-04_JPRB, 6.00085E-04_JPRB, 7.37114E-04_JPRB, 9.05433E-04_JPRB, & + & 1.11219E-03_JPRB, 1.36616E-03_JPRB, 1.67812E-03_JPRB, 2.06131E-03_JPRB/) + KAO_MCO2(:,11) = (/ & + & 4.82546E-06_JPRB, 6.21462E-06_JPRB, 8.00369E-06_JPRB, 1.03078E-05_JPRB, 1.32752E-05_JPRB, & + & 1.70969E-05_JPRB, 2.20188E-05_JPRB, 2.83575E-05_JPRB, 3.65211E-05_JPRB, 4.70348E-05_JPRB, & + & 6.05753E-05_JPRB, 7.80138E-05_JPRB, 1.00472E-04_JPRB, 1.29397E-04_JPRB, 1.66647E-04_JPRB, & + & 2.14622E-04_JPRB, 2.76407E-04_JPRB, 3.55980E-04_JPRB, 4.58459E-04_JPRB/) + KAO_MCO2(:,12) = (/ & + & 2.41346E-06_JPRB, 2.96282E-06_JPRB, 3.63723E-06_JPRB, 4.46516E-06_JPRB, 5.48153E-06_JPRB, & + & 6.72926E-06_JPRB, 8.26100E-06_JPRB, 1.01414E-05_JPRB, 1.24498E-05_JPRB, 1.52837E-05_JPRB, & + & 1.87627E-05_JPRB, 2.30335E-05_JPRB, 2.82765E-05_JPRB, 3.47129E-05_JPRB, 4.26144E-05_JPRB, & + & 5.23144E-05_JPRB, 6.42225E-05_JPRB, 7.88410E-05_JPRB, 9.67871E-05_JPRB/) + KAO_MCO2(:,13) = (/ & + & 2.76412E-06_JPRB, 3.46195E-06_JPRB, 4.33596E-06_JPRB, 5.43062E-06_JPRB, 6.80164E-06_JPRB, & + & 8.51879E-06_JPRB, 1.06695E-05_JPRB, 1.33631E-05_JPRB, 1.67367E-05_JPRB, 2.09621E-05_JPRB, & + & 2.62542E-05_JPRB, 3.28824E-05_JPRB, 4.11839E-05_JPRB, 5.15813E-05_JPRB, 6.46035E-05_JPRB, & + & 8.09134E-05_JPRB, 1.01341E-04_JPRB, 1.26925E-04_JPRB, 1.58969E-04_JPRB/) + KAO_MCO2(:,14) = (/ & + & 1.25126E-06_JPRB, 1.54971E-06_JPRB, 1.91935E-06_JPRB, 2.37715E-06_JPRB, 2.94416E-06_JPRB, & + & 3.64640E-06_JPRB, 4.51615E-06_JPRB, 5.59335E-06_JPRB, 6.92749E-06_JPRB, 8.57985E-06_JPRB, & + & 1.06263E-05_JPRB, 1.31610E-05_JPRB, 1.63001E-05_JPRB, 2.01881E-05_JPRB, 2.50034E-05_JPRB, & + & 3.09672E-05_JPRB, 3.83536E-05_JPRB, 4.75018E-05_JPRB, 5.88319E-05_JPRB/) + KAO_MCO2(:,15) = (/ & + & 1.59748E-06_JPRB, 2.08378E-06_JPRB, 2.71812E-06_JPRB, 3.54557E-06_JPRB, 4.62491E-06_JPRB, & + & 6.03282E-06_JPRB, 7.86932E-06_JPRB, 1.02649E-05_JPRB, 1.33897E-05_JPRB, 1.74658E-05_JPRB, & + & 2.27827E-05_JPRB, 2.97182E-05_JPRB, 3.87649E-05_JPRB, 5.05657E-05_JPRB, 6.59589E-05_JPRB, & + & 8.60380E-05_JPRB, 1.12230E-04_JPRB, 1.46394E-04_JPRB, 1.90959E-04_JPRB/) + KAO_MCO2(:,16) = (/ & + & 1.68148E-06_JPRB, 2.17133E-06_JPRB, 2.80388E-06_JPRB, 3.62071E-06_JPRB, 4.67549E-06_JPRB, & + & 6.03756E-06_JPRB, 7.79642E-06_JPRB, 1.00677E-05_JPRB, 1.30006E-05_JPRB, 1.67879E-05_JPRB, & + & 2.16786E-05_JPRB, 2.79941E-05_JPRB, 3.61493E-05_JPRB, 4.66803E-05_JPRB, 6.02792E-05_JPRB, & + & 7.78398E-05_JPRB, 1.00516E-04_JPRB, 1.29799E-04_JPRB, 1.67612E-04_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &3.2710E-07_JPRB,5.2119E-07_JPRB,8.4740E-07_JPRB,1.6908E-06_JPRB,2.3433E-06_JPRB,4.4129E-06_JPRB, & + &3.8930E-06_JPRB,2.3338E-06_JPRB,2.4115E-06_JPRB,2.4271E-06_JPRB,2.4836E-06_JPRB,2.6470E-06_JPRB, & + &2.9559E-06_JPRB,2.3940E-06_JPRB,2.9711E-06_JPRB,2.9511E-06_JPRB/) + FORREFO(2,:) = (/ & + &6.5125E-07_JPRB,1.2128E-06_JPRB,1.7249E-06_JPRB,2.7126E-06_JPRB,3.1780E-06_JPRB,2.1444E-06_JPRB, & + &1.8265E-06_JPRB,1.7385E-06_JPRB,1.4574E-06_JPRB,1.6135E-06_JPRB,2.4966E-06_JPRB,2.8127E-06_JPRB, & + &2.5229E-06_JPRB,2.3251E-06_JPRB,2.5353E-06_JPRB,3.0200E-06_JPRB/) + FORREFO(3,:) = (/ & + &1.4969E-06_JPRB,1.8516E-06_JPRB,2.5791E-06_JPRB,2.7846E-06_JPRB,1.9789E-06_JPRB,1.6688E-06_JPRB, & + &1.1037E-06_JPRB,9.9065E-07_JPRB,1.1557E-06_JPRB,7.0847E-07_JPRB,5.7758E-07_JPRB,4.0425E-07_JPRB, & + &3.2427E-07_JPRB,3.2267E-07_JPRB,3.1444E-07_JPRB,2.6046E-07_JPRB/) + FORREFO(4,:) = (/ & + &1.7567E-06_JPRB,1.6891E-06_JPRB,2.1003E-06_JPRB,2.0957E-06_JPRB,2.3664E-06_JPRB,2.1538E-06_JPRB, & + &1.5275E-06_JPRB,1.0487E-06_JPRB,8.7390E-07_JPRB,7.9360E-07_JPRB,7.7778E-07_JPRB,8.1445E-07_JPRB, & + &8.2121E-07_JPRB,5.4395E-07_JPRB,3.1273E-07_JPRB,3.1848E-07_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 7.73921E-02_JPRB, 6.45225E-02_JPRB, 5.37930E-02_JPRB, 4.48477E-02_JPRB, 3.73900E-02_JPRB, & + & 3.11723E-02_JPRB, 2.59887E-02_JPRB, 2.16670E-02_JPRB, 1.80640E-02_JPRB, 1.50601E-02_JPRB/) + SELFREFO(:, 2) = (/ & + & 8.47756E-02_JPRB, 7.10616E-02_JPRB, 5.95660E-02_JPRB, 4.99301E-02_JPRB, 4.18529E-02_JPRB, & + & 3.50824E-02_JPRB, 2.94072E-02_JPRB, 2.46500E-02_JPRB, 2.06624E-02_JPRB, 1.73199E-02_JPRB/) + SELFREFO(:, 3) = (/ & + & 8.84829E-02_JPRB, 7.46093E-02_JPRB, 6.29110E-02_JPRB, 5.30469E-02_JPRB, 4.47295E-02_JPRB, & + & 3.77161E-02_JPRB, 3.18025E-02_JPRB, 2.68160E-02_JPRB, 2.26114E-02_JPRB, 1.90661E-02_JPRB/) + SELFREFO(:, 4) = (/ & + & 9.27003E-02_JPRB, 7.88864E-02_JPRB, 6.71310E-02_JPRB, 5.71273E-02_JPRB, 4.86144E-02_JPRB, & + & 4.13700E-02_JPRB, 3.52052E-02_JPRB, 2.99590E-02_JPRB, 2.54946E-02_JPRB, 2.16955E-02_JPRB/) + SELFREFO(:, 5) = (/ & + & 9.14315E-02_JPRB, 7.85661E-02_JPRB, 6.75110E-02_JPRB, 5.80115E-02_JPRB, 4.98487E-02_JPRB, & + & 4.28344E-02_JPRB, 3.68072E-02_JPRB, 3.16280E-02_JPRB, 2.71776E-02_JPRB, 2.33534E-02_JPRB/) + SELFREFO(:, 6) = (/ & + & 7.72984E-02_JPRB, 6.91044E-02_JPRB, 6.17790E-02_JPRB, 5.52301E-02_JPRB, 4.93755E-02_JPRB, & + & 4.41414E-02_JPRB, 3.94622E-02_JPRB, 3.52790E-02_JPRB, 3.15392E-02_JPRB, 2.81959E-02_JPRB/) + SELFREFO(:, 7) = (/ & + & 7.46998E-02_JPRB, 6.66597E-02_JPRB, 5.94850E-02_JPRB, 5.30825E-02_JPRB, 4.73691E-02_JPRB, & + & 4.22707E-02_JPRB, 3.77210E-02_JPRB, 3.36610E-02_JPRB, 3.00380E-02_JPRB, 2.68049E-02_JPRB/) + SELFREFO(:, 8) = (/ & + & 7.59386E-02_JPRB, 6.66263E-02_JPRB, 5.84560E-02_JPRB, 5.12876E-02_JPRB, 4.49982E-02_JPRB, & + & 3.94801E-02_JPRB, 3.46387E-02_JPRB, 3.03910E-02_JPRB, 2.66642E-02_JPRB, 2.33944E-02_JPRB/) + SELFREFO(:, 9) = (/ & + & 7.26921E-02_JPRB, 6.43261E-02_JPRB, 5.69230E-02_JPRB, 5.03719E-02_JPRB, 4.45747E-02_JPRB, & + & 3.94447E-02_JPRB, 3.49051E-02_JPRB, 3.08880E-02_JPRB, 2.73332E-02_JPRB, 2.41875E-02_JPRB/) + SELFREFO(:,10) = (/ & + & 7.43684E-02_JPRB, 6.58735E-02_JPRB, 5.83490E-02_JPRB, 5.16840E-02_JPRB, 4.57803E-02_JPRB, & + & 4.05509E-02_JPRB, 3.59189E-02_JPRB, 3.18160E-02_JPRB, 2.81818E-02_JPRB, 2.49626E-02_JPRB/) + SELFREFO(:,11) = (/ & + & 8.97599E-02_JPRB, 7.73727E-02_JPRB, 6.66950E-02_JPRB, 5.74908E-02_JPRB, 4.95569E-02_JPRB, & + & 4.27179E-02_JPRB, 3.68227E-02_JPRB, 3.17410E-02_JPRB, 2.73606E-02_JPRB, 2.35848E-02_JPRB/) + SELFREFO(:,12) = (/ & + & 9.12262E-02_JPRB, 7.84848E-02_JPRB, 6.75230E-02_JPRB, 5.80922E-02_JPRB, 4.99786E-02_JPRB, & + & 4.29982E-02_JPRB, 3.69927E-02_JPRB, 3.18260E-02_JPRB, 2.73809E-02_JPRB, 2.35567E-02_JPRB/) + SELFREFO(:,13) = (/ & + & 9.03254E-02_JPRB, 7.83291E-02_JPRB, 6.79260E-02_JPRB, 5.89046E-02_JPRB, 5.10813E-02_JPRB, & + & 4.42970E-02_JPRB, 3.84139E-02_JPRB, 3.33120E-02_JPRB, 2.88877E-02_JPRB, 2.50511E-02_JPRB/) + SELFREFO(:,14) = (/ & + & 9.22803E-02_JPRB, 7.94172E-02_JPRB, 6.83470E-02_JPRB, 5.88199E-02_JPRB, 5.06209E-02_JPRB, & + & 4.35647E-02_JPRB, 3.74921E-02_JPRB, 3.22660E-02_JPRB, 2.77684E-02_JPRB, 2.38977E-02_JPRB/) + SELFREFO(:,15) = (/ & + & 9.36819E-02_JPRB, 8.10810E-02_JPRB, 7.01750E-02_JPRB, 6.07359E-02_JPRB, 5.25665E-02_JPRB, & + & 4.54959E-02_JPRB, 3.93764E-02_JPRB, 3.40800E-02_JPRB, 2.94960E-02_JPRB, 2.55286E-02_JPRB/) + SELFREFO(:,16) = (/ & + & 1.00195E-01_JPRB, 8.58713E-02_JPRB, 7.35950E-02_JPRB, 6.30737E-02_JPRB, 5.40566E-02_JPRB, & + & 4.63286E-02_JPRB, 3.97054E-02_JPRB, 3.40290E-02_JPRB, 2.91641E-02_JPRB, 2.49948E-02_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB6',1,ZHOOK_HANDLE) + +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB6:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB6 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb7.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb7.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb7.F90 (revision 6016) @@ -0,0 +1,1030 @@ +SUBROUTINE RRTM_KGB7 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 7: 980-1080 cm-1 (low - H2O,O3; high - O3) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201306 updated rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD + +USE YOERRTO7 , ONLY : KAO ,KBO, KAO_MCO2 ,KBO_MCO2 ,SELFREFO ,FORREFO, & + & FRACREFAO , FRACREFBO , KAO_D, KBO_D + +USE YOMMP0 , ONLY : NPROC, MYPROC + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB7',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB7:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB7:') +ENDIF + + +! Planck fraction mapping level : P = 706.27 mb, T = 278.94 K + FRACREFAO(:, 1) = (/ & + & 1.6312E-01_JPRB,1.4949E-01_JPRB,1.4305E-01_JPRB,1.3161E-01_JPRB,1.1684E-01_JPRB,9.9900E-02_JPRB, & + & 8.0912E-02_JPRB,6.0203E-02_JPRB,4.0149E-02_JPRB,4.3365E-03_JPRB,3.5844E-03_JPRB,2.8019E-03_JPRB, & + & 2.0756E-03_JPRB,1.3449E-03_JPRB,5.0492E-04_JPRB,7.1194E-05_JPRB/) + FRACREFAO(:, 2) = (/ & + & 1.6329E-01_JPRB,1.4989E-01_JPRB,1.4328E-01_JPRB,1.3101E-01_JPRB,1.1691E-01_JPRB,9.9754E-02_JPRB, & + & 8.0956E-02_JPRB,5.9912E-02_JPRB,4.0271E-02_JPRB,4.3298E-03_JPRB,3.5626E-03_JPRB,2.8421E-03_JPRB, & + & 2.1031E-03_JPRB,1.3360E-03_JPRB,4.8965E-04_JPRB,6.8900E-05_JPRB/) + FRACREFAO(:, 3) = (/ & + & 1.6236E-01_JPRB,1.5081E-01_JPRB,1.4341E-01_JPRB,1.3083E-01_JPRB,1.1684E-01_JPRB,9.9701E-02_JPRB, & + & 8.0956E-02_JPRB,5.9884E-02_JPRB,4.0245E-02_JPRB,4.3837E-03_JPRB,3.6683E-03_JPRB,2.9250E-03_JPRB, & + & 2.0969E-03_JPRB,1.3320E-03_JPRB,4.8965E-04_JPRB,6.8900E-05_JPRB/) + FRACREFAO(:, 4) = (/ & + & 1.6096E-01_JPRB,1.5183E-01_JPRB,1.4354E-01_JPRB,1.3081E-01_JPRB,1.1687E-01_JPRB,9.9619E-02_JPRB, & + & 8.0947E-02_JPRB,5.9899E-02_JPRB,4.0416E-02_JPRB,4.4389E-03_JPRB,3.7280E-03_JPRB,2.9548E-03_JPRB, & + & 2.0977E-03_JPRB,1.3305E-03_JPRB,4.8965E-04_JPRB,6.8900E-05_JPRB/) + FRACREFAO(:, 5) = (/ & + & 1.5661E-01_JPRB,1.5478E-01_JPRB,1.4414E-01_JPRB,1.3097E-01_JPRB,1.1695E-01_JPRB,9.9823E-02_JPRB, & + & 8.0750E-02_JPRB,6.0100E-02_JPRB,4.0741E-02_JPRB,4.4598E-03_JPRB,3.7366E-03_JPRB,2.9521E-03_JPRB, & + & 2.0980E-03_JPRB,1.3297E-03_JPRB,4.8965E-04_JPRB,6.8900E-05_JPRB/) + FRACREFAO(:, 6) = (/ & + & 1.4879E-01_JPRB,1.5853E-01_JPRB,1.4586E-01_JPRB,1.3162E-01_JPRB,1.1729E-01_JPRB,1.0031E-01_JPRB, & + & 8.0908E-02_JPRB,6.0460E-02_JPRB,4.1100E-02_JPRB,4.4578E-03_JPRB,3.7388E-03_JPRB,2.9508E-03_JPRB, & + & 2.0986E-03_JPRB,1.3288E-03_JPRB,4.8965E-04_JPRB,6.8900E-05_JPRB/) + FRACREFAO(:, 7) = (/ & + & 1.4117E-01_JPRB,1.4838E-01_JPRB,1.4807E-01_JPRB,1.3759E-01_JPRB,1.2218E-01_JPRB,1.0228E-01_JPRB, & + & 8.2130E-02_JPRB,6.1546E-02_JPRB,4.1522E-02_JPRB,4.4577E-03_JPRB,3.7428E-03_JPRB,2.9475E-03_JPRB, & + & 2.0997E-03_JPRB,1.3277E-03_JPRB,4.8965E-04_JPRB,6.8900E-05_JPRB/) + FRACREFAO(:, 8) = (/ & + & 1.4018E-01_JPRB,1.4207E-01_JPRB,1.3919E-01_JPRB,1.3332E-01_JPRB,1.2325E-01_JPRB,1.0915E-01_JPRB, & + & 9.0280E-02_JPRB,6.5554E-02_JPRB,4.1852E-02_JPRB,4.4707E-03_JPRB,3.7572E-03_JPRB,2.9364E-03_JPRB, & + & 2.1023E-03_JPRB,1.3249E-03_JPRB,4.8965E-04_JPRB,6.8900E-05_JPRB/) + FRACREFAO(:, 9) = (/ & + & 1.4863E-01_JPRB,1.4926E-01_JPRB,1.4740E-01_JPRB,1.3558E-01_JPRB,1.1999E-01_JPRB,1.0044E-01_JPRB, & + & 8.1927E-02_JPRB,6.0989E-02_JPRB,4.0665E-02_JPRB,4.4481E-03_JPRB,3.7369E-03_JPRB,2.9482E-03_JPRB, & + & 2.0976E-03_JPRB,1.3281E-03_JPRB,4.8965E-04_JPRB,6.8900E-05_JPRB/) + +! Planck fraction mapping level : P=95.58 mbar, T= 215.70 K +FRACREFBO(:) = (/ & + & 1.5872E-01_JPRB,1.5443E-01_JPRB,1.4413E-01_JPRB,1.3147E-01_JPRB,1.1634E-01_JPRB,9.8914E-02_JPRB, & + & 8.0236E-02_JPRB,6.0197E-02_JPRB,4.0624E-02_JPRB,4.4225E-03_JPRB,3.6688E-03_JPRB,2.9074E-03_JPRB, & + & 2.0862E-03_JPRB,1.3039E-03_JPRB,4.8561E-04_JPRB,6.8854E-05_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + + KAO_MCO2( 1, :, 1) = (/ & + & 7.38630E-06_JPRB, 8.97432E-06_JPRB, 1.09037E-05_JPRB, 1.32480E-05_JPRB, 1.60963E-05_JPRB, & + & 1.95569E-05_JPRB, 2.37615E-05_JPRB, 2.88701E-05_JPRB, 3.50770E-05_JPRB, 4.26184E-05_JPRB, & + & 5.17811E-05_JPRB, 6.29138E-05_JPRB, 7.64400E-05_JPRB, 9.28742E-05_JPRB, 1.12842E-04_JPRB, & + & 1.37102E-04_JPRB, 1.66578E-04_JPRB, 2.02392E-04_JPRB, 2.45905E-04_JPRB/) + KAO_MCO2( 2, :, 1) = (/ & + & 7.03916E-06_JPRB, 8.58785E-06_JPRB, 1.04773E-05_JPRB, 1.27824E-05_JPRB, 1.55947E-05_JPRB, & + & 1.90257E-05_JPRB, 2.32115E-05_JPRB, 2.83183E-05_JPRB, 3.45487E-05_JPRB, 4.21498E-05_JPRB, & + & 5.14233E-05_JPRB, 6.27370E-05_JPRB, 7.65398E-05_JPRB, 9.33794E-05_JPRB, 1.13924E-04_JPRB, & + & 1.38989E-04_JPRB, 1.69568E-04_JPRB, 2.06874E-04_JPRB, 2.52389E-04_JPRB/) + KAO_MCO2( 3, :, 1) = (/ & + & 7.80015E-06_JPRB, 9.48520E-06_JPRB, 1.15343E-05_JPRB, 1.40260E-05_JPRB, 1.70560E-05_JPRB, & + & 2.07405E-05_JPRB, 2.52211E-05_JPRB, 3.06695E-05_JPRB, 3.72950E-05_JPRB, 4.53517E-05_JPRB, & + & 5.51489E-05_JPRB, 6.70626E-05_JPRB, 8.15499E-05_JPRB, 9.91670E-05_JPRB, 1.20590E-04_JPRB, & + & 1.46640E-04_JPRB, 1.78319E-04_JPRB, 2.16841E-04_JPRB, 2.63684E-04_JPRB/) + KAO_MCO2( 4, :, 1) = (/ & + & 9.24267E-06_JPRB, 1.11747E-05_JPRB, 1.35105E-05_JPRB, 1.63346E-05_JPRB, 1.97490E-05_JPRB, & + & 2.38771E-05_JPRB, 2.88682E-05_JPRB, 3.49025E-05_JPRB, 4.21981E-05_JPRB, 5.10188E-05_JPRB, & + & 6.16832E-05_JPRB, 7.45768E-05_JPRB, 9.01656E-05_JPRB, 1.09013E-04_JPRB, 1.31800E-04_JPRB, & + & 1.59350E-04_JPRB, 1.92659E-04_JPRB, 2.32930E-04_JPRB, 2.81619E-04_JPRB/) + KAO_MCO2( 5, :, 1) = (/ & + & 1.59506E-05_JPRB, 1.90078E-05_JPRB, 2.26509E-05_JPRB, 2.69923E-05_JPRB, 3.21658E-05_JPRB, & + & 3.83309E-05_JPRB, 4.56777E-05_JPRB, 5.44325E-05_JPRB, 6.48654E-05_JPRB, 7.72978E-05_JPRB, & + & 9.21132E-05_JPRB, 1.09768E-04_JPRB, 1.30807E-04_JPRB, 1.55878E-04_JPRB, 1.85755E-04_JPRB, & + & 2.21357E-04_JPRB, 2.63784E-04_JPRB, 3.14342E-04_JPRB, 3.74591E-04_JPRB/) + KAO_MCO2( 6, :, 1) = (/ & + & 3.53189E-05_JPRB, 4.14789E-05_JPRB, 4.87131E-05_JPRB, 5.72092E-05_JPRB, 6.71870E-05_JPRB, & + & 7.89050E-05_JPRB, 9.26667E-05_JPRB, 1.08829E-04_JPRB, 1.27809E-04_JPRB, 1.50100E-04_JPRB, & + & 1.76279E-04_JPRB, 2.07024E-04_JPRB, 2.43131E-04_JPRB, 2.85535E-04_JPRB, 3.35335E-04_JPRB, & + & 3.93821E-04_JPRB, 4.62507E-04_JPRB, 5.43172E-04_JPRB, 6.37906E-04_JPRB/) + KAO_MCO2( 7, :, 1) = (/ & + & 6.63273E-05_JPRB, 7.76356E-05_JPRB, 9.08718E-05_JPRB, 1.06365E-04_JPRB, 1.24499E-04_JPRB, & + & 1.45725E-04_JPRB, 1.70570E-04_JPRB, 1.99651E-04_JPRB, 2.33689E-04_JPRB, 2.73531E-04_JPRB, & + & 3.20166E-04_JPRB, 3.74752E-04_JPRB, 4.38644E-04_JPRB, 5.13429E-04_JPRB, 6.00964E-04_JPRB, & + & 7.03424E-04_JPRB, 8.23352E-04_JPRB, 9.63726E-04_JPRB, 1.12803E-03_JPRB/) + KAO_MCO2( 8, :, 1) = (/ & + & 9.01134E-05_JPRB, 1.05517E-04_JPRB, 1.23553E-04_JPRB, 1.44673E-04_JPRB, 1.69402E-04_JPRB, & + & 1.98359E-04_JPRB, 2.32265E-04_JPRB, 2.71967E-04_JPRB, 3.18456E-04_JPRB, 3.72890E-04_JPRB, & + & 4.36630E-04_JPRB, 5.11265E-04_JPRB, 5.98657E-04_JPRB, 7.00989E-04_JPRB, 8.20811E-04_JPRB, & + & 9.61116E-04_JPRB, 1.12540E-03_JPRB, 1.31777E-03_JPRB, 1.54302E-03_JPRB/) + KAO_MCO2( 9, :, 1) = (/ & + & 1.14205E-05_JPRB, 1.36364E-05_JPRB, 1.62823E-05_JPRB, 1.94416E-05_JPRB, 2.32139E-05_JPRB, & + & 2.77181E-05_JPRB, 3.30963E-05_JPRB, 3.95181E-05_JPRB, 4.71858E-05_JPRB, 5.63414E-05_JPRB, & + & 6.72734E-05_JPRB, 8.03266E-05_JPRB, 9.59124E-05_JPRB, 1.14523E-04_JPRB, 1.36743E-04_JPRB, & + & 1.63276E-04_JPRB, 1.94957E-04_JPRB, 2.32784E-04_JPRB, 2.77952E-04_JPRB/) + KAO_MCO2( 1, :, 2) = (/ & + & 2.01754E-05_JPRB, 2.40506E-05_JPRB, 2.86701E-05_JPRB, 3.41769E-05_JPRB, 4.07414E-05_JPRB, & + & 4.85668E-05_JPRB, 5.78953E-05_JPRB, 6.90155E-05_JPRB, 8.22717E-05_JPRB, 9.80739E-05_JPRB, & + & 1.16912E-04_JPRB, 1.39367E-04_JPRB, 1.66136E-04_JPRB, 1.98047E-04_JPRB, 2.36087E-04_JPRB, & + & 2.81433E-04_JPRB, 3.35489E-04_JPRB, 3.99928E-04_JPRB, 4.76744E-04_JPRB/) + KAO_MCO2( 2, :, 2) = (/ & + & 2.08613E-05_JPRB, 2.48759E-05_JPRB, 2.96631E-05_JPRB, 3.53716E-05_JPRB, 4.21786E-05_JPRB, & + & 5.02955E-05_JPRB, 5.99746E-05_JPRB, 7.15163E-05_JPRB, 8.52791E-05_JPRB, 1.01690E-04_JPRB, & + & 1.21260E-04_JPRB, 1.44596E-04_JPRB, 1.72422E-04_JPRB, 2.05604E-04_JPRB, 2.45171E-04_JPRB, & + & 2.92352E-04_JPRB, 3.48613E-04_JPRB, 4.15702E-04_JPRB, 4.95700E-04_JPRB/) + KAO_MCO2( 3, :, 2) = (/ & + & 2.06879E-05_JPRB, 2.47009E-05_JPRB, 2.94924E-05_JPRB, 3.52133E-05_JPRB, 4.20439E-05_JPRB, & + & 5.01995E-05_JPRB, 5.99372E-05_JPRB, 7.15637E-05_JPRB, 8.54456E-05_JPRB, 1.02020E-04_JPRB, & + & 1.21810E-04_JPRB, 1.45439E-04_JPRB, 1.73651E-04_JPRB, 2.07335E-04_JPRB, 2.47554E-04_JPRB, & + & 2.95574E-04_JPRB, 3.52909E-04_JPRB, 4.21366E-04_JPRB, 5.03102E-04_JPRB/) + KAO_MCO2( 4, :, 2) = (/ & + & 2.12700E-05_JPRB, 2.54064E-05_JPRB, 3.03472E-05_JPRB, 3.62490E-05_JPRB, 4.32984E-05_JPRB, & + & 5.17188E-05_JPRB, 6.17767E-05_JPRB, 7.37906E-05_JPRB, 8.81410E-05_JPRB, 1.05282E-04_JPRB, & + & 1.25757E-04_JPRB, 1.50213E-04_JPRB, 1.79425E-04_JPRB, 2.14319E-04_JPRB, 2.55998E-04_JPRB, & + & 3.05782E-04_JPRB, 3.65249E-04_JPRB, 4.36280E-04_JPRB, 5.21125E-04_JPRB/) + KAO_MCO2( 5, :, 2) = (/ & + & 1.88144E-05_JPRB, 2.25220E-05_JPRB, 2.69602E-05_JPRB, 3.22730E-05_JPRB, 3.86328E-05_JPRB, & + & 4.62458E-05_JPRB, 5.53591E-05_JPRB, 6.62682E-05_JPRB, 7.93271E-05_JPRB, 9.49594E-05_JPRB, & + & 1.13672E-04_JPRB, 1.36073E-04_JPRB, 1.62887E-04_JPRB, 1.94986E-04_JPRB, 2.33410E-04_JPRB, & + & 2.79406E-04_JPRB, 3.34467E-04_JPRB, 4.00377E-04_JPRB, 4.79275E-04_JPRB/) + KAO_MCO2( 6, :, 2) = (/ & + & 1.20964E-05_JPRB, 1.46021E-05_JPRB, 1.76268E-05_JPRB, 2.12780E-05_JPRB, 2.56856E-05_JPRB, & + & 3.10062E-05_JPRB, 3.74289E-05_JPRB, 4.51820E-05_JPRB, 5.45411E-05_JPRB, 6.58388E-05_JPRB, & + & 7.94769E-05_JPRB, 9.59399E-05_JPRB, 1.15813E-04_JPRB, 1.39803E-04_JPRB, 1.68762E-04_JPRB, & + & 2.03720E-04_JPRB, 2.45919E-04_JPRB, 2.96859E-04_JPRB, 3.58350E-04_JPRB/) + KAO_MCO2( 7, :, 2) = (/ & + & 3.07117E-05_JPRB, 3.64441E-05_JPRB, 4.32465E-05_JPRB, 5.13186E-05_JPRB, 6.08974E-05_JPRB, & + & 7.22642E-05_JPRB, 8.57525E-05_JPRB, 1.01758E-04_JPRB, 1.20752E-04_JPRB, 1.43291E-04_JPRB, & + & 1.70037E-04_JPRB, 2.01775E-04_JPRB, 2.39436E-04_JPRB, 2.84128E-04_JPRB, 3.37161E-04_JPRB, & + & 4.00094E-04_JPRB, 4.74773E-04_JPRB, 5.63391E-04_JPRB, 6.68549E-04_JPRB/) + KAO_MCO2( 8, :, 2) = (/ & + & 9.34077E-05_JPRB, 1.10481E-04_JPRB, 1.30675E-04_JPRB, 1.54559E-04_JPRB, 1.82810E-04_JPRB, & + & 2.16224E-04_JPRB, 2.55745E-04_JPRB, 3.02491E-04_JPRB, 3.57780E-04_JPRB, 4.23175E-04_JPRB, & + & 5.00523E-04_JPRB, 5.92009E-04_JPRB, 7.00217E-04_JPRB, 8.28203E-04_JPRB, 9.79582E-04_JPRB, & + & 1.15863E-03_JPRB, 1.37041E-03_JPRB, 1.62089E-03_JPRB, 1.91716E-03_JPRB/) + KAO_MCO2( 9, :, 2) = (/ & + & 1.15325E-05_JPRB, 1.37935E-05_JPRB, 1.64978E-05_JPRB, 1.97322E-05_JPRB, 2.36007E-05_JPRB, & + & 2.82277E-05_JPRB, 3.37618E-05_JPRB, 4.03808E-05_JPRB, 4.82976E-05_JPRB, 5.77664E-05_JPRB, & + & 6.90916E-05_JPRB, 8.26372E-05_JPRB, 9.88384E-05_JPRB, 1.18216E-04_JPRB, 1.41392E-04_JPRB, & + & 1.69113E-04_JPRB, 2.02267E-04_JPRB, 2.41922E-04_JPRB, 2.89352E-04_JPRB/) + KAO_MCO2( 1, :, 3) = (/ & + & 2.56142E-05_JPRB, 3.05385E-05_JPRB, 3.64096E-05_JPRB, 4.34093E-05_JPRB, 5.17547E-05_JPRB, & + & 6.17045E-05_JPRB, 7.35672E-05_JPRB, 8.77104E-05_JPRB, 1.04573E-04_JPRB, 1.24677E-04_JPRB, & + & 1.48646E-04_JPRB, 1.77223E-04_JPRB, 2.11294E-04_JPRB, 2.51915E-04_JPRB, 3.00346E-04_JPRB, & + & 3.58087E-04_JPRB, 4.26929E-04_JPRB, 5.09006E-04_JPRB, 6.06862E-04_JPRB/) + KAO_MCO2( 2, :, 3) = (/ & + & 2.49802E-05_JPRB, 2.98040E-05_JPRB, 3.55593E-05_JPRB, 4.24259E-05_JPRB, 5.06186E-05_JPRB, & + & 6.03932E-05_JPRB, 7.20554E-05_JPRB, 8.59696E-05_JPRB, 1.02571E-04_JPRB, 1.22377E-04_JPRB, & + & 1.46009E-04_JPRB, 1.74204E-04_JPRB, 2.07844E-04_JPRB, 2.47979E-04_JPRB, 2.95865E-04_JPRB, & + & 3.52998E-04_JPRB, 4.21163E-04_JPRB, 5.02491E-04_JPRB, 5.99524E-04_JPRB/) + KAO_MCO2( 3, :, 3) = (/ & + & 2.54644E-05_JPRB, 3.03959E-05_JPRB, 3.62825E-05_JPRB, 4.33091E-05_JPRB, 5.16965E-05_JPRB, & + & 6.17083E-05_JPRB, 7.36589E-05_JPRB, 8.79240E-05_JPRB, 1.04952E-04_JPRB, 1.25277E-04_JPRB, & + & 1.49539E-04_JPRB, 1.78499E-04_JPRB, 2.13068E-04_JPRB, 2.54331E-04_JPRB, 3.03586E-04_JPRB, & + & 3.62380E-04_JPRB, 4.32560E-04_JPRB, 5.16331E-04_JPRB, 6.16326E-04_JPRB/) + KAO_MCO2( 4, :, 3) = (/ & + & 2.55054E-05_JPRB, 3.04699E-05_JPRB, 3.64007E-05_JPRB, 4.34859E-05_JPRB, 5.19501E-05_JPRB, & + & 6.20619E-05_JPRB, 7.41418E-05_JPRB, 8.85731E-05_JPRB, 1.05813E-04_JPRB, 1.26409E-04_JPRB, & + & 1.51014E-04_JPRB, 1.80408E-04_JPRB, 2.15523E-04_JPRB, 2.57474E-04_JPRB, 3.07589E-04_JPRB, & + & 3.67459E-04_JPRB, 4.38983E-04_JPRB, 5.24428E-04_JPRB, 6.26505E-04_JPRB/) + KAO_MCO2( 5, :, 3) = (/ & + & 2.48615E-05_JPRB, 2.97398E-05_JPRB, 3.55754E-05_JPRB, 4.25560E-05_JPRB, 5.09064E-05_JPRB, & + & 6.08952E-05_JPRB, 7.28441E-05_JPRB, 8.71375E-05_JPRB, 1.04236E-04_JPRB, 1.24689E-04_JPRB, & + & 1.49155E-04_JPRB, 1.78423E-04_JPRB, 2.13433E-04_JPRB, 2.55313E-04_JPRB, 3.05410E-04_JPRB, & + & 3.65338E-04_JPRB, 4.37024E-04_JPRB, 5.22777E-04_JPRB, 6.25356E-04_JPRB/) + KAO_MCO2( 6, :, 3) = (/ & + & 2.09074E-05_JPRB, 2.50891E-05_JPRB, 3.01072E-05_JPRB, 3.61290E-05_JPRB, 4.33553E-05_JPRB, & + & 5.20269E-05_JPRB, 6.24329E-05_JPRB, 7.49202E-05_JPRB, 8.99051E-05_JPRB, 1.07887E-04_JPRB, & + & 1.29466E-04_JPRB, 1.55361E-04_JPRB, 1.86435E-04_JPRB, 2.23724E-04_JPRB, 2.68471E-04_JPRB, & + & 3.22169E-04_JPRB, 3.86607E-04_JPRB, 4.63933E-04_JPRB, 5.56725E-04_JPRB/) + KAO_MCO2( 7, :, 3) = (/ & + & 1.25163E-05_JPRB, 1.51688E-05_JPRB, 1.83835E-05_JPRB, 2.22795E-05_JPRB, 2.70011E-05_JPRB, & + & 3.27234E-05_JPRB, 3.96583E-05_JPRB, 4.80630E-05_JPRB, 5.82488E-05_JPRB, 7.05933E-05_JPRB, & + & 8.55539E-05_JPRB, 1.03685E-04_JPRB, 1.25659E-04_JPRB, 1.52289E-04_JPRB, 1.84563E-04_JPRB, & + & 2.23677E-04_JPRB, 2.71081E-04_JPRB, 3.28530E-04_JPRB, 3.98154E-04_JPRB/) + KAO_MCO2( 8, :, 3) = (/ & + & 1.00408E-04_JPRB, 1.20081E-04_JPRB, 1.43608E-04_JPRB, 1.71745E-04_JPRB, 2.05395E-04_JPRB, & + & 2.45637E-04_JPRB, 2.93765E-04_JPRB, 3.51322E-04_JPRB, 4.20156E-04_JPRB, 5.02476E-04_JPRB, & + & 6.00926E-04_JPRB, 7.18665E-04_JPRB, 8.59472E-04_JPRB, 1.02787E-03_JPRB, 1.22926E-03_JPRB, & + & 1.47010E-03_JPRB, 1.75814E-03_JPRB, 2.10261E-03_JPRB, 2.51457E-03_JPRB/) + KAO_MCO2( 9, :, 3) = (/ & + & 8.50402E-06_JPRB, 1.02737E-05_JPRB, 1.24116E-05_JPRB, 1.49945E-05_JPRB, 1.81148E-05_JPRB, & + & 2.18844E-05_JPRB, 2.64385E-05_JPRB, 3.19403E-05_JPRB, 3.85871E-05_JPRB, 4.66169E-05_JPRB, & + & 5.63178E-05_JPRB, 6.80375E-05_JPRB, 8.21959E-05_JPRB, 9.93008E-05_JPRB, 1.19965E-04_JPRB, & + & 1.44930E-04_JPRB, 1.75089E-04_JPRB, 2.11525E-04_JPRB, 2.55543E-04_JPRB/) + KAO_MCO2( 1, :, 4) = (/ & + & 2.68659E-05_JPRB, 3.20986E-05_JPRB, 3.83506E-05_JPRB, 4.58203E-05_JPRB, 5.47450E-05_JPRB, & + & 6.54078E-05_JPRB, 7.81476E-05_JPRB, 9.33687E-05_JPRB, 1.11555E-04_JPRB, 1.33282E-04_JPRB, & + & 1.59242E-04_JPRB, 1.90259E-04_JPRB, 2.27316E-04_JPRB, 2.71592E-04_JPRB, 3.24490E-04_JPRB, & + & 3.87693E-04_JPRB, 4.63206E-04_JPRB, 5.53426E-04_JPRB, 6.61218E-04_JPRB/) + KAO_MCO2( 2, :, 4) = (/ & + & 2.74827E-05_JPRB, 3.28460E-05_JPRB, 3.92560E-05_JPRB, 4.69169E-05_JPRB, 5.60728E-05_JPRB, & + & 6.70155E-05_JPRB, 8.00937E-05_JPRB, 9.57241E-05_JPRB, 1.14405E-04_JPRB, 1.36731E-04_JPRB, & + & 1.63415E-04_JPRB, 1.95305E-04_JPRB, 2.33419E-04_JPRB, 2.78972E-04_JPRB, 3.33413E-04_JPRB, & + & 3.98480E-04_JPRB, 4.76244E-04_JPRB, 5.69184E-04_JPRB, 6.80261E-04_JPRB/) + KAO_MCO2( 3, :, 4) = (/ & + & 2.84702E-05_JPRB, 3.40189E-05_JPRB, 4.06490E-05_JPRB, 4.85713E-05_JPRB, 5.80375E-05_JPRB, & + & 6.93487E-05_JPRB, 8.28644E-05_JPRB, 9.90142E-05_JPRB, 1.18312E-04_JPRB, 1.41370E-04_JPRB, & + & 1.68922E-04_JPRB, 2.01844E-04_JPRB, 2.41182E-04_JPRB, 2.88188E-04_JPRB, 3.44354E-04_JPRB, & + & 4.11466E-04_JPRB, 4.91659E-04_JPRB, 5.87481E-04_JPRB, 7.01977E-04_JPRB/) + KAO_MCO2( 4, :, 4) = (/ & + & 2.92293E-05_JPRB, 3.49243E-05_JPRB, 4.17289E-05_JPRB, 4.98593E-05_JPRB, 5.95738E-05_JPRB, & + & 7.11810E-05_JPRB, 8.50498E-05_JPRB, 1.01621E-04_JPRB, 1.21420E-04_JPRB, 1.45078E-04_JPRB, & + & 1.73344E-04_JPRB, 2.07119E-04_JPRB, 2.47473E-04_JPRB, 2.95690E-04_JPRB, 3.53302E-04_JPRB, & + & 4.22139E-04_JPRB, 5.04388E-04_JPRB, 6.02662E-04_JPRB, 7.20083E-04_JPRB/) + KAO_MCO2( 5, :, 4) = (/ & + & 2.88531E-05_JPRB, 3.45646E-05_JPRB, 4.14067E-05_JPRB, 4.96033E-05_JPRB, 5.94224E-05_JPRB, & + & 7.11851E-05_JPRB, 8.52764E-05_JPRB, 1.02157E-04_JPRB, 1.22379E-04_JPRB, 1.46604E-04_JPRB, & + & 1.75625E-04_JPRB, 2.10391E-04_JPRB, 2.52038E-04_JPRB, 3.01929E-04_JPRB, 3.61697E-04_JPRB, & + & 4.33295E-04_JPRB, 5.19067E-04_JPRB, 6.21818E-04_JPRB, 7.44908E-04_JPRB/) + KAO_MCO2( 6, :, 4) = (/ & + & 2.79869E-05_JPRB, 3.36885E-05_JPRB, 4.05516E-05_JPRB, 4.88130E-05_JPRB, 5.87574E-05_JPRB, & + & 7.07278E-05_JPRB, 8.51368E-05_JPRB, 1.02481E-04_JPRB, 1.23359E-04_JPRB, 1.48490E-04_JPRB, & + & 1.78742E-04_JPRB, 2.15156E-04_JPRB, 2.58988E-04_JPRB, 3.11751E-04_JPRB, 3.75262E-04_JPRB, & + & 4.51712E-04_JPRB, 5.43737E-04_JPRB, 6.54510E-04_JPRB, 7.87849E-04_JPRB/) + KAO_MCO2( 7, :, 4) = (/ & + & 1.45797E-05_JPRB, 1.78204E-05_JPRB, 2.17815E-05_JPRB, 2.66230E-05_JPRB, 3.25407E-05_JPRB, & + & 3.97737E-05_JPRB, 4.86145E-05_JPRB, 5.94203E-05_JPRB, 7.26281E-05_JPRB, 8.87715E-05_JPRB, & + & 1.08503E-04_JPRB, 1.32621E-04_JPRB, 1.62100E-04_JPRB, 1.98130E-04_JPRB, 2.42170E-04_JPRB, & + & 2.95999E-04_JPRB, 3.61792E-04_JPRB, 4.42210E-04_JPRB, 5.40503E-04_JPRB/) + KAO_MCO2( 8, :, 4) = (/ & + & 6.32607E-05_JPRB, 7.63420E-05_JPRB, 9.21282E-05_JPRB, 1.11179E-04_JPRB, 1.34169E-04_JPRB, & + & 1.61913E-04_JPRB, 1.95393E-04_JPRB, 2.35797E-04_JPRB, 2.84557E-04_JPRB, 3.43398E-04_JPRB, & + & 4.14407E-04_JPRB, 5.00100E-04_JPRB, 6.03512E-04_JPRB, 7.28308E-04_JPRB, 8.78909E-04_JPRB, & + & 1.06065E-03_JPRB, 1.27998E-03_JPRB, 1.54466E-03_JPRB, 1.86407E-03_JPRB/) + KAO_MCO2( 9, :, 4) = (/ & + & 1.52296E-05_JPRB, 1.84301E-05_JPRB, 2.23032E-05_JPRB, 2.69902E-05_JPRB, 3.26622E-05_JPRB, & + & 3.95261E-05_JPRB, 4.78324E-05_JPRB, 5.78844E-05_JPRB, 7.00487E-05_JPRB, 8.47694E-05_JPRB, & + & 1.02584E-04_JPRB, 1.24142E-04_JPRB, 1.50230E-04_JPRB, 1.81800E-04_JPRB, 2.20005E-04_JPRB, & + & 2.66239E-04_JPRB, 3.22190E-04_JPRB, 3.89897E-04_JPRB, 4.71833E-04_JPRB/) + KAO_MCO2( 1, :, 5) = (/ & + & 3.43213E-05_JPRB, 4.11301E-05_JPRB, 4.92896E-05_JPRB, 5.90679E-05_JPRB, 7.07860E-05_JPRB, & + & 8.48288E-05_JPRB, 1.01657E-04_JPRB, 1.21825E-04_JPRB, 1.45993E-04_JPRB, 1.74955E-04_JPRB, & + & 2.09663E-04_JPRB, 2.51257E-04_JPRB, 3.01103E-04_JPRB, 3.60837E-04_JPRB, 4.32421E-04_JPRB, & + & 5.18206E-04_JPRB, 6.21010E-04_JPRB, 7.44208E-04_JPRB, 8.91846E-04_JPRB/) + KAO_MCO2( 2, :, 5) = (/ & + & 3.14792E-05_JPRB, 3.79075E-05_JPRB, 4.56485E-05_JPRB, 5.49703E-05_JPRB, 6.61956E-05_JPRB, & + & 7.97133E-05_JPRB, 9.59914E-05_JPRB, 1.15594E-04_JPRB, 1.39199E-04_JPRB, 1.67624E-04_JPRB, & + & 2.01854E-04_JPRB, 2.43075E-04_JPRB, 2.92712E-04_JPRB, 3.52487E-04_JPRB, 4.24467E-04_JPRB, & + & 5.11147E-04_JPRB, 6.15527E-04_JPRB, 7.41222E-04_JPRB, 8.92585E-04_JPRB/) + KAO_MCO2( 3, :, 5) = (/ & + & 3.21655E-05_JPRB, 3.87990E-05_JPRB, 4.68006E-05_JPRB, 5.64523E-05_JPRB, 6.80945E-05_JPRB, & + & 8.21377E-05_JPRB, 9.90770E-05_JPRB, 1.19510E-04_JPRB, 1.44156E-04_JPRB, 1.73886E-04_JPRB, & + & 2.09746E-04_JPRB, 2.53002E-04_JPRB, 3.05179E-04_JPRB, 3.68117E-04_JPRB, 4.44033E-04_JPRB, & + & 5.35607E-04_JPRB, 6.46066E-04_JPRB, 7.79304E-04_JPRB, 9.40020E-04_JPRB/) + KAO_MCO2( 4, :, 5) = (/ & + & 3.22870E-05_JPRB, 3.89864E-05_JPRB, 4.70759E-05_JPRB, 5.68439E-05_JPRB, 6.86388E-05_JPRB, & + & 8.28810E-05_JPRB, 1.00078E-04_JPRB, 1.20844E-04_JPRB, 1.45919E-04_JPRB, 1.76196E-04_JPRB, & + & 2.12756E-04_JPRB, 2.56902E-04_JPRB, 3.10207E-04_JPRB, 3.74574E-04_JPRB, 4.52296E-04_JPRB, & + & 5.46146E-04_JPRB, 6.59468E-04_JPRB, 7.96304E-04_JPRB, 9.61533E-04_JPRB/) + KAO_MCO2( 5, :, 5) = (/ & + & 3.31190E-05_JPRB, 3.99528E-05_JPRB, 4.81967E-05_JPRB, 5.81417E-05_JPRB, 7.01387E-05_JPRB, & + & 8.46111E-05_JPRB, 1.02070E-04_JPRB, 1.23131E-04_JPRB, 1.48538E-04_JPRB, 1.79187E-04_JPRB, & + & 2.16161E-04_JPRB, 2.60764E-04_JPRB, 3.14570E-04_JPRB, 3.79479E-04_JPRB, 4.57781E-04_JPRB, & + & 5.52240E-04_JPRB, 6.66190E-04_JPRB, 8.03652E-04_JPRB, 9.69477E-04_JPRB/) + KAO_MCO2( 6, :, 5) = (/ & + & 3.31287E-05_JPRB, 3.99772E-05_JPRB, 4.82413E-05_JPRB, 5.82139E-05_JPRB, 7.02480E-05_JPRB, & + & 8.47698E-05_JPRB, 1.02294E-04_JPRB, 1.23440E-04_JPRB, 1.48958E-04_JPRB, 1.79750E-04_JPRB, & + & 2.16909E-04_JPRB, 2.61749E-04_JPRB, 3.15858E-04_JPRB, 3.81153E-04_JPRB, 4.59945E-04_JPRB, & + & 5.55026E-04_JPRB, 6.69762E-04_JPRB, 8.08216E-04_JPRB, 9.75292E-04_JPRB/) + KAO_MCO2( 7, :, 5) = (/ & + & 3.35235E-05_JPRB, 4.02832E-05_JPRB, 4.84061E-05_JPRB, 5.81668E-05_JPRB, 6.98958E-05_JPRB, & + & 8.39898E-05_JPRB, 1.00926E-04_JPRB, 1.21277E-04_JPRB, 1.45731E-04_JPRB, 1.75117E-04_JPRB, & + & 2.10428E-04_JPRB, 2.52860E-04_JPRB, 3.03847E-04_JPRB, 3.65116E-04_JPRB, 4.38739E-04_JPRB, & + & 5.27208E-04_JPRB, 6.33516E-04_JPRB, 7.61260E-04_JPRB, 9.14762E-04_JPRB/) + KAO_MCO2( 8, :, 5) = (/ & + & 3.57666E-05_JPRB, 4.27511E-05_JPRB, 5.10995E-05_JPRB, 6.10783E-05_JPRB, 7.30057E-05_JPRB, & + & 8.72622E-05_JPRB, 1.04303E-04_JPRB, 1.24671E-04_JPRB, 1.49017E-04_JPRB, 1.78117E-04_JPRB, & + & 2.12900E-04_JPRB, 2.54475E-04_JPRB, 3.04169E-04_JPRB, 3.63567E-04_JPRB, 4.34565E-04_JPRB, & + & 5.19427E-04_JPRB, 6.20861E-04_JPRB, 7.42103E-04_JPRB, 8.87020E-04_JPRB/) + KAO_MCO2( 9, :, 5) = (/ & + & 2.96349E-05_JPRB, 3.55202E-05_JPRB, 4.25743E-05_JPRB, 5.10292E-05_JPRB, 6.11633E-05_JPRB, & + & 7.33099E-05_JPRB, 8.78687E-05_JPRB, 1.05319E-04_JPRB, 1.26234E-04_JPRB, 1.51304E-04_JPRB, & + & 1.81352E-04_JPRB, 2.17367E-04_JPRB, 2.60534E-04_JPRB, 3.12275E-04_JPRB, 3.74290E-04_JPRB, & + & 4.48622E-04_JPRB, 5.37715E-04_JPRB, 6.44502E-04_JPRB, 7.72495E-04_JPRB/) + KAO_MCO2( 1, :, 6) = (/ & + & 4.14659E-05_JPRB, 4.98693E-05_JPRB, 5.99757E-05_JPRB, 7.21302E-05_JPRB, 8.67479E-05_JPRB, & + & 1.04328E-04_JPRB, 1.25471E-04_JPRB, 1.50899E-04_JPRB, 1.81479E-04_JPRB, 2.18257E-04_JPRB, & + & 2.62489E-04_JPRB, 3.15685E-04_JPRB, 3.79660E-04_JPRB, 4.56601E-04_JPRB, 5.49135E-04_JPRB, & + & 6.60422E-04_JPRB, 7.94261E-04_JPRB, 9.55224E-04_JPRB, 1.14881E-03_JPRB/) + KAO_MCO2( 2, :, 6) = (/ & + & 4.25940E-05_JPRB, 5.11162E-05_JPRB, 6.13434E-05_JPRB, 7.36168E-05_JPRB, 8.83459E-05_JPRB, & + & 1.06022E-04_JPRB, 1.27235E-04_JPRB, 1.52691E-04_JPRB, 1.83241E-04_JPRB, 2.19904E-04_JPRB, & + & 2.63902E-04_JPRB, 3.16703E-04_JPRB, 3.80068E-04_JPRB, 4.56111E-04_JPRB, 5.47368E-04_JPRB, & + & 6.56885E-04_JPRB, 7.88313E-04_JPRB, 9.46036E-04_JPRB, 1.13532E-03_JPRB/) + KAO_MCO2( 3, :, 6) = (/ & + & 4.44940E-05_JPRB, 5.32922E-05_JPRB, 6.38303E-05_JPRB, 7.64522E-05_JPRB, 9.15700E-05_JPRB, & + & 1.09677E-04_JPRB, 1.31365E-04_JPRB, 1.57341E-04_JPRB, 1.88454E-04_JPRB, 2.25719E-04_JPRB, & + & 2.70353E-04_JPRB, 3.23813E-04_JPRB, 3.87844E-04_JPRB, 4.64537E-04_JPRB, 5.56395E-04_JPRB, & + & 6.66418E-04_JPRB, 7.98196E-04_JPRB, 9.56032E-04_JPRB, 1.14508E-03_JPRB/) + KAO_MCO2( 4, :, 6) = (/ & + & 4.83402E-05_JPRB, 5.78065E-05_JPRB, 6.91265E-05_JPRB, 8.26633E-05_JPRB, 9.88510E-05_JPRB, & + & 1.18209E-04_JPRB, 1.41357E-04_JPRB, 1.69038E-04_JPRB, 2.02140E-04_JPRB, 2.41725E-04_JPRB, & + & 2.89061E-04_JPRB, 3.45667E-04_JPRB, 4.13357E-04_JPRB, 4.94303E-04_JPRB, 5.91101E-04_JPRB, & + & 7.06854E-04_JPRB, 8.45275E-04_JPRB, 1.01080E-03_JPRB, 1.20874E-03_JPRB/) + KAO_MCO2( 5, :, 6) = (/ & + & 5.14797E-05_JPRB, 6.15328E-05_JPRB, 7.35491E-05_JPRB, 8.79120E-05_JPRB, 1.05080E-04_JPRB, & + & 1.25600E-04_JPRB, 1.50128E-04_JPRB, 1.79445E-04_JPRB, 2.14487E-04_JPRB, 2.56373E-04_JPRB, & + & 3.06438E-04_JPRB, 3.66281E-04_JPRB, 4.37809E-04_JPRB, 5.23305E-04_JPRB, 6.25498E-04_JPRB, & + & 7.47647E-04_JPRB, 8.93650E-04_JPRB, 1.06816E-03_JPRB, 1.27676E-03_JPRB/) + KAO_MCO2( 6, :, 6) = (/ & + & 5.71481E-05_JPRB, 6.83156E-05_JPRB, 8.16652E-05_JPRB, 9.76237E-05_JPRB, 1.16701E-04_JPRB, & + & 1.39505E-04_JPRB, 1.66766E-04_JPRB, 1.99354E-04_JPRB, 2.38311E-04_JPRB, 2.84879E-04_JPRB, & + & 3.40548E-04_JPRB, 4.07096E-04_JPRB, 4.86647E-04_JPRB, 5.81744E-04_JPRB, 6.95424E-04_JPRB, & + & 8.31318E-04_JPRB, 9.93769E-04_JPRB, 1.18796E-03_JPRB, 1.42010E-03_JPRB/) + KAO_MCO2( 7, :, 6) = (/ & + & 5.69513E-05_JPRB, 6.84420E-05_JPRB, 8.22512E-05_JPRB, 9.88466E-05_JPRB, 1.18790E-04_JPRB, & + & 1.42758E-04_JPRB, 1.71562E-04_JPRB, 2.06177E-04_JPRB, 2.47776E-04_JPRB, 2.97768E-04_JPRB, & + & 3.57848E-04_JPRB, 4.30049E-04_JPRB, 5.16817E-04_JPRB, 6.21093E-04_JPRB, 7.46407E-04_JPRB, & + & 8.97006E-04_JPRB, 1.07799E-03_JPRB, 1.29549E-03_JPRB, 1.55687E-03_JPRB/) + KAO_MCO2( 8, :, 6) = (/ & + & 4.39361E-06_JPRB, 5.50076E-06_JPRB, 6.88690E-06_JPRB, 8.62235E-06_JPRB, 1.07951E-05_JPRB, & + & 1.35154E-05_JPRB, 1.69212E-05_JPRB, 2.11851E-05_JPRB, 2.65236E-05_JPRB, 3.32074E-05_JPRB, & + & 4.15754E-05_JPRB, 5.20520E-05_JPRB, 6.51687E-05_JPRB, 8.15907E-05_JPRB, 1.02151E-04_JPRB, & + & 1.27892E-04_JPRB, 1.60120E-04_JPRB, 2.00469E-04_JPRB, 2.50985E-04_JPRB/) + KAO_MCO2( 9, :, 6) = (/ & + & 5.75515E-05_JPRB, 6.86850E-05_JPRB, 8.19722E-05_JPRB, 9.78298E-05_JPRB, 1.16755E-04_JPRB, & + & 1.39342E-04_JPRB, 1.66297E-04_JPRB, 1.98468E-04_JPRB, 2.36862E-04_JPRB, 2.82683E-04_JPRB, & + & 3.37369E-04_JPRB, 4.02633E-04_JPRB, 4.80523E-04_JPRB, 5.73481E-04_JPRB, 6.84422E-04_JPRB, & + & 8.16824E-04_JPRB, 9.74841E-04_JPRB, 1.16342E-03_JPRB, 1.38849E-03_JPRB/) + KAO_MCO2( 1, :, 7) = (/ & + & 6.84544E-05_JPRB, 8.16461E-05_JPRB, 9.73799E-05_JPRB, 1.16146E-04_JPRB, 1.38528E-04_JPRB, & + & 1.65223E-04_JPRB, 1.97063E-04_JPRB, 2.35039E-04_JPRB, 2.80333E-04_JPRB, 3.34355E-04_JPRB, & + & 3.98788E-04_JPRB, 4.75637E-04_JPRB, 5.67296E-04_JPRB, 6.76618E-04_JPRB, 8.07008E-04_JPRB, & + & 9.62525E-04_JPRB, 1.14801E-03_JPRB, 1.36924E-03_JPRB, 1.63310E-03_JPRB/) + KAO_MCO2( 2, :, 7) = (/ & + & 6.88332E-05_JPRB, 8.21719E-05_JPRB, 9.80955E-05_JPRB, 1.17105E-04_JPRB, 1.39798E-04_JPRB, & + & 1.66888E-04_JPRB, 1.99229E-04_JPRB, 2.37836E-04_JPRB, 2.83925E-04_JPRB, 3.38944E-04_JPRB, & + & 4.04627E-04_JPRB, 4.83037E-04_JPRB, 5.76641E-04_JPRB, 6.88385E-04_JPRB, 8.21782E-04_JPRB, & + & 9.81031E-04_JPRB, 1.17114E-03_JPRB, 1.39809E-03_JPRB, 1.66901E-03_JPRB/) + KAO_MCO2( 3, :, 7) = (/ & + & 7.49899E-05_JPRB, 8.94606E-05_JPRB, 1.06724E-04_JPRB, 1.27318E-04_JPRB, 1.51887E-04_JPRB, & + & 1.81196E-04_JPRB, 2.16161E-04_JPRB, 2.57873E-04_JPRB, 3.07635E-04_JPRB, 3.66999E-04_JPRB, & + & 4.37818E-04_JPRB, 5.22304E-04_JPRB, 6.23092E-04_JPRB, 7.43330E-04_JPRB, 8.86769E-04_JPRB, & + & 1.05789E-03_JPRB, 1.26203E-03_JPRB, 1.50556E-03_JPRB, 1.79608E-03_JPRB/) + KAO_MCO2( 4, :, 7) = (/ & + & 8.26801E-05_JPRB, 9.85802E-05_JPRB, 1.17538E-04_JPRB, 1.40141E-04_JPRB, 1.67092E-04_JPRB, & + & 1.99225E-04_JPRB, 2.37537E-04_JPRB, 2.83217E-04_JPRB, 3.37682E-04_JPRB, 4.02621E-04_JPRB, & + & 4.80048E-04_JPRB, 5.72365E-04_JPRB, 6.82435E-04_JPRB, 8.13673E-04_JPRB, 9.70148E-04_JPRB, & + & 1.15671E-03_JPRB, 1.37916E-03_JPRB, 1.64438E-03_JPRB, 1.96061E-03_JPRB/) + KAO_MCO2( 5, :, 7) = (/ & + & 9.29561E-05_JPRB, 1.10845E-04_JPRB, 1.32176E-04_JPRB, 1.57612E-04_JPRB, 1.87944E-04_JPRB, & + & 2.24112E-04_JPRB, 2.67241E-04_JPRB, 3.18669E-04_JPRB, 3.79995E-04_JPRB, 4.53121E-04_JPRB, & + & 5.40321E-04_JPRB, 6.44302E-04_JPRB, 7.68293E-04_JPRB, 9.16146E-04_JPRB, 1.09245E-03_JPRB, & + & 1.30268E-03_JPRB, 1.55338E-03_JPRB, 1.85231E-03_JPRB, 2.20877E-03_JPRB/) + KAO_MCO2( 6, :, 7) = (/ & + & 1.09700E-04_JPRB, 1.30879E-04_JPRB, 1.56148E-04_JPRB, 1.86294E-04_JPRB, 2.22261E-04_JPRB, & + & 2.65172E-04_JPRB, 3.16367E-04_JPRB, 3.77446E-04_JPRB, 4.50317E-04_JPRB, 5.37257E-04_JPRB, & + & 6.40983E-04_JPRB, 7.64734E-04_JPRB, 9.12376E-04_JPRB, 1.08852E-03_JPRB, 1.29868E-03_JPRB, & + & 1.54941E-03_JPRB, 1.84854E-03_JPRB, 2.20543E-03_JPRB, 2.63122E-03_JPRB/) + KAO_MCO2( 7, :, 7) = (/ & + & 1.43457E-04_JPRB, 1.71554E-04_JPRB, 2.05153E-04_JPRB, 2.45332E-04_JPRB, 2.93381E-04_JPRB, & + & 3.50840E-04_JPRB, 4.19552E-04_JPRB, 5.01722E-04_JPRB, 5.99985E-04_JPRB, 7.17492E-04_JPRB, & + & 8.58014E-04_JPRB, 1.02606E-03_JPRB, 1.22701E-03_JPRB, 1.46732E-03_JPRB, 1.75470E-03_JPRB, & + & 2.09836E-03_JPRB, 2.50933E-03_JPRB, 3.00078E-03_JPRB, 3.58849E-03_JPRB/) + KAO_MCO2( 8, :, 7) = (/ & + & 1.52152E-05_JPRB, 1.89421E-05_JPRB, 2.35819E-05_JPRB, 2.93582E-05_JPRB, 3.65494E-05_JPRB, & + & 4.55021E-05_JPRB, 5.66476E-05_JPRB, 7.05233E-05_JPRB, 8.77978E-05_JPRB, 1.09304E-04_JPRB, & + & 1.36077E-04_JPRB, 1.69409E-04_JPRB, 2.10905E-04_JPRB, 2.62565E-04_JPRB, 3.26880E-04_JPRB, & + & 4.06948E-04_JPRB, 5.06629E-04_JPRB, 6.30726E-04_JPRB, 7.85219E-04_JPRB/) + KAO_MCO2( 9, :, 7) = (/ & + & 1.15683E-04_JPRB, 1.37544E-04_JPRB, 1.63535E-04_JPRB, 1.94438E-04_JPRB, 2.31180E-04_JPRB, & + & 2.74866E-04_JPRB, 3.26807E-04_JPRB, 3.88563E-04_JPRB, 4.61989E-04_JPRB, 5.49289E-04_JPRB, & + & 6.53088E-04_JPRB, 7.76501E-04_JPRB, 9.23234E-04_JPRB, 1.09770E-03_JPRB, 1.30512E-03_JPRB, & + & 1.55175E-03_JPRB, 1.84498E-03_JPRB, 2.19362E-03_JPRB, 2.60815E-03_JPRB/) + KAO_MCO2( 1, :, 8) = (/ & + & 1.18154E-04_JPRB, 1.40516E-04_JPRB, 1.67111E-04_JPRB, 1.98739E-04_JPRB, 2.36353E-04_JPRB, & + & 2.81086E-04_JPRB, 3.34285E-04_JPRB, 3.97553E-04_JPRB, 4.72796E-04_JPRB, 5.62278E-04_JPRB, & + & 6.68697E-04_JPRB, 7.95257E-04_JPRB, 9.45770E-04_JPRB, 1.12477E-03_JPRB, 1.33765E-03_JPRB, & + & 1.59081E-03_JPRB, 1.89190E-03_JPRB, 2.24996E-03_JPRB, 2.67580E-03_JPRB/) + KAO_MCO2( 2, :, 8) = (/ & + & 1.40874E-04_JPRB, 1.67009E-04_JPRB, 1.97993E-04_JPRB, 2.34726E-04_JPRB, 2.78273E-04_JPRB, & + & 3.29899E-04_JPRB, 3.91102E-04_JPRB, 4.63661E-04_JPRB, 5.49680E-04_JPRB, 6.51659E-04_JPRB, & + & 7.72556E-04_JPRB, 9.15884E-04_JPRB, 1.08580E-03_JPRB, 1.28724E-03_JPRB, 1.52605E-03_JPRB, & + & 1.80917E-03_JPRB, 2.14482E-03_JPRB, 2.54273E-03_JPRB, 3.01446E-03_JPRB/) + KAO_MCO2( 3, :, 8) = (/ & + & 1.55092E-04_JPRB, 1.84132E-04_JPRB, 2.18609E-04_JPRB, 2.59542E-04_JPRB, 3.08140E-04_JPRB, & + & 3.65837E-04_JPRB, 4.34337E-04_JPRB, 5.15664E-04_JPRB, 6.12219E-04_JPRB, 7.26853E-04_JPRB, & + & 8.62952E-04_JPRB, 1.02453E-03_JPRB, 1.21637E-03_JPRB, 1.44413E-03_JPRB, 1.71453E-03_JPRB, & + & 2.03557E-03_JPRB, 2.41671E-03_JPRB, 2.86923E-03_JPRB, 3.40647E-03_JPRB/) + KAO_MCO2( 4, :, 8) = (/ & + & 1.80666E-04_JPRB, 2.14521E-04_JPRB, 2.54721E-04_JPRB, 3.02454E-04_JPRB, 3.59131E-04_JPRB, & + & 4.26429E-04_JPRB, 5.06339E-04_JPRB, 6.01223E-04_JPRB, 7.13887E-04_JPRB, 8.47663E-04_JPRB, & + & 1.00651E-03_JPRB, 1.19512E-03_JPRB, 1.41908E-03_JPRB, 1.68500E-03_JPRB, 2.00076E-03_JPRB, & + & 2.37568E-03_JPRB, 2.82087E-03_JPRB, 3.34947E-03_JPRB, 3.97714E-03_JPRB/) + KAO_MCO2( 5, :, 8) = (/ & + & 2.21554E-04_JPRB, 2.63265E-04_JPRB, 3.12829E-04_JPRB, 3.71724E-04_JPRB, 4.41707E-04_JPRB, & + & 5.24865E-04_JPRB, 6.23679E-04_JPRB, 7.41096E-04_JPRB, 8.80619E-04_JPRB, 1.04641E-03_JPRB, & + & 1.24341E-03_JPRB, 1.47750E-03_JPRB, 1.75567E-03_JPRB, 2.08620E-03_JPRB, 2.47896E-03_JPRB, & + & 2.94566E-03_JPRB, 3.50023E-03_JPRB, 4.15920E-03_JPRB, 4.94224E-03_JPRB/) + KAO_MCO2( 6, :, 8) = (/ & + & 2.78997E-04_JPRB, 3.32548E-04_JPRB, 3.96378E-04_JPRB, 4.72460E-04_JPRB, 5.63146E-04_JPRB, & + & 6.71238E-04_JPRB, 8.00077E-04_JPRB, 9.53647E-04_JPRB, 1.13669E-03_JPRB, 1.35487E-03_JPRB, & + & 1.61493E-03_JPRB, 1.92491E-03_JPRB, 2.29438E-03_JPRB, 2.73477E-03_JPRB, 3.25969E-03_JPRB, & + & 3.88537E-03_JPRB, 4.63114E-03_JPRB, 5.52005E-03_JPRB, 6.57958E-03_JPRB/) + KAO_MCO2( 7, :, 8) = (/ & + & 2.84939E-04_JPRB, 3.40606E-04_JPRB, 4.07149E-04_JPRB, 4.86691E-04_JPRB, 5.81774E-04_JPRB, & + & 6.95432E-04_JPRB, 8.31295E-04_JPRB, 9.93700E-04_JPRB, 1.18783E-03_JPRB, 1.41989E-03_JPRB, & + & 1.69729E-03_JPRB, 2.02888E-03_JPRB, 2.42526E-03_JPRB, 2.89907E-03_JPRB, 3.46544E-03_JPRB, & + & 4.14246E-03_JPRB, 4.95176E-03_JPRB, 5.91915E-03_JPRB, 7.07554E-03_JPRB/) + KAO_MCO2( 8, :, 8) = (/ & + & 5.30764E-05_JPRB, 6.47812E-05_JPRB, 7.90673E-05_JPRB, 9.65039E-05_JPRB, 1.17786E-04_JPRB, & + & 1.43761E-04_JPRB, 1.75464E-04_JPRB, 2.14159E-04_JPRB, 2.61387E-04_JPRB, 3.19030E-04_JPRB, & + & 3.89385E-04_JPRB, 4.75255E-04_JPRB, 5.80062E-04_JPRB, 7.07982E-04_JPRB, 8.64111E-04_JPRB, & + & 1.05467E-03_JPRB, 1.28726E-03_JPRB, 1.57113E-03_JPRB, 1.91761E-03_JPRB/) + KAO_MCO2( 9, :, 8) = (/ & + & 2.76806E-04_JPRB, 3.29639E-04_JPRB, 3.92556E-04_JPRB, 4.67481E-04_JPRB, 5.56708E-04_JPRB, & + & 6.62964E-04_JPRB, 7.89501E-04_JPRB, 9.40190E-04_JPRB, 1.11964E-03_JPRB, 1.33334E-03_JPRB, & + & 1.58783E-03_JPRB, 1.89089E-03_JPRB, 2.25180E-03_JPRB, 2.68159E-03_JPRB, 3.19341E-03_JPRB, & + & 3.80293E-03_JPRB, 4.52878E-03_JPRB, 5.39316E-03_JPRB, 6.42253E-03_JPRB/) + KAO_MCO2( 1, :, 9) = (/ & + & 3.30614E-04_JPRB, 3.93289E-04_JPRB, 4.67844E-04_JPRB, 5.56534E-04_JPRB, 6.62036E-04_JPRB, & + & 7.87539E-04_JPRB, 9.36833E-04_JPRB, 1.11443E-03_JPRB, 1.32569E-03_JPRB, 1.57700E-03_JPRB, & + & 1.87596E-03_JPRB, 2.23158E-03_JPRB, 2.65463E-03_JPRB, 3.15787E-03_JPRB, 3.75650E-03_JPRB, & + & 4.46862E-03_JPRB, 5.31575E-03_JPRB, 6.32345E-03_JPRB, 7.52219E-03_JPRB/) + KAO_MCO2( 2, :, 9) = (/ & + & 3.78453E-04_JPRB, 4.50735E-04_JPRB, 5.36824E-04_JPRB, 6.39355E-04_JPRB, 7.61469E-04_JPRB, & + & 9.06906E-04_JPRB, 1.08012E-03_JPRB, 1.28642E-03_JPRB, 1.53212E-03_JPRB, 1.82475E-03_JPRB, & + & 2.17326E-03_JPRB, 2.58835E-03_JPRB, 3.08271E-03_JPRB, 3.67149E-03_JPRB, 4.37273E-03_JPRB, & + & 5.20790E-03_JPRB, 6.20259E-03_JPRB, 7.38725E-03_JPRB, 8.79818E-03_JPRB/) + KAO_MCO2( 3, :, 9) = (/ & + & 4.57576E-04_JPRB, 5.45512E-04_JPRB, 6.50348E-04_JPRB, 7.75330E-04_JPRB, 9.24332E-04_JPRB, & + & 1.10197E-03_JPRB, 1.31374E-03_JPRB, 1.56621E-03_JPRB, 1.86721E-03_JPRB, 2.22604E-03_JPRB, & + & 2.65384E-03_JPRB, 3.16385E-03_JPRB, 3.77187E-03_JPRB, 4.49675E-03_JPRB, 5.36092E-03_JPRB, & + & 6.39117E-03_JPRB, 7.61942E-03_JPRB, 9.08370E-03_JPRB, 1.08294E-02_JPRB/) + KAO_MCO2( 4, :, 9) = (/ & + & 5.18277E-04_JPRB, 6.18764E-04_JPRB, 7.38735E-04_JPRB, 8.81967E-04_JPRB, 1.05297E-03_JPRB, & + & 1.25713E-03_JPRB, 1.50087E-03_JPRB, 1.79187E-03_JPRB, 2.13929E-03_JPRB, 2.55407E-03_JPRB, & + & 3.04928E-03_JPRB, 3.64050E-03_JPRB, 4.34635E-03_JPRB, 5.18905E-03_JPRB, 6.19514E-03_JPRB, & + & 7.39631E-03_JPRB, 8.83036E-03_JPRB, 1.05425E-02_JPRB, 1.25865E-02_JPRB/) + KAO_MCO2( 5, :, 9) = (/ & + & 4.45365E-04_JPRB, 5.32106E-04_JPRB, 6.35742E-04_JPRB, 7.59563E-04_JPRB, 9.07500E-04_JPRB, & + & 1.08425E-03_JPRB, 1.29542E-03_JPRB, 1.54773E-03_JPRB, 1.84917E-03_JPRB, 2.20933E-03_JPRB, & + & 2.63963E-03_JPRB, 3.15374E-03_JPRB, 3.76797E-03_JPRB, 4.50184E-03_JPRB, 5.37865E-03_JPRB, & + & 6.42622E-03_JPRB, 7.67783E-03_JPRB, 9.17320E-03_JPRB, 1.09598E-02_JPRB/) + KAO_MCO2( 6, :, 9) = (/ & + & 2.87301E-04_JPRB, 3.43009E-04_JPRB, 4.09519E-04_JPRB, 4.88926E-04_JPRB, 5.83730E-04_JPRB, & + & 6.96916E-04_JPRB, 8.32050E-04_JPRB, 9.93386E-04_JPRB, 1.18601E-03_JPRB, 1.41597E-03_JPRB, & + & 1.69053E-03_JPRB, 2.01833E-03_JPRB, 2.40969E-03_JPRB, 2.87693E-03_JPRB, 3.43478E-03_JPRB, & + & 4.10079E-03_JPRB, 4.89594E-03_JPRB, 5.84527E-03_JPRB, 6.97867E-03_JPRB/) + KAO_MCO2( 7, :, 9) = (/ & + & 1.10743E-04_JPRB, 1.32286E-04_JPRB, 1.58020E-04_JPRB, 1.88760E-04_JPRB, 2.25480E-04_JPRB, & + & 2.69342E-04_JPRB, 3.21738E-04_JPRB, 3.84326E-04_JPRB, 4.59090E-04_JPRB, 5.48397E-04_JPRB, & + & 6.55078E-04_JPRB, 7.82511E-04_JPRB, 9.34734E-04_JPRB, 1.11657E-03_JPRB, 1.33378E-03_JPRB, & + & 1.59324E-03_JPRB, 1.90318E-03_JPRB, 2.27340E-03_JPRB, 2.71565E-03_JPRB/) + KAO_MCO2( 8, :, 9) = (/ & + & 8.63177E-05_JPRB, 1.03067E-04_JPRB, 1.23066E-04_JPRB, 1.46946E-04_JPRB, 1.75459E-04_JPRB, & + & 2.09505E-04_JPRB, 2.50158E-04_JPRB, 2.98698E-04_JPRB, 3.56658E-04_JPRB, 4.25864E-04_JPRB, & + & 5.08498E-04_JPRB, 6.07168E-04_JPRB, 7.24982E-04_JPRB, 8.65658E-04_JPRB, 1.03363E-03_JPRB, & + & 1.23420E-03_JPRB, 1.47368E-03_JPRB, 1.75963E-03_JPRB, 2.10107E-03_JPRB/) + KAO_MCO2( 9, :, 9) = (/ & + & 4.52715E-04_JPRB, 5.41540E-04_JPRB, 6.47792E-04_JPRB, 7.74892E-04_JPRB, 9.26929E-04_JPRB, & + & 1.10880E-03_JPRB, 1.32635E-03_JPRB, 1.58658E-03_JPRB, 1.89787E-03_JPRB, 2.27024E-03_JPRB, & + & 2.71568E-03_JPRB, 3.24850E-03_JPRB, 3.88587E-03_JPRB, 4.64830E-03_JPRB, 5.56031E-03_JPRB, & + & 6.65127E-03_JPRB, 7.95627E-03_JPRB, 9.51732E-03_JPRB, 1.13847E-02_JPRB/) + KAO_MCO2( 1, :,10) = (/ & + & 9.10418E-04_JPRB, 1.08631E-03_JPRB, 1.29619E-03_JPRB, 1.54662E-03_JPRB, 1.84543E-03_JPRB, & + & 2.20198E-03_JPRB, 2.62741E-03_JPRB, 3.13503E-03_JPRB, 3.74073E-03_JPRB, 4.46344E-03_JPRB, & + & 5.32580E-03_JPRB, 6.35476E-03_JPRB, 7.58251E-03_JPRB, 9.04748E-03_JPRB, 1.07955E-02_JPRB, & + & 1.28812E-02_JPRB, 1.53699E-02_JPRB, 1.83394E-02_JPRB, 2.18826E-02_JPRB/) + KAO_MCO2( 2, :,10) = (/ & + & 9.06680E-04_JPRB, 1.08622E-03_JPRB, 1.30130E-03_JPRB, 1.55898E-03_JPRB, 1.86768E-03_JPRB, & + & 2.23750E-03_JPRB, 2.68056E-03_JPRB, 3.21135E-03_JPRB, 3.84724E-03_JPRB, 4.60905E-03_JPRB, & + & 5.52171E-03_JPRB, 6.61508E-03_JPRB, 7.92496E-03_JPRB, 9.49421E-03_JPRB, 1.13742E-02_JPRB, & + & 1.36265E-02_JPRB, 1.63247E-02_JPRB, 1.95572E-02_JPRB, 2.34298E-02_JPRB/) + KAO_MCO2( 3, :,10) = (/ & + & 8.17976E-04_JPRB, 9.79458E-04_JPRB, 1.17282E-03_JPRB, 1.40435E-03_JPRB, 1.68160E-03_JPRB, & + & 2.01357E-03_JPRB, 2.41108E-03_JPRB, 2.88707E-03_JPRB, 3.45703E-03_JPRB, 4.13950E-03_JPRB, & + & 4.95671E-03_JPRB, 5.93525E-03_JPRB, 7.10696E-03_JPRB, 8.51000E-03_JPRB, 1.01900E-02_JPRB, & + & 1.22017E-02_JPRB, 1.46105E-02_JPRB, 1.74949E-02_JPRB, 2.09486E-02_JPRB/) + KAO_MCO2( 4, :,10) = (/ & + & 3.70314E-04_JPRB, 4.41440E-04_JPRB, 5.26226E-04_JPRB, 6.27298E-04_JPRB, 7.47782E-04_JPRB, & + & 8.91407E-04_JPRB, 1.06262E-03_JPRB, 1.26671E-03_JPRB, 1.51001E-03_JPRB, 1.80003E-03_JPRB, & + & 2.14576E-03_JPRB, 2.55789E-03_JPRB, 3.04918E-03_JPRB, 3.63483E-03_JPRB, 4.33297E-03_JPRB, & + & 5.16520E-03_JPRB, 6.15727E-03_JPRB, 7.33988E-03_JPRB, 8.74963E-03_JPRB/) + KAO_MCO2( 5, :,10) = (/ & + & 1.00859E-04_JPRB, 1.19692E-04_JPRB, 1.42041E-04_JPRB, 1.68563E-04_JPRB, 2.00038E-04_JPRB, & + & 2.37389E-04_JPRB, 2.81715E-04_JPRB, 3.34318E-04_JPRB, 3.96742E-04_JPRB, 4.70823E-04_JPRB, & + & 5.58736E-04_JPRB, 6.63065E-04_JPRB, 7.86874E-04_JPRB, 9.33801E-04_JPRB, 1.10816E-03_JPRB, & + & 1.31508E-03_JPRB, 1.56064E-03_JPRB, 1.85204E-03_JPRB, 2.19786E-03_JPRB/) + KAO_MCO2( 6, :,10) = (/ & + & 9.24477E-05_JPRB, 1.09659E-04_JPRB, 1.30074E-04_JPRB, 1.54290E-04_JPRB, 1.83015E-04_JPRB, & + & 2.17087E-04_JPRB, 2.57503E-04_JPRB, 3.05442E-04_JPRB, 3.62307E-04_JPRB, 4.29759E-04_JPRB, & + & 5.09768E-04_JPRB, 6.04672E-04_JPRB, 7.17245E-04_JPRB, 8.50776E-04_JPRB, 1.00917E-03_JPRB, & + & 1.19704E-03_JPRB, 1.41990E-03_JPRB, 1.68425E-03_JPRB, 1.99780E-03_JPRB/) + KAO_MCO2( 7, :,10) = (/ & + & 8.42943E-05_JPRB, 1.00044E-04_JPRB, 1.18735E-04_JPRB, 1.40919E-04_JPRB, 1.67248E-04_JPRB, & + & 1.98496E-04_JPRB, 2.35582E-04_JPRB, 2.79597E-04_JPRB, 3.31836E-04_JPRB, 3.93835E-04_JPRB, & + & 4.67418E-04_JPRB, 5.54748E-04_JPRB, 6.58395E-04_JPRB, 7.81407E-04_JPRB, 9.27402E-04_JPRB, & + & 1.10067E-03_JPRB, 1.30632E-03_JPRB, 1.55039E-03_JPRB, 1.84005E-03_JPRB/) + KAO_MCO2( 8, :,10) = (/ & + & 6.86464E-05_JPRB, 8.18163E-05_JPRB, 9.75129E-05_JPRB, 1.16221E-04_JPRB, 1.38518E-04_JPRB, & + & 1.65093E-04_JPRB, 1.96767E-04_JPRB, 2.34517E-04_JPRB, 2.79509E-04_JPRB, 3.33133E-04_JPRB, & + & 3.97046E-04_JPRB, 4.73220E-04_JPRB, 5.64008E-04_JPRB, 6.72214E-04_JPRB, 8.01179E-04_JPRB, & + & 9.54887E-04_JPRB, 1.13808E-03_JPRB, 1.35643E-03_JPRB, 1.61666E-03_JPRB/) + KAO_MCO2( 9, :,10) = (/ & + & 1.03095E-04_JPRB, 1.21985E-04_JPRB, 1.44335E-04_JPRB, 1.70781E-04_JPRB, 2.02072E-04_JPRB, & + & 2.39096E-04_JPRB, 2.82904E-04_JPRB, 3.34739E-04_JPRB, 3.96070E-04_JPRB, 4.68639E-04_JPRB, & + & 5.54505E-04_JPRB, 6.56103E-04_JPRB, 7.76316E-04_JPRB, 9.18556E-04_JPRB, 1.08686E-03_JPRB, & + & 1.28599E-03_JPRB, 1.52162E-03_JPRB, 1.80041E-03_JPRB, 2.13029E-03_JPRB/) + KAO_MCO2( 1, :,11) = (/ & + & 1.01275E-03_JPRB, 1.21433E-03_JPRB, 1.45605E-03_JPRB, 1.74587E-03_JPRB, 2.09339E-03_JPRB, & + & 2.51007E-03_JPRB, 3.00970E-03_JPRB, 3.60878E-03_JPRB, 4.32711E-03_JPRB, 5.18842E-03_JPRB, & + & 6.22117E-03_JPRB, 7.45950E-03_JPRB, 8.94430E-03_JPRB, 1.07247E-02_JPRB, 1.28594E-02_JPRB, & + & 1.54191E-02_JPRB, 1.84882E-02_JPRB, 2.21683E-02_JPRB, 2.65809E-02_JPRB/) + KAO_MCO2( 2, :,11) = (/ & + & 1.06856E-03_JPRB, 1.27885E-03_JPRB, 1.53052E-03_JPRB, 1.83171E-03_JPRB, 2.19218E-03_JPRB, & + & 2.62359E-03_JPRB, 3.13990E-03_JPRB, 3.75781E-03_JPRB, 4.49732E-03_JPRB, 5.38236E-03_JPRB, & + & 6.44158E-03_JPRB, 7.70924E-03_JPRB, 9.22637E-03_JPRB, 1.10421E-02_JPRB, 1.32151E-02_JPRB, & + & 1.58157E-02_JPRB, 1.89281E-02_JPRB, 2.26531E-02_JPRB, 2.71110E-02_JPRB/) + KAO_MCO2( 3, :,11) = (/ & + & 7.34896E-04_JPRB, 8.77863E-04_JPRB, 1.04864E-03_JPRB, 1.25265E-03_JPRB, 1.49634E-03_JPRB, & + & 1.78744E-03_JPRB, 2.13516E-03_JPRB, 2.55054E-03_JPRB, 3.04672E-03_JPRB, 3.63943E-03_JPRB, & + & 4.34745E-03_JPRB, 5.19321E-03_JPRB, 6.20349E-03_JPRB, 7.41032E-03_JPRB, 8.85192E-03_JPRB, & + & 1.05740E-02_JPRB, 1.26311E-02_JPRB, 1.50883E-02_JPRB, 1.80236E-02_JPRB/) + KAO_MCO2( 4, :,11) = (/ & + & 5.89491E-05_JPRB, 7.12560E-05_JPRB, 8.61322E-05_JPRB, 1.04114E-04_JPRB, 1.25850E-04_JPRB, & + & 1.52124E-04_JPRB, 1.83883E-04_JPRB, 2.22272E-04_JPRB, 2.68676E-04_JPRB, 3.24768E-04_JPRB, & + & 3.92571E-04_JPRB, 4.74528E-04_JPRB, 5.73595E-04_JPRB, 6.93346E-04_JPRB, 8.38096E-04_JPRB, & + & 1.01307E-03_JPRB, 1.22457E-03_JPRB, 1.48022E-03_JPRB, 1.78924E-03_JPRB/) + KAO_MCO2( 5, :,11) = (/ & + & 5.32400E-05_JPRB, 6.45465E-05_JPRB, 7.82542E-05_JPRB, 9.48731E-05_JPRB, 1.15021E-04_JPRB, & + & 1.39448E-04_JPRB, 1.69063E-04_JPRB, 2.04966E-04_JPRB, 2.48495E-04_JPRB, 3.01268E-04_JPRB, & + & 3.65248E-04_JPRB, 4.42816E-04_JPRB, 5.36856E-04_JPRB, 6.50868E-04_JPRB, 7.89092E-04_JPRB, & + & 9.56672E-04_JPRB, 1.15984E-03_JPRB, 1.40615E-03_JPRB, 1.70478E-03_JPRB/) + KAO_MCO2( 6, :,11) = (/ & + & 5.31408E-05_JPRB, 6.42409E-05_JPRB, 7.76597E-05_JPRB, 9.38814E-05_JPRB, 1.13491E-04_JPRB, & + & 1.37198E-04_JPRB, 1.65856E-04_JPRB, 2.00500E-04_JPRB, 2.42381E-04_JPRB, 2.93010E-04_JPRB, & + & 3.54214E-04_JPRB, 4.28203E-04_JPRB, 5.17647E-04_JPRB, 6.25774E-04_JPRB, 7.56486E-04_JPRB, & + & 9.14503E-04_JPRB, 1.10553E-03_JPRB, 1.33645E-03_JPRB, 1.61561E-03_JPRB/) + KAO_MCO2( 7, :,11) = (/ & + & 5.24517E-05_JPRB, 6.32485E-05_JPRB, 7.62676E-05_JPRB, 9.19667E-05_JPRB, 1.10897E-04_JPRB, & + & 1.33725E-04_JPRB, 1.61251E-04_JPRB, 1.94443E-04_JPRB, 2.34467E-04_JPRB, 2.82730E-04_JPRB, & + & 3.40928E-04_JPRB, 4.11106E-04_JPRB, 4.95728E-04_JPRB, 5.97770E-04_JPRB, 7.20816E-04_JPRB, & + & 8.69190E-04_JPRB, 1.04811E-03_JPRB, 1.26385E-03_JPRB, 1.52400E-03_JPRB/) + KAO_MCO2( 8, :,11) = (/ & + & 5.01768E-05_JPRB, 6.02217E-05_JPRB, 7.22774E-05_JPRB, 8.67466E-05_JPRB, 1.04112E-04_JPRB, & + & 1.24955E-04_JPRB, 1.49969E-04_JPRB, 1.79991E-04_JPRB, 2.16024E-04_JPRB, 2.59270E-04_JPRB, & + & 3.11173E-04_JPRB, 3.73467E-04_JPRB, 4.48231E-04_JPRB, 5.37962E-04_JPRB, 6.45656E-04_JPRB, & + & 7.74910E-04_JPRB, 9.30039E-04_JPRB, 1.11622E-03_JPRB, 1.33968E-03_JPRB/) + KAO_MCO2( 9, :,11) = (/ & + & 5.46391E-05_JPRB, 6.58765E-05_JPRB, 7.94252E-05_JPRB, 9.57603E-05_JPRB, 1.15455E-04_JPRB, & + & 1.39200E-04_JPRB, 1.67829E-04_JPRB, 2.02346E-04_JPRB, 2.43962E-04_JPRB, 2.94137E-04_JPRB, & + & 3.54632E-04_JPRB, 4.27568E-04_JPRB, 5.15504E-04_JPRB, 6.21526E-04_JPRB, 7.49353E-04_JPRB, & + & 9.03471E-04_JPRB, 1.08929E-03_JPRB, 1.31331E-03_JPRB, 1.58342E-03_JPRB/) + KAO_MCO2( 1, :,12) = (/ & + & 1.18469E-03_JPRB, 1.41755E-03_JPRB, 1.69619E-03_JPRB, 2.02959E-03_JPRB, 2.42854E-03_JPRB, & + & 2.90589E-03_JPRB, 3.47708E-03_JPRB, 4.16055E-03_JPRB, 4.97836E-03_JPRB, 5.95691E-03_JPRB, & + & 7.12782E-03_JPRB, 8.52889E-03_JPRB, 1.02053E-02_JPRB, 1.22113E-02_JPRB, 1.46116E-02_JPRB, & + & 1.74837E-02_JPRB, 2.09204E-02_JPRB, 2.50325E-02_JPRB, 2.99530E-02_JPRB/) + KAO_MCO2( 2, :,12) = (/ & + & 1.09092E-03_JPRB, 1.30288E-03_JPRB, 1.55602E-03_JPRB, 1.85834E-03_JPRB, 2.21940E-03_JPRB, & + & 2.65061E-03_JPRB, 3.16560E-03_JPRB, 3.78064E-03_JPRB, 4.51519E-03_JPRB, 5.39245E-03_JPRB, & + & 6.44016E-03_JPRB, 7.69143E-03_JPRB, 9.18580E-03_JPRB, 1.09705E-02_JPRB, 1.31020E-02_JPRB, & + & 1.56476E-02_JPRB, 1.86878E-02_JPRB, 2.23187E-02_JPRB, 2.66550E-02_JPRB/) + KAO_MCO2( 3, :,12) = (/ & + & 3.97521E-04_JPRB, 4.74103E-04_JPRB, 5.65438E-04_JPRB, 6.74369E-04_JPRB, 8.04285E-04_JPRB, & + & 9.59228E-04_JPRB, 1.14402E-03_JPRB, 1.36442E-03_JPRB, 1.62727E-03_JPRB, 1.94076E-03_JPRB, & + & 2.31464E-03_JPRB, 2.76055E-03_JPRB, 3.29237E-03_JPRB, 3.92663E-03_JPRB, 4.68309E-03_JPRB, & + & 5.58528E-03_JPRB, 6.66128E-03_JPRB, 7.94456E-03_JPRB, 9.47505E-03_JPRB/) + KAO_MCO2( 4, :,12) = (/ & + & 7.18557E-05_JPRB, 8.56230E-05_JPRB, 1.02028E-04_JPRB, 1.21576E-04_JPRB, 1.44870E-04_JPRB, & + & 1.72626E-04_JPRB, 2.05701E-04_JPRB, 2.45112E-04_JPRB, 2.92075E-04_JPRB, 3.48035E-04_JPRB, & + & 4.14718E-04_JPRB, 4.94176E-04_JPRB, 5.88858E-04_JPRB, 7.01682E-04_JPRB, 8.36121E-04_JPRB, & + & 9.96319E-04_JPRB, 1.18721E-03_JPRB, 1.41467E-03_JPRB, 1.68572E-03_JPRB/) + KAO_MCO2( 5, :,12) = (/ & + & 7.33026E-05_JPRB, 8.69077E-05_JPRB, 1.03038E-04_JPRB, 1.22162E-04_JPRB, 1.44836E-04_JPRB, & + & 1.71717E-04_JPRB, 2.03588E-04_JPRB, 2.41375E-04_JPRB, 2.86175E-04_JPRB, 3.39289E-04_JPRB, & + & 4.02262E-04_JPRB, 4.76923E-04_JPRB, 5.65440E-04_JPRB, 6.70387E-04_JPRB, 7.94812E-04_JPRB, & + & 9.42331E-04_JPRB, 1.11723E-03_JPRB, 1.32459E-03_JPRB, 1.57044E-03_JPRB/) + KAO_MCO2( 6, :,12) = (/ & + & 7.44053E-05_JPRB, 8.82167E-05_JPRB, 1.04592E-04_JPRB, 1.24007E-04_JPRB, 1.47025E-04_JPRB, & + & 1.74317E-04_JPRB, 2.06674E-04_JPRB, 2.45038E-04_JPRB, 2.90523E-04_JPRB, 3.44451E-04_JPRB, & + & 4.08389E-04_JPRB, 4.84196E-04_JPRB, 5.74074E-04_JPRB, 6.80637E-04_JPRB, 8.06979E-04_JPRB, & + & 9.56774E-04_JPRB, 1.13437E-03_JPRB, 1.34494E-03_JPRB, 1.59459E-03_JPRB/) + KAO_MCO2( 7, :,12) = (/ & + & 7.68762E-05_JPRB, 9.11305E-05_JPRB, 1.08028E-04_JPRB, 1.28058E-04_JPRB, 1.51802E-04_JPRB, & + & 1.79949E-04_JPRB, 2.13315E-04_JPRB, 2.52868E-04_JPRB, 2.99754E-04_JPRB, 3.55334E-04_JPRB, & + & 4.21220E-04_JPRB, 4.99322E-04_JPRB, 5.91905E-04_JPRB, 7.01656E-04_JPRB, 8.31756E-04_JPRB, & + & 9.85979E-04_JPRB, 1.16880E-03_JPRB, 1.38551E-03_JPRB, 1.64241E-03_JPRB/) + KAO_MCO2( 8, :,12) = (/ & + & 8.45996E-05_JPRB, 1.00214E-04_JPRB, 1.18711E-04_JPRB, 1.40622E-04_JPRB, 1.66577E-04_JPRB, & + & 1.97323E-04_JPRB, 2.33743E-04_JPRB, 2.76885E-04_JPRB, 3.27991E-04_JPRB, 3.88529E-04_JPRB, & + & 4.60241E-04_JPRB, 5.45189E-04_JPRB, 6.45816E-04_JPRB, 7.65016E-04_JPRB, 9.06216E-04_JPRB, & + & 1.07348E-03_JPRB, 1.27161E-03_JPRB, 1.50632E-03_JPRB, 1.78434E-03_JPRB/) + KAO_MCO2( 9, :,12) = (/ & + & 7.73583E-05_JPRB, 9.16767E-05_JPRB, 1.08645E-04_JPRB, 1.28755E-04_JPRB, 1.52586E-04_JPRB, & + & 1.80829E-04_JPRB, 2.14299E-04_JPRB, 2.53964E-04_JPRB, 3.00970E-04_JPRB, 3.56678E-04_JPRB, & + & 4.22696E-04_JPRB, 5.00934E-04_JPRB, 5.93652E-04_JPRB, 7.03533E-04_JPRB, 8.33751E-04_JPRB, & + & 9.88072E-04_JPRB, 1.17096E-03_JPRB, 1.38769E-03_JPRB, 1.64454E-03_JPRB/) + KAO_MCO2( 1, :,13) = (/ & + & 1.20952E-03_JPRB, 1.44504E-03_JPRB, 1.72642E-03_JPRB, 2.06260E-03_JPRB, 2.46423E-03_JPRB, & + & 2.94407E-03_JPRB, 3.51735E-03_JPRB, 4.20226E-03_JPRB, 5.02053E-03_JPRB, 5.99814E-03_JPRB, & + & 7.16612E-03_JPRB, 8.56153E-03_JPRB, 1.02287E-02_JPRB, 1.22204E-02_JPRB, 1.46000E-02_JPRB, & + & 1.74430E-02_JPRB, 2.08395E-02_JPRB, 2.48974E-02_JPRB, 2.97455E-02_JPRB/) + KAO_MCO2( 2, :,13) = (/ & + & 8.47667E-04_JPRB, 1.01027E-03_JPRB, 1.20407E-03_JPRB, 1.43505E-03_JPRB, 1.71034E-03_JPRB, & + & 2.03843E-03_JPRB, 2.42946E-03_JPRB, 2.89550E-03_JPRB, 3.45094E-03_JPRB, 4.11293E-03_JPRB, & + & 4.90192E-03_JPRB, 5.84225E-03_JPRB, 6.96296E-03_JPRB, 8.29866E-03_JPRB, 9.89058E-03_JPRB, & + & 1.17879E-02_JPRB, 1.40492E-02_JPRB, 1.67442E-02_JPRB, 1.99562E-02_JPRB/) + KAO_MCO2( 3, :,13) = (/ & + & 1.45612E-04_JPRB, 1.71739E-04_JPRB, 2.02554E-04_JPRB, 2.38897E-04_JPRB, 2.81762E-04_JPRB, & + & 3.32318E-04_JPRB, 3.91945E-04_JPRB, 4.62271E-04_JPRB, 5.45215E-04_JPRB, 6.43041E-04_JPRB, & + & 7.58421E-04_JPRB, 8.94503E-04_JPRB, 1.05500E-03_JPRB, 1.24430E-03_JPRB, 1.46756E-03_JPRB, & + & 1.73088E-03_JPRB, 2.04145E-03_JPRB, 2.40774E-03_JPRB, 2.83975E-03_JPRB/) + KAO_MCO2( 4, :,13) = (/ & + & 1.40167E-04_JPRB, 1.65266E-04_JPRB, 1.94858E-04_JPRB, 2.29750E-04_JPRB, 2.70889E-04_JPRB, & + & 3.19394E-04_JPRB, 3.76585E-04_JPRB, 4.44016E-04_JPRB, 5.23522E-04_JPRB, 6.17264E-04_JPRB, & + & 7.27791E-04_JPRB, 8.58110E-04_JPRB, 1.01176E-03_JPRB, 1.19293E-03_JPRB, 1.40654E-03_JPRB, & + & 1.65839E-03_JPRB, 1.95534E-03_JPRB, 2.30547E-03_JPRB, 2.71828E-03_JPRB/) + KAO_MCO2( 5, :,13) = (/ & + & 1.37406E-04_JPRB, 1.61990E-04_JPRB, 1.90973E-04_JPRB, 2.25141E-04_JPRB, 2.65423E-04_JPRB, & + & 3.12911E-04_JPRB, 3.68896E-04_JPRB, 4.34898E-04_JPRB, 5.12709E-04_JPRB, 6.04442E-04_JPRB, & + & 7.12587E-04_JPRB, 8.40082E-04_JPRB, 9.90387E-04_JPRB, 1.16758E-03_JPRB, 1.37648E-03_JPRB, & + & 1.62276E-03_JPRB, 1.91310E-03_JPRB, 2.25539E-03_JPRB, 2.65892E-03_JPRB/) + KAO_MCO2( 6, :,13) = (/ & + & 1.35356E-04_JPRB, 1.59577E-04_JPRB, 1.88132E-04_JPRB, 2.21797E-04_JPRB, 2.61485E-04_JPRB, & + & 3.08276E-04_JPRB, 3.63440E-04_JPRB, 4.28475E-04_JPRB, 5.05147E-04_JPRB, 5.95539E-04_JPRB, & + & 7.02106E-04_JPRB, 8.27743E-04_JPRB, 9.75861E-04_JPRB, 1.15048E-03_JPRB, 1.35635E-03_JPRB, & + & 1.59906E-03_JPRB, 1.88520E-03_JPRB, 2.22255E-03_JPRB, 2.62025E-03_JPRB/) + KAO_MCO2( 7, :,13) = (/ & + & 1.33359E-04_JPRB, 1.57252E-04_JPRB, 1.85424E-04_JPRB, 2.18645E-04_JPRB, 2.57817E-04_JPRB, & + & 3.04007E-04_JPRB, 3.58472E-04_JPRB, 4.22695E-04_JPRB, 4.98425E-04_JPRB, 5.87722E-04_JPRB, & + & 6.93017E-04_JPRB, 8.17177E-04_JPRB, 9.63581E-04_JPRB, 1.13621E-03_JPRB, 1.33978E-03_JPRB, & + & 1.57981E-03_JPRB, 1.86284E-03_JPRB, 2.19659E-03_JPRB, 2.59012E-03_JPRB/) + KAO_MCO2( 8, :,13) = (/ & + & 1.29667E-04_JPRB, 1.53001E-04_JPRB, 1.80534E-04_JPRB, 2.13022E-04_JPRB, 2.51356E-04_JPRB, & + & 2.96589E-04_JPRB, 3.49961E-04_JPRB, 4.12938E-04_JPRB, 4.87249E-04_JPRB, 5.74931E-04_JPRB, & + & 6.78393E-04_JPRB, 8.00473E-04_JPRB, 9.44521E-04_JPRB, 1.11449E-03_JPRB, 1.31505E-03_JPRB, & + & 1.55170E-03_JPRB, 1.83094E-03_JPRB, 2.16042E-03_JPRB, 2.54920E-03_JPRB/) + KAO_MCO2( 9, :,13) = (/ & + & 1.37892E-04_JPRB, 1.62557E-04_JPRB, 1.91635E-04_JPRB, 2.25914E-04_JPRB, 2.66324E-04_JPRB, & + & 3.13963E-04_JPRB, 3.70124E-04_JPRB, 4.36330E-04_JPRB, 5.14379E-04_JPRB, 6.06389E-04_JPRB, & + & 7.14858E-04_JPRB, 8.42730E-04_JPRB, 9.93473E-04_JPRB, 1.17118E-03_JPRB, 1.38068E-03_JPRB, & + & 1.62765E-03_JPRB, 1.91880E-03_JPRB, 2.26202E-03_JPRB, 2.66665E-03_JPRB/) + KAO_MCO2( 1, :,14) = (/ & + & 1.28098E-03_JPRB, 1.52939E-03_JPRB, 1.82597E-03_JPRB, 2.18007E-03_JPRB, 2.60284E-03_JPRB, & + & 3.10759E-03_JPRB, 3.71022E-03_JPRB, 4.42972E-03_JPRB, 5.28874E-03_JPRB, 6.31435E-03_JPRB, & + & 7.53885E-03_JPRB, 9.00081E-03_JPRB, 1.07463E-02_JPRB, 1.28302E-02_JPRB, 1.53183E-02_JPRB, & + & 1.82889E-02_JPRB, 2.18355E-02_JPRB, 2.60699E-02_JPRB, 3.11255E-02_JPRB/) + KAO_MCO2( 2, :,14) = (/ & + & 1.27275E-04_JPRB, 1.48842E-04_JPRB, 1.74064E-04_JPRB, 2.03561E-04_JPRB, 2.38055E-04_JPRB, & + & 2.78395E-04_JPRB, 3.25570E-04_JPRB, 3.80740E-04_JPRB, 4.45259E-04_JPRB, 5.20710E-04_JPRB, & + & 6.08947E-04_JPRB, 7.12137E-04_JPRB, 8.32812E-04_JPRB, 9.73937E-04_JPRB, 1.13898E-03_JPRB, & + & 1.33198E-03_JPRB, 1.55769E-03_JPRB, 1.82165E-03_JPRB, 2.13034E-03_JPRB/) + KAO_MCO2( 3, :,14) = (/ & + & 1.27744E-04_JPRB, 1.49255E-04_JPRB, 1.74389E-04_JPRB, 2.03755E-04_JPRB, 2.38066E-04_JPRB, & + & 2.78155E-04_JPRB, 3.24995E-04_JPRB, 3.79722E-04_JPRB, 4.43666E-04_JPRB, 5.18376E-04_JPRB, & + & 6.05668E-04_JPRB, 7.07660E-04_JPRB, 8.26826E-04_JPRB, 9.66059E-04_JPRB, 1.12874E-03_JPRB, & + & 1.31881E-03_JPRB, 1.54089E-03_JPRB, 1.80037E-03_JPRB, 2.10354E-03_JPRB/) + KAO_MCO2( 4, :,14) = (/ & + & 1.28543E-04_JPRB, 1.50136E-04_JPRB, 1.75357E-04_JPRB, 2.04814E-04_JPRB, 2.39219E-04_JPRB, & + & 2.79404E-04_JPRB, 3.26339E-04_JPRB, 3.81159E-04_JPRB, 4.45188E-04_JPRB, 5.19972E-04_JPRB, & + & 6.07319E-04_JPRB, 7.09339E-04_JPRB, 8.28496E-04_JPRB, 9.67670E-04_JPRB, 1.13022E-03_JPRB, & + & 1.32008E-03_JPRB, 1.54184E-03_JPRB, 1.80084E-03_JPRB, 2.10335E-03_JPRB/) + KAO_MCO2( 5, :,14) = (/ & + & 1.29218E-04_JPRB, 1.50897E-04_JPRB, 1.76214E-04_JPRB, 2.05778E-04_JPRB, 2.40302E-04_JPRB, & + & 2.80618E-04_JPRB, 3.27698E-04_JPRB, 3.82678E-04_JPRB, 4.46881E-04_JPRB, 5.21855E-04_JPRB, & + & 6.09409E-04_JPRB, 7.11652E-04_JPRB, 8.31048E-04_JPRB, 9.70475E-04_JPRB, 1.13330E-03_JPRB, & + & 1.32343E-03_JPRB, 1.54547E-03_JPRB, 1.80476E-03_JPRB, 2.10755E-03_JPRB/) + KAO_MCO2( 6, :,14) = (/ & + & 1.30502E-04_JPRB, 1.52368E-04_JPRB, 1.77898E-04_JPRB, 2.07706E-04_JPRB, 2.42508E-04_JPRB, & + & 2.83141E-04_JPRB, 3.30583E-04_JPRB, 3.85974E-04_JPRB, 4.50646E-04_JPRB, 5.26153E-04_JPRB, & + & 6.14313E-04_JPRB, 7.17244E-04_JPRB, 8.37422E-04_JPRB, 9.77736E-04_JPRB, 1.14156E-03_JPRB, & + & 1.33283E-03_JPRB, 1.55616E-03_JPRB, 1.81690E-03_JPRB, 2.12133E-03_JPRB/) + KAO_MCO2( 7, :,14) = (/ & + & 1.32820E-04_JPRB, 1.55041E-04_JPRB, 1.80980E-04_JPRB, 2.11259E-04_JPRB, 2.46604E-04_JPRB, & + & 2.87862E-04_JPRB, 3.36022E-04_JPRB, 3.92240E-04_JPRB, 4.57864E-04_JPRB, 5.34467E-04_JPRB, & + & 6.23886E-04_JPRB, 7.28265E-04_JPRB, 8.50107E-04_JPRB, 9.92334E-04_JPRB, 1.15836E-03_JPRB, & + & 1.35215E-03_JPRB, 1.57838E-03_JPRB, 1.84244E-03_JPRB, 2.15069E-03_JPRB/) + KAO_MCO2( 8, :,14) = (/ & + & 1.40203E-04_JPRB, 1.63590E-04_JPRB, 1.90879E-04_JPRB, 2.22720E-04_JPRB, 2.59872E-04_JPRB, & + & 3.03221E-04_JPRB, 3.53801E-04_JPRB, 4.12819E-04_JPRB, 4.81681E-04_JPRB, 5.62031E-04_JPRB, & + & 6.55783E-04_JPRB, 7.65175E-04_JPRB, 8.92814E-04_JPRB, 1.04174E-03_JPRB, 1.21552E-03_JPRB, & + & 1.41828E-03_JPRB, 1.65486E-03_JPRB, 1.93091E-03_JPRB, 2.25301E-03_JPRB/) + KAO_MCO2( 9, :,14) = (/ & + & 1.30642E-04_JPRB, 1.52513E-04_JPRB, 1.78046E-04_JPRB, 2.07853E-04_JPRB, 2.42651E-04_JPRB, & + & 2.83275E-04_JPRB, 3.30699E-04_JPRB, 3.86063E-04_JPRB, 4.50696E-04_JPRB, 5.26149E-04_JPRB, & + & 6.14234E-04_JPRB, 7.17066E-04_JPRB, 8.37113E-04_JPRB, 9.77259E-04_JPRB, 1.14087E-03_JPRB, & + & 1.33186E-03_JPRB, 1.55484E-03_JPRB, 1.81514E-03_JPRB, 2.11902E-03_JPRB/) + KAO_MCO2( 1, :,15) = (/ & + & 1.37603E-03_JPRB, 1.64035E-03_JPRB, 1.95543E-03_JPRB, 2.33105E-03_JPRB, 2.77881E-03_JPRB, & + & 3.31257E-03_JPRB, 3.94887E-03_JPRB, 4.70739E-03_JPRB, 5.61162E-03_JPRB, 6.68952E-03_JPRB, & + & 7.97449E-03_JPRB, 9.50627E-03_JPRB, 1.13323E-02_JPRB, 1.35091E-02_JPRB, 1.61039E-02_JPRB, & + & 1.91973E-02_JPRB, 2.28848E-02_JPRB, 2.72806E-02_JPRB, 3.25208E-02_JPRB/) + KAO_MCO2( 2, :,15) = (/ & + & 1.67843E-04_JPRB, 1.93707E-04_JPRB, 2.23557E-04_JPRB, 2.58007E-04_JPRB, 2.97765E-04_JPRB, & + & 3.43650E-04_JPRB, 3.96606E-04_JPRB, 4.57722E-04_JPRB, 5.28256E-04_JPRB, 6.09659E-04_JPRB, & + & 7.03606E-04_JPRB, 8.12031E-04_JPRB, 9.37163E-04_JPRB, 1.08158E-03_JPRB, 1.24825E-03_JPRB, & + & 1.44060E-03_JPRB, 1.66259E-03_JPRB, 1.91880E-03_JPRB, 2.21448E-03_JPRB/) + KAO_MCO2( 3, :,15) = (/ & + & 1.67595E-04_JPRB, 1.93410E-04_JPRB, 2.23200E-04_JPRB, 2.57579E-04_JPRB, 2.97253E-04_JPRB, & + & 3.43039E-04_JPRB, 3.95876E-04_JPRB, 4.56852E-04_JPRB, 5.27220E-04_JPRB, 6.08426E-04_JPRB, & + & 7.02141E-04_JPRB, 8.10291E-04_JPRB, 9.35098E-04_JPRB, 1.07913E-03_JPRB, 1.24534E-03_JPRB, & + & 1.43716E-03_JPRB, 1.65853E-03_JPRB, 1.91398E-03_JPRB, 2.20879E-03_JPRB/) + KAO_MCO2( 4, :,15) = (/ & + & 1.67354E-04_JPRB, 1.93130E-04_JPRB, 2.22877E-04_JPRB, 2.57206E-04_JPRB, 2.96823E-04_JPRB, & + & 3.42541E-04_JPRB, 3.95301E-04_JPRB, 4.56187E-04_JPRB, 5.26452E-04_JPRB, 6.07539E-04_JPRB, & + & 7.01116E-04_JPRB, 8.09106E-04_JPRB, 9.33728E-04_JPRB, 1.07755E-03_JPRB, 1.24352E-03_JPRB, & + & 1.43505E-03_JPRB, 1.65608E-03_JPRB, 1.91116E-03_JPRB, 2.20553E-03_JPRB/) + KAO_MCO2( 5, :,15) = (/ & + & 1.67437E-04_JPRB, 1.93232E-04_JPRB, 2.23002E-04_JPRB, 2.57358E-04_JPRB, 2.97006E-04_JPRB, & + & 3.42763E-04_JPRB, 3.95570E-04_JPRB, 4.56511E-04_JPRB, 5.26842E-04_JPRB, 6.08007E-04_JPRB, & + & 7.01677E-04_JPRB, 8.09778E-04_JPRB, 9.34533E-04_JPRB, 1.07851E-03_JPRB, 1.24466E-03_JPRB, & + & 1.43642E-03_JPRB, 1.65771E-03_JPRB, 1.91310E-03_JPRB, 2.20783E-03_JPRB/) + KAO_MCO2( 6, :,15) = (/ & + & 1.67267E-04_JPRB, 1.93027E-04_JPRB, 2.22753E-04_JPRB, 2.57057E-04_JPRB, 2.96645E-04_JPRB, & + & 3.42328E-04_JPRB, 3.95047E-04_JPRB, 4.55885E-04_JPRB, 5.26092E-04_JPRB, 6.07110E-04_JPRB, & + & 7.00606E-04_JPRB, 8.08500E-04_JPRB, 9.33010E-04_JPRB, 1.07669E-03_JPRB, 1.24251E-03_JPRB, & + & 1.43385E-03_JPRB, 1.65467E-03_JPRB, 1.90949E-03_JPRB, 2.20355E-03_JPRB/) + KAO_MCO2( 7, :,15) = (/ & + & 1.67354E-04_JPRB, 1.93130E-04_JPRB, 2.22877E-04_JPRB, 2.57206E-04_JPRB, 2.96823E-04_JPRB, & + & 3.42541E-04_JPRB, 3.95301E-04_JPRB, 4.56187E-04_JPRB, 5.26452E-04_JPRB, 6.07539E-04_JPRB, & + & 7.01116E-04_JPRB, 8.09106E-04_JPRB, 9.33728E-04_JPRB, 1.07755E-03_JPRB, 1.24352E-03_JPRB, & + & 1.43505E-03_JPRB, 1.65608E-03_JPRB, 1.91116E-03_JPRB, 2.20553E-03_JPRB/) + KAO_MCO2( 8, :,15) = (/ & + & 1.67276E-04_JPRB, 1.93038E-04_JPRB, 2.22769E-04_JPRB, 2.57079E-04_JPRB, 2.96673E-04_JPRB, & + & 3.42365E-04_JPRB, 3.95094E-04_JPRB, 4.55944E-04_JPRB, 5.26166E-04_JPRB, 6.07203E-04_JPRB, & + & 7.00722E-04_JPRB, 8.08643E-04_JPRB, 9.33186E-04_JPRB, 1.07691E-03_JPRB, 1.24277E-03_JPRB, & + & 1.43417E-03_JPRB, 1.65506E-03_JPRB, 1.90996E-03_JPRB, 2.20412E-03_JPRB/) + KAO_MCO2( 9, :,15) = (/ & + & 1.67437E-04_JPRB, 1.93232E-04_JPRB, 2.23002E-04_JPRB, 2.57358E-04_JPRB, 2.97006E-04_JPRB, & + & 3.42763E-04_JPRB, 3.95570E-04_JPRB, 4.56511E-04_JPRB, 5.26842E-04_JPRB, 6.08007E-04_JPRB, & + & 7.01677E-04_JPRB, 8.09778E-04_JPRB, 9.34533E-04_JPRB, 1.07851E-03_JPRB, 1.24466E-03_JPRB, & + & 1.43642E-03_JPRB, 1.65771E-03_JPRB, 1.91310E-03_JPRB, 2.20783E-03_JPRB/) + KAO_MCO2( 1, :,16) = (/ & + & 1.42104E-03_JPRB, 1.69791E-03_JPRB, 2.02872E-03_JPRB, 2.42399E-03_JPRB, 2.89626E-03_JPRB, & + & 3.46055E-03_JPRB, 4.13478E-03_JPRB, 4.94038E-03_JPRB, 5.90294E-03_JPRB, 7.05303E-03_JPRB, & + & 8.42720E-03_JPRB, 1.00691E-02_JPRB, 1.20309E-02_JPRB, 1.43749E-02_JPRB, 1.71757E-02_JPRB, & + & 2.05221E-02_JPRB, 2.45205E-02_JPRB, 2.92979E-02_JPRB, 3.50061E-02_JPRB/) + KAO_MCO2( 2, :,16) = (/ & + & 1.63777E-04_JPRB, 1.88736E-04_JPRB, 2.17498E-04_JPRB, 2.50643E-04_JPRB, 2.88839E-04_JPRB, & + & 3.32857E-04_JPRB, 3.83582E-04_JPRB, 4.42037E-04_JPRB, 5.09401E-04_JPRB, 5.87030E-04_JPRB, & + & 6.76490E-04_JPRB, 7.79583E-04_JPRB, 8.98386E-04_JPRB, 1.03530E-03_JPRB, 1.19307E-03_JPRB, & + & 1.37488E-03_JPRB, 1.58441E-03_JPRB, 1.82586E-03_JPRB, 2.10411E-03_JPRB/) + KAO_MCO2( 3, :,16) = (/ & + & 1.63679E-04_JPRB, 1.88621E-04_JPRB, 2.17365E-04_JPRB, 2.50489E-04_JPRB, 2.88661E-04_JPRB, & + & 3.32650E-04_JPRB, 3.83342E-04_JPRB, 4.41759E-04_JPRB, 5.09079E-04_JPRB, 5.86657E-04_JPRB, & + & 6.76057E-04_JPRB, 7.79080E-04_JPRB, 8.97804E-04_JPRB, 1.03462E-03_JPRB, 1.19228E-03_JPRB, & + & 1.37397E-03_JPRB, 1.58335E-03_JPRB, 1.82464E-03_JPRB, 2.10269E-03_JPRB/) + KAO_MCO2( 4, :,16) = (/ & + & 1.63679E-04_JPRB, 1.88621E-04_JPRB, 2.17365E-04_JPRB, 2.50489E-04_JPRB, 2.88661E-04_JPRB, & + & 3.32650E-04_JPRB, 3.83342E-04_JPRB, 4.41759E-04_JPRB, 5.09079E-04_JPRB, 5.86657E-04_JPRB, & + & 6.76057E-04_JPRB, 7.79080E-04_JPRB, 8.97804E-04_JPRB, 1.03462E-03_JPRB, 1.19228E-03_JPRB, & + & 1.37397E-03_JPRB, 1.58335E-03_JPRB, 1.82464E-03_JPRB, 2.10269E-03_JPRB/) + KAO_MCO2( 5, :,16) = (/ & + & 1.63586E-04_JPRB, 1.88513E-04_JPRB, 2.17239E-04_JPRB, 2.50343E-04_JPRB, 2.88490E-04_JPRB, & + & 3.32451E-04_JPRB, 3.83111E-04_JPRB, 4.41490E-04_JPRB, 5.08766E-04_JPRB, 5.86292E-04_JPRB, & + & 6.75633E-04_JPRB, 7.78588E-04_JPRB, 8.97231E-04_JPRB, 1.03395E-03_JPRB, 1.19151E-03_JPRB, & + & 1.37307E-03_JPRB, 1.58231E-03_JPRB, 1.82342E-03_JPRB, 2.10128E-03_JPRB/) + KAO_MCO2( 6, :,16) = (/ & + & 1.63679E-04_JPRB, 1.88621E-04_JPRB, 2.17365E-04_JPRB, 2.50489E-04_JPRB, 2.88661E-04_JPRB, & + & 3.32650E-04_JPRB, 3.83342E-04_JPRB, 4.41759E-04_JPRB, 5.09079E-04_JPRB, 5.86657E-04_JPRB, & + & 6.76057E-04_JPRB, 7.79080E-04_JPRB, 8.97804E-04_JPRB, 1.03462E-03_JPRB, 1.19228E-03_JPRB, & + & 1.37397E-03_JPRB, 1.58335E-03_JPRB, 1.82464E-03_JPRB, 2.10269E-03_JPRB/) + KAO_MCO2( 7, :,16) = (/ & + & 1.63679E-04_JPRB, 1.88621E-04_JPRB, 2.17365E-04_JPRB, 2.50489E-04_JPRB, 2.88661E-04_JPRB, & + & 3.32650E-04_JPRB, 3.83342E-04_JPRB, 4.41759E-04_JPRB, 5.09079E-04_JPRB, 5.86657E-04_JPRB, & + & 6.76057E-04_JPRB, 7.79080E-04_JPRB, 8.97804E-04_JPRB, 1.03462E-03_JPRB, 1.19228E-03_JPRB, & + & 1.37397E-03_JPRB, 1.58335E-03_JPRB, 1.82464E-03_JPRB, 2.10269E-03_JPRB/) + KAO_MCO2( 8, :,16) = (/ & + & 1.63479E-04_JPRB, 1.88391E-04_JPRB, 2.17098E-04_JPRB, 2.50180E-04_JPRB, 2.88303E-04_JPRB, & + & 3.32236E-04_JPRB, 3.82863E-04_JPRB, 4.41205E-04_JPRB, 5.08437E-04_JPRB, 5.85914E-04_JPRB, & + & 6.75198E-04_JPRB, 7.78087E-04_JPRB, 8.96654E-04_JPRB, 1.03329E-03_JPRB, 1.19074E-03_JPRB, & + & 1.37219E-03_JPRB, 1.58129E-03_JPRB, 1.82226E-03_JPRB, 2.09994E-03_JPRB/) + KAO_MCO2( 9, :,16) = (/ & + & 1.63586E-04_JPRB, 1.88513E-04_JPRB, 2.17239E-04_JPRB, 2.50343E-04_JPRB, 2.88490E-04_JPRB, & + & 3.32451E-04_JPRB, 3.83111E-04_JPRB, 4.41490E-04_JPRB, 5.08766E-04_JPRB, 5.86292E-04_JPRB, & + & 6.75633E-04_JPRB, 7.78588E-04_JPRB, 8.97231E-04_JPRB, 1.03395E-03_JPRB, 1.19151E-03_JPRB, & + & 1.37307E-03_JPRB, 1.58231E-03_JPRB, 1.82342E-03_JPRB, 2.10128E-03_JPRB/) + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + + KBO_MCO2(:, 1) = (/ & + & 3.72069E-06_JPRB, 4.81866E-06_JPRB, 6.24064E-06_JPRB, 8.08226E-06_JPRB, 1.04673E-05_JPRB, & + & 1.35562E-05_JPRB, 1.75567E-05_JPRB, 2.27376E-05_JPRB, 2.94475E-05_JPRB, 3.81375E-05_JPRB, & + & 4.93918E-05_JPRB, 6.39674E-05_JPRB, 8.28441E-05_JPRB, 1.07291E-04_JPRB, 1.38953E-04_JPRB, & + & 1.79958E-04_JPRB, 2.33064E-04_JPRB, 3.01840E-04_JPRB, 3.90913E-04_JPRB/) + KBO_MCO2(:, 2) = (/ & + & 8.14357E-06_JPRB, 1.06031E-05_JPRB, 1.38056E-05_JPRB, 1.79752E-05_JPRB, 2.34041E-05_JPRB, & + & 3.04728E-05_JPRB, 3.96763E-05_JPRB, 5.16596E-05_JPRB, 6.72622E-05_JPRB, 8.75770E-05_JPRB, & + & 1.14027E-04_JPRB, 1.48467E-04_JPRB, 1.93307E-04_JPRB, 2.51691E-04_JPRB, 3.27708E-04_JPRB, & + & 4.26685E-04_JPRB, 5.55555E-04_JPRB, 7.23346E-04_JPRB, 9.41814E-04_JPRB/) + KBO_MCO2(:, 3) = (/ & + & 1.09367E-05_JPRB, 1.42063E-05_JPRB, 1.84533E-05_JPRB, 2.39701E-05_JPRB, 3.11362E-05_JPRB, & + & 4.04446E-05_JPRB, 5.25358E-05_JPRB, 6.82417E-05_JPRB, 8.86432E-05_JPRB, 1.15144E-04_JPRB, & + & 1.49567E-04_JPRB, 1.94281E-04_JPRB, 2.52363E-04_JPRB, 3.27809E-04_JPRB, 4.25810E-04_JPRB, & + & 5.53109E-04_JPRB, 7.18466E-04_JPRB, 9.33256E-04_JPRB, 1.21226E-03_JPRB/) + KBO_MCO2(:, 4) = (/ & + & 1.76192E-05_JPRB, 2.27752E-05_JPRB, 2.94401E-05_JPRB, 3.80553E-05_JPRB, 4.91916E-05_JPRB, & + & 6.35867E-05_JPRB, 8.21944E-05_JPRB, 1.06247E-04_JPRB, 1.37339E-04_JPRB, 1.77529E-04_JPRB, & + & 2.29480E-04_JPRB, 2.96635E-04_JPRB, 3.83440E-04_JPRB, 4.95648E-04_JPRB, 6.40691E-04_JPRB, & + & 8.28180E-04_JPRB, 1.07054E-03_JPRB, 1.38381E-03_JPRB, 1.78876E-03_JPRB/) + KBO_MCO2(:, 5) = (/ & + & 3.72142E-05_JPRB, 4.78603E-05_JPRB, 6.15520E-05_JPRB, 7.91605E-05_JPRB, 1.01806E-04_JPRB, & + & 1.30931E-04_JPRB, 1.68387E-04_JPRB, 2.16558E-04_JPRB, 2.78510E-04_JPRB, 3.58185E-04_JPRB, & + & 4.60653E-04_JPRB, 5.92435E-04_JPRB, 7.61915E-04_JPRB, 9.79881E-04_JPRB, 1.26020E-03_JPRB, & + & 1.62071E-03_JPRB, 2.08436E-03_JPRB, 2.68064E-03_JPRB, 3.44751E-03_JPRB/) + KBO_MCO2(:, 6) = (/ & + & 7.74131E-05_JPRB, 9.98876E-05_JPRB, 1.28887E-04_JPRB, 1.66305E-04_JPRB, 2.14587E-04_JPRB, & + & 2.76886E-04_JPRB, 3.57272E-04_JPRB, 4.60994E-04_JPRB, 5.94831E-04_JPRB, 7.67521E-04_JPRB, & + & 9.90348E-04_JPRB, 1.27787E-03_JPRB, 1.64886E-03_JPRB, 2.12755E-03_JPRB, 2.74522E-03_JPRB, & + & 3.54221E-03_JPRB, 4.57059E-03_JPRB, 5.89752E-03_JPRB, 7.60968E-03_JPRB/) + KBO_MCO2(:, 7) = (/ & + & 1.32294E-04_JPRB, 1.70977E-04_JPRB, 2.20973E-04_JPRB, 2.85587E-04_JPRB, 3.69095E-04_JPRB, & + & 4.77022E-04_JPRB, 6.16507E-04_JPRB, 7.96779E-04_JPRB, 1.02976E-03_JPRB, 1.33088E-03_JPRB, & + & 1.72004E-03_JPRB, 2.22299E-03_JPRB, 2.87301E-03_JPRB, 3.71310E-03_JPRB, 4.79884E-03_JPRB, & + & 6.20207E-03_JPRB, 8.01561E-03_JPRB, 1.03594E-02_JPRB, 1.33886E-02_JPRB/) + KBO_MCO2(:, 8) = (/ & + & 3.59868E-05_JPRB, 4.63611E-05_JPRB, 5.97261E-05_JPRB, 7.69439E-05_JPRB, 9.91253E-05_JPRB, & + & 1.27701E-04_JPRB, 1.64515E-04_JPRB, 2.11941E-04_JPRB, 2.73040E-04_JPRB, 3.51752E-04_JPRB, & + & 4.53155E-04_JPRB, 5.83790E-04_JPRB, 7.52085E-04_JPRB, 9.68897E-04_JPRB, 1.24821E-03_JPRB, & + & 1.60804E-03_JPRB, 2.07161E-03_JPRB, 2.66882E-03_JPRB, 3.43818E-03_JPRB/) + KBO_MCO2(:, 9) = (/ & + & 5.09543E-05_JPRB, 6.60510E-05_JPRB, 8.56205E-05_JPRB, 1.10988E-04_JPRB, 1.43872E-04_JPRB, & + & 1.86498E-04_JPRB, 2.41753E-04_JPRB, 3.13380E-04_JPRB, 4.06228E-04_JPRB, 5.26585E-04_JPRB, & + & 6.82601E-04_JPRB, 8.84842E-04_JPRB, 1.14700E-03_JPRB, 1.48684E-03_JPRB, 1.92735E-03_JPRB, & + & 2.49839E-03_JPRB, 3.23861E-03_JPRB, 4.19814E-03_JPRB, 5.44196E-03_JPRB/) + KBO_MCO2(:,10) = (/ & + & 2.08253E-05_JPRB, 2.64900E-05_JPRB, 3.36954E-05_JPRB, 4.28609E-05_JPRB, 5.45194E-05_JPRB, & + & 6.93491E-05_JPRB, 8.82125E-05_JPRB, 1.12207E-04_JPRB, 1.42728E-04_JPRB, 1.81551E-04_JPRB, & + & 2.30935E-04_JPRB, 2.93751E-04_JPRB, 3.73653E-04_JPRB, 4.75290E-04_JPRB, 6.04572E-04_JPRB, & + & 7.69021E-04_JPRB, 9.78201E-04_JPRB, 1.24428E-03_JPRB, 1.58273E-03_JPRB/) + KBO_MCO2(:,11) = (/ & + & 2.08953E-05_JPRB, 2.65543E-05_JPRB, 3.37459E-05_JPRB, 4.28852E-05_JPRB, 5.44996E-05_JPRB, & + & 6.92595E-05_JPRB, 8.80169E-05_JPRB, 1.11854E-04_JPRB, 1.42147E-04_JPRB, 1.80644E-04_JPRB, & + & 2.29568E-04_JPRB, 2.91741E-04_JPRB, 3.70752E-04_JPRB, 4.71161E-04_JPRB, 5.98764E-04_JPRB, & + & 7.60925E-04_JPRB, 9.67005E-04_JPRB, 1.22889E-03_JPRB, 1.56171E-03_JPRB/) + KBO_MCO2(:,12) = (/ & + & 2.65295E-05_JPRB, 3.36318E-05_JPRB, 4.26356E-05_JPRB, 5.40498E-05_JPRB, 6.85198E-05_JPRB, & + & 8.68636E-05_JPRB, 1.10118E-04_JPRB, 1.39599E-04_JPRB, 1.76972E-04_JPRB, 2.24350E-04_JPRB, & + & 2.84412E-04_JPRB, 3.60553E-04_JPRB, 4.57079E-04_JPRB, 5.79446E-04_JPRB, 7.34572E-04_JPRB, & + & 9.31230E-04_JPRB, 1.18053E-03_JPRB, 1.49658E-03_JPRB, 1.89724E-03_JPRB/) + KBO_MCO2(:,13) = (/ & + & 3.45358E-05_JPRB, 4.36743E-05_JPRB, 5.52309E-05_JPRB, 6.98455E-05_JPRB, 8.83273E-05_JPRB, & + & 1.11700E-04_JPRB, 1.41256E-04_JPRB, 1.78634E-04_JPRB, 2.25902E-04_JPRB, 2.85678E-04_JPRB, & + & 3.61271E-04_JPRB, 4.56867E-04_JPRB, 5.77758E-04_JPRB, 7.30639E-04_JPRB, 9.23973E-04_JPRB, & + & 1.16847E-03_JPRB, 1.47765E-03_JPRB, 1.86865E-03_JPRB, 2.36311E-03_JPRB/) + KBO_MCO2(:,14) = (/ & + & 3.99721E-05_JPRB, 5.12343E-05_JPRB, 6.56698E-05_JPRB, 8.41725E-05_JPRB, 1.07888E-04_JPRB, & + & 1.38286E-04_JPRB, 1.77249E-04_JPRB, 2.27190E-04_JPRB, 2.91201E-04_JPRB, 3.73248E-04_JPRB, & + & 4.78412E-04_JPRB, 6.13207E-04_JPRB, 7.85980E-04_JPRB, 1.00743E-03_JPRB, 1.29128E-03_JPRB, & + & 1.65510E-03_JPRB, 2.12144E-03_JPRB, 2.71916E-03_JPRB, 3.48529E-03_JPRB/) + KBO_MCO2(:,15) = (/ & + & 8.51533E-06_JPRB, 1.23021E-05_JPRB, 1.77730E-05_JPRB, 2.56767E-05_JPRB, 3.70953E-05_JPRB, & + & 5.35918E-05_JPRB, 7.74243E-05_JPRB, 1.11855E-04_JPRB, 1.61598E-04_JPRB, 2.33461E-04_JPRB, & + & 3.37283E-04_JPRB, 4.87275E-04_JPRB, 7.03968E-04_JPRB, 1.01703E-03_JPRB, 1.46930E-03_JPRB, & + & 2.12271E-03_JPRB, 3.06670E-03_JPRB, 4.43047E-03_JPRB, 6.40072E-03_JPRB/) + KBO_MCO2(:,16) = (/ & + & 2.93050E-06_JPRB, 3.65298E-06_JPRB, 4.55358E-06_JPRB, 5.67622E-06_JPRB, 7.07564E-06_JPRB, & + & 8.82006E-06_JPRB, 1.09945E-05_JPRB, 1.37051E-05_JPRB, 1.70840E-05_JPRB, 2.12959E-05_JPRB, & + & 2.65461E-05_JPRB, 3.30908E-05_JPRB, 4.12490E-05_JPRB, 5.14185E-05_JPRB, 6.40952E-05_JPRB, & + & 7.98972E-05_JPRB, 9.95951E-05_JPRB, 1.24149E-04_JPRB, 1.54757E-04_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296_rb,260_rb,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &2.0677E-07_JPRB,2.0363E-07_JPRB,2.0583E-07_JPRB,2.0547E-07_JPRB,2.0267E-07_JPRB,2.0154E-07_JPRB, & + &2.0190E-07_JPRB,2.0103E-07_JPRB,1.9869E-07_JPRB,1.9663E-07_JPRB,1.9701E-07_JPRB,2.0103E-07_JPRB, & + &2.0527E-07_JPRB,2.0206E-07_JPRB,2.0364E-07_JPRB,2.0364E-07_JPRB/) + FORREFO(2,:) = (/ & + &2.2427E-07_JPRB,2.1489E-07_JPRB,2.0453E-07_JPRB,1.9710E-07_JPRB,1.9650E-07_JPRB,1.9738E-07_JPRB, & + &1.9767E-07_JPRB,1.9769E-07_JPRB,1.9940E-07_JPRB,1.9846E-07_JPRB,1.9898E-07_JPRB,1.9853E-07_JPRB, & + &2.0000E-07_JPRB,2.0517E-07_JPRB,2.0482E-07_JPRB,2.0482E-07_JPRB/) + FORREFO(3,:) = (/ & + &2.2672E-07_JPRB,2.1706E-07_JPRB,2.0571E-07_JPRB,1.9747E-07_JPRB,1.9706E-07_JPRB,1.9698E-07_JPRB, & + &1.9781E-07_JPRB,1.9774E-07_JPRB,1.9724E-07_JPRB,1.9714E-07_JPRB,1.9751E-07_JPRB,1.9758E-07_JPRB, & + &1.9840E-07_JPRB,1.9968E-07_JPRB,1.9931E-07_JPRB,1.9880E-07_JPRB/) + FORREFO(4,:) = (/ & + &2.2191E-07_JPRB,2.0899E-07_JPRB,2.0265E-07_JPRB,2.0101E-07_JPRB,2.0034E-07_JPRB,2.0021E-07_JPRB, & + &1.9987E-07_JPRB,1.9978E-07_JPRB,1.9902E-07_JPRB,1.9742E-07_JPRB,1.9672E-07_JPRB,1.9615E-07_JPRB, & + &1.9576E-07_JPRB,1.9540E-07_JPRB,1.9588E-07_JPRB,1.9590E-07_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 5.18832E-02_JPRB, 4.28690E-02_JPRB, 3.54210E-02_JPRB, 2.92670E-02_JPRB, 2.41822E-02_JPRB, & + & 1.99808E-02_JPRB, 1.65093E-02_JPRB, 1.36410E-02_JPRB, 1.12710E-02_JPRB, 9.31280E-03_JPRB/) + SELFREFO(:, 2) = (/ & + & 4.36030E-02_JPRB, 3.78379E-02_JPRB, 3.28350E-02_JPRB, 2.84936E-02_JPRB, 2.47262E-02_JPRB, & + & 2.14569E-02_JPRB, 1.86199E-02_JPRB, 1.61580E-02_JPRB, 1.40216E-02_JPRB, 1.21677E-02_JPRB/) + SELFREFO(:, 3) = (/ & + & 4.26492E-02_JPRB, 3.71443E-02_JPRB, 3.23500E-02_JPRB, 2.81745E-02_JPRB, 2.45379E-02_JPRB, & + & 2.13707E-02_JPRB, 1.86124E-02_JPRB, 1.62100E-02_JPRB, 1.41177E-02_JPRB, 1.22955E-02_JPRB/) + SELFREFO(:, 4) = (/ & + & 4.03591E-02_JPRB, 3.54614E-02_JPRB, 3.11580E-02_JPRB, 2.73769E-02_JPRB, 2.40546E-02_JPRB, & + & 2.11355E-02_JPRB, 1.85706E-02_JPRB, 1.63170E-02_JPRB, 1.43369E-02_JPRB, 1.25970E-02_JPRB/) + SELFREFO(:, 5) = (/ & + & 3.94512E-02_JPRB, 3.46232E-02_JPRB, 3.03860E-02_JPRB, 2.66674E-02_JPRB, 2.34038E-02_JPRB, & + & 2.05397E-02_JPRB, 1.80260E-02_JPRB, 1.58200E-02_JPRB, 1.38839E-02_JPRB, 1.21848E-02_JPRB/) + SELFREFO(:, 6) = (/ & + & 3.90567E-02_JPRB, 3.40694E-02_JPRB, 2.97190E-02_JPRB, 2.59241E-02_JPRB, 2.26138E-02_JPRB, & + & 1.97261E-02_JPRB, 1.72072E-02_JPRB, 1.50100E-02_JPRB, 1.30933E-02_JPRB, 1.14214E-02_JPRB/) + SELFREFO(:, 7) = (/ & + & 3.85397E-02_JPRB, 3.36462E-02_JPRB, 2.93740E-02_JPRB, 2.56443E-02_JPRB, 2.23881E-02_JPRB, & + & 1.95454E-02_JPRB, 1.70636E-02_JPRB, 1.48970E-02_JPRB, 1.30055E-02_JPRB, 1.13541E-02_JPRB/) + SELFREFO(:, 8) = (/ & + & 3.79692E-02_JPRB, 3.31360E-02_JPRB, 2.89180E-02_JPRB, 2.52369E-02_JPRB, 2.20245E-02_JPRB, & + & 1.92209E-02_JPRB, 1.67742E-02_JPRB, 1.46390E-02_JPRB, 1.27756E-02_JPRB, 1.11493E-02_JPRB/) + SELFREFO(:, 9) = (/ & + & 3.68819E-02_JPRB, 3.22827E-02_JPRB, 2.82570E-02_JPRB, 2.47333E-02_JPRB, 2.16490E-02_JPRB, & + & 1.89494E-02_JPRB, 1.65863E-02_JPRB, 1.45180E-02_JPRB, 1.27076E-02_JPRB, 1.11229E-02_JPRB/) + SELFREFO(:,10) = (/ & + & 3.65157E-02_JPRB, 3.20121E-02_JPRB, 2.80640E-02_JPRB, 2.46028E-02_JPRB, 2.15685E-02_JPRB, & + & 1.89084E-02_JPRB, 1.65764E-02_JPRB, 1.45320E-02_JPRB, 1.27397E-02_JPRB, 1.11685E-02_JPRB/) + SELFREFO(:,11) = (/ & + & 3.59917E-02_JPRB, 3.16727E-02_JPRB, 2.78720E-02_JPRB, 2.45274E-02_JPRB, 2.15841E-02_JPRB, & + & 1.89940E-02_JPRB, 1.67148E-02_JPRB, 1.47090E-02_JPRB, 1.29439E-02_JPRB, 1.13907E-02_JPRB/) + SELFREFO(:,12) = (/ & + & 3.66963E-02_JPRB, 3.20483E-02_JPRB, 2.79890E-02_JPRB, 2.44439E-02_JPRB, 2.13478E-02_JPRB, & + & 1.86438E-02_JPRB, 1.62824E-02_JPRB, 1.42200E-02_JPRB, 1.24189E-02_JPRB, 1.08459E-02_JPRB/) + SELFREFO(:,13) = (/ & + & 3.66422E-02_JPRB, 3.19026E-02_JPRB, 2.77760E-02_JPRB, 2.41832E-02_JPRB, 2.10551E-02_JPRB, & + & 1.83317E-02_JPRB, 1.59605E-02_JPRB, 1.38960E-02_JPRB, 1.20986E-02_JPRB, 1.05336E-02_JPRB/) + SELFREFO(:,14) = (/ & + & 3.81260E-02_JPRB, 3.29322E-02_JPRB, 2.84460E-02_JPRB, 2.45709E-02_JPRB, 2.12237E-02_JPRB, & + & 1.83325E-02_JPRB, 1.58352E-02_JPRB, 1.36780E-02_JPRB, 1.18147E-02_JPRB, 1.02052E-02_JPRB/) + SELFREFO(:,15) = (/ & + & 3.51264E-02_JPRB, 3.05081E-02_JPRB, 2.64970E-02_JPRB, 2.30133E-02_JPRB, 1.99876E-02_JPRB, & + & 1.73597E-02_JPRB, 1.50773E-02_JPRB, 1.30950E-02_JPRB, 1.13733E-02_JPRB, 9.87800E-03_JPRB/) + SELFREFO(:,16) = (/ & + & 3.51264E-02_JPRB, 3.05081E-02_JPRB, 2.64970E-02_JPRB, 2.30133E-02_JPRB, 1.99876E-02_JPRB, & + & 1.73597E-02_JPRB, 1.50773E-02_JPRB, 1.30950E-02_JPRB, 1.13733E-02_JPRB, 9.87800E-03_JPRB/) + + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB7',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE + +CALL ABOR1("RRTM_KGB7:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB7 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb8.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb8.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb8.F90 (revision 6016) @@ -0,0 +1,624 @@ +SUBROUTINE RRTM_KGB8 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 8: 1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD +USE YOMMP0 , ONLY : NPROC, MYPROC + +USE YOERRTO8 , ONLY : KAO ,KBO ,SELFREFO ,FORREFO,FRACREFAO ,& + & FRACREFBO, CFC12O ,CFC22ADJO ,KAO_MCO2,KBO_MCO2,& + & KAO_MN2O,KBO_MN2O,KAO_MO3 , KAO_D, KBO_D + + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB8',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB8:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB8:') +ENDIF + + +! Planck fraction mapping level : P=473.4280 mb, T = 259.83 K + FRACREFAO(:) = (/ & + & 1.6004E-01_JPRB,1.5437E-01_JPRB,1.4502E-01_JPRB,1.3084E-01_JPRB,1.1523E-01_JPRB,9.7743E-02_JPRB, & + & 8.0376E-02_JPRB,6.0261E-02_JPRB,4.1111E-02_JPRB,4.4772E-03_JPRB,3.6511E-03_JPRB,2.9154E-03_JPRB, & + & 2.1184E-03_JPRB,1.3048E-03_JPRB,4.6637E-04_JPRB,6.5624E-05_JPRB/) + +! Planck fraction mapping level : P=95.5835 mb, T= 215.7 K + FRACREFBO(:) = (/ & + & 1.4987E-01_JPRB,1.4665E-01_JPRB,1.4154E-01_JPRB,1.3200E-01_JPRB,1.1902E-01_JPRB,1.0352E-01_JPRB, & + & 8.4939E-02_JPRB,6.4105E-02_JPRB,4.3190E-02_JPRB,4.5129E-03_JPRB,3.7656E-03_JPRB,2.8733E-03_JPRB, & + & 2.0947E-03_JPRB,1.3201E-03_JPRB,5.1832E-04_JPRB,7.7473E-05_JPRB/) + +! 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 + +CFC12O( :) = (/& + & 85.4027_JPRB, 89.4696_JPRB, 74.0959_JPRB, 67.7480_JPRB,& + & 61.2444_JPRB, 59.9073_JPRB, 60.8296_JPRB, 63.0998_JPRB,& + & 59.6110_JPRB, 64.0735_JPRB, 57.2622_JPRB, 58.9721_JPRB,& + & 43.5505_JPRB, 26.1192_JPRB, 32.7023_JPRB, 32.8667_JPRB/) + +! Original CFC22 is multiplied by 1.485 to account for the 780-850 cm-1 +! and 1290-1335 cm-1 bands. +CFC22ADJO( :) = (/& + & 135.335_JPRB, 89.6642_JPRB, 76.2375_JPRB, 65.9748_JPRB,& + & 63.1164_JPRB, 60.2935_JPRB, 64.0299_JPRB, 75.4264_JPRB,& + & 51.3018_JPRB, 7.07911_JPRB, 5.86928_JPRB, 0.398693_JPRB,& + & 2.82885_JPRB, 9.12751_JPRB, 6.28271_JPRB, 0.0_JPRB/) + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. +! The array KA contains absorption coef5s at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the cooresponding TREF for this pressure level, +! JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The second index, JP, runs from 1 to 13 and refers +! to the corresponding pressure level in PREF (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The third index, IG, goes from 1 to 16, +! and tells us which "g-channel" the absorption coefficients are for. + + + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + + KAO_MCO2(:, 1) = (/ & + & 8.88964E-07_JPRB, 1.13087E-06_JPRB, 1.43861E-06_JPRB, 1.83010E-06_JPRB, 2.32811E-06_JPRB, & + & 2.96165E-06_JPRB, 3.76760E-06_JPRB, 4.79286E-06_JPRB, 6.09712E-06_JPRB, 7.75630E-06_JPRB, & + & 9.86699E-06_JPRB, 1.25521E-05_JPRB, 1.59678E-05_JPRB, 2.03130E-05_JPRB, 2.58407E-05_JPRB, & + & 3.28727E-05_JPRB, 4.18182E-05_JPRB, 5.31980E-05_JPRB, 6.76745E-05_JPRB/) + KAO_MCO2(:, 2) = (/ & + & 1.10492E-05_JPRB, 1.35003E-05_JPRB, 1.64952E-05_JPRB, 2.01545E-05_JPRB, 2.46256E-05_JPRB, & + & 3.00885E-05_JPRB, 3.67632E-05_JPRB, 4.49188E-05_JPRB, 5.48835E-05_JPRB, 6.70588E-05_JPRB, & + & 8.19351E-05_JPRB, 1.00111E-04_JPRB, 1.22320E-04_JPRB, 1.49455E-04_JPRB, 1.82610E-04_JPRB, & + & 2.23121E-04_JPRB, 2.72618E-04_JPRB, 3.33095E-04_JPRB, 4.06988E-04_JPRB/) + KAO_MCO2(:, 3) = (/ & + & 1.51034E-05_JPRB, 1.81249E-05_JPRB, 2.17508E-05_JPRB, 2.61020E-05_JPRB, 3.13238E-05_JPRB, & + & 3.75901E-05_JPRB, 4.51101E-05_JPRB, 5.41344E-05_JPRB, 6.49640E-05_JPRB, 7.79601E-05_JPRB, & + & 9.35562E-05_JPRB, 1.12272E-04_JPRB, 1.34732E-04_JPRB, 1.61686E-04_JPRB, 1.94031E-04_JPRB, & + & 2.32847E-04_JPRB, 2.79429E-04_JPRB, 3.35329E-04_JPRB, 4.02411E-04_JPRB/) + KAO_MCO2(:, 4) = (/ & + & 1.57088E-05_JPRB, 1.89537E-05_JPRB, 2.28688E-05_JPRB, 2.75928E-05_JPRB, 3.32924E-05_JPRB, & + & 4.01695E-05_JPRB, 4.84671E-05_JPRB, 5.84787E-05_JPRB, 7.05584E-05_JPRB, 8.51332E-05_JPRB, & + & 1.02719E-04_JPRB, 1.23937E-04_JPRB, 1.49538E-04_JPRB, 1.80427E-04_JPRB, 2.17697E-04_JPRB, & + & 2.62666E-04_JPRB, 3.16923E-04_JPRB, 3.82388E-04_JPRB, 4.61376E-04_JPRB/) + KAO_MCO2(:, 5) = (/ & + & 3.09299E-05_JPRB, 3.73196E-05_JPRB, 4.50294E-05_JPRB, 5.43320E-05_JPRB, 6.55563E-05_JPRB, & + & 7.90995E-05_JPRB, 9.54405E-05_JPRB, 1.15157E-04_JPRB, 1.38948E-04_JPRB, 1.67652E-04_JPRB, & + & 2.02288E-04_JPRB, 2.44078E-04_JPRB, 2.94501E-04_JPRB, 3.55342E-04_JPRB, 4.28751E-04_JPRB, & + & 5.17327E-04_JPRB, 6.24200E-04_JPRB, 7.53153E-04_JPRB, 9.08745E-04_JPRB/) + KAO_MCO2(:, 6) = (/ & + & 1.98653E-05_JPRB, 2.38878E-05_JPRB, 2.87248E-05_JPRB, 3.45413E-05_JPRB, 4.15355E-05_JPRB, & + & 4.99459E-05_JPRB, 6.00593E-05_JPRB, 7.22206E-05_JPRB, 8.68445E-05_JPRB, 1.04429E-04_JPRB, & + & 1.25575E-04_JPRB, 1.51003E-04_JPRB, 1.81579E-04_JPRB, 2.18346E-04_JPRB, 2.62559E-04_JPRB, & + & 3.15724E-04_JPRB, 3.79654E-04_JPRB, 4.56529E-04_JPRB, 5.48971E-04_JPRB/) + KAO_MCO2(:, 7) = (/ & + & 1.54276E-06_JPRB, 1.90144E-06_JPRB, 2.34351E-06_JPRB, 2.88836E-06_JPRB, 3.55989E-06_JPRB, & + & 4.38754E-06_JPRB, 5.40761E-06_JPRB, 6.66485E-06_JPRB, 8.21439E-06_JPRB, 1.01242E-05_JPRB, & + & 1.24780E-05_JPRB, 1.53790E-05_JPRB, 1.89546E-05_JPRB, 2.33614E-05_JPRB, 2.87928E-05_JPRB, & + & 3.54869E-05_JPRB, 4.37374E-05_JPRB, 5.39060E-05_JPRB, 6.64388E-05_JPRB/) + KAO_MCO2(:, 8) = (/ & + & 1.66907E-06_JPRB, 2.11106E-06_JPRB, 2.67008E-06_JPRB, 3.37714E-06_JPRB, 4.27143E-06_JPRB, & + & 5.40254E-06_JPRB, 6.83318E-06_JPRB, 8.64266E-06_JPRB, 1.09313E-05_JPRB, 1.38260E-05_JPRB, & + & 1.74872E-05_JPRB, 2.21180E-05_JPRB, 2.79750E-05_JPRB, 3.53830E-05_JPRB, 4.47527E-05_JPRB, & + & 5.66036E-05_JPRB, 7.15927E-05_JPRB, 9.05509E-05_JPRB, 1.14529E-04_JPRB/) + KAO_MCO2(:, 9) = (/ & + & 1.22817E-06_JPRB, 1.56416E-06_JPRB, 1.99206E-06_JPRB, 2.53703E-06_JPRB, 3.23108E-06_JPRB, & + & 4.11501E-06_JPRB, 5.24074E-06_JPRB, 6.67445E-06_JPRB, 8.50037E-06_JPRB, 1.08258E-05_JPRB, & + & 1.37874E-05_JPRB, 1.75592E-05_JPRB, 2.23629E-05_JPRB, 2.84807E-05_JPRB, 3.62721E-05_JPRB, & + & 4.61950E-05_JPRB, 5.88325E-05_JPRB, 7.49272E-05_JPRB, 9.54249E-05_JPRB/) + KAO_MCO2(:,10) = (/ & + & 3.45943E-08_JPRB, 3.84726E-08_JPRB, 4.27856E-08_JPRB, 4.75821E-08_JPRB, 5.29164E-08_JPRB, & + & 5.88487E-08_JPRB, 6.54460E-08_JPRB, 7.27829E-08_JPRB, 8.09423E-08_JPRB, 9.00164E-08_JPRB, & + & 1.00108E-07_JPRB, 1.11331E-07_JPRB, 1.23811E-07_JPRB, 1.37691E-07_JPRB, 1.53128E-07_JPRB, & + & 1.70294E-07_JPRB, 1.89385E-07_JPRB, 2.10616E-07_JPRB, 2.34228E-07_JPRB/) + KAO_MCO2(:,11) = (/ & + & 2.89971E-08_JPRB, 3.35110E-08_JPRB, 3.87275E-08_JPRB, 4.47561E-08_JPRB, 5.17230E-08_JPRB, & + & 5.97745E-08_JPRB, 6.90794E-08_JPRB, 7.98327E-08_JPRB, 9.22599E-08_JPRB, 1.06622E-07_JPRB, & + & 1.23219E-07_JPRB, 1.42400E-07_JPRB, 1.64567E-07_JPRB, 1.90184E-07_JPRB, 2.19789E-07_JPRB, & + & 2.54003E-07_JPRB, 2.93542E-07_JPRB, 3.39237E-07_JPRB, 3.92044E-07_JPRB/) + KAO_MCO2(:,12) = (/ & + & 2.51330E-08_JPRB, 2.96783E-08_JPRB, 3.50457E-08_JPRB, 4.13837E-08_JPRB, 4.88679E-08_JPRB, & + & 5.77056E-08_JPRB, 6.81416E-08_JPRB, 8.04650E-08_JPRB, 9.50171E-08_JPRB, 1.12201E-07_JPRB, & + & 1.32492E-07_JPRB, 1.56454E-07_JPRB, 1.84748E-07_JPRB, 2.18160E-07_JPRB, 2.57614E-07_JPRB, & + & 3.04203E-07_JPRB, 3.59218E-07_JPRB, 4.24182E-07_JPRB, 5.00895E-07_JPRB/) + KAO_MCO2(:,13) = (/ & + & 1.16966E-07_JPRB, 1.13960E-07_JPRB, 1.11032E-07_JPRB, 1.08179E-07_JPRB, 1.05400E-07_JPRB, & + & 1.02691E-07_JPRB, 1.00053E-07_JPRB, 9.74820E-08_JPRB, 9.49772E-08_JPRB, 9.25368E-08_JPRB, & + & 9.01591E-08_JPRB, 8.78425E-08_JPRB, 8.55854E-08_JPRB, 8.33863E-08_JPRB, 8.12437E-08_JPRB, & + & 7.91562E-08_JPRB, 7.71223E-08_JPRB, 7.51407E-08_JPRB, 7.32100E-08_JPRB/) + KAO_MCO2(:,14) = (/ & + & 9.17853E-08_JPRB, 8.94322E-08_JPRB, 8.71395E-08_JPRB, 8.49055E-08_JPRB, 8.27289E-08_JPRB, & + & 8.06080E-08_JPRB, 7.85415E-08_JPRB, 7.65279E-08_JPRB, 7.45660E-08_JPRB, 7.26544E-08_JPRB, & + & 7.07918E-08_JPRB, 6.89770E-08_JPRB, 6.72086E-08_JPRB, 6.54856E-08_JPRB, 6.38068E-08_JPRB, & + & 6.21710E-08_JPRB, 6.05772E-08_JPRB, 5.90242E-08_JPRB, 5.75110E-08_JPRB/) + KAO_MCO2(:,15) = (/ & + & 8.34607E-08_JPRB, 8.13236E-08_JPRB, 7.92413E-08_JPRB, 7.72122E-08_JPRB, 7.52351E-08_JPRB, & + & 7.33087E-08_JPRB, 7.14315E-08_JPRB, 6.96025E-08_JPRB, 6.78202E-08_JPRB, 6.60837E-08_JPRB, & + & 6.43915E-08_JPRB, 6.27427E-08_JPRB, 6.11361E-08_JPRB, 5.95707E-08_JPRB, 5.80453E-08_JPRB, & + & 5.65590E-08_JPRB, 5.51108E-08_JPRB, 5.36996E-08_JPRB, 5.23246E-08_JPRB/) + KAO_MCO2(:,16) = (/ & + & 8.34607E-08_JPRB, 8.13236E-08_JPRB, 7.92413E-08_JPRB, 7.72122E-08_JPRB, 7.52351E-08_JPRB, & + & 7.33087E-08_JPRB, 7.14315E-08_JPRB, 6.96025E-08_JPRB, 6.78202E-08_JPRB, 6.60837E-08_JPRB, & + & 6.43915E-08_JPRB, 6.27427E-08_JPRB, 6.11361E-08_JPRB, 5.95707E-08_JPRB, 5.80453E-08_JPRB, & + & 5.65590E-08_JPRB, 5.51108E-08_JPRB, 5.36996E-08_JPRB, 5.23246E-08_JPRB/) + + KAO_MO3(:, 1) = (/ & + & 1.18276E-01_JPRB, 1.18009E-01_JPRB, 1.17742E-01_JPRB, 1.17476E-01_JPRB, 1.17210E-01_JPRB, & + & 1.16945E-01_JPRB, 1.16681E-01_JPRB, 1.16417E-01_JPRB, 1.16153E-01_JPRB, 1.15891E-01_JPRB, & + & 1.15629E-01_JPRB, 1.15367E-01_JPRB, 1.15106E-01_JPRB, 1.14846E-01_JPRB, 1.14586E-01_JPRB, & + & 1.14327E-01_JPRB, 1.14069E-01_JPRB, 1.13811E-01_JPRB, 1.13553E-01_JPRB/) + KAO_MO3(:, 2) = (/ & + & 1.83777E-01_JPRB, 1.84268E-01_JPRB, 1.84761E-01_JPRB, 1.85255E-01_JPRB, 1.85751E-01_JPRB, & + & 1.86248E-01_JPRB, 1.86746E-01_JPRB, 1.87245E-01_JPRB, 1.87746E-01_JPRB, 1.88248E-01_JPRB, & + & 1.88752E-01_JPRB, 1.89257E-01_JPRB, 1.89763E-01_JPRB, 1.90270E-01_JPRB, 1.90779E-01_JPRB, & + & 1.91290E-01_JPRB, 1.91801E-01_JPRB, 1.92314E-01_JPRB, 1.92829E-01_JPRB/) + KAO_MO3(:, 3) = (/ & + & 2.33414E-01_JPRB, 2.34511E-01_JPRB, 2.35614E-01_JPRB, 2.36722E-01_JPRB, 2.37836E-01_JPRB, & + & 2.38954E-01_JPRB, 2.40078E-01_JPRB, 2.41207E-01_JPRB, 2.42342E-01_JPRB, 2.43481E-01_JPRB, & + & 2.44626E-01_JPRB, 2.45777E-01_JPRB, 2.46933E-01_JPRB, 2.48094E-01_JPRB, 2.49261E-01_JPRB, & + & 2.50433E-01_JPRB, 2.51611E-01_JPRB, 2.52794E-01_JPRB, 2.53983E-01_JPRB/) + KAO_MO3(:, 4) = (/ & + & 2.84906E-01_JPRB, 2.87358E-01_JPRB, 2.89832E-01_JPRB, 2.92328E-01_JPRB, 2.94844E-01_JPRB, & + & 2.97383E-01_JPRB, 2.99943E-01_JPRB, 3.02525E-01_JPRB, 3.05130E-01_JPRB, 3.07757E-01_JPRB, & + & 3.10406E-01_JPRB, 3.13078E-01_JPRB, 3.15774E-01_JPRB, 3.18492E-01_JPRB, 3.21234E-01_JPRB, & + & 3.24000E-01_JPRB, 3.26789E-01_JPRB, 3.29603E-01_JPRB, 3.32440E-01_JPRB/) + KAO_MO3(:, 5) = (/ & + & 3.40508E-01_JPRB, 3.44095E-01_JPRB, 3.47720E-01_JPRB, 3.51383E-01_JPRB, 3.55084E-01_JPRB, & + & 3.58824E-01_JPRB, 3.62604E-01_JPRB, 3.66424E-01_JPRB, 3.70284E-01_JPRB, 3.74184E-01_JPRB, & + & 3.78126E-01_JPRB, 3.82109E-01_JPRB, 3.86134E-01_JPRB, 3.90202E-01_JPRB, 3.94312E-01_JPRB, & + & 3.98466E-01_JPRB, 4.02663E-01_JPRB, 4.06905E-01_JPRB, 4.11191E-01_JPRB/) + KAO_MO3(:, 6) = (/ & + & 3.78368E-01_JPRB, 3.83690E-01_JPRB, 3.89086E-01_JPRB, 3.94558E-01_JPRB, 4.00107E-01_JPRB, & + & 4.05735E-01_JPRB, 4.11441E-01_JPRB, 4.17227E-01_JPRB, 4.23095E-01_JPRB, 4.29046E-01_JPRB, & + & 4.35080E-01_JPRB, 4.41199E-01_JPRB, 4.47404E-01_JPRB, 4.53697E-01_JPRB, 4.60078E-01_JPRB, & + & 4.66548E-01_JPRB, 4.73110E-01_JPRB, 4.79764E-01_JPRB, 4.86511E-01_JPRB/) + KAO_MO3(:, 7) = (/ & + & 4.51965E-01_JPRB, 4.58461E-01_JPRB, 4.65051E-01_JPRB, 4.71735E-01_JPRB, 4.78516E-01_JPRB, & + & 4.85394E-01_JPRB, 4.92371E-01_JPRB, 4.99448E-01_JPRB, 5.06627E-01_JPRB, 5.13909E-01_JPRB, & + & 5.21296E-01_JPRB, 5.28789E-01_JPRB, 5.36390E-01_JPRB, 5.44100E-01_JPRB, 5.51920E-01_JPRB, & + & 5.59854E-01_JPRB, 5.67901E-01_JPRB, 5.76064E-01_JPRB, 5.84344E-01_JPRB/) + KAO_MO3(:, 8) = (/ & + & 3.00557E-01_JPRB, 3.03974E-01_JPRB, 3.07430E-01_JPRB, 3.10925E-01_JPRB, 3.14460E-01_JPRB, & + & 3.18035E-01_JPRB, 3.21651E-01_JPRB, 3.25307E-01_JPRB, 3.29006E-01_JPRB, 3.32746E-01_JPRB, & + & 3.36529E-01_JPRB, 3.40355E-01_JPRB, 3.44224E-01_JPRB, 3.48137E-01_JPRB, 3.52095E-01_JPRB, & + & 3.56098E-01_JPRB, 3.60146E-01_JPRB, 3.64241E-01_JPRB, 3.68381E-01_JPRB/) + KAO_MO3(:, 9) = (/ & + & 2.10042E-01_JPRB, 2.12905E-01_JPRB, 2.15806E-01_JPRB, 2.18748E-01_JPRB, 2.21729E-01_JPRB, & + & 2.24751E-01_JPRB, 2.27814E-01_JPRB, 2.30919E-01_JPRB, 2.34066E-01_JPRB, 2.37256E-01_JPRB, & + & 2.40489E-01_JPRB, 2.43767E-01_JPRB, 2.47089E-01_JPRB, 2.50457E-01_JPRB, 2.53870E-01_JPRB, & + & 2.57330E-01_JPRB, 2.60837E-01_JPRB, 2.64392E-01_JPRB, 2.67996E-01_JPRB/) + KAO_MO3(:,10) = (/ & + & 2.09288E-01_JPRB, 2.11759E-01_JPRB, 2.14259E-01_JPRB, 2.16789E-01_JPRB, 2.19349E-01_JPRB, & + & 2.21939E-01_JPRB, 2.24559E-01_JPRB, 2.27210E-01_JPRB, 2.29893E-01_JPRB, 2.32607E-01_JPRB, & + & 2.35354E-01_JPRB, 2.38133E-01_JPRB, 2.40944E-01_JPRB, 2.43789E-01_JPRB, 2.46667E-01_JPRB, & + & 2.49580E-01_JPRB, 2.52527E-01_JPRB, 2.55508E-01_JPRB, 2.58525E-01_JPRB/) + KAO_MO3(:,11) = (/ & + & 2.28947E-01_JPRB, 2.30609E-01_JPRB, 2.32283E-01_JPRB, 2.33969E-01_JPRB, 2.35667E-01_JPRB, & + & 2.37378E-01_JPRB, 2.39101E-01_JPRB, 2.40836E-01_JPRB, 2.42584E-01_JPRB, 2.44345E-01_JPRB, & + & 2.46118E-01_JPRB, 2.47905E-01_JPRB, 2.49704E-01_JPRB, 2.51516E-01_JPRB, 2.53342E-01_JPRB, & + & 2.55181E-01_JPRB, 2.57033E-01_JPRB, 2.58899E-01_JPRB, 2.60778E-01_JPRB/) + KAO_MO3(:,12) = (/ & + & 2.57263E-01_JPRB, 2.58272E-01_JPRB, 2.59285E-01_JPRB, 2.60302E-01_JPRB, 2.61323E-01_JPRB, & + & 2.62347E-01_JPRB, 2.63376E-01_JPRB, 2.64409E-01_JPRB, 2.65446E-01_JPRB, 2.66487E-01_JPRB, & + & 2.67532E-01_JPRB, 2.68581E-01_JPRB, 2.69635E-01_JPRB, 2.70692E-01_JPRB, 2.71753E-01_JPRB, & + & 2.72819E-01_JPRB, 2.73889E-01_JPRB, 2.74963E-01_JPRB, 2.76042E-01_JPRB/) + KAO_MO3(:,13) = (/ & + & 2.43322E-01_JPRB, 2.45918E-01_JPRB, 2.48541E-01_JPRB, 2.51192E-01_JPRB, 2.53872E-01_JPRB, & + & 2.56580E-01_JPRB, 2.59317E-01_JPRB, 2.62083E-01_JPRB, 2.64879E-01_JPRB, 2.67704E-01_JPRB, & + & 2.70560E-01_JPRB, 2.73446E-01_JPRB, 2.76363E-01_JPRB, 2.79311E-01_JPRB, 2.82290E-01_JPRB, & + & 2.85302E-01_JPRB, 2.88345E-01_JPRB, 2.91421E-01_JPRB, 2.94529E-01_JPRB/) + KAO_MO3(:,14) = (/ & + & 2.10568E-01_JPRB, 2.16529E-01_JPRB, 2.22660E-01_JPRB, 2.28964E-01_JPRB, 2.35446E-01_JPRB, & + & 2.42113E-01_JPRB, 2.48967E-01_JPRB, 2.56016E-01_JPRB, 2.63265E-01_JPRB, 2.70719E-01_JPRB, & + & 2.78383E-01_JPRB, 2.86265E-01_JPRB, 2.94370E-01_JPRB, 3.02704E-01_JPRB, 3.11275E-01_JPRB, & + & 3.20088E-01_JPRB, 3.29150E-01_JPRB, 3.38470E-01_JPRB, 3.48052E-01_JPRB/) + KAO_MO3(:,15) = (/ & + & 2.60406E-02_JPRB, 2.78779E-02_JPRB, 2.98448E-02_JPRB, 3.19505E-02_JPRB, 3.42048E-02_JPRB, & + & 3.66181E-02_JPRB, 3.92017E-02_JPRB, 4.19675E-02_JPRB, 4.49285E-02_JPRB, 4.80985E-02_JPRB, & + & 5.14920E-02_JPRB, 5.51250E-02_JPRB, 5.90143E-02_JPRB, 6.31781E-02_JPRB, 6.76356E-02_JPRB, & + & 7.24076E-02_JPRB, 7.75163E-02_JPRB, 8.29854E-02_JPRB, 8.88404E-02_JPRB/) + KAO_MO3(:,16) = (/ & + & 2.31483E-02_JPRB, 2.46840E-02_JPRB, 2.63217E-02_JPRB, 2.80681E-02_JPRB, 2.99302E-02_JPRB, & + & 3.19160E-02_JPRB, 3.40335E-02_JPRB, 3.62914E-02_JPRB, 3.86992E-02_JPRB, 4.12668E-02_JPRB, & + & 4.40046E-02_JPRB, 4.69242E-02_JPRB, 5.00374E-02_JPRB, 5.33571E-02_JPRB, 5.68971E-02_JPRB, & + & 6.06720E-02_JPRB, 6.46974E-02_JPRB, 6.89897E-02_JPRB, 7.35669E-02_JPRB/) + + KAO_MN2O(:, 1) = (/ & + & 3.02276E-02_JPRB, 3.10321E-02_JPRB, 3.18580E-02_JPRB, 3.27059E-02_JPRB, 3.35764E-02_JPRB, & + & 3.44700E-02_JPRB, 3.53875E-02_JPRB, 3.63293E-02_JPRB, 3.72962E-02_JPRB, 3.82889E-02_JPRB, & + & 3.93079E-02_JPRB, 4.03541E-02_JPRB, 4.14281E-02_JPRB, 4.25307E-02_JPRB, 4.36627E-02_JPRB, & + & 4.48248E-02_JPRB, 4.60178E-02_JPRB, 4.72425E-02_JPRB, 4.84999E-02_JPRB/) + KAO_MN2O(:, 2) = (/ & + & 6.10132E-02_JPRB, 6.17435E-02_JPRB, 6.24825E-02_JPRB, 6.32304E-02_JPRB, 6.39872E-02_JPRB, & + & 6.47531E-02_JPRB, 6.55281E-02_JPRB, 6.63124E-02_JPRB, 6.71061E-02_JPRB, 6.79093E-02_JPRB, & + & 6.87221E-02_JPRB, 6.95446E-02_JPRB, 7.03770E-02_JPRB, 7.12194E-02_JPRB, 7.20718E-02_JPRB, & + & 7.29344E-02_JPRB, 7.38074E-02_JPRB, 7.46908E-02_JPRB, 7.55848E-02_JPRB/) + KAO_MN2O(:, 3) = (/ & + & 1.04479E-01_JPRB, 1.05566E-01_JPRB, 1.06664E-01_JPRB, 1.07774E-01_JPRB, 1.08895E-01_JPRB, & + & 1.10028E-01_JPRB, 1.11173E-01_JPRB, 1.12329E-01_JPRB, 1.13498E-01_JPRB, 1.14679E-01_JPRB, & + & 1.15872E-01_JPRB, 1.17077E-01_JPRB, 1.18295E-01_JPRB, 1.19526E-01_JPRB, 1.20770E-01_JPRB, & + & 1.22026E-01_JPRB, 1.23296E-01_JPRB, 1.24578E-01_JPRB, 1.25875E-01_JPRB/) + KAO_MN2O(:, 4) = (/ & + & 2.07260E-01_JPRB, 2.08126E-01_JPRB, 2.08996E-01_JPRB, 2.09869E-01_JPRB, 2.10746E-01_JPRB, & + & 2.11627E-01_JPRB, 2.12511E-01_JPRB, 2.13399E-01_JPRB, 2.14291E-01_JPRB, 2.15187E-01_JPRB, & + & 2.16086E-01_JPRB, 2.16989E-01_JPRB, 2.17896E-01_JPRB, 2.18807E-01_JPRB, 2.19721E-01_JPRB, & + & 2.20640E-01_JPRB, 2.21562E-01_JPRB, 2.22488E-01_JPRB, 2.23418E-01_JPRB/) + KAO_MN2O(:, 5) = (/ & + & 3.71566E-01_JPRB, 3.71353E-01_JPRB, 3.71141E-01_JPRB, 3.70928E-01_JPRB, 3.70716E-01_JPRB, & + & 3.70504E-01_JPRB, 3.70292E-01_JPRB, 3.70080E-01_JPRB, 3.69869E-01_JPRB, 3.69657E-01_JPRB, & + & 3.69446E-01_JPRB, 3.69234E-01_JPRB, 3.69023E-01_JPRB, 3.68812E-01_JPRB, 3.68601E-01_JPRB, & + & 3.68390E-01_JPRB, 3.68179E-01_JPRB, 3.67969E-01_JPRB, 3.67758E-01_JPRB/) + KAO_MN2O(:, 6) = (/ & + & 5.28092E-01_JPRB, 5.27262E-01_JPRB, 5.26433E-01_JPRB, 5.25605E-01_JPRB, 5.24779E-01_JPRB, & + & 5.23954E-01_JPRB, 5.23130E-01_JPRB, 5.22307E-01_JPRB, 5.21486E-01_JPRB, 5.20666E-01_JPRB, & + & 5.19847E-01_JPRB, 5.19030E-01_JPRB, 5.18214E-01_JPRB, 5.17399E-01_JPRB, 5.16586E-01_JPRB, & + & 5.15773E-01_JPRB, 5.14962E-01_JPRB, 5.14153E-01_JPRB, 5.13344E-01_JPRB/) + KAO_MN2O(:, 7) = (/ & + & 3.88140E-01_JPRB, 3.87956E-01_JPRB, 3.87773E-01_JPRB, 3.87590E-01_JPRB, 3.87407E-01_JPRB, & + & 3.87224E-01_JPRB, 3.87041E-01_JPRB, 3.86858E-01_JPRB, 3.86675E-01_JPRB, 3.86492E-01_JPRB, & + & 3.86310E-01_JPRB, 3.86127E-01_JPRB, 3.85945E-01_JPRB, 3.85763E-01_JPRB, 3.85580E-01_JPRB, & + & 3.85398E-01_JPRB, 3.85216E-01_JPRB, 3.85034E-01_JPRB, 3.84852E-01_JPRB/) + KAO_MN2O(:, 8) = (/ & + & 3.12991E-01_JPRB, 3.12246E-01_JPRB, 3.11504E-01_JPRB, 3.10763E-01_JPRB, 3.10024E-01_JPRB, & + & 3.09287E-01_JPRB, 3.08552E-01_JPRB, 3.07818E-01_JPRB, 3.07086E-01_JPRB, 3.06356E-01_JPRB, & + & 3.05628E-01_JPRB, 3.04901E-01_JPRB, 3.04176E-01_JPRB, 3.03453E-01_JPRB, 3.02732E-01_JPRB, & + & 3.02012E-01_JPRB, 3.01294E-01_JPRB, 3.00577E-01_JPRB, 2.99863E-01_JPRB/) + KAO_MN2O(:, 9) = (/ & + & 4.11761E-01_JPRB, 4.11309E-01_JPRB, 4.10858E-01_JPRB, 4.10407E-01_JPRB, 4.09957E-01_JPRB, & + & 4.09507E-01_JPRB, 4.09057E-01_JPRB, 4.08608E-01_JPRB, 4.08160E-01_JPRB, 4.07712E-01_JPRB, & + & 4.07265E-01_JPRB, 4.06818E-01_JPRB, 4.06371E-01_JPRB, 4.05925E-01_JPRB, 4.05480E-01_JPRB, & + & 4.05035E-01_JPRB, 4.04590E-01_JPRB, 4.04146E-01_JPRB, 4.03703E-01_JPRB/) + KAO_MN2O(:,10) = (/ & + & 2.84648E-01_JPRB, 2.87025E-01_JPRB, 2.89421E-01_JPRB, 2.91838E-01_JPRB, 2.94275E-01_JPRB, & + & 2.96732E-01_JPRB, 2.99210E-01_JPRB, 3.01708E-01_JPRB, 3.04227E-01_JPRB, 3.06768E-01_JPRB, & + & 3.09329E-01_JPRB, 3.11912E-01_JPRB, 3.14517E-01_JPRB, 3.17143E-01_JPRB, 3.19791E-01_JPRB, & + & 3.22461E-01_JPRB, 3.25154E-01_JPRB, 3.27869E-01_JPRB, 3.30606E-01_JPRB/) + KAO_MN2O(:,11) = (/ & + & 2.75090E-01_JPRB, 2.79370E-01_JPRB, 2.83716E-01_JPRB, 2.88129E-01_JPRB, 2.92611E-01_JPRB, & + & 2.97163E-01_JPRB, 3.01786E-01_JPRB, 3.06480E-01_JPRB, 3.11248E-01_JPRB, 3.16090E-01_JPRB, & + & 3.21007E-01_JPRB, 3.26001E-01_JPRB, 3.31072E-01_JPRB, 3.36222E-01_JPRB, 3.41452E-01_JPRB, & + & 3.46764E-01_JPRB, 3.52158E-01_JPRB, 3.57636E-01_JPRB, 3.63200E-01_JPRB/) + KAO_MN2O(:,12) = (/ & + & 1.67753E-01_JPRB, 1.71386E-01_JPRB, 1.75098E-01_JPRB, 1.78890E-01_JPRB, 1.82765E-01_JPRB, & + & 1.86723E-01_JPRB, 1.90767E-01_JPRB, 1.94899E-01_JPRB, 1.99120E-01_JPRB, 2.03433E-01_JPRB, & + & 2.07839E-01_JPRB, 2.12340E-01_JPRB, 2.16939E-01_JPRB, 2.21638E-01_JPRB, 2.26438E-01_JPRB, & + & 2.31342E-01_JPRB, 2.36353E-01_JPRB, 2.41472E-01_JPRB, 2.46701E-01_JPRB/) + KAO_MN2O(:,13) = (/ & + & 1.40543E-01_JPRB, 1.42049E-01_JPRB, 1.43571E-01_JPRB, 1.45109E-01_JPRB, 1.46663E-01_JPRB, & + & 1.48234E-01_JPRB, 1.49822E-01_JPRB, 1.51427E-01_JPRB, 1.53049E-01_JPRB, 1.54689E-01_JPRB, & + & 1.56346E-01_JPRB, 1.58021E-01_JPRB, 1.59713E-01_JPRB, 1.61424E-01_JPRB, 1.63153E-01_JPRB, & + & 1.64901E-01_JPRB, 1.66668E-01_JPRB, 1.68453E-01_JPRB, 1.70258E-01_JPRB/) + KAO_MN2O(:,14) = (/ & + & 1.51530E-01_JPRB, 1.50944E-01_JPRB, 1.50360E-01_JPRB, 1.49779E-01_JPRB, 1.49199E-01_JPRB, & + & 1.48622E-01_JPRB, 1.48047E-01_JPRB, 1.47474E-01_JPRB, 1.46903E-01_JPRB, 1.46335E-01_JPRB, & + & 1.45769E-01_JPRB, 1.45205E-01_JPRB, 1.44643E-01_JPRB, 1.44083E-01_JPRB, 1.43526E-01_JPRB, & + & 1.42971E-01_JPRB, 1.42418E-01_JPRB, 1.41867E-01_JPRB, 1.41318E-01_JPRB/) + KAO_MN2O(:,15) = (/ & + & 2.20492E-01_JPRB, 2.16479E-01_JPRB, 2.12539E-01_JPRB, 2.08671E-01_JPRB, 2.04873E-01_JPRB, & + & 2.01145E-01_JPRB, 1.97484E-01_JPRB, 1.93890E-01_JPRB, 1.90361E-01_JPRB, 1.86897E-01_JPRB, & + & 1.83495E-01_JPRB, 1.80156E-01_JPRB, 1.76877E-01_JPRB, 1.73658E-01_JPRB, 1.70497E-01_JPRB, & + & 1.67394E-01_JPRB, 1.64348E-01_JPRB, 1.61356E-01_JPRB, 1.58420E-01_JPRB/) + KAO_MN2O(:,16) = (/ & + & 2.19848E-01_JPRB, 2.15847E-01_JPRB, 2.11919E-01_JPRB, 2.08062E-01_JPRB, 2.04275E-01_JPRB, & + & 2.00558E-01_JPRB, 1.96908E-01_JPRB, 1.93324E-01_JPRB, 1.89806E-01_JPRB, 1.86351E-01_JPRB, & + & 1.82960E-01_JPRB, 1.79630E-01_JPRB, 1.76361E-01_JPRB, 1.73151E-01_JPRB, 1.70000E-01_JPRB, & + & 1.66906E-01_JPRB, 1.63868E-01_JPRB, 1.60886E-01_JPRB, 1.57958E-01_JPRB/) + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + + KBO_MCO2(:, 1) = (/ & + & 4.74280E-08_JPRB, 6.62724E-08_JPRB, 9.26042E-08_JPRB, 1.29398E-07_JPRB, 1.80812E-07_JPRB, & + & 2.52653E-07_JPRB, 3.53039E-07_JPRB, 4.93310E-07_JPRB, 6.89316E-07_JPRB, 9.63198E-07_JPRB, & + & 1.34590E-06_JPRB, 1.88067E-06_JPRB, 2.62790E-06_JPRB, 3.67204E-06_JPRB, 5.13104E-06_JPRB, & + & 7.16974E-06_JPRB, 1.00185E-05_JPRB, 1.39991E-05_JPRB, 1.95613E-05_JPRB/) + KBO_MCO2(:, 2) = (/ & + & 1.14872E-07_JPRB, 1.63356E-07_JPRB, 2.32304E-07_JPRB, 3.30352E-07_JPRB, 4.69783E-07_JPRB, & + & 6.68064E-07_JPRB, 9.50033E-07_JPRB, 1.35101E-06_JPRB, 1.92123E-06_JPRB, 2.73213E-06_JPRB, & + & 3.88527E-06_JPRB, 5.52513E-06_JPRB, 7.85711E-06_JPRB, 1.11734E-05_JPRB, 1.58893E-05_JPRB, & + & 2.25957E-05_JPRB, 3.21326E-05_JPRB, 4.56948E-05_JPRB, 6.49811E-05_JPRB/) + KBO_MCO2(:, 3) = (/ & + & 3.30676E-07_JPRB, 4.76313E-07_JPRB, 6.86094E-07_JPRB, 9.88267E-07_JPRB, 1.42353E-06_JPRB, & + & 2.05048E-06_JPRB, 2.95356E-06_JPRB, 4.25439E-06_JPRB, 6.12813E-06_JPRB, 8.82711E-06_JPRB, & + & 1.27148E-05_JPRB, 1.83147E-05_JPRB, 2.63810E-05_JPRB, 3.79998E-05_JPRB, 5.47359E-05_JPRB, & + & 7.88430E-05_JPRB, 1.13568E-04_JPRB, 1.63585E-04_JPRB, 2.35632E-04_JPRB/) + KBO_MCO2(:, 4) = (/ & + & 6.58642E-07_JPRB, 9.52761E-07_JPRB, 1.37822E-06_JPRB, 1.99368E-06_JPRB, 2.88396E-06_JPRB, & + & 4.17181E-06_JPRB, 6.03475E-06_JPRB, 8.72960E-06_JPRB, 1.26279E-05_JPRB, 1.82669E-05_JPRB, & + & 2.64241E-05_JPRB, 3.82239E-05_JPRB, 5.52929E-05_JPRB, 7.99844E-05_JPRB, 1.15702E-04_JPRB, & + & 1.67369E-04_JPRB, 2.42109E-04_JPRB, 3.50223E-04_JPRB, 5.06617E-04_JPRB/) + KBO_MCO2(:, 5) = (/ & + & 1.26418E-06_JPRB, 1.82095E-06_JPRB, 2.62292E-06_JPRB, 3.77810E-06_JPRB, 5.44204E-06_JPRB, & + & 7.83881E-06_JPRB, 1.12911E-05_JPRB, 1.62640E-05_JPRB, 2.34269E-05_JPRB, 3.37445E-05_JPRB, & + & 4.86061E-05_JPRB, 7.00131E-05_JPRB, 1.00848E-04_JPRB, 1.45263E-04_JPRB, 2.09239E-04_JPRB, & + & 3.01392E-04_JPRB, 4.34131E-04_JPRB, 6.25329E-04_JPRB, 9.00733E-04_JPRB/) + KBO_MCO2(:, 6) = (/ & + & 2.38529E-06_JPRB, 3.43110E-06_JPRB, 4.93545E-06_JPRB, 7.09937E-06_JPRB, 1.02120E-05_JPRB, & + & 1.46895E-05_JPRB, 2.11300E-05_JPRB, 3.03943E-05_JPRB, 4.37205E-05_JPRB, 6.28894E-05_JPRB, & + & 9.04630E-05_JPRB, 1.30126E-04_JPRB, 1.87179E-04_JPRB, 2.69247E-04_JPRB, 3.87296E-04_JPRB, & + & 5.57104E-04_JPRB, 8.01364E-04_JPRB, 1.15272E-03_JPRB, 1.65812E-03_JPRB/) + KBO_MCO2(:, 7) = (/ & + & 5.41398E-06_JPRB, 7.54295E-06_JPRB, 1.05091E-05_JPRB, 1.46417E-05_JPRB, 2.03993E-05_JPRB, & + & 2.84211E-05_JPRB, 3.95973E-05_JPRB, 5.51683E-05_JPRB, 7.68626E-05_JPRB, 1.07088E-04_JPRB, & + & 1.49199E-04_JPRB, 2.07869E-04_JPRB, 2.89610E-04_JPRB, 4.03496E-04_JPRB, 5.62165E-04_JPRB, & + & 7.83229E-04_JPRB, 1.09122E-03_JPRB, 1.52033E-03_JPRB, 2.11818E-03_JPRB/) + KBO_MCO2(:, 8) = (/ & + & 1.09995E-05_JPRB, 1.54018E-05_JPRB, 2.15660E-05_JPRB, 3.01973E-05_JPRB, 4.22831E-05_JPRB, & + & 5.92059E-05_JPRB, 8.29017E-05_JPRB, 1.16081E-04_JPRB, 1.62540E-04_JPRB, 2.27592E-04_JPRB, & + & 3.18681E-04_JPRB, 4.46226E-04_JPRB, 6.24817E-04_JPRB, 8.74886E-04_JPRB, 1.22504E-03_JPRB, & + & 1.71533E-03_JPRB, 2.40185E-03_JPRB, 3.36313E-03_JPRB, 4.70915E-03_JPRB/) + KBO_MCO2(:, 9) = (/ & + & 3.29051E-05_JPRB, 4.59996E-05_JPRB, 6.43050E-05_JPRB, 8.98950E-05_JPRB, 1.25668E-04_JPRB, & + & 1.75678E-04_JPRB, 2.45588E-04_JPRB, 3.43319E-04_JPRB, 4.79942E-04_JPRB, 6.70933E-04_JPRB, & + & 9.37930E-04_JPRB, 1.31118E-03_JPRB, 1.83295E-03_JPRB, 2.56237E-03_JPRB, 3.58206E-03_JPRB, & + & 5.00753E-03_JPRB, 7.00027E-03_JPRB, 9.78599E-03_JPRB, 1.36803E-02_JPRB/) + KBO_MCO2(:,10) = (/ & + & 1.95126E-05_JPRB, 2.65944E-05_JPRB, 3.62463E-05_JPRB, 4.94013E-05_JPRB, 6.73305E-05_JPRB, & + & 9.17669E-05_JPRB, 1.25072E-04_JPRB, 1.70465E-04_JPRB, 2.32332E-04_JPRB, 3.16652E-04_JPRB, & + & 4.31575E-04_JPRB, 5.88208E-04_JPRB, 8.01687E-04_JPRB, 1.09264E-03_JPRB, 1.48920E-03_JPRB, & + & 2.02968E-03_JPRB, 2.76631E-03_JPRB, 3.77029E-03_JPRB, 5.13865E-03_JPRB/) + KBO_MCO2(:,11) = (/ & + & 8.67271E-05_JPRB, 1.19228E-04_JPRB, 1.63908E-04_JPRB, 2.25332E-04_JPRB, 3.09774E-04_JPRB, & + & 4.25860E-04_JPRB, 5.85450E-04_JPRB, 8.04845E-04_JPRB, 1.10646E-03_JPRB, 1.52110E-03_JPRB, & + & 2.09112E-03_JPRB, 2.87476E-03_JPRB, 3.95207E-03_JPRB, 5.43309E-03_JPRB, 7.46911E-03_JPRB, & + & 1.02681E-02_JPRB, 1.41161E-02_JPRB, 1.94060E-02_JPRB, 2.66783E-02_JPRB/) + KBO_MCO2(:,12) = (/ & + & 3.79194E-07_JPRB, 5.51419E-07_JPRB, 8.01866E-07_JPRB, 1.16606E-06_JPRB, 1.69567E-06_JPRB, & + & 2.46582E-06_JPRB, 3.58577E-06_JPRB, 5.21438E-06_JPRB, 7.58268E-06_JPRB, 1.10266E-05_JPRB, & + & 1.60348E-05_JPRB, 2.33176E-05_JPRB, 3.39081E-05_JPRB, 4.93087E-05_JPRB, 7.17040E-05_JPRB, & + & 1.04271E-04_JPRB, 1.51630E-04_JPRB, 2.20498E-04_JPRB, 3.20644E-04_JPRB/) + KBO_MCO2(:,13) = (/ & + & 1.72555E-07_JPRB, 2.29952E-07_JPRB, 3.06441E-07_JPRB, 4.08373E-07_JPRB, 5.44209E-07_JPRB, & + & 7.25229E-07_JPRB, 9.66461E-07_JPRB, 1.28793E-06_JPRB, 1.71634E-06_JPRB, 2.28724E-06_JPRB, & + & 3.04805E-06_JPRB, 4.06192E-06_JPRB, 5.41303E-06_JPRB, 7.21356E-06_JPRB, 9.61299E-06_JPRB, & + & 1.28106E-05_JPRB, 1.70717E-05_JPRB, 2.27503E-05_JPRB, 3.03177E-05_JPRB/) + KBO_MCO2(:,14) = (/ & + & 7.42245E-09_JPRB, 7.17780E-09_JPRB, 6.94122E-09_JPRB, 6.71243E-09_JPRB, 6.49118E-09_JPRB, & + & 6.27723E-09_JPRB, 6.07032E-09_JPRB, 5.87024E-09_JPRB, 5.67675E-09_JPRB, 5.48964E-09_JPRB, & + & 5.30870E-09_JPRB, 5.13372E-09_JPRB, 4.96451E-09_JPRB, 4.80087E-09_JPRB, 4.64263E-09_JPRB, & + & 4.48961E-09_JPRB, 4.34163E-09_JPRB, 4.19852E-09_JPRB, 4.06014E-09_JPRB/) + KBO_MCO2(:,15) = (/ & + & 7.41847E-09_JPRB, 7.17332E-09_JPRB, 6.93627E-09_JPRB, 6.70705E-09_JPRB, 6.48541E-09_JPRB, & + & 6.27109E-09_JPRB, 6.06386E-09_JPRB, 5.86347E-09_JPRB, 5.66970E-09_JPRB, 5.48234E-09_JPRB, & + & 5.30117E-09_JPRB, 5.12599E-09_JPRB, 4.95659E-09_JPRB, 4.79280E-09_JPRB, 4.63441E-09_JPRB, & + & 4.48126E-09_JPRB, 4.33317E-09_JPRB, 4.18998E-09_JPRB, 4.05152E-09_JPRB/) + KBO_MCO2(:,16) = (/ & + & 7.42855E-09_JPRB, 7.18278E-09_JPRB, 6.94513E-09_JPRB, 6.71535E-09_JPRB, 6.49317E-09_JPRB, & + & 6.27834E-09_JPRB, 6.07062E-09_JPRB, 5.86977E-09_JPRB, 5.67557E-09_JPRB, 5.48779E-09_JPRB, & + & 5.30622E-09_JPRB, 5.13066E-09_JPRB, 4.96091E-09_JPRB, 4.79678E-09_JPRB, 4.63808E-09_JPRB, & + & 4.48462E-09_JPRB, 4.33625E-09_JPRB, 4.19278E-09_JPRB, 4.05406E-09_JPRB/) + + KBO_MN2O(:, 1) = (/ & + & 2.49055E-04_JPRB, 2.53574E-04_JPRB, 2.58175E-04_JPRB, 2.62860E-04_JPRB, 2.67629E-04_JPRB, & + & 2.72485E-04_JPRB, 2.77429E-04_JPRB, 2.82463E-04_JPRB, 2.87588E-04_JPRB, 2.92806E-04_JPRB, & + & 2.98119E-04_JPRB, 3.03528E-04_JPRB, 3.09036E-04_JPRB, 3.14643E-04_JPRB, 3.20352E-04_JPRB, & + & 3.26165E-04_JPRB, 3.32083E-04_JPRB, 3.38109E-04_JPRB, 3.44243E-04_JPRB/) + KBO_MN2O(:, 2) = (/ & + & 3.79251E-04_JPRB, 4.04353E-04_JPRB, 4.31117E-04_JPRB, 4.59652E-04_JPRB, 4.90075E-04_JPRB, & + & 5.22513E-04_JPRB, 5.57097E-04_JPRB, 5.93970E-04_JPRB, 6.33284E-04_JPRB, 6.75200E-04_JPRB, & + & 7.19890E-04_JPRB, 7.67539E-04_JPRB, 8.18340E-04_JPRB, 8.72505E-04_JPRB, 9.30255E-04_JPRB, & + & 9.91827E-04_JPRB, 1.05747E-03_JPRB, 1.12747E-03_JPRB, 1.20209E-03_JPRB/) + KBO_MN2O(:, 3) = (/ & + & 7.61140E-04_JPRB, 8.36483E-04_JPRB, 9.19284E-04_JPRB, 1.01028E-03_JPRB, 1.11029E-03_JPRB, & + & 1.22019E-03_JPRB, 1.34098E-03_JPRB, 1.47372E-03_JPRB, 1.61959E-03_JPRB, 1.77991E-03_JPRB, & + & 1.95610E-03_JPRB, 2.14973E-03_JPRB, 2.36253E-03_JPRB, 2.59639E-03_JPRB, 2.85340E-03_JPRB, & + & 3.13585E-03_JPRB, 3.44626E-03_JPRB, 3.78740E-03_JPRB, 4.16230E-03_JPRB/) + KBO_MN2O(:, 4) = (/ & + & 2.01074E-03_JPRB, 2.26915E-03_JPRB, 2.56077E-03_JPRB, 2.88987E-03_JPRB, 3.26126E-03_JPRB, & + & 3.68038E-03_JPRB, 4.15337E-03_JPRB, 4.68714E-03_JPRB, 5.28951E-03_JPRB, 5.96929E-03_JPRB, & + & 6.73643E-03_JPRB, 7.60217E-03_JPRB, 8.57916E-03_JPRB, 9.68172E-03_JPRB, 1.09260E-02_JPRB, & + & 1.23301E-02_JPRB, 1.39147E-02_JPRB, 1.57030E-02_JPRB, 1.77211E-02_JPRB/) + KBO_MN2O(:, 5) = (/ & + & 7.43302E-03_JPRB, 8.32582E-03_JPRB, 9.32585E-03_JPRB, 1.04460E-02_JPRB, 1.17007E-02_JPRB, & + & 1.31061E-02_JPRB, 1.46803E-02_JPRB, 1.64436E-02_JPRB, 1.84186E-02_JPRB, 2.06309E-02_JPRB, & + & 2.31090E-02_JPRB, 2.58846E-02_JPRB, 2.89937E-02_JPRB, 3.24762E-02_JPRB, 3.63769E-02_JPRB, & + & 4.07463E-02_JPRB, 4.56404E-02_JPRB, 5.11223E-02_JPRB, 5.72627E-02_JPRB/) + KBO_MN2O(:, 6) = (/ & + & 2.71911E-02_JPRB, 2.94258E-02_JPRB, 3.18441E-02_JPRB, 3.44612E-02_JPRB, 3.72933E-02_JPRB, & + & 4.03582E-02_JPRB, 4.36750E-02_JPRB, 4.72644E-02_JPRB, 5.11487E-02_JPRB, 5.53523E-02_JPRB, & + & 5.99014E-02_JPRB, 6.48243E-02_JPRB, 7.01518E-02_JPRB, 7.59172E-02_JPRB, 8.21563E-02_JPRB, & + & 8.89082E-02_JPRB, 9.62150E-02_JPRB, 1.04122E-01_JPRB, 1.12679E-01_JPRB/) + KBO_MN2O(:, 7) = (/ & + & 1.63331E-01_JPRB, 1.80469E-01_JPRB, 1.99406E-01_JPRB, 2.20330E-01_JPRB, 2.43449E-01_JPRB, & + & 2.68995E-01_JPRB, 2.97221E-01_JPRB, 3.28408E-01_JPRB, 3.62869E-01_JPRB, 4.00945E-01_JPRB, & + & 4.43017E-01_JPRB, 4.89503E-01_JPRB, 5.40867E-01_JPRB, 5.97621E-01_JPRB, 6.60330E-01_JPRB, & + & 7.29619E-01_JPRB, 8.06179E-01_JPRB, 8.90772E-01_JPRB, 9.84242E-01_JPRB/) + KBO_MN2O(:, 8) = (/ & + & 1.32648E+00_JPRB, 1.33515E+00_JPRB, 1.34387E+00_JPRB, 1.35265E+00_JPRB, 1.36149E+00_JPRB, & + & 1.37038E+00_JPRB, 1.37933E+00_JPRB, 1.38835E+00_JPRB, 1.39742E+00_JPRB, 1.40655E+00_JPRB, & + & 1.41574E+00_JPRB, 1.42499E+00_JPRB, 1.43429E+00_JPRB, 1.44367E+00_JPRB, 1.45310E+00_JPRB, & + & 1.46259E+00_JPRB, 1.47215E+00_JPRB, 1.48176E+00_JPRB, 1.49144E+00_JPRB/) + KBO_MN2O(:, 9) = (/ & + & 3.12620E+00_JPRB, 3.03118E+00_JPRB, 2.93905E+00_JPRB, 2.84972E+00_JPRB, 2.76310E+00_JPRB, & + & 2.67911E+00_JPRB, 2.59768E+00_JPRB, 2.51873E+00_JPRB, 2.44217E+00_JPRB, 2.36794E+00_JPRB, & + & 2.29596E+00_JPRB, 2.22618E+00_JPRB, 2.15851E+00_JPRB, 2.09290E+00_JPRB, 2.02929E+00_JPRB, & + & 1.96761E+00_JPRB, 1.90780E+00_JPRB, 1.84982E+00_JPRB, 1.79359E+00_JPRB/) + KBO_MN2O(:,10) = (/ & + & 1.60677E-02_JPRB, 1.82485E-02_JPRB, 2.07254E-02_JPRB, 2.35384E-02_JPRB, 2.67332E-02_JPRB, & + & 3.03617E-02_JPRB, 3.44827E-02_JPRB, 3.91629E-02_JPRB, 4.44785E-02_JPRB, 5.05154E-02_JPRB, & + & 5.73718E-02_JPRB, 6.51589E-02_JPRB, 7.40027E-02_JPRB, 8.40470E-02_JPRB, 9.54546E-02_JPRB, & + & 1.08411E-01_JPRB, 1.23125E-01_JPRB, 1.39836E-01_JPRB, 1.58816E-01_JPRB/) + KBO_MN2O(:,11) = (/ & + & 1.55287E-02_JPRB, 1.78265E-02_JPRB, 2.04642E-02_JPRB, 2.34922E-02_JPRB, 2.69683E-02_JPRB, & + & 3.09588E-02_JPRB, 3.55397E-02_JPRB, 4.07984E-02_JPRB, 4.68352E-02_JPRB, 5.37653E-02_JPRB, & + & 6.17208E-02_JPRB, 7.08535E-02_JPRB, 8.13375E-02_JPRB, 9.33728E-02_JPRB, 1.07189E-01_JPRB, & + & 1.23049E-01_JPRB, 1.41257E-01_JPRB, 1.62158E-01_JPRB, 1.86152E-01_JPRB/) + KBO_MN2O(:,12) = (/ & + & 7.13719E-03_JPRB, 8.18879E-03_JPRB, 9.39535E-03_JPRB, 1.07797E-02_JPRB, 1.23680E-02_JPRB, & + & 1.41903E-02_JPRB, 1.62811E-02_JPRB, 1.86800E-02_JPRB, 2.14324E-02_JPRB, 2.45902E-02_JPRB, & + & 2.82134E-02_JPRB, 3.23704E-02_JPRB, 3.71400E-02_JPRB, 4.26122E-02_JPRB, 4.88908E-02_JPRB, & + & 5.60945E-02_JPRB, 6.43596E-02_JPRB, 7.38424E-02_JPRB, 8.47224E-02_JPRB/) + KBO_MN2O(:,13) = (/ & + & 9.28813E-03_JPRB, 1.06108E-02_JPRB, 1.21218E-02_JPRB, 1.38480E-02_JPRB, 1.58199E-02_JPRB, & + & 1.80727E-02_JPRB, 2.06463E-02_JPRB, 2.35864E-02_JPRB, 2.69452E-02_JPRB, 3.07822E-02_JPRB, & + & 3.51657E-02_JPRB, 4.01734E-02_JPRB, 4.58941E-02_JPRB, 5.24296E-02_JPRB, 5.98956E-02_JPRB, & + & 6.84249E-02_JPRB, 7.81688E-02_JPRB, 8.93002E-02_JPRB, 1.02017E-01_JPRB/) + KBO_MN2O(:,14) = (/ & + & 2.17205E-02_JPRB, 2.51661E-02_JPRB, 2.91581E-02_JPRB, 3.37835E-02_JPRB, 3.91425E-02_JPRB, & + & 4.53517E-02_JPRB, 5.25458E-02_JPRB, 6.08811E-02_JPRB, 7.05387E-02_JPRB, 8.17282E-02_JPRB, & + & 9.46927E-02_JPRB, 1.09714E-01_JPRB, 1.27118E-01_JPRB, 1.47282E-01_JPRB, 1.70645E-01_JPRB, & + & 1.97715E-01_JPRB, 2.29078E-01_JPRB, 2.65417E-01_JPRB, 3.07520E-01_JPRB/) + KBO_MN2O(:,15) = (/ & + & 4.89156E-02_JPRB, 5.70504E-02_JPRB, 6.65379E-02_JPRB, 7.76033E-02_JPRB, 9.05089E-02_JPRB, & + & 1.05561E-01_JPRB, 1.23116E-01_JPRB, 1.43590E-01_JPRB, 1.67469E-01_JPRB, 1.95320E-01_JPRB, & + & 2.27802E-01_JPRB, 2.65686E-01_JPRB, 3.09869E-01_JPRB, 3.61401E-01_JPRB, 4.21503E-01_JPRB, & + & 4.91600E-01_JPRB, 5.73354E-01_JPRB, 6.68703E-01_JPRB, 7.79910E-01_JPRB/) + KBO_MN2O(:,16) = (/ & + & 1.13156E-02_JPRB, 1.46199E-02_JPRB, 1.88891E-02_JPRB, 2.44050E-02_JPRB, 3.15316E-02_JPRB, & + & 4.07393E-02_JPRB, 5.26358E-02_JPRB, 6.80061E-02_JPRB, 8.78649E-02_JPRB, 1.13523E-01_JPRB, & + & 1.46673E-01_JPRB, 1.89504E-01_JPRB, 2.44841E-01_JPRB, 3.16338E-01_JPRB, 4.08713E-01_JPRB, & + & 5.28064E-01_JPRB, 6.82266E-01_JPRB, 8.81496E-01_JPRB, 1.13891E+00_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &4.8166E-07_JPRB,3.7500E-07_JPRB,4.8978E-07_JPRB,5.9624E-07_JPRB,6.3742E-07_JPRB,7.5551E-07_JPRB, & + &7.7706E-07_JPRB,6.8681E-07_JPRB,7.5212E-07_JPRB,8.0956E-07_JPRB,7.8117E-07_JPRB,7.4835E-07_JPRB, & + &9.4118E-07_JPRB,1.2585E-06_JPRB,1.4976E-06_JPRB,1.4976E-06_JPRB/) + FORREFO(2,:) = (/ & + &3.1320E-07_JPRB,4.0764E-07_JPRB,4.7468E-07_JPRB,5.9976E-07_JPRB,7.3324E-07_JPRB,8.1488E-07_JPRB, & + &7.6442E-07_JPRB,8.2007E-07_JPRB,7.7721E-07_JPRB,7.6377E-07_JPRB,8.0327E-07_JPRB,7.1881E-07_JPRB, & + &8.2148E-07_JPRB,1.0203E-06_JPRB,1.5033E-06_JPRB,1.5032E-06_JPRB/) + FORREFO(3,:) = (/ & + &4.1831E-07_JPRB,5.5043E-07_JPRB,5.7783E-07_JPRB,6.1294E-07_JPRB,6.3396E-07_JPRB,6.2292E-07_JPRB, & + &6.1719E-07_JPRB,6.4183E-07_JPRB,7.6180E-07_JPRB,9.5477E-07_JPRB,9.5901E-07_JPRB,1.0207E-06_JPRB, & + &1.0387E-06_JPRB,1.1305E-06_JPRB,1.3602E-06_JPRB,1.5063E-06_JPRB/) + FORREFO(4,:) = (/ & + &8.5878E-07_JPRB,6.0921E-07_JPRB,5.5773E-07_JPRB,5.3374E-07_JPRB,5.0495E-07_JPRB,4.9844E-07_JPRB, & + &5.1536E-07_JPRB,5.2908E-07_JPRB,4.7977E-07_JPRB,5.3177E-07_JPRB,4.9266E-07_JPRB,4.5403E-07_JPRB, & + &3.9695E-07_JPRB,3.4792E-07_JPRB,3.4912E-07_JPRB,3.4102E-07_JPRB/) + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 3.16029E-02_JPRB, 2.74633E-02_JPRB, 2.38660E-02_JPRB, 2.07399E-02_JPRB, 1.80232E-02_JPRB, & + & 1.56624E-02_JPRB, 1.36108E-02_JPRB, 1.18280E-02_JPRB, 1.02787E-02_JPRB, 8.93231E-03_JPRB/) + SELFREFO(:, 2) = (/ & + & 3.10422E-02_JPRB, 2.71312E-02_JPRB, 2.37130E-02_JPRB, 2.07254E-02_JPRB, 1.81142E-02_JPRB, & + & 1.58320E-02_JPRB, 1.38374E-02_JPRB, 1.20940E-02_JPRB, 1.05703E-02_JPRB, 9.23854E-03_JPRB/) + SELFREFO(:, 3) = (/ & + & 3.08657E-02_JPRB, 2.69431E-02_JPRB, 2.35190E-02_JPRB, 2.05301E-02_JPRB, 1.79210E-02_JPRB, & + & 1.56435E-02_JPRB, 1.36554E-02_JPRB, 1.19200E-02_JPRB, 1.04051E-02_JPRB, 9.08279E-03_JPRB/) + SELFREFO(:, 4) = (/ & + & 3.02668E-02_JPRB, 2.64686E-02_JPRB, 2.31470E-02_JPRB, 2.02422E-02_JPRB, 1.77020E-02_JPRB, & + & 1.54806E-02_JPRB, 1.35379E-02_JPRB, 1.18390E-02_JPRB, 1.03533E-02_JPRB, 9.05406E-03_JPRB/) + SELFREFO(:, 5) = (/ & + & 2.98317E-02_JPRB, 2.61491E-02_JPRB, 2.29210E-02_JPRB, 2.00914E-02_JPRB, 1.76112E-02_JPRB, & + & 1.54371E-02_JPRB, 1.35314E-02_JPRB, 1.18610E-02_JPRB, 1.03968E-02_JPRB, 9.11332E-03_JPRB/) + SELFREFO(:, 6) = (/ & + & 2.95545E-02_JPRB, 2.59083E-02_JPRB, 2.27120E-02_JPRB, 1.99100E-02_JPRB, 1.74537E-02_JPRB, & + & 1.53004E-02_JPRB, 1.34128E-02_JPRB, 1.17580E-02_JPRB, 1.03074E-02_JPRB, 9.03576E-03_JPRB/) + SELFREFO(:, 7) = (/ & + & 2.97352E-02_JPRB, 2.60320E-02_JPRB, 2.27900E-02_JPRB, 1.99517E-02_JPRB, 1.74670E-02_JPRB, & + & 1.52916E-02_JPRB, 1.33872E-02_JPRB, 1.17200E-02_JPRB, 1.02604E-02_JPRB, 8.98258E-03_JPRB/) + SELFREFO(:, 8) = (/ & + & 2.96543E-02_JPRB, 2.59760E-02_JPRB, 2.27540E-02_JPRB, 1.99316E-02_JPRB, 1.74593E-02_JPRB, & + & 1.52937E-02_JPRB, 1.33967E-02_JPRB, 1.17350E-02_JPRB, 1.02794E-02_JPRB, 9.00437E-03_JPRB/) + SELFREFO(:, 9) = (/ & + & 2.97998E-02_JPRB, 2.60786E-02_JPRB, 2.28220E-02_JPRB, 1.99721E-02_JPRB, 1.74781E-02_JPRB, & + & 1.52955E-02_JPRB, 1.33855E-02_JPRB, 1.17140E-02_JPRB, 1.02512E-02_JPRB, 8.97110E-03_JPRB/) + SELFREFO(:,10) = (/ & + & 2.98826E-02_JPRB, 2.61096E-02_JPRB, 2.28130E-02_JPRB, 1.99326E-02_JPRB, 1.74159E-02_JPRB, & + & 1.52170E-02_JPRB, 1.32957E-02_JPRB, 1.16170E-02_JPRB, 1.01502E-02_JPRB, 8.86867E-03_JPRB/) + SELFREFO(:,11) = (/ & + & 2.94710E-02_JPRB, 2.58147E-02_JPRB, 2.26120E-02_JPRB, 1.98066E-02_JPRB, 1.73493E-02_JPRB, & + & 1.51969E-02_JPRB, 1.33115E-02_JPRB, 1.16600E-02_JPRB, 1.02134E-02_JPRB, 8.94628E-03_JPRB/) + SELFREFO(:,12) = (/ & + & 2.96297E-02_JPRB, 2.59544E-02_JPRB, 2.27350E-02_JPRB, 1.99149E-02_JPRB, 1.74446E-02_JPRB, & + & 1.52808E-02_JPRB, 1.33853E-02_JPRB, 1.17250E-02_JPRB, 1.02706E-02_JPRB, 8.99663E-03_JPRB/) + SELFREFO(:,13) = (/ & + & 2.96272E-02_JPRB, 2.59013E-02_JPRB, 2.26440E-02_JPRB, 1.97963E-02_JPRB, 1.73067E-02_JPRB, & + & 1.51302E-02_JPRB, 1.32275E-02_JPRB, 1.15640E-02_JPRB, 1.01097E-02_JPRB, 8.83833E-03_JPRB/) + SELFREFO(:,14) = (/ & + & 2.89906E-02_JPRB, 2.53971E-02_JPRB, 2.22490E-02_JPRB, 1.94911E-02_JPRB, 1.70751E-02_JPRB, & + & 1.49585E-02_JPRB, 1.31044E-02_JPRB, 1.14800E-02_JPRB, 1.00570E-02_JPRB, 8.81038E-03_JPRB/) + SELFREFO(:,15) = (/ & + & 2.80884E-02_JPRB, 2.46987E-02_JPRB, 2.17180E-02_JPRB, 1.90970E-02_JPRB, 1.67924E-02_JPRB, & + & 1.47659E-02_JPRB, 1.29839E-02_JPRB, 1.14170E-02_JPRB, 1.00392E-02_JPRB, 8.82765E-03_JPRB/) + SELFREFO(:,16) = (/ & + & 2.80884E-02_JPRB, 2.46987E-02_JPRB, 2.17180E-02_JPRB, 1.90970E-02_JPRB, 1.67924E-02_JPRB, & + & 1.47659E-02_JPRB, 1.29839E-02_JPRB, 1.14170E-02_JPRB, 1.00392E-02_JPRB, 8.82765E-03_JPRB/) + + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB8',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB8:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB8 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb9.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb9.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_kgb9.F90 (revision 6016) @@ -0,0 +1,1028 @@ +SUBROUTINE RRTM_KGB9 + +! Originally by Eli J. Mlawer, Atmospheric & Environmental Research. +! BAND 9: 1180-1390 cm-1 (low - H2O,CH4; high - CH4) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! ABozzo 201306 updated to rrtmg v4.85 +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN ,ONLY : NULRAD +USE MPL_MODULE,ONLY : MPL_BROADCAST +USE YOMTAG ,ONLY : MTAGRAD +USE YOMMP0 , ONLY : NPROC, MYPROC + +USE YOERRTO9 , ONLY : KAO ,KBO ,SELFREFO ,FORREFO, FRACREFAO ,& + & FRACREFBO, KAO_MN2O, KBO_MN2O, KAO_D, KBO_D + + +! ------------------------------------------------------------------ + +IMPLICIT NONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB9',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KAO_D,KBO_D + KAO = REAL(KAO_D,JPRB) + KBO = REAL(KBO_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KAO,MTAGRAD,1,CDSTRING='RRTM_KGB9:') + CALL MPL_BROADCAST (KBO,MTAGRAD,1,CDSTRING='RRTM_KGB9:') +ENDIF + +! Planck fractions mapping level : P=212.7250 mb, T = 223.06 K + FRACREFAO(:, 1) = (/ & + & 1.8129E-01_JPRB,1.6119E-01_JPRB,1.3308E-01_JPRB,1.2342E-01_JPRB,1.1259E-01_JPRB,9.7580E-02_JPRB, & + & 7.9176E-02_JPRB,5.8541E-02_JPRB,3.9084E-02_JPRB,4.2419E-03_JPRB,3.4314E-03_JPRB,2.6935E-03_JPRB, & + & 1.9404E-03_JPRB,1.2218E-03_JPRB,4.5263E-04_JPRB,6.0909E-05_JPRB/) + FRACREFAO(:, 2) = (/ & + & 1.9665E-01_JPRB,1.5640E-01_JPRB,1.3101E-01_JPRB,1.2153E-01_JPRB,1.1037E-01_JPRB,9.6043E-02_JPRB, & + & 7.7856E-02_JPRB,5.7547E-02_JPRB,3.8670E-02_JPRB,4.1955E-03_JPRB,3.4104E-03_JPRB,2.6781E-03_JPRB, & + & 1.9245E-03_JPRB,1.2093E-03_JPRB,4.4113E-04_JPRB,6.0913E-05_JPRB/) + FRACREFAO(:, 3) = (/ & + & 2.0273E-01_JPRB,1.5506E-01_JPRB,1.3044E-01_JPRB,1.2043E-01_JPRB,1.0952E-01_JPRB,9.5384E-02_JPRB, & + & 7.7157E-02_JPRB,5.7176E-02_JPRB,3.8379E-02_JPRB,4.1584E-03_JPRB,3.3836E-03_JPRB,2.6412E-03_JPRB, & + & 1.8865E-03_JPRB,1.1791E-03_JPRB,4.2094E-04_JPRB,4.7410E-05_JPRB/) + FRACREFAO(:, 4) = (/ & + & 2.0272E-01_JPRB,1.5963E-01_JPRB,1.2913E-01_JPRB,1.2060E-01_JPRB,1.0820E-01_JPRB,9.4685E-02_JPRB, & + & 7.6544E-02_JPRB,5.6851E-02_JPRB,3.8155E-02_JPRB,4.0913E-03_JPRB,3.3442E-03_JPRB,2.6054E-03_JPRB, & + & 1.8875E-03_JPRB,1.1263E-03_JPRB,3.7743E-04_JPRB,4.7410E-05_JPRB/) + FRACREFAO(:, 5) = (/ & + & 2.0280E-01_JPRB,1.6353E-01_JPRB,1.2910E-01_JPRB,1.1968E-01_JPRB,1.0725E-01_JPRB,9.4112E-02_JPRB, & + & 7.5828E-02_JPRB,5.6526E-02_JPRB,3.7972E-02_JPRB,4.0205E-03_JPRB,3.3063E-03_JPRB,2.5681E-03_JPRB, & + & 1.8386E-03_JPRB,1.0757E-03_JPRB,3.5301E-04_JPRB,4.7410E-05_JPRB/) + FRACREFAO(:, 6) = (/ & + & 2.0294E-01_JPRB,1.6840E-01_JPRB,1.2852E-01_JPRB,1.1813E-01_JPRB,1.0724E-01_JPRB,9.2946E-02_JPRB, & + & 7.5029E-02_JPRB,5.6158E-02_JPRB,3.7744E-02_JPRB,3.9632E-03_JPRB,3.2434E-03_JPRB,2.5275E-03_JPRB, & + & 1.7558E-03_JPRB,1.0080E-03_JPRB,3.5301E-04_JPRB,4.7410E-05_JPRB/) + FRACREFAO(:, 7) = (/ & + & 2.0313E-01_JPRB,1.7390E-01_JPRB,1.2864E-01_JPRB,1.1689E-01_JPRB,1.0601E-01_JPRB,9.1791E-02_JPRB, & + & 7.4224E-02_JPRB,5.5500E-02_JPRB,3.7374E-02_JPRB,3.9214E-03_JPRB,3.1984E-03_JPRB,2.4162E-03_JPRB, & + & 1.6394E-03_JPRB,9.7275E-04_JPRB,3.5299E-04_JPRB,4.7410E-05_JPRB/) + FRACREFAO(:, 8) = (/ & + & 2.0332E-01_JPRB,1.7800E-01_JPRB,1.3286E-01_JPRB,1.1555E-01_JPRB,1.0407E-01_JPRB,9.0475E-02_JPRB, & + & 7.2452E-02_JPRB,5.4566E-02_JPRB,3.6677E-02_JPRB,3.7889E-03_JPRB,3.0351E-03_JPRB,2.2587E-03_JPRB, & + & 1.5764E-03_JPRB,9.7270E-04_JPRB,3.5300E-04_JPRB,4.7410E-05_JPRB/) + FRACREFAO(:, 9) = (/ & + & 1.9624E-01_JPRB,1.6519E-01_JPRB,1.3663E-01_JPRB,1.1535E-01_JPRB,1.0719E-01_JPRB,9.4156E-02_JPRB, & + & 7.6745E-02_JPRB,5.6987E-02_JPRB,3.8135E-02_JPRB,4.1626E-03_JPRB,3.4243E-03_JPRB,2.7116E-03_JPRB, & + & 1.7095E-03_JPRB,9.7271E-04_JPRB,3.5299E-04_JPRB,4.7410E-05_JPRB/) + +! Planck fraction mapping level : p=3.20e-2 mb, t = 197.92 k + FRACREFBO(:) = (/ & + & 2.0914E-01_JPRB,1.5077E-01_JPRB,1.2878E-01_JPRB,1.1856E-01_JPRB,1.0695E-01_JPRB,9.3048E-02_JPRB, & + & 7.7645E-02_JPRB,6.0785E-02_JPRB,4.0642E-02_JPRB,4.0499E-03_JPRB,3.3931E-03_JPRB,2.6363E-03_JPRB, & + & 1.9151E-03_JPRB,1.1963E-03_JPRB,4.3471E-04_JPRB,5.1421E-05_JPRB/) + + +! ------------------------------------------------------------------ + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 11, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + + KAO_MN2O( 1, :, 1) = (/ & + & 5.41078E-02_JPRB, 5.59051E-02_JPRB, 5.77620E-02_JPRB, 5.96805E-02_JPRB, 6.16628E-02_JPRB, & + & 6.37110E-02_JPRB, 6.58272E-02_JPRB, 6.80137E-02_JPRB, 7.02728E-02_JPRB, 7.26069E-02_JPRB, & + & 7.50185E-02_JPRB, 7.75103E-02_JPRB, 8.00848E-02_JPRB, 8.27449E-02_JPRB, 8.54933E-02_JPRB, & + & 8.83330E-02_JPRB, 9.12670E-02_JPRB, 9.42984E-02_JPRB, 9.74306E-02_JPRB/) + KAO_MN2O( 2, :, 1) = (/ & + & 1.19602E-01_JPRB, 1.22963E-01_JPRB, 1.26417E-01_JPRB, 1.29969E-01_JPRB, 1.33621E-01_JPRB, & + & 1.37375E-01_JPRB, 1.41235E-01_JPRB, 1.45203E-01_JPRB, 1.49283E-01_JPRB, 1.53477E-01_JPRB, & + & 1.57789E-01_JPRB, 1.62223E-01_JPRB, 1.66780E-01_JPRB, 1.71466E-01_JPRB, 1.76284E-01_JPRB, & + & 1.81237E-01_JPRB, 1.86329E-01_JPRB, 1.91564E-01_JPRB, 1.96946E-01_JPRB/) + KAO_MN2O( 3, :, 1) = (/ & + & 1.49614E-01_JPRB, 1.53427E-01_JPRB, 1.57337E-01_JPRB, 1.61346E-01_JPRB, 1.65457E-01_JPRB, & + & 1.69674E-01_JPRB, 1.73997E-01_JPRB, 1.78431E-01_JPRB, 1.82978E-01_JPRB, 1.87641E-01_JPRB, & + & 1.92422E-01_JPRB, 1.97325E-01_JPRB, 2.02354E-01_JPRB, 2.07510E-01_JPRB, 2.12798E-01_JPRB, & + & 2.18221E-01_JPRB, 2.23781E-01_JPRB, 2.29484E-01_JPRB, 2.35331E-01_JPRB/) + KAO_MN2O( 4, :, 1) = (/ & + & 1.80029E-01_JPRB, 1.84202E-01_JPRB, 1.88472E-01_JPRB, 1.92841E-01_JPRB, 1.97311E-01_JPRB, & + & 2.01884E-01_JPRB, 2.06564E-01_JPRB, 2.11352E-01_JPRB, 2.16252E-01_JPRB, 2.21264E-01_JPRB, & + & 2.26393E-01_JPRB, 2.31641E-01_JPRB, 2.37010E-01_JPRB, 2.42504E-01_JPRB, 2.48126E-01_JPRB, & + & 2.53877E-01_JPRB, 2.59762E-01_JPRB, 2.65783E-01_JPRB, 2.71944E-01_JPRB/) + KAO_MN2O( 5, :, 1) = (/ & + & 2.08279E-01_JPRB, 2.13029E-01_JPRB, 2.17888E-01_JPRB, 2.22858E-01_JPRB, 2.27941E-01_JPRB, & + & 2.33140E-01_JPRB, 2.38458E-01_JPRB, 2.43897E-01_JPRB, 2.49460E-01_JPRB, 2.55150E-01_JPRB, & + & 2.60969E-01_JPRB, 2.66922E-01_JPRB, 2.73010E-01_JPRB, 2.79237E-01_JPRB, 2.85606E-01_JPRB, & + & 2.92120E-01_JPRB, 2.98783E-01_JPRB, 3.05598E-01_JPRB, 3.12568E-01_JPRB/) + KAO_MN2O( 6, :, 1) = (/ & + & 2.17336E-01_JPRB, 2.22571E-01_JPRB, 2.27931E-01_JPRB, 2.33421E-01_JPRB, 2.39043E-01_JPRB, & + & 2.44801E-01_JPRB, 2.50697E-01_JPRB, 2.56735E-01_JPRB, 2.62918E-01_JPRB, 2.69251E-01_JPRB, & + & 2.75735E-01_JPRB, 2.82377E-01_JPRB, 2.89178E-01_JPRB, 2.96142E-01_JPRB, 3.03275E-01_JPRB, & + & 3.10579E-01_JPRB, 3.18060E-01_JPRB, 3.25720E-01_JPRB, 3.33565E-01_JPRB/) + KAO_MN2O( 7, :, 1) = (/ & + & 2.23903E-01_JPRB, 2.29349E-01_JPRB, 2.34926E-01_JPRB, 2.40640E-01_JPRB, 2.46493E-01_JPRB, & + & 2.52488E-01_JPRB, 2.58628E-01_JPRB, 2.64918E-01_JPRB, 2.71361E-01_JPRB, 2.77961E-01_JPRB, & + & 2.84721E-01_JPRB, 2.91646E-01_JPRB, 2.98739E-01_JPRB, 3.06005E-01_JPRB, 3.13447E-01_JPRB, & + & 3.21070E-01_JPRB, 3.28879E-01_JPRB, 3.36877E-01_JPRB, 3.45071E-01_JPRB/) + KAO_MN2O( 8, :, 1) = (/ & + & 2.23400E-01_JPRB, 2.28843E-01_JPRB, 2.34418E-01_JPRB, 2.40130E-01_JPRB, 2.45980E-01_JPRB, & + & 2.51973E-01_JPRB, 2.58112E-01_JPRB, 2.64401E-01_JPRB, 2.70843E-01_JPRB, 2.77442E-01_JPRB, & + & 2.84202E-01_JPRB, 2.91126E-01_JPRB, 2.98219E-01_JPRB, 3.05485E-01_JPRB, 3.12928E-01_JPRB, & + & 3.20552E-01_JPRB, 3.28362E-01_JPRB, 3.36362E-01_JPRB, 3.44557E-01_JPRB/) + KAO_MN2O( 9, :, 1) = (/ & + & 1.89279E-01_JPRB, 1.94423E-01_JPRB, 1.99707E-01_JPRB, 2.05135E-01_JPRB, 2.10710E-01_JPRB, & + & 2.16437E-01_JPRB, 2.22319E-01_JPRB, 2.28361E-01_JPRB, 2.34568E-01_JPRB, 2.40943E-01_JPRB, & + & 2.47492E-01_JPRB, 2.54218E-01_JPRB, 2.61127E-01_JPRB, 2.68224E-01_JPRB, 2.75514E-01_JPRB, & + & 2.83002E-01_JPRB, 2.90694E-01_JPRB, 2.98594E-01_JPRB, 3.06709E-01_JPRB/) + KAO_MN2O( 1, :, 2) = (/ & + & 9.46669E-02_JPRB, 9.77137E-02_JPRB, 1.00858E-01_JPRB, 1.04104E-01_JPRB, 1.07455E-01_JPRB, & + & 1.10913E-01_JPRB, 1.14483E-01_JPRB, 1.18167E-01_JPRB, 1.21971E-01_JPRB, 1.25896E-01_JPRB, & + & 1.29948E-01_JPRB, 1.34130E-01_JPRB, 1.38447E-01_JPRB, 1.42903E-01_JPRB, 1.47502E-01_JPRB, & + & 1.52249E-01_JPRB, 1.57149E-01_JPRB, 1.62207E-01_JPRB, 1.67427E-01_JPRB/) + KAO_MN2O( 2, :, 2) = (/ & + & 5.11901E-01_JPRB, 5.24950E-01_JPRB, 5.38331E-01_JPRB, 5.52053E-01_JPRB, 5.66125E-01_JPRB, & + & 5.80556E-01_JPRB, 5.95354E-01_JPRB, 6.10530E-01_JPRB, 6.26093E-01_JPRB, 6.42052E-01_JPRB, & + & 6.58418E-01_JPRB, 6.75202E-01_JPRB, 6.92413E-01_JPRB, 7.10062E-01_JPRB, 7.28162E-01_JPRB, & + & 7.46723E-01_JPRB, 7.65758E-01_JPRB, 7.85277E-01_JPRB, 8.05294E-01_JPRB/) + KAO_MN2O( 3, :, 2) = (/ & + & 8.32946E-01_JPRB, 8.45780E-01_JPRB, 8.58813E-01_JPRB, 8.72046E-01_JPRB, 8.85482E-01_JPRB, & + & 8.99126E-01_JPRB, 9.12980E-01_JPRB, 9.27048E-01_JPRB, 9.41332E-01_JPRB, 9.55837E-01_JPRB, & + & 9.70565E-01_JPRB, 9.85520E-01_JPRB, 1.00070E+00_JPRB, 1.01612E+00_JPRB, 1.03178E+00_JPRB, & + & 1.04768E+00_JPRB, 1.06382E+00_JPRB, 1.08021E+00_JPRB, 1.09686E+00_JPRB/) + KAO_MN2O( 4, :, 2) = (/ & + & 1.04032E+00_JPRB, 1.05475E+00_JPRB, 1.06937E+00_JPRB, 1.08419E+00_JPRB, 1.09922E+00_JPRB, & + & 1.11446E+00_JPRB, 1.12991E+00_JPRB, 1.14557E+00_JPRB, 1.16145E+00_JPRB, 1.17755E+00_JPRB, & + & 1.19387E+00_JPRB, 1.21042E+00_JPRB, 1.22720E+00_JPRB, 1.24421E+00_JPRB, 1.26146E+00_JPRB, & + & 1.27895E+00_JPRB, 1.29668E+00_JPRB, 1.31465E+00_JPRB, 1.33287E+00_JPRB/) + KAO_MN2O( 5, :, 2) = (/ & + & 1.22685E+00_JPRB, 1.24267E+00_JPRB, 1.25870E+00_JPRB, 1.27493E+00_JPRB, 1.29137E+00_JPRB, & + & 1.30803E+00_JPRB, 1.32490E+00_JPRB, 1.34199E+00_JPRB, 1.35930E+00_JPRB, 1.37683E+00_JPRB, & + & 1.39459E+00_JPRB, 1.41257E+00_JPRB, 1.43079E+00_JPRB, 1.44925E+00_JPRB, 1.46794E+00_JPRB, & + & 1.48687E+00_JPRB, 1.50605E+00_JPRB, 1.52547E+00_JPRB, 1.54515E+00_JPRB/) + KAO_MN2O( 6, :, 2) = (/ & + & 1.53781E+00_JPRB, 1.55206E+00_JPRB, 1.56645E+00_JPRB, 1.58097E+00_JPRB, 1.59563E+00_JPRB, & + & 1.61042E+00_JPRB, 1.62535E+00_JPRB, 1.64042E+00_JPRB, 1.65562E+00_JPRB, 1.67097E+00_JPRB, & + & 1.68646E+00_JPRB, 1.70210E+00_JPRB, 1.71788E+00_JPRB, 1.73380E+00_JPRB, 1.74987E+00_JPRB, & + & 1.76610E+00_JPRB, 1.78247E+00_JPRB, 1.79899E+00_JPRB, 1.81567E+00_JPRB/) + KAO_MN2O( 7, :, 2) = (/ & + & 1.90476E+00_JPRB, 1.91858E+00_JPRB, 1.93251E+00_JPRB, 1.94653E+00_JPRB, 1.96065E+00_JPRB, & + & 1.97488E+00_JPRB, 1.98921E+00_JPRB, 2.00365E+00_JPRB, 2.01819E+00_JPRB, 2.03283E+00_JPRB, & + & 2.04758E+00_JPRB, 2.06244E+00_JPRB, 2.07741E+00_JPRB, 2.09248E+00_JPRB, 2.10767E+00_JPRB, & + & 2.12296E+00_JPRB, 2.13837E+00_JPRB, 2.15388E+00_JPRB, 2.16951E+00_JPRB/) + KAO_MN2O( 8, :, 2) = (/ & + & 2.38211E+00_JPRB, 2.39819E+00_JPRB, 2.41438E+00_JPRB, 2.43068E+00_JPRB, 2.44709E+00_JPRB, & + & 2.46361E+00_JPRB, 2.48024E+00_JPRB, 2.49699E+00_JPRB, 2.51384E+00_JPRB, 2.53082E+00_JPRB, & + & 2.54790E+00_JPRB, 2.56510E+00_JPRB, 2.58242E+00_JPRB, 2.59985E+00_JPRB, 2.61741E+00_JPRB, & + & 2.63508E+00_JPRB, 2.65287E+00_JPRB, 2.67078E+00_JPRB, 2.68881E+00_JPRB/) + KAO_MN2O( 9, :, 2) = (/ & + & 1.26464E+00_JPRB, 1.28107E+00_JPRB, 1.29772E+00_JPRB, 1.31458E+00_JPRB, 1.33166E+00_JPRB, & + & 1.34896E+00_JPRB, 1.36649E+00_JPRB, 1.38424E+00_JPRB, 1.40223E+00_JPRB, 1.42044E+00_JPRB, & + & 1.43890E+00_JPRB, 1.45759E+00_JPRB, 1.47653E+00_JPRB, 1.49572E+00_JPRB, 1.51515E+00_JPRB, & + & 1.53483E+00_JPRB, 1.55478E+00_JPRB, 1.57498E+00_JPRB, 1.59544E+00_JPRB/) + KAO_MN2O( 1, :, 3) = (/ & + & 1.50082E-01_JPRB, 1.59095E-01_JPRB, 1.68650E-01_JPRB, 1.78779E-01_JPRB, 1.89516E-01_JPRB, & + & 2.00898E-01_JPRB, 2.12963E-01_JPRB, 2.25753E-01_JPRB, 2.39311E-01_JPRB, 2.53683E-01_JPRB, & + & 2.68919E-01_JPRB, 2.85069E-01_JPRB, 3.02190E-01_JPRB, 3.20339E-01_JPRB, 3.39577E-01_JPRB, & + & 3.59971E-01_JPRB, 3.81590E-01_JPRB, 4.04507E-01_JPRB, 4.28801E-01_JPRB/) + KAO_MN2O( 2, :, 3) = (/ & + & 3.09551E+00_JPRB, 3.09780E+00_JPRB, 3.10008E+00_JPRB, 3.10237E+00_JPRB, 3.10466E+00_JPRB, & + & 3.10695E+00_JPRB, 3.10925E+00_JPRB, 3.11154E+00_JPRB, 3.11384E+00_JPRB, 3.11614E+00_JPRB, & + & 3.11844E+00_JPRB, 3.12074E+00_JPRB, 3.12305E+00_JPRB, 3.12535E+00_JPRB, 3.12766E+00_JPRB, & + & 3.12997E+00_JPRB, 3.13228E+00_JPRB, 3.13459E+00_JPRB, 3.13691E+00_JPRB/) + KAO_MN2O( 3, :, 3) = (/ & + & 4.42661E+00_JPRB, 4.40858E+00_JPRB, 4.39062E+00_JPRB, 4.37274E+00_JPRB, 4.35493E+00_JPRB, & + & 4.33719E+00_JPRB, 4.31953E+00_JPRB, 4.30193E+00_JPRB, 4.28441E+00_JPRB, 4.26696E+00_JPRB, & + & 4.24958E+00_JPRB, 4.23227E+00_JPRB, 4.21503E+00_JPRB, 4.19787E+00_JPRB, 4.18077E+00_JPRB, & + & 4.16374E+00_JPRB, 4.14678E+00_JPRB, 4.12989E+00_JPRB, 4.11307E+00_JPRB/) + KAO_MN2O( 4, :, 3) = (/ & + & 5.77864E+00_JPRB, 5.74085E+00_JPRB, 5.70331E+00_JPRB, 5.66602E+00_JPRB, 5.62897E+00_JPRB, & + & 5.59216E+00_JPRB, 5.55559E+00_JPRB, 5.51926E+00_JPRB, 5.48317E+00_JPRB, 5.44731E+00_JPRB, & + & 5.41169E+00_JPRB, 5.37631E+00_JPRB, 5.34115E+00_JPRB, 5.30622E+00_JPRB, 5.27152E+00_JPRB, & + & 5.23705E+00_JPRB, 5.20281E+00_JPRB, 5.16879E+00_JPRB, 5.13499E+00_JPRB/) + KAO_MN2O( 5, :, 3) = (/ & + & 7.17294E+00_JPRB, 7.10890E+00_JPRB, 7.04542E+00_JPRB, 6.98251E+00_JPRB, 6.92017E+00_JPRB, & + & 6.85838E+00_JPRB, 6.79714E+00_JPRB, 6.73645E+00_JPRB, 6.67630E+00_JPRB, 6.61669E+00_JPRB, & + & 6.55761E+00_JPRB, 6.49905E+00_JPRB, 6.44102E+00_JPRB, 6.38351E+00_JPRB, 6.32651E+00_JPRB, & + & 6.27003E+00_JPRB, 6.21404E+00_JPRB, 6.15856E+00_JPRB, 6.10357E+00_JPRB/) + KAO_MN2O( 6, :, 3) = (/ & + & 9.05082E+00_JPRB, 8.96132E+00_JPRB, 8.87271E+00_JPRB, 8.78498E+00_JPRB, 8.69811E+00_JPRB, & + & 8.61210E+00_JPRB, 8.52694E+00_JPRB, 8.44262E+00_JPRB, 8.35914E+00_JPRB, 8.27648E+00_JPRB, & + & 8.19464E+00_JPRB, 8.11361E+00_JPRB, 8.03338E+00_JPRB, 7.95394E+00_JPRB, 7.87529E+00_JPRB, & + & 7.79742E+00_JPRB, 7.72032E+00_JPRB, 7.64398E+00_JPRB, 7.56839E+00_JPRB/) + KAO_MN2O( 7, :, 3) = (/ & + & 1.18749E+01_JPRB, 1.17648E+01_JPRB, 1.16556E+01_JPRB, 1.15475E+01_JPRB, 1.14403E+01_JPRB, & + & 1.13342E+01_JPRB, 1.12290E+01_JPRB, 1.11248E+01_JPRB, 1.10216E+01_JPRB, 1.09194E+01_JPRB, & + & 1.08180E+01_JPRB, 1.07177E+01_JPRB, 1.06182E+01_JPRB, 1.05197E+01_JPRB, 1.04221E+01_JPRB, & + & 1.03254E+01_JPRB, 1.02296E+01_JPRB, 1.01347E+01_JPRB, 1.00407E+01_JPRB/) + KAO_MN2O( 8, :, 3) = (/ & + & 1.41428E+01_JPRB, 1.40323E+01_JPRB, 1.39227E+01_JPRB, 1.38139E+01_JPRB, 1.37060E+01_JPRB, & + & 1.35989E+01_JPRB, 1.34927E+01_JPRB, 1.33873E+01_JPRB, 1.32827E+01_JPRB, 1.31790E+01_JPRB, & + & 1.30760E+01_JPRB, 1.29738E+01_JPRB, 1.28725E+01_JPRB, 1.27719E+01_JPRB, 1.26722E+01_JPRB, & + & 1.25732E+01_JPRB, 1.24750E+01_JPRB, 1.23775E+01_JPRB, 1.22808E+01_JPRB/) + KAO_MN2O( 9, :, 3) = (/ & + & 7.34993E+00_JPRB, 7.29335E+00_JPRB, 7.23720E+00_JPRB, 7.18149E+00_JPRB, 7.12620E+00_JPRB, & + & 7.07134E+00_JPRB, 7.01690E+00_JPRB, 6.96288E+00_JPRB, 6.90928E+00_JPRB, 6.85609E+00_JPRB, & + & 6.80331E+00_JPRB, 6.75094E+00_JPRB, 6.69897E+00_JPRB, 6.64739E+00_JPRB, 6.59622E+00_JPRB, & + & 6.54544E+00_JPRB, 6.49505E+00_JPRB, 6.44505E+00_JPRB, 6.39543E+00_JPRB/) + KAO_MN2O( 1, :, 4) = (/ & + & 6.11248E-01_JPRB, 6.37225E-01_JPRB, 6.64306E-01_JPRB, 6.92538E-01_JPRB, 7.21970E-01_JPRB, & + & 7.52653E-01_JPRB, 7.84639E-01_JPRB, 8.17985E-01_JPRB, 8.52749E-01_JPRB, 8.88989E-01_JPRB, & + & 9.26770E-01_JPRB, 9.66157E-01_JPRB, 1.00722E+00_JPRB, 1.05002E+00_JPRB, 1.09465E+00_JPRB, & + & 1.14117E+00_JPRB, 1.18967E+00_JPRB, 1.24022E+00_JPRB, 1.29293E+00_JPRB/) + KAO_MN2O( 2, :, 4) = (/ & + & 5.07253E+00_JPRB, 5.05299E+00_JPRB, 5.03353E+00_JPRB, 5.01414E+00_JPRB, 4.99483E+00_JPRB, & + & 4.97559E+00_JPRB, 4.95642E+00_JPRB, 4.93733E+00_JPRB, 4.91831E+00_JPRB, 4.89937E+00_JPRB, & + & 4.88050E+00_JPRB, 4.86170E+00_JPRB, 4.84297E+00_JPRB, 4.82432E+00_JPRB, 4.80573E+00_JPRB, & + & 4.78722E+00_JPRB, 4.76878E+00_JPRB, 4.75042E+00_JPRB, 4.73212E+00_JPRB/) + KAO_MN2O( 3, :, 4) = (/ & + & 7.45829E+00_JPRB, 7.42266E+00_JPRB, 7.38719E+00_JPRB, 7.35190E+00_JPRB, 7.31677E+00_JPRB, & + & 7.28181E+00_JPRB, 7.24702E+00_JPRB, 7.21240E+00_JPRB, 7.17794E+00_JPRB, 7.14364E+00_JPRB, & + & 7.10951E+00_JPRB, 7.07554E+00_JPRB, 7.04173E+00_JPRB, 7.00809E+00_JPRB, 6.97461E+00_JPRB, & + & 6.94128E+00_JPRB, 6.90812E+00_JPRB, 6.87511E+00_JPRB, 6.84226E+00_JPRB/) + KAO_MN2O( 4, :, 4) = (/ & + & 9.58893E+00_JPRB, 9.54796E+00_JPRB, 9.50716E+00_JPRB, 9.46654E+00_JPRB, 9.42609E+00_JPRB, & + & 9.38581E+00_JPRB, 9.34571E+00_JPRB, 9.30578E+00_JPRB, 9.26602E+00_JPRB, 9.22642E+00_JPRB, & + & 9.18700E+00_JPRB, 9.14775E+00_JPRB, 9.10866E+00_JPRB, 9.06974E+00_JPRB, 9.03099E+00_JPRB, & + & 8.99240E+00_JPRB, 8.95398E+00_JPRB, 8.91572E+00_JPRB, 8.87762E+00_JPRB/) + KAO_MN2O( 5, :, 4) = (/ & + & 1.16344E+01_JPRB, 1.16012E+01_JPRB, 1.15681E+01_JPRB, 1.15351E+01_JPRB, 1.15022E+01_JPRB, & + & 1.14694E+01_JPRB, 1.14366E+01_JPRB, 1.14040E+01_JPRB, 1.13715E+01_JPRB, 1.13390E+01_JPRB, & + & 1.13067E+01_JPRB, 1.12744E+01_JPRB, 1.12422E+01_JPRB, 1.12102E+01_JPRB, 1.11782E+01_JPRB, & + & 1.11463E+01_JPRB, 1.11145E+01_JPRB, 1.10828E+01_JPRB, 1.10511E+01_JPRB/) + KAO_MN2O( 6, :, 4) = (/ & + & 1.12460E+01_JPRB, 1.12402E+01_JPRB, 1.12344E+01_JPRB, 1.12286E+01_JPRB, 1.12228E+01_JPRB, & + & 1.12170E+01_JPRB, 1.12112E+01_JPRB, 1.12055E+01_JPRB, 1.11997E+01_JPRB, 1.11939E+01_JPRB, & + & 1.11882E+01_JPRB, 1.11824E+01_JPRB, 1.11766E+01_JPRB, 1.11709E+01_JPRB, 1.11651E+01_JPRB, & + & 1.11594E+01_JPRB, 1.11536E+01_JPRB, 1.11479E+01_JPRB, 1.11421E+01_JPRB/) + KAO_MN2O( 7, :, 4) = (/ & + & 8.89265E+00_JPRB, 8.91419E+00_JPRB, 8.93578E+00_JPRB, 8.95743E+00_JPRB, 8.97913E+00_JPRB, & + & 9.00088E+00_JPRB, 9.02268E+00_JPRB, 9.04454E+00_JPRB, 9.06645E+00_JPRB, 9.08841E+00_JPRB, & + & 9.11043E+00_JPRB, 9.13250E+00_JPRB, 9.15462E+00_JPRB, 9.17680E+00_JPRB, 9.19903E+00_JPRB, & + & 9.22131E+00_JPRB, 9.24365E+00_JPRB, 9.26604E+00_JPRB, 9.28849E+00_JPRB/) + KAO_MN2O( 8, :, 4) = (/ & + & 6.83933E+00_JPRB, 6.86688E+00_JPRB, 6.89453E+00_JPRB, 6.92230E+00_JPRB, 6.95018E+00_JPRB, & + & 6.97817E+00_JPRB, 7.00627E+00_JPRB, 7.03449E+00_JPRB, 7.06282E+00_JPRB, 7.09126E+00_JPRB, & + & 7.11982E+00_JPRB, 7.14850E+00_JPRB, 7.17729E+00_JPRB, 7.20619E+00_JPRB, 7.23521E+00_JPRB, & + & 7.26435E+00_JPRB, 7.29361E+00_JPRB, 7.32298E+00_JPRB, 7.35248E+00_JPRB/) + KAO_MN2O( 9, :, 4) = (/ & + & 1.10637E+01_JPRB, 1.10232E+01_JPRB, 1.09829E+01_JPRB, 1.09427E+01_JPRB, 1.09026E+01_JPRB, & + & 1.08627E+01_JPRB, 1.08230E+01_JPRB, 1.07833E+01_JPRB, 1.07439E+01_JPRB, 1.07046E+01_JPRB, & + & 1.06654E+01_JPRB, 1.06263E+01_JPRB, 1.05875E+01_JPRB, 1.05487E+01_JPRB, 1.05101E+01_JPRB, & + & 1.04716E+01_JPRB, 1.04333E+01_JPRB, 1.03951E+01_JPRB, 1.03571E+01_JPRB/) + KAO_MN2O( 1, :, 5) = (/ & + & 2.53460E+00_JPRB, 2.56050E+00_JPRB, 2.58667E+00_JPRB, 2.61310E+00_JPRB, 2.63980E+00_JPRB, & + & 2.66678E+00_JPRB, 2.69403E+00_JPRB, 2.72156E+00_JPRB, 2.74937E+00_JPRB, 2.77746E+00_JPRB, & + & 2.80585E+00_JPRB, 2.83452E+00_JPRB, 2.86348E+00_JPRB, 2.89275E+00_JPRB, 2.92231E+00_JPRB, & + & 2.95217E+00_JPRB, 2.98234E+00_JPRB, 3.01281E+00_JPRB, 3.04360E+00_JPRB/) + KAO_MN2O( 2, :, 5) = (/ & + & 7.45650E+00_JPRB, 7.44283E+00_JPRB, 7.42919E+00_JPRB, 7.41557E+00_JPRB, 7.40198E+00_JPRB, & + & 7.38841E+00_JPRB, 7.37487E+00_JPRB, 7.36135E+00_JPRB, 7.34786E+00_JPRB, 7.33439E+00_JPRB, & + & 7.32095E+00_JPRB, 7.30753E+00_JPRB, 7.29413E+00_JPRB, 7.28076E+00_JPRB, 7.26742E+00_JPRB, & + & 7.25410E+00_JPRB, 7.24080E+00_JPRB, 7.22753E+00_JPRB, 7.21428E+00_JPRB/) + KAO_MN2O( 3, :, 5) = (/ & + & 1.06311E+01_JPRB, 1.06110E+01_JPRB, 1.05909E+01_JPRB, 1.05709E+01_JPRB, 1.05509E+01_JPRB, & + & 1.05310E+01_JPRB, 1.05111E+01_JPRB, 1.04912E+01_JPRB, 1.04713E+01_JPRB, 1.04516E+01_JPRB, & + & 1.04318E+01_JPRB, 1.04121E+01_JPRB, 1.03924E+01_JPRB, 1.03727E+01_JPRB, 1.03531E+01_JPRB, & + & 1.03336E+01_JPRB, 1.03140E+01_JPRB, 1.02945E+01_JPRB, 1.02751E+01_JPRB/) + KAO_MN2O( 4, :, 5) = (/ & + & 1.03924E+01_JPRB, 1.03895E+01_JPRB, 1.03867E+01_JPRB, 1.03838E+01_JPRB, 1.03809E+01_JPRB, & + & 1.03780E+01_JPRB, 1.03751E+01_JPRB, 1.03722E+01_JPRB, 1.03693E+01_JPRB, 1.03665E+01_JPRB, & + & 1.03636E+01_JPRB, 1.03607E+01_JPRB, 1.03578E+01_JPRB, 1.03549E+01_JPRB, 1.03521E+01_JPRB, & + & 1.03492E+01_JPRB, 1.03463E+01_JPRB, 1.03434E+01_JPRB, 1.03406E+01_JPRB/) + KAO_MN2O( 5, :, 5) = (/ & + & 7.82277E+00_JPRB, 7.83872E+00_JPRB, 7.85471E+00_JPRB, 7.87073E+00_JPRB, 7.88678E+00_JPRB, & + & 7.90287E+00_JPRB, 7.91899E+00_JPRB, 7.93514E+00_JPRB, 7.95132E+00_JPRB, 7.96754E+00_JPRB, & + & 7.98379E+00_JPRB, 8.00008E+00_JPRB, 8.01639E+00_JPRB, 8.03274E+00_JPRB, 8.04913E+00_JPRB, & + & 8.06555E+00_JPRB, 8.08200E+00_JPRB, 8.09848E+00_JPRB, 8.11500E+00_JPRB/) + KAO_MN2O( 6, :, 5) = (/ & + & 6.05225E+00_JPRB, 6.06883E+00_JPRB, 6.08545E+00_JPRB, 6.10212E+00_JPRB, 6.11883E+00_JPRB, & + & 6.13559E+00_JPRB, 6.15240E+00_JPRB, 6.16925E+00_JPRB, 6.18615E+00_JPRB, 6.20309E+00_JPRB, & + & 6.22008E+00_JPRB, 6.23712E+00_JPRB, 6.25420E+00_JPRB, 6.27133E+00_JPRB, 6.28851E+00_JPRB, & + & 6.30574E+00_JPRB, 6.32301E+00_JPRB, 6.34033E+00_JPRB, 6.35769E+00_JPRB/) + KAO_MN2O( 7, :, 5) = (/ & + & 5.24135E+00_JPRB, 5.25696E+00_JPRB, 5.27261E+00_JPRB, 5.28831E+00_JPRB, 5.30405E+00_JPRB, & + & 5.31984E+00_JPRB, 5.33568E+00_JPRB, 5.35157E+00_JPRB, 5.36750E+00_JPRB, 5.38348E+00_JPRB, & + & 5.39951E+00_JPRB, 5.41558E+00_JPRB, 5.43171E+00_JPRB, 5.44788E+00_JPRB, 5.46410E+00_JPRB, & + & 5.48037E+00_JPRB, 5.49668E+00_JPRB, 5.51305E+00_JPRB, 5.52946E+00_JPRB/) + KAO_MN2O( 8, :, 5) = (/ & + & 4.40240E+00_JPRB, 4.40915E+00_JPRB, 4.41591E+00_JPRB, 4.42268E+00_JPRB, 4.42946E+00_JPRB, & + & 4.43625E+00_JPRB, 4.44305E+00_JPRB, 4.44986E+00_JPRB, 4.45668E+00_JPRB, 4.46351E+00_JPRB, & + & 4.47035E+00_JPRB, 4.47720E+00_JPRB, 4.48407E+00_JPRB, 4.49094E+00_JPRB, 4.49782E+00_JPRB, & + & 4.50472E+00_JPRB, 4.51162E+00_JPRB, 4.51854E+00_JPRB, 4.52547E+00_JPRB/) + KAO_MN2O( 9, :, 5) = (/ & + & 8.56554E+00_JPRB, 8.59185E+00_JPRB, 8.61824E+00_JPRB, 8.64470E+00_JPRB, 8.67125E+00_JPRB, & + & 8.69788E+00_JPRB, 8.72460E+00_JPRB, 8.75139E+00_JPRB, 8.77827E+00_JPRB, 8.80523E+00_JPRB, & + & 8.83227E+00_JPRB, 8.85939E+00_JPRB, 8.88660E+00_JPRB, 8.91389E+00_JPRB, 8.94127E+00_JPRB, & + & 8.96873E+00_JPRB, 8.99627E+00_JPRB, 9.02390E+00_JPRB, 9.05161E+00_JPRB/) + KAO_MN2O( 1, :, 6) = (/ & + & 5.78695E+00_JPRB, 5.78939E+00_JPRB, 5.79182E+00_JPRB, 5.79426E+00_JPRB, 5.79670E+00_JPRB, & + & 5.79914E+00_JPRB, 5.80158E+00_JPRB, 5.80403E+00_JPRB, 5.80647E+00_JPRB, 5.80892E+00_JPRB, & + & 5.81136E+00_JPRB, 5.81381E+00_JPRB, 5.81626E+00_JPRB, 5.81870E+00_JPRB, 5.82115E+00_JPRB, & + & 5.82361E+00_JPRB, 5.82606E+00_JPRB, 5.82851E+00_JPRB, 5.83096E+00_JPRB/) + KAO_MN2O( 2, :, 6) = (/ & + & 1.22893E+01_JPRB, 1.22556E+01_JPRB, 1.22221E+01_JPRB, 1.21886E+01_JPRB, 1.21552E+01_JPRB, & + & 1.21220E+01_JPRB, 1.20888E+01_JPRB, 1.20557E+01_JPRB, 1.20227E+01_JPRB, 1.19898E+01_JPRB, & + & 1.19569E+01_JPRB, 1.19242E+01_JPRB, 1.18915E+01_JPRB, 1.18590E+01_JPRB, 1.18265E+01_JPRB, & + & 1.17941E+01_JPRB, 1.17618E+01_JPRB, 1.17296E+01_JPRB, 1.16975E+01_JPRB/) + KAO_MN2O( 3, :, 6) = (/ & + & 7.93118E+00_JPRB, 7.94590E+00_JPRB, 7.96065E+00_JPRB, 7.97542E+00_JPRB, 7.99022E+00_JPRB, & + & 8.00505E+00_JPRB, 8.01990E+00_JPRB, 8.03478E+00_JPRB, 8.04970E+00_JPRB, 8.06463E+00_JPRB, & + & 8.07960E+00_JPRB, 8.09459E+00_JPRB, 8.10961E+00_JPRB, 8.12466E+00_JPRB, 8.13974E+00_JPRB, & + & 8.15485E+00_JPRB, 8.16998E+00_JPRB, 8.18514E+00_JPRB, 8.20033E+00_JPRB/) + KAO_MN2O( 4, :, 6) = (/ & + & 4.08899E+00_JPRB, 4.11435E+00_JPRB, 4.13988E+00_JPRB, 4.16556E+00_JPRB, 4.19140E+00_JPRB, & + & 4.21740E+00_JPRB, 4.24357E+00_JPRB, 4.26989E+00_JPRB, 4.29638E+00_JPRB, 4.32304E+00_JPRB, & + & 4.34985E+00_JPRB, 4.37684E+00_JPRB, 4.40399E+00_JPRB, 4.43131E+00_JPRB, 4.45880E+00_JPRB, & + & 4.48646E+00_JPRB, 4.51430E+00_JPRB, 4.54230E+00_JPRB, 4.57048E+00_JPRB/) + KAO_MN2O( 5, :, 6) = (/ & + & 2.61358E+00_JPRB, 2.64029E+00_JPRB, 2.66728E+00_JPRB, 2.69454E+00_JPRB, 2.72209E+00_JPRB, & + & 2.74991E+00_JPRB, 2.77802E+00_JPRB, 2.80641E+00_JPRB, 2.83510E+00_JPRB, 2.86408E+00_JPRB, & + & 2.89335E+00_JPRB, 2.92293E+00_JPRB, 2.95280E+00_JPRB, 2.98299E+00_JPRB, 3.01348E+00_JPRB, & + & 3.04428E+00_JPRB, 3.07540E+00_JPRB, 3.10683E+00_JPRB, 3.13859E+00_JPRB/) + KAO_MN2O( 6, :, 6) = (/ & + & 2.40720E+00_JPRB, 2.43430E+00_JPRB, 2.46169E+00_JPRB, 2.48940E+00_JPRB, 2.51741E+00_JPRB, & + & 2.54575E+00_JPRB, 2.57440E+00_JPRB, 2.60337E+00_JPRB, 2.63267E+00_JPRB, 2.66230E+00_JPRB, & + & 2.69226E+00_JPRB, 2.72256E+00_JPRB, 2.75320E+00_JPRB, 2.78419E+00_JPRB, 2.81552E+00_JPRB, & + & 2.84721E+00_JPRB, 2.87925E+00_JPRB, 2.91166E+00_JPRB, 2.94443E+00_JPRB/) + KAO_MN2O( 7, :, 6) = (/ & + & 1.99607E+00_JPRB, 2.01725E+00_JPRB, 2.03865E+00_JPRB, 2.06028E+00_JPRB, 2.08214E+00_JPRB, & + & 2.10423E+00_JPRB, 2.12655E+00_JPRB, 2.14912E+00_JPRB, 2.17192E+00_JPRB, 2.19496E+00_JPRB, & + & 2.21825E+00_JPRB, 2.24179E+00_JPRB, 2.26557E+00_JPRB, 2.28961E+00_JPRB, 2.31390E+00_JPRB, & + & 2.33845E+00_JPRB, 2.36326E+00_JPRB, 2.38834E+00_JPRB, 2.41368E+00_JPRB/) + KAO_MN2O( 8, :, 6) = (/ & + & 1.94150E+00_JPRB, 1.96398E+00_JPRB, 1.98671E+00_JPRB, 2.00971E+00_JPRB, 2.03298E+00_JPRB, & + & 2.05651E+00_JPRB, 2.08032E+00_JPRB, 2.10440E+00_JPRB, 2.12876E+00_JPRB, 2.15341E+00_JPRB, & + & 2.17834E+00_JPRB, 2.20355E+00_JPRB, 2.22906E+00_JPRB, 2.25487E+00_JPRB, 2.28097E+00_JPRB, & + & 2.30738E+00_JPRB, 2.33409E+00_JPRB, 2.36111E+00_JPRB, 2.38844E+00_JPRB/) + KAO_MN2O( 9, :, 6) = (/ & + & 2.47259E+00_JPRB, 2.48950E+00_JPRB, 2.50653E+00_JPRB, 2.52367E+00_JPRB, 2.54093E+00_JPRB, & + & 2.55831E+00_JPRB, 2.57581E+00_JPRB, 2.59343E+00_JPRB, 2.61117E+00_JPRB, 2.62903E+00_JPRB, & + & 2.64701E+00_JPRB, 2.66511E+00_JPRB, 2.68334E+00_JPRB, 2.70169E+00_JPRB, 2.72017E+00_JPRB, & + & 2.73878E+00_JPRB, 2.75751E+00_JPRB, 2.77637E+00_JPRB, 2.79536E+00_JPRB/) + KAO_MN2O( 1, :, 7) = (/ & + & 1.23417E+01_JPRB, 1.22618E+01_JPRB, 1.21823E+01_JPRB, 1.21034E+01_JPRB, 1.20250E+01_JPRB, & + & 1.19471E+01_JPRB, 1.18697E+01_JPRB, 1.17928E+01_JPRB, 1.17164E+01_JPRB, 1.16405E+01_JPRB, & + & 1.15651E+01_JPRB, 1.14901E+01_JPRB, 1.14157E+01_JPRB, 1.13417E+01_JPRB, 1.12683E+01_JPRB, & + & 1.11952E+01_JPRB, 1.11227E+01_JPRB, 1.10507E+01_JPRB, 1.09791E+01_JPRB/) + KAO_MN2O( 2, :, 7) = (/ & + & 9.30957E+00_JPRB, 9.32775E+00_JPRB, 9.34597E+00_JPRB, 9.36421E+00_JPRB, 9.38250E+00_JPRB, & + & 9.40082E+00_JPRB, 9.41918E+00_JPRB, 9.43757E+00_JPRB, 9.45600E+00_JPRB, 9.47446E+00_JPRB, & + & 9.49296E+00_JPRB, 9.51150E+00_JPRB, 9.53007E+00_JPRB, 9.54868E+00_JPRB, 9.56732E+00_JPRB, & + & 9.58601E+00_JPRB, 9.60472E+00_JPRB, 9.62348E+00_JPRB, 9.64227E+00_JPRB/) + KAO_MN2O( 3, :, 7) = (/ & + & 4.15867E+00_JPRB, 4.19254E+00_JPRB, 4.22668E+00_JPRB, 4.26110E+00_JPRB, 4.29581E+00_JPRB, & + & 4.33079E+00_JPRB, 4.36606E+00_JPRB, 4.40162E+00_JPRB, 4.43747E+00_JPRB, 4.47360E+00_JPRB, & + & 4.51004E+00_JPRB, 4.54677E+00_JPRB, 4.58380E+00_JPRB, 4.62113E+00_JPRB, 4.65876E+00_JPRB, & + & 4.69670E+00_JPRB, 4.73495E+00_JPRB, 4.77351E+00_JPRB, 4.81239E+00_JPRB/) + KAO_MN2O( 4, :, 7) = (/ & + & 3.55634E+00_JPRB, 3.59382E+00_JPRB, 3.63169E+00_JPRB, 3.66996E+00_JPRB, 3.70863E+00_JPRB, & + & 3.74771E+00_JPRB, 3.78720E+00_JPRB, 3.82711E+00_JPRB, 3.86744E+00_JPRB, 3.90820E+00_JPRB, & + & 3.94938E+00_JPRB, 3.99100E+00_JPRB, 4.03305E+00_JPRB, 4.07555E+00_JPRB, 4.11850E+00_JPRB, & + & 4.16190E+00_JPRB, 4.20576E+00_JPRB, 4.25008E+00_JPRB, 4.29486E+00_JPRB/) + KAO_MN2O( 5, :, 7) = (/ & + & 3.09468E+00_JPRB, 3.12655E+00_JPRB, 3.15876E+00_JPRB, 3.19129E+00_JPRB, 3.22416E+00_JPRB, & + & 3.25737E+00_JPRB, 3.29092E+00_JPRB, 3.32482E+00_JPRB, 3.35907E+00_JPRB, 3.39366E+00_JPRB, & + & 3.42862E+00_JPRB, 3.46393E+00_JPRB, 3.49961E+00_JPRB, 3.53566E+00_JPRB, 3.57208E+00_JPRB, & + & 3.60887E+00_JPRB, 3.64604E+00_JPRB, 3.68360E+00_JPRB, 3.72154E+00_JPRB/) + KAO_MN2O( 6, :, 7) = (/ & + & 2.75473E+00_JPRB, 2.78356E+00_JPRB, 2.81268E+00_JPRB, 2.84211E+00_JPRB, 2.87185E+00_JPRB, & + & 2.90190E+00_JPRB, 2.93227E+00_JPRB, 2.96295E+00_JPRB, 2.99395E+00_JPRB, 3.02528E+00_JPRB, & + & 3.05694E+00_JPRB, 3.08892E+00_JPRB, 3.12125E+00_JPRB, 3.15391E+00_JPRB, 3.18691E+00_JPRB, & + & 3.22025E+00_JPRB, 3.25395E+00_JPRB, 3.28800E+00_JPRB, 3.32240E+00_JPRB/) + KAO_MN2O( 7, :, 7) = (/ & + & 2.68587E+00_JPRB, 2.71431E+00_JPRB, 2.74306E+00_JPRB, 2.77211E+00_JPRB, 2.80146E+00_JPRB, & + & 2.83113E+00_JPRB, 2.86111E+00_JPRB, 2.89141E+00_JPRB, 2.92203E+00_JPRB, 2.95298E+00_JPRB, & + & 2.98425E+00_JPRB, 3.01585E+00_JPRB, 3.04779E+00_JPRB, 3.08006E+00_JPRB, 3.11268E+00_JPRB, & + & 3.14564E+00_JPRB, 3.17896E+00_JPRB, 3.21262E+00_JPRB, 3.24664E+00_JPRB/) + KAO_MN2O( 8, :, 7) = (/ & + & 2.54778E+00_JPRB, 2.57461E+00_JPRB, 2.60173E+00_JPRB, 2.62914E+00_JPRB, 2.65683E+00_JPRB, & + & 2.68482E+00_JPRB, 2.71310E+00_JPRB, 2.74168E+00_JPRB, 2.77056E+00_JPRB, 2.79974E+00_JPRB, & + & 2.82923E+00_JPRB, 2.85903E+00_JPRB, 2.88915E+00_JPRB, 2.91958E+00_JPRB, 2.95033E+00_JPRB, & + & 2.98141E+00_JPRB, 3.01282E+00_JPRB, 3.04455E+00_JPRB, 3.07662E+00_JPRB/) + KAO_MN2O( 9, :, 7) = (/ & + & 2.78137E+00_JPRB, 2.80957E+00_JPRB, 2.83805E+00_JPRB, 2.86682E+00_JPRB, 2.89589E+00_JPRB, & + & 2.92525E+00_JPRB, 2.95491E+00_JPRB, 2.98486E+00_JPRB, 3.01512E+00_JPRB, 3.04569E+00_JPRB, & + & 3.07657E+00_JPRB, 3.10776E+00_JPRB, 3.13927E+00_JPRB, 3.17110E+00_JPRB, 3.20324E+00_JPRB, & + & 3.23572E+00_JPRB, 3.26852E+00_JPRB, 3.30166E+00_JPRB, 3.33513E+00_JPRB/) + KAO_MN2O( 1, :, 8) = (/ & + & 2.28384E+01_JPRB, 2.27450E+01_JPRB, 2.26519E+01_JPRB, 2.25593E+01_JPRB, 2.24670E+01_JPRB, & + & 2.23751E+01_JPRB, 2.22835E+01_JPRB, 2.21924E+01_JPRB, 2.21016E+01_JPRB, 2.20112E+01_JPRB, & + & 2.19211E+01_JPRB, 2.18314E+01_JPRB, 2.17421E+01_JPRB, 2.16532E+01_JPRB, 2.15646E+01_JPRB, & + & 2.14764E+01_JPRB, 2.13885E+01_JPRB, 2.13010E+01_JPRB, 2.12139E+01_JPRB/) + KAO_MN2O( 2, :, 8) = (/ & + & 4.48608E+00_JPRB, 4.52259E+00_JPRB, 4.55939E+00_JPRB, 4.59649E+00_JPRB, 4.63389E+00_JPRB, & + & 4.67160E+00_JPRB, 4.70961E+00_JPRB, 4.74793E+00_JPRB, 4.78656E+00_JPRB, 4.82551E+00_JPRB, & + & 4.86478E+00_JPRB, 4.90436E+00_JPRB, 4.94427E+00_JPRB, 4.98450E+00_JPRB, 5.02506E+00_JPRB, & + & 5.06595E+00_JPRB, 5.10717E+00_JPRB, 5.14873E+00_JPRB, 5.19062E+00_JPRB/) + KAO_MN2O( 3, :, 8) = (/ & + & 3.69928E+00_JPRB, 3.72584E+00_JPRB, 3.75259E+00_JPRB, 3.77953E+00_JPRB, 3.80666E+00_JPRB, & + & 3.83399E+00_JPRB, 3.86152E+00_JPRB, 3.88924E+00_JPRB, 3.91717E+00_JPRB, 3.94529E+00_JPRB, & + & 3.97361E+00_JPRB, 4.00214E+00_JPRB, 4.03088E+00_JPRB, 4.05982E+00_JPRB, 4.08896E+00_JPRB, & + & 4.11832E+00_JPRB, 4.14789E+00_JPRB, 4.17767E+00_JPRB, 4.20766E+00_JPRB/) + KAO_MN2O( 4, :, 8) = (/ & + & 3.17856E+00_JPRB, 3.19596E+00_JPRB, 3.21345E+00_JPRB, 3.23104E+00_JPRB, 3.24872E+00_JPRB, & + & 3.26650E+00_JPRB, 3.28437E+00_JPRB, 3.30235E+00_JPRB, 3.32042E+00_JPRB, 3.33859E+00_JPRB, & + & 3.35686E+00_JPRB, 3.37523E+00_JPRB, 3.39370E+00_JPRB, 3.41227E+00_JPRB, 3.43095E+00_JPRB, & + & 3.44972E+00_JPRB, 3.46860E+00_JPRB, 3.48758E+00_JPRB, 3.50667E+00_JPRB/) + KAO_MN2O( 5, :, 8) = (/ & + & 3.16549E+00_JPRB, 3.18288E+00_JPRB, 3.20037E+00_JPRB, 3.21795E+00_JPRB, 3.23563E+00_JPRB, & + & 3.25340E+00_JPRB, 3.27128E+00_JPRB, 3.28925E+00_JPRB, 3.30732E+00_JPRB, 3.32549E+00_JPRB, & + & 3.34376E+00_JPRB, 3.36213E+00_JPRB, 3.38060E+00_JPRB, 3.39917E+00_JPRB, 3.41785E+00_JPRB, & + & 3.43662E+00_JPRB, 3.45551E+00_JPRB, 3.47449E+00_JPRB, 3.49358E+00_JPRB/) + KAO_MN2O( 6, :, 8) = (/ & + & 3.16612E+00_JPRB, 3.18355E+00_JPRB, 3.20108E+00_JPRB, 3.21870E+00_JPRB, 3.23643E+00_JPRB, & + & 3.25425E+00_JPRB, 3.27217E+00_JPRB, 3.29018E+00_JPRB, 3.30830E+00_JPRB, 3.32652E+00_JPRB, & + & 3.34483E+00_JPRB, 3.36325E+00_JPRB, 3.38177E+00_JPRB, 3.40039E+00_JPRB, 3.41911E+00_JPRB, & + & 3.43794E+00_JPRB, 3.45687E+00_JPRB, 3.47591E+00_JPRB, 3.49505E+00_JPRB/) + KAO_MN2O( 7, :, 8) = (/ & + & 3.19644E+00_JPRB, 3.21419E+00_JPRB, 3.23203E+00_JPRB, 3.24996E+00_JPRB, 3.26800E+00_JPRB, & + & 3.28614E+00_JPRB, 3.30438E+00_JPRB, 3.32272E+00_JPRB, 3.34116E+00_JPRB, 3.35970E+00_JPRB, & + & 3.37835E+00_JPRB, 3.39710E+00_JPRB, 3.41596E+00_JPRB, 3.43492E+00_JPRB, 3.45398E+00_JPRB, & + & 3.47315E+00_JPRB, 3.49243E+00_JPRB, 3.51181E+00_JPRB, 3.53130E+00_JPRB/) + KAO_MN2O( 8, :, 8) = (/ & + & 3.35759E+00_JPRB, 3.37775E+00_JPRB, 3.39804E+00_JPRB, 3.41845E+00_JPRB, 3.43899E+00_JPRB, & + & 3.45964E+00_JPRB, 3.48042E+00_JPRB, 3.50133E+00_JPRB, 3.52236E+00_JPRB, 3.54351E+00_JPRB, & + & 3.56480E+00_JPRB, 3.58621E+00_JPRB, 3.60775E+00_JPRB, 3.62942E+00_JPRB, 3.65122E+00_JPRB, & + & 3.67315E+00_JPRB, 3.69521E+00_JPRB, 3.71741E+00_JPRB, 3.73974E+00_JPRB/) + KAO_MN2O( 9, :, 8) = (/ & + & 3.17378E+00_JPRB, 3.19135E+00_JPRB, 3.20901E+00_JPRB, 3.22677E+00_JPRB, 3.24462E+00_JPRB, & + & 3.26258E+00_JPRB, 3.28063E+00_JPRB, 3.29879E+00_JPRB, 3.31704E+00_JPRB, 3.33540E+00_JPRB, & + & 3.35386E+00_JPRB, 3.37242E+00_JPRB, 3.39108E+00_JPRB, 3.40984E+00_JPRB, 3.42871E+00_JPRB, & + & 3.44769E+00_JPRB, 3.46677E+00_JPRB, 3.48595E+00_JPRB, 3.50524E+00_JPRB/) + KAO_MN2O( 1, :, 9) = (/ & + & 2.09106E+01_JPRB, 2.08779E+01_JPRB, 2.08452E+01_JPRB, 2.08126E+01_JPRB, 2.07800E+01_JPRB, & + & 2.07475E+01_JPRB, 2.07150E+01_JPRB, 2.06826E+01_JPRB, 2.06502E+01_JPRB, 2.06179E+01_JPRB, & + & 2.05856E+01_JPRB, 2.05534E+01_JPRB, 2.05213E+01_JPRB, 2.04891E+01_JPRB, 2.04571E+01_JPRB, & + & 2.04251E+01_JPRB, 2.03931E+01_JPRB, 2.03612E+01_JPRB, 2.03293E+01_JPRB/) + KAO_MN2O( 2, :, 9) = (/ & + & 2.60494E+00_JPRB, 2.62757E+00_JPRB, 2.65040E+00_JPRB, 2.67343E+00_JPRB, 2.69665E+00_JPRB, & + & 2.72008E+00_JPRB, 2.74372E+00_JPRB, 2.76756E+00_JPRB, 2.79160E+00_JPRB, 2.81586E+00_JPRB, & + & 2.84032E+00_JPRB, 2.86500E+00_JPRB, 2.88989E+00_JPRB, 2.91500E+00_JPRB, 2.94033E+00_JPRB, & + & 2.96588E+00_JPRB, 2.99164E+00_JPRB, 3.01764E+00_JPRB, 3.04386E+00_JPRB/) + KAO_MN2O( 3, :, 9) = (/ & + & 2.42238E+00_JPRB, 2.44514E+00_JPRB, 2.46811E+00_JPRB, 2.49130E+00_JPRB, 2.51471E+00_JPRB, & + & 2.53834E+00_JPRB, 2.56219E+00_JPRB, 2.58626E+00_JPRB, 2.61056E+00_JPRB, 2.63509E+00_JPRB, & + & 2.65985E+00_JPRB, 2.68484E+00_JPRB, 2.71007E+00_JPRB, 2.73554E+00_JPRB, 2.76124E+00_JPRB, & + & 2.78718E+00_JPRB, 2.81337E+00_JPRB, 2.83981E+00_JPRB, 2.86649E+00_JPRB/) + KAO_MN2O( 4, :, 9) = (/ & + & 2.33681E+00_JPRB, 2.35961E+00_JPRB, 2.38263E+00_JPRB, 2.40588E+00_JPRB, 2.42935E+00_JPRB, & + & 2.45305E+00_JPRB, 2.47699E+00_JPRB, 2.50115E+00_JPRB, 2.52556E+00_JPRB, 2.55020E+00_JPRB, & + & 2.57508E+00_JPRB, 2.60021E+00_JPRB, 2.62558E+00_JPRB, 2.65119E+00_JPRB, 2.67706E+00_JPRB, & + & 2.70318E+00_JPRB, 2.72955E+00_JPRB, 2.75619E+00_JPRB, 2.78308E+00_JPRB/) + KAO_MN2O( 5, :, 9) = (/ & + & 2.26420E+00_JPRB, 2.28696E+00_JPRB, 2.30996E+00_JPRB, 2.33319E+00_JPRB, 2.35665E+00_JPRB, & + & 2.38035E+00_JPRB, 2.40429E+00_JPRB, 2.42846E+00_JPRB, 2.45288E+00_JPRB, 2.47755E+00_JPRB, & + & 2.50246E+00_JPRB, 2.52763E+00_JPRB, 2.55304E+00_JPRB, 2.57871E+00_JPRB, 2.60465E+00_JPRB, & + & 2.63084E+00_JPRB, 2.65729E+00_JPRB, 2.68401E+00_JPRB, 2.71100E+00_JPRB/) + KAO_MN2O( 6, :, 9) = (/ & + & 2.19628E+00_JPRB, 2.21902E+00_JPRB, 2.24199E+00_JPRB, 2.26520E+00_JPRB, 2.28865E+00_JPRB, & + & 2.31234E+00_JPRB, 2.33628E+00_JPRB, 2.36047E+00_JPRB, 2.38491E+00_JPRB, 2.40959E+00_JPRB, & + & 2.43454E+00_JPRB, 2.45974E+00_JPRB, 2.48521E+00_JPRB, 2.51094E+00_JPRB, 2.53693E+00_JPRB, & + & 2.56319E+00_JPRB, 2.58973E+00_JPRB, 2.61654E+00_JPRB, 2.64363E+00_JPRB/) + KAO_MN2O( 7, :, 9) = (/ & + & 2.07829E+00_JPRB, 2.10090E+00_JPRB, 2.12375E+00_JPRB, 2.14685E+00_JPRB, 2.17021E+00_JPRB, & + & 2.19381E+00_JPRB, 2.21767E+00_JPRB, 2.24180E+00_JPRB, 2.26618E+00_JPRB, 2.29083E+00_JPRB, & + & 2.31575E+00_JPRB, 2.34094E+00_JPRB, 2.36640E+00_JPRB, 2.39214E+00_JPRB, 2.41816E+00_JPRB, & + & 2.44446E+00_JPRB, 2.47105E+00_JPRB, 2.49793E+00_JPRB, 2.52510E+00_JPRB/) + KAO_MN2O( 8, :, 9) = (/ & + & 1.68230E+00_JPRB, 1.70305E+00_JPRB, 1.72404E+00_JPRB, 1.74530E+00_JPRB, 1.76681E+00_JPRB, & + & 1.78860E+00_JPRB, 1.81065E+00_JPRB, 1.83297E+00_JPRB, 1.85557E+00_JPRB, 1.87845E+00_JPRB, & + & 1.90161E+00_JPRB, 1.92505E+00_JPRB, 1.94878E+00_JPRB, 1.97281E+00_JPRB, 1.99713E+00_JPRB, & + & 2.02176E+00_JPRB, 2.04668E+00_JPRB, 2.07191E+00_JPRB, 2.09746E+00_JPRB/) + KAO_MN2O( 9, :, 9) = (/ & + & 2.23224E+00_JPRB, 2.25486E+00_JPRB, 2.27771E+00_JPRB, 2.30079E+00_JPRB, 2.32411E+00_JPRB, & + & 2.34766E+00_JPRB, 2.37145E+00_JPRB, 2.39548E+00_JPRB, 2.41975E+00_JPRB, 2.44427E+00_JPRB, & + & 2.46904E+00_JPRB, 2.49406E+00_JPRB, 2.51933E+00_JPRB, 2.54486E+00_JPRB, 2.57065E+00_JPRB, & + & 2.59670E+00_JPRB, 2.62301E+00_JPRB, 2.64959E+00_JPRB, 2.67644E+00_JPRB/) + KAO_MN2O( 1, :,10) = (/ & + & 1.30711E+01_JPRB, 1.31853E+01_JPRB, 1.33004E+01_JPRB, 1.34166E+01_JPRB, 1.35339E+01_JPRB, & + & 1.36521E+01_JPRB, 1.37714E+01_JPRB, 1.38917E+01_JPRB, 1.40130E+01_JPRB, 1.41355E+01_JPRB, & + & 1.42590E+01_JPRB, 1.43835E+01_JPRB, 1.45092E+01_JPRB, 1.46360E+01_JPRB, 1.47638E+01_JPRB, & + & 1.48928E+01_JPRB, 1.50229E+01_JPRB, 1.51542E+01_JPRB, 1.52866E+01_JPRB/) + KAO_MN2O( 2, :,10) = (/ & + & 2.71206E-01_JPRB, 2.90148E-01_JPRB, 3.10413E-01_JPRB, 3.32093E-01_JPRB, 3.55287E-01_JPRB, & + & 3.80102E-01_JPRB, 4.06649E-01_JPRB, 4.35051E-01_JPRB, 4.65436E-01_JPRB, 4.97943E-01_JPRB, & + & 5.32721E-01_JPRB, 5.69928E-01_JPRB, 6.09733E-01_JPRB, 6.52319E-01_JPRB, 6.97879E-01_JPRB, & + & 7.46621E-01_JPRB, 7.98767E-01_JPRB, 8.54555E-01_JPRB, 9.14239E-01_JPRB/) + KAO_MN2O( 3, :,10) = (/ & + & 2.65609E-01_JPRB, 2.84236E-01_JPRB, 3.04170E-01_JPRB, 3.25501E-01_JPRB, 3.48329E-01_JPRB, & + & 3.72758E-01_JPRB, 3.98900E-01_JPRB, 4.26875E-01_JPRB, 4.56812E-01_JPRB, 4.88849E-01_JPRB, & + & 5.23132E-01_JPRB, 5.59820E-01_JPRB, 5.99080E-01_JPRB, 6.41095E-01_JPRB, 6.86055E-01_JPRB, & + & 7.34169E-01_JPRB, 7.85657E-01_JPRB, 8.40756E-01_JPRB, 8.99718E-01_JPRB/) + KAO_MN2O( 4, :,10) = (/ & + & 2.55277E-01_JPRB, 2.73370E-01_JPRB, 2.92745E-01_JPRB, 3.13494E-01_JPRB, 3.35714E-01_JPRB, & + & 3.59508E-01_JPRB, 3.84989E-01_JPRB, 4.12275E-01_JPRB, 4.41496E-01_JPRB, 4.72788E-01_JPRB, & + & 5.06298E-01_JPRB, 5.42183E-01_JPRB, 5.80611E-01_JPRB, 6.21763E-01_JPRB, 6.65831E-01_JPRB, & + & 7.13023E-01_JPRB, 7.63560E-01_JPRB, 8.17678E-01_JPRB, 8.75633E-01_JPRB/) + KAO_MN2O( 5, :,10) = (/ & + & 2.41481E-01_JPRB, 2.58840E-01_JPRB, 2.77446E-01_JPRB, 2.97390E-01_JPRB, 3.18768E-01_JPRB, & + & 3.41682E-01_JPRB, 3.66244E-01_JPRB, 3.92571E-01_JPRB, 4.20791E-01_JPRB, 4.51039E-01_JPRB, & + & 4.83461E-01_JPRB, 5.18215E-01_JPRB, 5.55466E-01_JPRB, 5.95396E-01_JPRB, 6.38195E-01_JPRB, & + & 6.84071E-01_JPRB, 7.33245E-01_JPRB, 7.85954E-01_JPRB, 8.42452E-01_JPRB/) + KAO_MN2O( 6, :,10) = (/ & + & 2.37173E-01_JPRB, 2.54360E-01_JPRB, 2.72792E-01_JPRB, 2.92559E-01_JPRB, 3.13759E-01_JPRB, & + & 3.36495E-01_JPRB, 3.60878E-01_JPRB, 3.87029E-01_JPRB, 4.15074E-01_JPRB, 4.45152E-01_JPRB, & + & 4.77409E-01_JPRB, 5.12004E-01_JPRB, 5.49105E-01_JPRB, 5.88895E-01_JPRB, 6.31569E-01_JPRB, & + & 6.77334E-01_JPRB, 7.26416E-01_JPRB, 7.79055E-01_JPRB, 8.35508E-01_JPRB/) + KAO_MN2O( 7, :,10) = (/ & + & 2.27414E-01_JPRB, 2.44231E-01_JPRB, 2.62292E-01_JPRB, 2.81689E-01_JPRB, 3.02520E-01_JPRB, & + & 3.24891E-01_JPRB, 3.48917E-01_JPRB, 3.74720E-01_JPRB, 4.02430E-01_JPRB, 4.32190E-01_JPRB, & + & 4.64151E-01_JPRB, 4.98475E-01_JPRB, 5.35337E-01_JPRB, 5.74926E-01_JPRB, 6.17442E-01_JPRB, & + & 6.63102E-01_JPRB, 7.12138E-01_JPRB, 7.64801E-01_JPRB, 8.21358E-01_JPRB/) + KAO_MN2O( 8, :,10) = (/ & + & 1.77234E-01_JPRB, 1.92029E-01_JPRB, 2.08060E-01_JPRB, 2.25429E-01_JPRB, 2.44248E-01_JPRB, & + & 2.64638E-01_JPRB, 2.86730E-01_JPRB, 3.10667E-01_JPRB, 3.36601E-01_JPRB, 3.64701E-01_JPRB, & + & 3.95147E-01_JPRB, 4.28134E-01_JPRB, 4.63875E-01_JPRB, 5.02600E-01_JPRB, 5.44557E-01_JPRB, & + & 5.90017E-01_JPRB, 6.39272E-01_JPRB, 6.92639E-01_JPRB, 7.50461E-01_JPRB/) + KAO_MN2O( 9, :,10) = (/ & + & 2.41727E-01_JPRB, 2.59094E-01_JPRB, 2.77710E-01_JPRB, 2.97662E-01_JPRB, 3.19049E-01_JPRB, & + & 3.41972E-01_JPRB, 3.66541E-01_JPRB, 3.92877E-01_JPRB, 4.21104E-01_JPRB, 4.51359E-01_JPRB, & + & 4.83788E-01_JPRB, 5.18547E-01_JPRB, 5.55804E-01_JPRB, 5.95737E-01_JPRB, 6.38539E-01_JPRB, & + & 6.84417E-01_JPRB, 7.33590E-01_JPRB, 7.86297E-01_JPRB, 8.42790E-01_JPRB/) + KAO_MN2O( 1, :,11) = (/ & + & 6.65287E+00_JPRB, 6.69137E+00_JPRB, 6.73008E+00_JPRB, 6.76903E+00_JPRB, 6.80820E+00_JPRB, & + & 6.84759E+00_JPRB, 6.88721E+00_JPRB, 6.92707E+00_JPRB, 6.96715E+00_JPRB, 7.00746E+00_JPRB, & + & 7.04801E+00_JPRB, 7.08879E+00_JPRB, 7.12981E+00_JPRB, 7.17107E+00_JPRB, 7.21256E+00_JPRB, & + & 7.25430E+00_JPRB, 7.29628E+00_JPRB, 7.33850E+00_JPRB, 7.38096E+00_JPRB/) + KAO_MN2O( 2, :,11) = (/ & + & 2.06252E-01_JPRB, 2.27731E-01_JPRB, 2.51447E-01_JPRB, 2.77633E-01_JPRB, 3.06546E-01_JPRB, & + & 3.38470E-01_JPRB, 3.73719E-01_JPRB, 4.12638E-01_JPRB, 4.55611E-01_JPRB, 5.03058E-01_JPRB, & + & 5.55447E-01_JPRB, 6.13292E-01_JPRB, 6.77160E-01_JPRB, 7.47680E-01_JPRB, 8.25544E-01_JPRB, & + & 9.11517E-01_JPRB, 1.00644E+00_JPRB, 1.11125E+00_JPRB, 1.22698E+00_JPRB/) + KAO_MN2O( 3, :,11) = (/ & + & 2.05840E-01_JPRB, 2.27279E-01_JPRB, 2.50952E-01_JPRB, 2.77090E-01_JPRB, 3.05950E-01_JPRB, & + & 3.37816E-01_JPRB, 3.73002E-01_JPRB, 4.11852E-01_JPRB, 4.54748E-01_JPRB, 5.02113E-01_JPRB, & + & 5.54411E-01_JPRB, 6.12155E-01_JPRB, 6.75915E-01_JPRB, 7.46315E-01_JPRB, 8.24047E-01_JPRB, & + & 9.09876E-01_JPRB, 1.00465E+00_JPRB, 1.10928E+00_JPRB, 1.22482E+00_JPRB/) + KAO_MN2O( 4, :,11) = (/ & + & 2.04702E-01_JPRB, 2.26031E-01_JPRB, 2.49582E-01_JPRB, 2.75587E-01_JPRB, 3.04301E-01_JPRB, & + & 3.36008E-01_JPRB, 3.71018E-01_JPRB, 4.09675E-01_JPRB, 4.52361E-01_JPRB, 4.99495E-01_JPRB, & + & 5.51539E-01_JPRB, 6.09007E-01_JPRB, 6.72461E-01_JPRB, 7.42528E-01_JPRB, 8.19895E-01_JPRB, & + & 9.05323E-01_JPRB, 9.99653E-01_JPRB, 1.10381E+00_JPRB, 1.21882E+00_JPRB/) + KAO_MN2O( 5, :,11) = (/ & + & 2.03481E-01_JPRB, 2.24689E-01_JPRB, 2.48108E-01_JPRB, 2.73967E-01_JPRB, 3.02522E-01_JPRB, & + & 3.34053E-01_JPRB, 3.68871E-01_JPRB, 4.07317E-01_JPRB, 4.49771E-01_JPRB, 4.96649E-01_JPRB, & + & 5.48414E-01_JPRB, 6.05574E-01_JPRB, 6.68691E-01_JPRB, 7.38387E-01_JPRB, 8.15347E-01_JPRB, & + & 9.00329E-01_JPRB, 9.94168E-01_JPRB, 1.09779E+00_JPRB, 1.21221E+00_JPRB/) + KAO_MN2O( 6, :,11) = (/ & + & 2.01513E-01_JPRB, 2.22529E-01_JPRB, 2.45738E-01_JPRB, 2.71367E-01_JPRB, 2.99670E-01_JPRB, & + & 3.30924E-01_JPRB, 3.65437E-01_JPRB, 4.03550E-01_JPRB, 4.45639E-01_JPRB, 4.92117E-01_JPRB, & + & 5.43442E-01_JPRB, 6.00120E-01_JPRB, 6.62710E-01_JPRB, 7.31827E-01_JPRB, 8.08153E-01_JPRB, & + & 8.92439E-01_JPRB, 9.85516E-01_JPRB, 1.08830E+00_JPRB, 1.20180E+00_JPRB/) + KAO_MN2O( 7, :,11) = (/ & + & 1.97136E-01_JPRB, 2.17723E-01_JPRB, 2.40459E-01_JPRB, 2.65570E-01_JPRB, 2.93304E-01_JPRB, & + & 3.23933E-01_JPRB, 3.57762E-01_JPRB, 3.95122E-01_JPRB, 4.36385E-01_JPRB, 4.81956E-01_JPRB, & + & 5.32287E-01_JPRB, 5.87873E-01_JPRB, 6.49264E-01_JPRB, 7.17067E-01_JPRB, 7.91950E-01_JPRB, & + & 8.74653E-01_JPRB, 9.65992E-01_JPRB, 1.06687E+00_JPRB, 1.17828E+00_JPRB/) + KAO_MN2O( 8, :,11) = (/ & + & 1.79518E-01_JPRB, 1.98371E-01_JPRB, 2.19204E-01_JPRB, 2.42224E-01_JPRB, 2.67662E-01_JPRB, & + & 2.95772E-01_JPRB, 3.26833E-01_JPRB, 3.61157E-01_JPRB, 3.99085E-01_JPRB, 4.40996E-01_JPRB, & + & 4.87309E-01_JPRB, 5.38486E-01_JPRB, 5.95037E-01_JPRB, 6.57526E-01_JPRB, 7.26579E-01_JPRB, & + & 8.02883E-01_JPRB, 8.87201E-01_JPRB, 9.80373E-01_JPRB, 1.08333E+00_JPRB/) + KAO_MN2O( 9, :,11) = (/ & + & 2.03481E-01_JPRB, 2.24689E-01_JPRB, 2.48108E-01_JPRB, 2.73967E-01_JPRB, 3.02522E-01_JPRB, & + & 3.34053E-01_JPRB, 3.68871E-01_JPRB, 4.07317E-01_JPRB, 4.49771E-01_JPRB, 4.96649E-01_JPRB, & + & 5.48414E-01_JPRB, 6.05574E-01_JPRB, 6.68691E-01_JPRB, 7.38387E-01_JPRB, 8.15347E-01_JPRB, & + & 9.00329E-01_JPRB, 9.94168E-01_JPRB, 1.09779E+00_JPRB, 1.21221E+00_JPRB/) + KAO_MN2O( 1, :,12) = (/ & + & 5.89636E+00_JPRB, 5.95081E+00_JPRB, 6.00576E+00_JPRB, 6.06121E+00_JPRB, 6.11718E+00_JPRB, & + & 6.17366E+00_JPRB, 6.23067E+00_JPRB, 6.28820E+00_JPRB, 6.34627E+00_JPRB, 6.40487E+00_JPRB, & + & 6.46401E+00_JPRB, 6.52369E+00_JPRB, 6.58393E+00_JPRB, 6.64472E+00_JPRB, 6.70608E+00_JPRB, & + & 6.76800E+00_JPRB, 6.83050E+00_JPRB, 6.89357E+00_JPRB, 6.95722E+00_JPRB/) + KAO_MN2O( 2, :,12) = (/ & + & 7.18699E-05_JPRB, 9.48140E-05_JPRB, 1.25083E-04_JPRB, 1.65015E-04_JPRB, 2.17695E-04_JPRB, & + & 2.87193E-04_JPRB, 3.78877E-04_JPRB, 4.99831E-04_JPRB, 6.59400E-04_JPRB, 8.69909E-04_JPRB, & + & 1.14762E-03_JPRB, 1.51400E-03_JPRB, 1.99733E-03_JPRB, 2.63497E-03_JPRB, 3.47616E-03_JPRB, & + & 4.58591E-03_JPRB, 6.04993E-03_JPRB, 7.98133E-03_JPRB, 1.05293E-02_JPRB/) + KAO_MN2O( 3, :,12) = (/ & + & 7.20868E-05_JPRB, 9.50993E-05_JPRB, 1.25458E-04_JPRB, 1.65508E-04_JPRB, 2.18344E-04_JPRB, & + & 2.88046E-04_JPRB, 3.80000E-04_JPRB, 5.01307E-04_JPRB, 6.61341E-04_JPRB, 8.72462E-04_JPRB, & + & 1.15098E-03_JPRB, 1.51841E-03_JPRB, 2.00313E-03_JPRB, 2.64260E-03_JPRB, 3.48620E-03_JPRB, & + & 4.59911E-03_JPRB, 6.06729E-03_JPRB, 8.00416E-03_JPRB, 1.05593E-02_JPRB/) + KAO_MN2O( 4, :,12) = (/ & + & 7.21734E-05_JPRB, 9.52161E-05_JPRB, 1.25616E-04_JPRB, 1.65721E-04_JPRB, 2.18630E-04_JPRB, & + & 2.88432E-04_JPRB, 3.80519E-04_JPRB, 5.02007E-04_JPRB, 6.62282E-04_JPRB, 8.73727E-04_JPRB, & + & 1.15268E-03_JPRB, 1.52070E-03_JPRB, 2.00621E-03_JPRB, 2.64673E-03_JPRB, 3.49174E-03_JPRB, & + & 4.60655E-03_JPRB, 6.07727E-03_JPRB, 8.01755E-03_JPRB, 1.05773E-02_JPRB/) + KAO_MN2O( 5, :,12) = (/ & + & 7.22599E-05_JPRB, 9.53329E-05_JPRB, 1.25773E-04_JPRB, 1.65933E-04_JPRB, 2.18916E-04_JPRB, & + & 2.88818E-04_JPRB, 3.81038E-04_JPRB, 5.02706E-04_JPRB, 6.63223E-04_JPRB, 8.74992E-04_JPRB, & + & 1.15438E-03_JPRB, 1.52298E-03_JPRB, 2.00928E-03_JPRB, 2.65085E-03_JPRB, 3.49728E-03_JPRB, & + & 4.61398E-03_JPRB, 6.08725E-03_JPRB, 8.03094E-03_JPRB, 1.05952E-02_JPRB/) + KAO_MN2O( 6, :,12) = (/ & + & 7.29962E-05_JPRB, 9.63091E-05_JPRB, 1.27067E-04_JPRB, 1.67649E-04_JPRB, 2.21191E-04_JPRB, & + & 2.91833E-04_JPRB, 3.85036E-04_JPRB, 5.08005E-04_JPRB, 6.70247E-04_JPRB, 8.84304E-04_JPRB, & + & 1.16672E-03_JPRB, 1.53934E-03_JPRB, 2.03096E-03_JPRB, 2.67959E-03_JPRB, 3.53537E-03_JPRB, & + & 4.66447E-03_JPRB, 6.15417E-03_JPRB, 8.11962E-03_JPRB, 1.07128E-02_JPRB/) + KAO_MN2O( 7, :,12) = (/ & + & 7.47398E-05_JPRB, 9.86139E-05_JPRB, 1.30114E-04_JPRB, 1.71677E-04_JPRB, 2.26516E-04_JPRB, & + & 2.98872E-04_JPRB, 3.94340E-04_JPRB, 5.20305E-04_JPRB, 6.86506E-04_JPRB, 9.05797E-04_JPRB, & + & 1.19514E-03_JPRB, 1.57690E-03_JPRB, 2.08061E-03_JPRB, 2.74522E-03_JPRB, 3.62213E-03_JPRB, & + & 4.77915E-03_JPRB, 6.30576E-03_JPRB, 8.32001E-03_JPRB, 1.09777E-02_JPRB/) + KAO_MN2O( 8, :,12) = (/ & + & 7.57487E-05_JPRB, 9.99802E-05_JPRB, 1.31963E-04_JPRB, 1.74177E-04_JPRB, 2.29896E-04_JPRB, & + & 3.03438E-04_JPRB, 4.00506E-04_JPRB, 5.28625E-04_JPRB, 6.97729E-04_JPRB, 9.20927E-04_JPRB, & + & 1.21553E-03_JPRB, 1.60437E-03_JPRB, 2.11759E-03_JPRB, 2.79499E-03_JPRB, 3.68909E-03_JPRB, & + & 4.86921E-03_JPRB, 6.42684E-03_JPRB, 8.48274E-03_JPRB, 1.11963E-02_JPRB/) + KAO_MN2O( 9, :,12) = (/ & + & 7.22467E-05_JPRB, 9.53177E-05_JPRB, 1.25756E-04_JPRB, 1.65915E-04_JPRB, 2.18898E-04_JPRB, & + & 2.88800E-04_JPRB, 3.81024E-04_JPRB, 5.02700E-04_JPRB, 6.63231E-04_JPRB, 8.75024E-04_JPRB, & + & 1.15445E-03_JPRB, 1.52311E-03_JPRB, 2.00950E-03_JPRB, 2.65121E-03_JPRB, 3.49784E-03_JPRB, & + & 4.61483E-03_JPRB, 6.08852E-03_JPRB, 8.03280E-03_JPRB, 1.05980E-02_JPRB/) + KAO_MN2O( 1, :,13) = (/ & + & 1.14265E+01_JPRB, 1.16380E+01_JPRB, 1.18534E+01_JPRB, 1.20728E+01_JPRB, 1.22962E+01_JPRB, & + & 1.25238E+01_JPRB, 1.27556E+01_JPRB, 1.29917E+01_JPRB, 1.32322E+01_JPRB, 1.34771E+01_JPRB, & + & 1.37265E+01_JPRB, 1.39806E+01_JPRB, 1.42394E+01_JPRB, 1.45029E+01_JPRB, 1.47714E+01_JPRB, & + & 1.50448E+01_JPRB, 1.53232E+01_JPRB, 1.56068E+01_JPRB, 1.58957E+01_JPRB/) + KAO_MN2O( 2, :,13) = (/ & + & 7.97796E-05_JPRB, 1.05659E-04_JPRB, 1.39932E-04_JPRB, 1.85324E-04_JPRB, 2.45439E-04_JPRB, & + & 3.25054E-04_JPRB, 4.30496E-04_JPRB, 5.70140E-04_JPRB, 7.55082E-04_JPRB, 1.00002E-03_JPRB, & + & 1.32440E-03_JPRB, 1.75401E-03_JPRB, 2.32298E-03_JPRB, 3.07651E-03_JPRB, 4.07447E-03_JPRB, & + & 5.39614E-03_JPRB, 7.14655E-03_JPRB, 9.46475E-03_JPRB, 1.25349E-02_JPRB/) + KAO_MN2O( 3, :,13) = (/ & + & 7.95035E-05_JPRB, 1.05293E-04_JPRB, 1.39449E-04_JPRB, 1.84684E-04_JPRB, 2.44592E-04_JPRB, & + & 3.23934E-04_JPRB, 4.29013E-04_JPRB, 5.68178E-04_JPRB, 7.52486E-04_JPRB, 9.96580E-04_JPRB, & + & 1.31985E-03_JPRB, 1.74800E-03_JPRB, 2.31502E-03_JPRB, 3.06597E-03_JPRB, 4.06052E-03_JPRB, & + & 5.37770E-03_JPRB, 7.12214E-03_JPRB, 9.43244E-03_JPRB, 1.24922E-02_JPRB/) + KAO_MN2O( 4, :,13) = (/ & + & 7.92339E-05_JPRB, 1.04938E-04_JPRB, 1.38980E-04_JPRB, 1.84065E-04_JPRB, 2.43776E-04_JPRB, & + & 3.22857E-04_JPRB, 4.27593E-04_JPRB, 5.66305E-04_JPRB, 7.50016E-04_JPRB, 9.93322E-04_JPRB, & + & 1.31556E-03_JPRB, 1.74233E-03_JPRB, 2.30754E-03_JPRB, 3.05612E-03_JPRB, 4.04752E-03_JPRB, & + & 5.36055E-03_JPRB, 7.09953E-03_JPRB, 9.40262E-03_JPRB, 1.24528E-02_JPRB/) + KAO_MN2O( 5, :,13) = (/ & + & 7.90000E-05_JPRB, 1.04627E-04_JPRB, 1.38566E-04_JPRB, 1.83516E-04_JPRB, 2.43046E-04_JPRB, & + & 3.21887E-04_JPRB, 4.26303E-04_JPRB, 5.64591E-04_JPRB, 7.47738E-04_JPRB, 9.90295E-04_JPRB, & + & 1.31154E-03_JPRB, 1.73698E-03_JPRB, 2.30044E-03_JPRB, 3.04667E-03_JPRB, 4.03498E-03_JPRB, & + & 5.34388E-03_JPRB, 7.07737E-03_JPRB, 9.37318E-03_JPRB, 1.24137E-02_JPRB/) + KAO_MN2O( 6, :,13) = (/ & + & 7.76004E-05_JPRB, 1.02776E-04_JPRB, 1.36118E-04_JPRB, 1.80278E-04_JPRB, 2.38764E-04_JPRB, & + & 3.16224E-04_JPRB, 4.18814E-04_JPRB, 5.54686E-04_JPRB, 7.34638E-04_JPRB, 9.72970E-04_JPRB, & + & 1.28862E-03_JPRB, 1.70668E-03_JPRB, 2.26036E-03_JPRB, 2.99367E-03_JPRB, 3.96488E-03_JPRB, & + & 5.25118E-03_JPRB, 6.95477E-03_JPRB, 9.21105E-03_JPRB, 1.21993E-02_JPRB/) + KAO_MN2O( 7, :,13) = (/ & + & 7.52813E-05_JPRB, 9.97094E-05_JPRB, 1.32064E-04_JPRB, 1.74918E-04_JPRB, 2.31677E-04_JPRB, & + & 3.06854E-04_JPRB, 4.06426E-04_JPRB, 5.38308E-04_JPRB, 7.12984E-04_JPRB, 9.44341E-04_JPRB, & + & 1.25077E-03_JPRB, 1.65664E-03_JPRB, 2.19420E-03_JPRB, 2.90620E-03_JPRB, 3.84923E-03_JPRB, & + & 5.09828E-03_JPRB, 6.75263E-03_JPRB, 8.94379E-03_JPRB, 1.18460E-02_JPRB/) + KAO_MN2O( 8, :,13) = (/ & + & 6.87436E-05_JPRB, 9.10605E-05_JPRB, 1.20622E-04_JPRB, 1.59781E-04_JPRB, 2.11653E-04_JPRB, & + & 2.80364E-04_JPRB, 3.71381E-04_JPRB, 4.91946E-04_JPRB, 6.51651E-04_JPRB, 8.63203E-04_JPRB, & + & 1.14343E-03_JPRB, 1.51464E-03_JPRB, 2.00635E-03_JPRB, 2.65769E-03_JPRB, 3.52048E-03_JPRB, & + & 4.66337E-03_JPRB, 6.17729E-03_JPRB, 8.18269E-03_JPRB, 1.08391E-02_JPRB/) + KAO_MN2O( 9, :,13) = (/ & + & 7.90357E-05_JPRB, 1.04671E-04_JPRB, 1.38622E-04_JPRB, 1.83585E-04_JPRB, 2.43132E-04_JPRB, & + & 3.21994E-04_JPRB, 4.26434E-04_JPRB, 5.64750E-04_JPRB, 7.47931E-04_JPRB, 9.90526E-04_JPRB, & + & 1.31181E-03_JPRB, 1.73730E-03_JPRB, 2.30081E-03_JPRB, 3.04709E-03_JPRB, 4.03543E-03_JPRB, & + & 5.34435E-03_JPRB, 7.07782E-03_JPRB, 9.37355E-03_JPRB, 1.24139E-02_JPRB/) + KAO_MN2O( 1, :,14) = (/ & + & 1.61373E+01_JPRB, 1.64784E+01_JPRB, 1.68266E+01_JPRB, 1.71822E+01_JPRB, 1.75454E+01_JPRB, & + & 1.79162E+01_JPRB, 1.82948E+01_JPRB, 1.86814E+01_JPRB, 1.90762E+01_JPRB, 1.94794E+01_JPRB, & + & 1.98911E+01_JPRB, 2.03114E+01_JPRB, 2.07407E+01_JPRB, 2.11790E+01_JPRB, 2.16266E+01_JPRB, & + & 2.20836E+01_JPRB, 2.25504E+01_JPRB, 2.30269E+01_JPRB, 2.35136E+01_JPRB/) + KAO_MN2O( 2, :,14) = (/ & + & 6.92866E-10_JPRB, 9.24655E-10_JPRB, 1.23398E-09_JPRB, 1.64680E-09_JPRB, 2.19771E-09_JPRB, & + & 2.93292E-09_JPRB, 3.91409E-09_JPRB, 5.22349E-09_JPRB, 6.97093E-09_JPRB, 9.30295E-09_JPRB, & + & 1.24151E-08_JPRB, 1.65684E-08_JPRB, 2.21111E-08_JPRB, 2.95081E-08_JPRB, 3.93796E-08_JPRB, & + & 5.25535E-08_JPRB, 7.01346E-08_JPRB, 9.35970E-08_JPRB, 1.24908E-07_JPRB/) + KAO_MN2O( 3, :,14) = (/ & + & 6.94564E-10_JPRB, 9.26928E-10_JPRB, 1.23703E-09_JPRB, 1.65088E-09_JPRB, 2.20317E-09_JPRB, & + & 2.94024E-09_JPRB, 3.92389E-09_JPRB, 5.23661E-09_JPRB, 6.98851E-09_JPRB, 9.32650E-09_JPRB, & + & 1.24467E-08_JPRB, 1.66107E-08_JPRB, 2.21677E-08_JPRB, 2.95839E-08_JPRB, 3.94811E-08_JPRB, & + & 5.26894E-08_JPRB, 7.03165E-08_JPRB, 9.38407E-08_JPRB, 1.25235E-07_JPRB/) + KAO_MN2O( 4, :,14) = (/ & + & 6.98644E-10_JPRB, 9.32310E-10_JPRB, 1.24413E-09_JPRB, 1.66023E-09_JPRB, 2.21551E-09_JPRB, & + & 2.95649E-09_JPRB, 3.94531E-09_JPRB, 5.26484E-09_JPRB, 7.02570E-09_JPRB, 9.37548E-09_JPRB, & + & 1.25112E-08_JPRB, 1.66956E-08_JPRB, 2.22795E-08_JPRB, 2.97311E-08_JPRB, 3.96748E-08_JPRB, & + & 5.29443E-08_JPRB, 7.06518E-08_JPRB, 9.42817E-08_JPRB, 1.25815E-07_JPRB/) + KAO_MN2O( 5, :,14) = (/ & + & 7.03261E-10_JPRB, 9.38472E-10_JPRB, 1.25235E-09_JPRB, 1.67121E-09_JPRB, 2.23016E-09_JPRB, & + & 2.97605E-09_JPRB, 3.97141E-09_JPRB, 5.29968E-09_JPRB, 7.07220E-09_JPRB, 9.43754E-09_JPRB, & + & 1.25940E-08_JPRB, 1.68062E-08_JPRB, 2.24271E-08_JPRB, 2.99280E-08_JPRB, 3.99376E-08_JPRB, & + & 5.32951E-08_JPRB, 7.11200E-08_JPRB, 9.49066E-08_JPRB, 1.26649E-07_JPRB/) + KAO_MN2O( 6, :,14) = (/ & + & 7.12478E-10_JPRB, 9.50674E-10_JPRB, 1.26850E-09_JPRB, 1.69259E-09_JPRB, 2.25845E-09_JPRB, & + & 3.01350E-09_JPRB, 4.02096E-09_JPRB, 5.36525E-09_JPRB, 7.15896E-09_JPRB, 9.55233E-09_JPRB, & + & 1.27459E-08_JPRB, 1.70071E-08_JPRB, 2.26928E-08_JPRB, 3.02795E-08_JPRB, 4.04025E-08_JPRB, & + & 5.39099E-08_JPRB, 7.19330E-08_JPRB, 9.59815E-08_JPRB, 1.28070E-07_JPRB/) + KAO_MN2O( 7, :,14) = (/ & + & 7.28994E-10_JPRB, 9.72644E-10_JPRB, 1.29773E-09_JPRB, 1.73147E-09_JPRB, 2.31017E-09_JPRB, & + & 3.08230E-09_JPRB, 4.11249E-09_JPRB, 5.48700E-09_JPRB, 7.32092E-09_JPRB, 9.76777E-09_JPRB, & + & 1.30324E-08_JPRB, 1.73883E-08_JPRB, 2.31999E-08_JPRB, 3.09540E-08_JPRB, 4.12996E-08_JPRB, & + & 5.51032E-08_JPRB, 7.35203E-08_JPRB, 9.80928E-08_JPRB, 1.30878E-07_JPRB/) + KAO_MN2O( 8, :,14) = (/ & + & 7.87604E-10_JPRB, 1.05043E-09_JPRB, 1.40097E-09_JPRB, 1.86848E-09_JPRB, 2.49201E-09_JPRB, & + & 3.32360E-09_JPRB, 4.43271E-09_JPRB, 5.91194E-09_JPRB, 7.88479E-09_JPRB, 1.05160E-08_JPRB, & + & 1.40253E-08_JPRB, 1.87056E-08_JPRB, 2.49478E-08_JPRB, 3.32730E-08_JPRB, 4.43764E-08_JPRB, & + & 5.91851E-08_JPRB, 7.89356E-08_JPRB, 1.05277E-07_JPRB, 1.40408E-07_JPRB/) + KAO_MN2O( 9, :,14) = (/ & + & 7.03261E-10_JPRB, 9.38472E-10_JPRB, 1.25235E-09_JPRB, 1.67121E-09_JPRB, 2.23016E-09_JPRB, & + & 2.97605E-09_JPRB, 3.97141E-09_JPRB, 5.29968E-09_JPRB, 7.07220E-09_JPRB, 9.43754E-09_JPRB, & + & 1.25940E-08_JPRB, 1.68062E-08_JPRB, 2.24271E-08_JPRB, 2.99280E-08_JPRB, 3.99376E-08_JPRB, & + & 5.32951E-08_JPRB, 7.11200E-08_JPRB, 9.49066E-08_JPRB, 1.26649E-07_JPRB/) + KAO_MN2O( 1, :,15) = (/ & + & 2.14029E+01_JPRB, 2.16782E+01_JPRB, 2.19571E+01_JPRB, 2.22396E+01_JPRB, 2.25257E+01_JPRB, & + & 2.28155E+01_JPRB, 2.31090E+01_JPRB, 2.34063E+01_JPRB, 2.37074E+01_JPRB, 2.40124E+01_JPRB, & + & 2.43213E+01_JPRB, 2.46342E+01_JPRB, 2.49511E+01_JPRB, 2.52721E+01_JPRB, 2.55972E+01_JPRB, & + & 2.59265E+01_JPRB, 2.62600E+01_JPRB, 2.65979E+01_JPRB, 2.69400E+01_JPRB/) + KAO_MN2O( 2, :,15) = (/ & + & 5.68659E-10_JPRB, 7.55629E-10_JPRB, 1.00407E-09_JPRB, 1.33421E-09_JPRB, 1.77288E-09_JPRB, & + & 2.35579E-09_JPRB, 3.13036E-09_JPRB, 4.15960E-09_JPRB, 5.52724E-09_JPRB, 7.34455E-09_JPRB, & + & 9.75939E-09_JPRB, 1.29682E-08_JPRB, 1.72320E-08_JPRB, 2.28978E-08_JPRB, 3.04264E-08_JPRB, & + & 4.04304E-08_JPRB, 5.37236E-08_JPRB, 7.13875E-08_JPRB, 9.48591E-08_JPRB/) + KAO_MN2O( 3, :,15) = (/ & + & 5.59573E-10_JPRB, 7.43558E-10_JPRB, 9.88035E-10_JPRB, 1.31290E-09_JPRB, 1.74457E-09_JPRB, & + & 2.31817E-09_JPRB, 3.08037E-09_JPRB, 4.09318E-09_JPRB, 5.43900E-09_JPRB, 7.22730E-09_JPRB, & + & 9.60360E-09_JPRB, 1.27612E-08_JPRB, 1.69570E-08_JPRB, 2.25324E-08_JPRB, 2.99409E-08_JPRB, & + & 3.97853E-08_JPRB, 5.28665E-08_JPRB, 7.02486E-08_JPRB, 9.33459E-08_JPRB/) + KAO_MN2O( 4, :,15) = (/ & + & 5.50488E-10_JPRB, 7.31486E-10_JPRB, 9.71996E-10_JPRB, 1.29158E-09_JPRB, 1.71625E-09_JPRB, & + & 2.28055E-09_JPRB, 3.03039E-09_JPRB, 4.02676E-09_JPRB, 5.35075E-09_JPRB, 7.11005E-09_JPRB, & + & 9.44781E-09_JPRB, 1.25542E-08_JPRB, 1.66820E-08_JPRB, 2.21670E-08_JPRB, 2.94554E-08_JPRB, & + & 3.91402E-08_JPRB, 5.20093E-08_JPRB, 6.91098E-08_JPRB, 9.18327E-08_JPRB/) + KAO_MN2O( 5, :,15) = (/ & + & 5.34010E-10_JPRB, 7.09574E-10_JPRB, 9.42858E-10_JPRB, 1.25284E-09_JPRB, 1.66473E-09_JPRB, & + & 2.21203E-09_JPRB, 2.93927E-09_JPRB, 3.90560E-09_JPRB, 5.18963E-09_JPRB, 6.89580E-09_JPRB, & + & 9.16290E-09_JPRB, 1.21754E-08_JPRB, 1.61782E-08_JPRB, 2.14970E-08_JPRB, 2.85645E-08_JPRB, & + & 3.79555E-08_JPRB, 5.04340E-08_JPRB, 6.70149E-08_JPRB, 8.90470E-08_JPRB/) + KAO_MN2O( 6, :,15) = (/ & + & 5.08144E-10_JPRB, 6.75221E-10_JPRB, 8.97231E-10_JPRB, 1.19224E-09_JPRB, 1.58424E-09_JPRB, & + & 2.10513E-09_JPRB, 2.79729E-09_JPRB, 3.71703E-09_JPRB, 4.93919E-09_JPRB, 6.56317E-09_JPRB, & + & 8.72112E-09_JPRB, 1.15886E-08_JPRB, 1.53989E-08_JPRB, 2.04620E-08_JPRB, 2.71898E-08_JPRB, & + & 3.61297E-08_JPRB, 4.80091E-08_JPRB, 6.37943E-08_JPRB, 8.47696E-08_JPRB/) + KAO_MN2O( 7, :,15) = (/ & + & 4.56716E-10_JPRB, 6.06884E-10_JPRB, 8.06427E-10_JPRB, 1.07158E-09_JPRB, 1.42391E-09_JPRB, & + & 1.89210E-09_JPRB, 2.51422E-09_JPRB, 3.34089E-09_JPRB, 4.43938E-09_JPRB, 5.89904E-09_JPRB, & + & 7.83864E-09_JPRB, 1.04160E-08_JPRB, 1.38408E-08_JPRB, 1.83916E-08_JPRB, 2.44387E-08_JPRB, & + & 3.24742E-08_JPRB, 4.31517E-08_JPRB, 5.73399E-08_JPRB, 7.61932E-08_JPRB/) + KAO_MN2O( 8, :,15) = (/ & + & 2.78366E-10_JPRB, 3.69881E-10_JPRB, 4.91482E-10_JPRB, 6.53061E-10_JPRB, 8.67760E-10_JPRB, & + & 1.15304E-09_JPRB, 1.53211E-09_JPRB, 2.03581E-09_JPRB, 2.70510E-09_JPRB, 3.59441E-09_JPRB, & + & 4.77611E-09_JPRB, 6.34629E-09_JPRB, 8.43268E-09_JPRB, 1.12050E-08_JPRB, 1.48887E-08_JPRB, & + & 1.97835E-08_JPRB, 2.62875E-08_JPRB, 3.49296E-08_JPRB, 4.64130E-08_JPRB/) + KAO_MN2O( 9, :,15) = (/ & + & 5.34010E-10_JPRB, 7.09574E-10_JPRB, 9.42858E-10_JPRB, 1.25284E-09_JPRB, 1.66473E-09_JPRB, & + & 2.21203E-09_JPRB, 2.93927E-09_JPRB, 3.90560E-09_JPRB, 5.18963E-09_JPRB, 6.89580E-09_JPRB, & + & 9.16290E-09_JPRB, 1.21754E-08_JPRB, 1.61782E-08_JPRB, 2.14970E-08_JPRB, 2.85645E-08_JPRB, & + & 3.79555E-08_JPRB, 5.04340E-08_JPRB, 6.70149E-08_JPRB, 8.90470E-08_JPRB/) + KAO_MN2O( 1, :,16) = (/ & + & 2.90784E+01_JPRB, 2.93787E+01_JPRB, 2.96820E+01_JPRB, 2.99885E+01_JPRB, 3.02982E+01_JPRB, & + & 3.06110E+01_JPRB, 3.09271E+01_JPRB, 3.12464E+01_JPRB, 3.15690E+01_JPRB, 3.18950E+01_JPRB, & + & 3.22243E+01_JPRB, 3.25571E+01_JPRB, 3.28932E+01_JPRB, 3.32329E+01_JPRB, 3.35760E+01_JPRB, & + & 3.39227E+01_JPRB, 3.42730E+01_JPRB, 3.46269E+01_JPRB, 3.49844E+01_JPRB/) + KAO_MN2O( 2, :,16) = (/ & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB/) + KAO_MN2O( 3, :,16) = (/ & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB/) + KAO_MN2O( 4, :,16) = (/ & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB/) + KAO_MN2O( 5, :,16) = (/ & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB/) + KAO_MN2O( 6, :,16) = (/ & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB/) + KAO_MN2O( 7, :,16) = (/ & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB/) + KAO_MN2O( 8, :,16) = (/ & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB/) + KAO_MN2O( 9, :,16) = (/ & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, & + & 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB, 0.00000E+00_JPRB/) + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + + KBO_MN2O(:, 1) = (/ & + & 8.42688E-03_JPRB, 8.96787E-03_JPRB, 9.54358E-03_JPRB, 1.01563E-02_JPRB, 1.08083E-02_JPRB, & + & 1.15021E-02_JPRB, 1.22405E-02_JPRB, 1.30263E-02_JPRB, 1.38626E-02_JPRB, 1.47525E-02_JPRB, & + & 1.56996E-02_JPRB, 1.67075E-02_JPRB, 1.77800E-02_JPRB, 1.89215E-02_JPRB, 2.01362E-02_JPRB, & + & 2.14289E-02_JPRB, 2.28045E-02_JPRB, 2.42685E-02_JPRB, 2.58265E-02_JPRB/) + KBO_MN2O(:, 2) = (/ & + & 2.24976E-02_JPRB, 2.38935E-02_JPRB, 2.53762E-02_JPRB, 2.69508E-02_JPRB, 2.86231E-02_JPRB, & + & 3.03991E-02_JPRB, 3.22854E-02_JPRB, 3.42887E-02_JPRB, 3.64163E-02_JPRB, 3.86760E-02_JPRB, & + & 4.10759E-02_JPRB, 4.36246E-02_JPRB, 4.63315E-02_JPRB, 4.92064E-02_JPRB, 5.22597E-02_JPRB, & + & 5.55024E-02_JPRB, 5.89464E-02_JPRB, 6.26040E-02_JPRB, 6.64886E-02_JPRB/) + KBO_MN2O(:, 3) = (/ & + & 5.93542E-02_JPRB, 6.37312E-02_JPRB, 6.84310E-02_JPRB, 7.34774E-02_JPRB, 7.88960E-02_JPRB, & + & 8.47141E-02_JPRB, 9.09613E-02_JPRB, 9.76692E-02_JPRB, 1.04872E-01_JPRB, 1.12605E-01_JPRB, & + & 1.20910E-01_JPRB, 1.29826E-01_JPRB, 1.39400E-01_JPRB, 1.49680E-01_JPRB, 1.60718E-01_JPRB, & + & 1.72570E-01_JPRB, 1.85296E-01_JPRB, 1.98961E-01_JPRB, 2.13633E-01_JPRB/) + KBO_MN2O(:, 4) = (/ & + & 1.98022E-01_JPRB, 2.05895E-01_JPRB, 2.14082E-01_JPRB, 2.22594E-01_JPRB, 2.31445E-01_JPRB, & + & 2.40647E-01_JPRB, 2.50216E-01_JPRB, 2.60164E-01_JPRB, 2.70509E-01_JPRB, 2.81265E-01_JPRB, & + & 2.92448E-01_JPRB, 3.04076E-01_JPRB, 3.16167E-01_JPRB, 3.28738E-01_JPRB, 3.41809E-01_JPRB, & + & 3.55400E-01_JPRB, 3.69531E-01_JPRB, 3.84224E-01_JPRB, 3.99501E-01_JPRB/) + KBO_MN2O(:, 5) = (/ & + & 6.41413E-01_JPRB, 6.46239E-01_JPRB, 6.51101E-01_JPRB, 6.56000E-01_JPRB, 6.60936E-01_JPRB, & + & 6.65910E-01_JPRB, 6.70920E-01_JPRB, 6.75968E-01_JPRB, 6.81054E-01_JPRB, 6.86179E-01_JPRB, & + & 6.91342E-01_JPRB, 6.96544E-01_JPRB, 7.01785E-01_JPRB, 7.07065E-01_JPRB, 7.12385E-01_JPRB, & + & 7.17746E-01_JPRB, 7.23146E-01_JPRB, 7.28587E-01_JPRB, 7.34070E-01_JPRB/) + KBO_MN2O(:, 6) = (/ & + & 1.47906E+00_JPRB, 1.48768E+00_JPRB, 1.49635E+00_JPRB, 1.50507E+00_JPRB, 1.51384E+00_JPRB, & + & 1.52267E+00_JPRB, 1.53154E+00_JPRB, 1.54047E+00_JPRB, 1.54944E+00_JPRB, 1.55847E+00_JPRB, & + & 1.56755E+00_JPRB, 1.57669E+00_JPRB, 1.58588E+00_JPRB, 1.59512E+00_JPRB, 1.60442E+00_JPRB, & + & 1.61377E+00_JPRB, 1.62317E+00_JPRB, 1.63263E+00_JPRB, 1.64215E+00_JPRB/) + KBO_MN2O(:, 7) = (/ & + & 3.53152E+00_JPRB, 3.55492E+00_JPRB, 3.57848E+00_JPRB, 3.60219E+00_JPRB, 3.62606E+00_JPRB, & + & 3.65008E+00_JPRB, 3.67427E+00_JPRB, 3.69862E+00_JPRB, 3.72313E+00_JPRB, 3.74780E+00_JPRB, & + & 3.77263E+00_JPRB, 3.79763E+00_JPRB, 3.82279E+00_JPRB, 3.84812E+00_JPRB, 3.87362E+00_JPRB, & + & 3.89929E+00_JPRB, 3.92513E+00_JPRB, 3.95114E+00_JPRB, 3.97732E+00_JPRB/) + KBO_MN2O(:, 8) = (/ & + & 9.06783E+00_JPRB, 9.04597E+00_JPRB, 9.02415E+00_JPRB, 9.00239E+00_JPRB, 8.98069E+00_JPRB, & + & 8.95903E+00_JPRB, 8.93743E+00_JPRB, 8.91588E+00_JPRB, 8.89438E+00_JPRB, 8.87293E+00_JPRB, & + & 8.85154E+00_JPRB, 8.83020E+00_JPRB, 8.80890E+00_JPRB, 8.78766E+00_JPRB, 8.76647E+00_JPRB, & + & 8.74533E+00_JPRB, 8.72425E+00_JPRB, 8.70321E+00_JPRB, 8.68223E+00_JPRB/) + KBO_MN2O(:, 9) = (/ & + & 3.88220E+01_JPRB, 3.85805E+01_JPRB, 3.83405E+01_JPRB, 3.81019E+01_JPRB, 3.78649E+01_JPRB, & + & 3.76293E+01_JPRB, 3.73952E+01_JPRB, 3.71625E+01_JPRB, 3.69313E+01_JPRB, 3.67016E+01_JPRB, & + & 3.64732E+01_JPRB, 3.62463E+01_JPRB, 3.60208E+01_JPRB, 3.57967E+01_JPRB, 3.55740E+01_JPRB, & + & 3.53527E+01_JPRB, 3.51327E+01_JPRB, 3.49142E+01_JPRB, 3.46970E+01_JPRB/) + KBO_MN2O(:, 10) = (/ & + & 1.14211E+02_JPRB, 1.13955E+02_JPRB, 1.13700E+02_JPRB, 1.13445E+02_JPRB, 1.13191E+02_JPRB, & + & 1.12938E+02_JPRB, 1.12685E+02_JPRB, 1.12433E+02_JPRB, 1.12181E+02_JPRB, 1.11930E+02_JPRB, & + & 1.11679E+02_JPRB, 1.11429E+02_JPRB, 1.11180E+02_JPRB, 1.10931E+02_JPRB, 1.10682E+02_JPRB, & + & 1.10434E+02_JPRB, 1.10187E+02_JPRB, 1.09940E+02_JPRB, 1.09694E+02_JPRB/) + KBO_MN2O(:, 11) = (/ & + & 1.60513E+02_JPRB, 1.60857E+02_JPRB, 1.61201E+02_JPRB, 1.61547E+02_JPRB, 1.61893E+02_JPRB, & + & 1.62240E+02_JPRB, 1.62587E+02_JPRB, 1.62936E+02_JPRB, 1.63285E+02_JPRB, 1.63635E+02_JPRB, & + & 1.63985E+02_JPRB, 1.64337E+02_JPRB, 1.64689E+02_JPRB, 1.65041E+02_JPRB, 1.65395E+02_JPRB, & + & 1.65749E+02_JPRB, 1.66105E+02_JPRB, 1.66460E+02_JPRB, 1.66817E+02_JPRB/) + KBO_MN2O(:, 12) = (/ & + & 1.71473E+02_JPRB, 1.72766E+02_JPRB, 1.74068E+02_JPRB, 1.75381E+02_JPRB, 1.76703E+02_JPRB, & + & 1.78035E+02_JPRB, 1.79377E+02_JPRB, 1.80729E+02_JPRB, 1.82091E+02_JPRB, 1.83464E+02_JPRB, & + & 1.84847E+02_JPRB, 1.86240E+02_JPRB, 1.87644E+02_JPRB, 1.89059E+02_JPRB, 1.90484E+02_JPRB, & + & 1.91920E+02_JPRB, 1.93367E+02_JPRB, 1.94824E+02_JPRB, 1.96293E+02_JPRB/) + KBO_MN2O(:, 13) = (/ & + & 2.71287E+01_JPRB, 2.75538E+01_JPRB, 2.79856E+01_JPRB, 2.84241E+01_JPRB, 2.88695E+01_JPRB, & + & 2.93219E+01_JPRB, 2.97814E+01_JPRB, 3.02480E+01_JPRB, 3.07220E+01_JPRB, 3.12035E+01_JPRB, & + & 3.16924E+01_JPRB, 3.21890E+01_JPRB, 3.26934E+01_JPRB, 3.32058E+01_JPRB, 3.37261E+01_JPRB, & + & 3.42546E+01_JPRB, 3.47914E+01_JPRB, 3.53365E+01_JPRB, 3.58903E+01_JPRB/) + KBO_MN2O(:, 14) = (/ & + & 1.70389E+01_JPRB, 1.70899E+01_JPRB, 1.71411E+01_JPRB, 1.71924E+01_JPRB, 1.72439E+01_JPRB, & + & 1.72955E+01_JPRB, 1.73473E+01_JPRB, 1.73992E+01_JPRB, 1.74513E+01_JPRB, 1.75035E+01_JPRB, & + & 1.75559E+01_JPRB, 1.76085E+01_JPRB, 1.76612E+01_JPRB, 1.77141E+01_JPRB, 1.77671E+01_JPRB, & + & 1.78203E+01_JPRB, 1.78736E+01_JPRB, 1.79271E+01_JPRB, 1.79808E+01_JPRB/) + KBO_MN2O(:, 15) = (/ & + & 2.49725E+00_JPRB, 2.66861E+00_JPRB, 2.85174E+00_JPRB, 3.04743E+00_JPRB, 3.25655E+00_JPRB, & + & 3.48003E+00_JPRB, 3.71883E+00_JPRB, 3.97403E+00_JPRB, 4.24673E+00_JPRB, 4.53815E+00_JPRB, & + & 4.84957E+00_JPRB, 5.18236E+00_JPRB, 5.53798E+00_JPRB, 5.91801E+00_JPRB, 6.32412E+00_JPRB, & + & 6.75809E+00_JPRB, 7.22185E+00_JPRB, 7.71742E+00_JPRB, 8.24701E+00_JPRB/) + KBO_MN2O(:, 16) = (/ & + & 1.82935E-03_JPRB, 2.58912E-03_JPRB, 3.66444E-03_JPRB, 5.18637E-03_JPRB, 7.34039E-03_JPRB, & + & 1.03890E-02_JPRB, 1.47038E-02_JPRB, 2.08106E-02_JPRB, 2.94538E-02_JPRB, 4.16865E-02_JPRB, & + & 5.89999E-02_JPRB, 8.35040E-02_JPRB, 1.18185E-01_JPRB, 1.67270E-01_JPRB, 2.36741E-01_JPRB, & + & 3.35065E-01_JPRB, 4.74225E-01_JPRB, 6.71180E-01_JPRB, 9.49936E-01_JPRB/) + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + + FORREFO(1,:) = (/ & + &7.5352E-06_JPRB,2.9812E-05_JPRB,1.4497E-04_JPRB,4.4006E-04_JPRB,1.0492E-03_JPRB,1.9676E-03_JPRB, & + &1.9989E-03_JPRB,1.9099E-03_JPRB,2.2121E-03_JPRB,2.4491E-03_JPRB,2.9573E-03_JPRB,2.6344E-03_JPRB, & + &3.0629E-03_JPRB,3.3547E-03_JPRB,5.0643E-03_JPRB,5.0642E-03_JPRB/) + FORREFO(2,:) = (/ & + &6.6070E-06_JPRB,4.8618E-05_JPRB,3.1112E-04_JPRB,8.4235E-04_JPRB,1.4179E-03_JPRB,1.4315E-03_JPRB, & + &1.4685E-03_JPRB,1.6554E-03_JPRB,2.1171E-03_JPRB,2.3545E-03_JPRB,2.5165E-03_JPRB,2.7680E-03_JPRB, & + &2.6985E-03_JPRB,3.5345E-03_JPRB,4.2924E-03_JPRB,5.0712E-03_JPRB/) + FORREFO(3,:) = (/ & + &6.5962E-06_JPRB,7.2595E-04_JPRB,1.3429E-03_JPRB,1.1675E-03_JPRB,9.8384E-04_JPRB,8.8787E-04_JPRB, & + &8.7557E-04_JPRB,8.0589E-04_JPRB,7.7024E-04_JPRB,8.7518E-04_JPRB,9.5213E-04_JPRB,9.0849E-04_JPRB, & + &1.2596E-03_JPRB,2.5106E-03_JPRB,3.9471E-03_JPRB,5.0742E-03_JPRB/) + FORREFO(4,:) = (/ & + &3.6217E-04_JPRB,1.0709E-03_JPRB,1.0628E-03_JPRB,8.5640E-04_JPRB,8.9332E-04_JPRB,8.3372E-04_JPRB, & + &7.8539E-04_JPRB,8.2828E-04_JPRB,8.3329E-04_JPRB,8.5118E-04_JPRB,8.2878E-04_JPRB,6.8570E-04_JPRB, & + &6.3815E-04_JPRB,8.0648E-04_JPRB,2.3236E-03_JPRB,4.0321E-03_JPRB/) + + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + SELFREFO(:, 1) = (/ & + & 2.83453E-02_JPRB, 2.51439E-02_JPRB, 2.23040E-02_JPRB, 1.97849E-02_JPRB, 1.75503E-02_JPRB, & + & 1.55681E-02_JPRB, 1.38097E-02_JPRB, 1.22500E-02_JPRB, 1.08664E-02_JPRB, 9.63912E-03_JPRB/) + SELFREFO(:, 2) = (/ & + & 3.05185E-02_JPRB, 2.72374E-02_JPRB, 2.43090E-02_JPRB, 2.16955E-02_JPRB, 1.93629E-02_JPRB, & + & 1.72811E-02_JPRB, 1.54232E-02_JPRB, 1.37650E-02_JPRB, 1.22851E-02_JPRB, 1.09643E-02_JPRB/) + SELFREFO(:, 3) = (/ & + & 4.23833E-02_JPRB, 3.76250E-02_JPRB, 3.34010E-02_JPRB, 2.96512E-02_JPRB, 2.63223E-02_JPRB, & + & 2.33672E-02_JPRB, 2.07439E-02_JPRB, 1.84150E-02_JPRB, 1.63476E-02_JPRB, 1.45123E-02_JPRB/) + SELFREFO(:, 4) = (/ & + & 5.76481E-02_JPRB, 5.13686E-02_JPRB, 4.57730E-02_JPRB, 4.07870E-02_JPRB, 3.63441E-02_JPRB, & + & 3.23851E-02_JPRB, 2.88574E-02_JPRB, 2.57140E-02_JPRB, 2.29130E-02_JPRB, 2.04171E-02_JPRB/) + SELFREFO(:, 5) = (/ & + & 6.92255E-02_JPRB, 6.33521E-02_JPRB, 5.79770E-02_JPRB, 5.30580E-02_JPRB, 4.85563E-02_JPRB, & + & 4.44365E-02_JPRB, 4.06663E-02_JPRB, 3.72160E-02_JPRB, 3.40584E-02_JPRB, 3.11687E-02_JPRB/) + SELFREFO(:, 6) = (/ & + & 6.07694E-02_JPRB, 5.94182E-02_JPRB, 5.80970E-02_JPRB, 5.68052E-02_JPRB, 5.55422E-02_JPRB, & + & 5.43072E-02_JPRB, 5.30997E-02_JPRB, 5.19190E-02_JPRB, 5.07646E-02_JPRB, 4.96358E-02_JPRB/) + SELFREFO(:, 7) = (/ & + & 6.23749E-02_JPRB, 6.07744E-02_JPRB, 5.92150E-02_JPRB, 5.76956E-02_JPRB, 5.62152E-02_JPRB, & + & 5.47728E-02_JPRB, 5.33674E-02_JPRB, 5.19980E-02_JPRB, 5.06638E-02_JPRB, 4.93638E-02_JPRB/) + SELFREFO(:, 8) = (/ & + & 6.90744E-02_JPRB, 6.61811E-02_JPRB, 6.34090E-02_JPRB, 6.07530E-02_JPRB, 5.82083E-02_JPRB, & + & 5.57702E-02_JPRB, 5.34342E-02_JPRB, 5.11960E-02_JPRB, 4.90516E-02_JPRB, 4.69970E-02_JPRB/) + SELFREFO(:, 9) = (/ & + & 8.08992E-02_JPRB, 7.68876E-02_JPRB, 7.30750E-02_JPRB, 6.94514E-02_JPRB, 6.60075E-02_JPRB, & + & 6.27344E-02_JPRB, 5.96236E-02_JPRB, 5.66670E-02_JPRB, 5.38570E-02_JPRB, 5.11864E-02_JPRB/) + SELFREFO(:,10) = (/ & + & 8.70197E-02_JPRB, 8.27485E-02_JPRB, 7.86870E-02_JPRB, 7.48248E-02_JPRB, 7.11522E-02_JPRB, & + & 6.76599E-02_JPRB, 6.43389E-02_JPRB, 6.11810E-02_JPRB, 5.81781E-02_JPRB, 5.53225E-02_JPRB/) + SELFREFO(:,11) = (/ & + & 8.84776E-02_JPRB, 8.54262E-02_JPRB, 8.24800E-02_JPRB, 7.96354E-02_JPRB, 7.68890E-02_JPRB, & + & 7.42373E-02_JPRB, 7.16770E-02_JPRB, 6.92050E-02_JPRB, 6.68183E-02_JPRB, 6.45139E-02_JPRB/) + SELFREFO(:,12) = (/ & + & 9.82552E-02_JPRB, 9.25696E-02_JPRB, 8.72130E-02_JPRB, 8.21664E-02_JPRB, 7.74118E-02_JPRB, & + & 7.29323E-02_JPRB, 6.87121E-02_JPRB, 6.47360E-02_JPRB, 6.09900E-02_JPRB, 5.74608E-02_JPRB/) + SELFREFO(:,13) = (/ & + & 9.32447E-02_JPRB, 8.96818E-02_JPRB, 8.62550E-02_JPRB, 8.29592E-02_JPRB, 7.97893E-02_JPRB, & + & 7.67405E-02_JPRB, 7.38082E-02_JPRB, 7.09880E-02_JPRB, 6.82755E-02_JPRB, 6.56667E-02_JPRB/) + SELFREFO(:,14) = (/ & + & 1.15363E-01_JPRB, 1.08593E-01_JPRB, 1.02220E-01_JPRB, 9.62210E-02_JPRB, 9.05741E-02_JPRB, & + & 8.52585E-02_JPRB, 8.02549E-02_JPRB, 7.55450E-02_JPRB, 7.11115E-02_JPRB, 6.69382E-02_JPRB/) + SELFREFO(:,15) = (/ & + & 1.23179E-01_JPRB, 1.19247E-01_JPRB, 1.15440E-01_JPRB, 1.11755E-01_JPRB, 1.08187E-01_JPRB, & + & 1.04734E-01_JPRB, 1.01391E-01_JPRB, 9.81540E-02_JPRB, 9.50207E-02_JPRB, 9.19875E-02_JPRB/) + SELFREFO(:,16) = (/ & + & 1.44104E-01_JPRB, 1.36412E-01_JPRB, 1.29130E-01_JPRB, 1.22237E-01_JPRB, 1.15712E-01_JPRB, & + & 1.09535E-01_JPRB, 1.03688E-01_JPRB, 9.81530E-02_JPRB, 9.29135E-02_JPRB, 8.79537E-02_JPRB/) + +IF (LHOOK) CALL DR_HOOK('RRTM_KGB9',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("RRTM_KGB9:ERROR READING FILE RADRRTM") + +END SUBROUTINE RRTM_KGB9 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_prepare_gases.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_prepare_gases.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_prepare_gases.F90 (revision 6016) @@ -0,0 +1,261 @@ +! This file has been modified for the use in ICON + +SUBROUTINE RRTM_PREPARE_GASES & + &( KIDIA, KFDIA, KLON, KLEV, & + & PAPH , PAP , & + & PTH , PT , & + & PQ , PCO2 , PCH4, PN2O , PNO2, PC11, PC12, PC22, PCL4, POZN, & + & PCOLDRY, PWBRODL, PWKL, PWX , & + & PAVEL , PTAVEL , PZ , PTZ , KREFLECT) + +!----compiled for Cray with -h nopattern---- + +! Prepare the units of the gas concentrations for the longwave +! RRTM gas absorption model. This file is adapted from +! rrtm_ecrt_140gp_mcica.F90, written mainly by Jean-Jacques +! Morcrette. + +!- Original +! 2015-07-15 Robin Hogan + +!- Modifications + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMCST , ONLY : RG +USE PARRRTM , ONLY : JPXSEC, JPINPX +USE YOMDYNCORE,ONLY : RPLRG + +!------------------------------Arguments-------------------------------- + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KLON! Number of atmospheres (longitudes) +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV! Number of atmospheric layers +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA + +REAL(KIND=JPRB) ,INTENT(IN) :: PAPH(KLON,KLEV+1) ! Interface pressures (Pa) +REAL(KIND=JPRB) ,INTENT(IN) :: PAP(KLON,KLEV) ! Layer pressures (Pa) +REAL(KIND=JPRB) ,INTENT(IN) :: PTH(KLON,KLEV+1) ! Interface temperatures (K) +REAL(KIND=JPRB) ,INTENT(IN) :: PT(KLON,KLEV) ! Layer temperature (K) +REAL(KIND=JPRB) ,INTENT(IN) :: PQ(KLON,KLEV) ! H2O specific humidity (mmr) +REAL(KIND=JPRB) ,INTENT(IN) :: PCO2(KLON,KLEV) ! CO2 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PCH4(KLON,KLEV) ! CH4 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PN2O(KLON,KLEV) ! N2O mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PNO2(KLON,KLEV) ! NO2 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC11(KLON,KLEV) ! CFC11 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC12(KLON,KLEV) ! CFC12 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC22(KLON,KLEV) ! CFC22 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PCL4(KLON,KLEV) ! CCL4 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: POZN(KLON,KLEV) ! O3 mass mixing ratio + +REAL(KIND=JPRB) ,INTENT(OUT) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWBRODL(KIDIA:KFDIA,KLEV) ! broadening gas column density (mol/cm2) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWKL(KIDIA:KFDIA,JPINPX,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWX(KIDIA:KFDIA,JPXSEC,KLEV) ! Amount of trace gases +REAL(KIND=JPRB) ,INTENT(OUT) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PZ(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTZ(KIDIA:KFDIA,0:KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: KREFLECT(KIDIA:KFDIA) + +! real rch4 ! CH4 mass mixing ratio +! real rn2o ! N2O mass mixing ratio +! real rcfc11 ! CFC11 mass mixing ratio +! real rcfc12 ! CFC12 mass mixing ratio +! real rcfc22 ! CFC22 mass mixing ratio +! real rccl4 ! CCl4 mass mixing ratio +!- from PROFILE +!- from SURFACE +REAL(KIND=JPRB) :: ZAMD ! Effective molecular weight of dry air (g/mol) +REAL(KIND=JPRB) :: ZAMW ! Molecular weight of water vapor (g/mol) +REAL(KIND=JPRB) :: ZAMCO2 ! Molecular weight of carbon dioxide (g/mol) +REAL(KIND=JPRB) :: ZAMO ! Molecular weight of ozone (g/mol) +REAL(KIND=JPRB) :: ZAMCH4 ! Molecular weight of methane (g/mol) +REAL(KIND=JPRB) :: ZAMN2O ! Molecular weight of nitrous oxide (g/mol) +REAL(KIND=JPRB) :: ZAMC11 ! Molecular weight of CFC11 (g/mol) - CFCL3 +REAL(KIND=JPRB) :: ZAMC12 ! Molecular weight of CFC12 (g/mol) - CF2CL2 +REAL(KIND=JPRB) :: ZAMC22 ! Molecular weight of CFC22 (g/mol) - CHF2CL +REAL(KIND=JPRB) :: ZAMCL4 ! Molecular weight of CCl4 (g/mol) - CCL4 +REAL(KIND=JPRB) :: ZAVGDRO ! Avogadro's number (molecules/mole) +REAL(KIND=JPRB) :: ZGRAVIT ! Gravitational acceleration (cm/s**2) + +REAL(KIND=JPRB) :: ZSUMMOL + +! Atomic weights for conversion from mass to volume mixing ratios; these +! are the same values used in ECRT to assure accurate conversion to vmr +data ZAMD / 28.970_JPRB / +data ZAMW / 18.0154_JPRB / +data ZAMCO2 / 44.011_JPRB / +data ZAMO / 47.9982_JPRB / +data ZAMCH4 / 16.043_JPRB / +data ZAMN2O / 44.013_JPRB / +data ZAMC11 / 137.3686_JPRB / +data ZAMC12 / 120.9140_JPRB / +data ZAMC22 / 86.4690_JPRB / +data ZAMCL4 / 153.8230_JPRB / +data ZAVGDRO/ 6.02214E23_JPRB / + +INTEGER(KIND=JPIM) :: IATM, JMOL, IXMAX, J1, J2, JK, JL +INTEGER(KIND=JPIM), PARAMETER :: ITMOL = 7 + +REAL(KIND=JPRB) :: ZAMM + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! *** + +! *** mji +! Initialize all molecular amounts to zero here, +! then pass ECRT amounts into RRTM arrays below. + +! DATA ZWKL /MAXPRDW*0.0/ +! DATA ZWX /MAXPROD*0.0/ +! DATA KREFLECT /0/ + +! Activate cross section molecules: +! NXMOL - number of cross-sections input by user +! IXINDX(I) - index of cross-section molecule corresponding to Ith +! cross-section specified by user +! = 0 -- not allowed in RRTM +! = 1 -- CCL4 +! = 2 -- CFC11 +! = 3 -- CFC12 +! = 4 -- CFC22 +! DATA KXMOL /2/ +! DATA KXINDX /0,2,3,0,31*0/ + +! IREFLECT=KREFLECT +! NXMOL=KXMOL + +IF (LHOOK) CALL DR_HOOK('RRTM_PREPARE_GASES',0,ZHOOK_HANDLE) + +!$ACC DATA PRESENT(PAPH, PAP, & +!$ACC PTH, PT, & +!$ACC PQ, PCO2, PCH4, PN2O, PNO2, PC11, PC12, PC22, PCL4, POZN, & +!$ACC PCOLDRY, PWBRODL, PWKL, PWX , & +!$ACC PAVEL, PTAVEL, PZ, PTZ , KREFLECT) + +ZGRAVIT=(RG/RPLRG)*1.E2_JPRB + +!$ACC PARALLEL DEFAULT(NONE) ASYNC(1) +!$ACC LOOP GANG VECTOR +DO JL = KIDIA, KFDIA + KREFLECT(JL)=0 +ENDDO +!$ACC END PARALLEL + +!$ACC PARALLEL DEFAULT(NONE) ASYNC(1) +!DO J1=1,35 +! IXINDX(J1)=0 +!$ACC LOOP GANG VECTOR COLLAPSE(3) +DO J2=1,KLEV + DO J1=1,35 + DO JL = KIDIA, KFDIA + PWKL(JL,J1,J2)=0.0_JPRB + ENDDO + ENDDO +ENDDO +!IXINDX(2)=2 +!IXINDX(3)=3 +!$ACC END PARALLEL + +! Set parameters needed for RRTM execution: +IATM = 0 +! IXSECT = 1 +! NUMANGS = 0 +! IOUT = -1 +IXMAX = 4 + +!$ACC PARALLEL DEFAULT(NONE) ASYNC(1) +!$ACC LOOP GANG(STATIC:1) VECTOR +DO JL = KIDIA, KFDIA +! Install ECRT arrays into RRTM arrays for pressure, temperature, +! and molecular amounts. Pressures are converted from Pascals +! (ECRT) to mb (RRTM). H2O, CO2, O3 and trace gas amounts are +! converted from mass mixing ratio to volume mixing ratio. CO2 +! converted with same dry air and CO2 molecular weights used in +! ECRT to assure correct conversion back to the proper CO2 vmr. +! 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: RRTM levels count from bottom to top, while the ECRT input +! variables count from the top down and must be reversed + PZ(JL,0) = PAPH(JL,KLEV+1)/100._JPRB + PTZ(JL,0) = PTH(JL,KLEV+1) +ENDDO + + !$ACC LOOP SEQ + DO JK = 1, KLEV + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ZAMM) + DO JL = KIDIA, KFDIA + PAVEL(JL,JK) = PAP(JL,KLEV-JK+1)/100._JPRB + PTAVEL(JL,JK) = PT(JL,KLEV-JK+1) + PZ(JL,JK) = PAPH(JL,KLEV-JK+1)/100._JPRB + PTZ(JL,JK) = PTH(JL,KLEV-JK+1) + ! RRTMG cannot cope with zero or negative water vapour + PWKL(JL,1,JK) = MAX(PQ(JL,KLEV-JK+1),1.0E-15)*ZAMD/ZAMW + PWKL(JL,2,JK) = PCO2(JL,KLEV-JK+1)*ZAMD/ZAMCO2 + PWKL(JL,3,JK) = POZN(JL,KLEV-JK+1)*ZAMD/ZAMO + PWKL(JL,4,JK) = PN2O(JL,KLEV-JK+1)*ZAMD/ZAMN2O + PWKL(JL,6,JK) = PCH4(JL,KLEV-JK+1)*ZAMD/ZAMCH4 + PWKL(JL,7,JK) = 0.209488_JPRB + ZAMM = (1.0_JPRB-PWKL(JL,1,JK))*ZAMD + PWKL(JL,1,JK)*ZAMW + PCOLDRY(JL,JK) = (PZ(JL,JK-1)-PZ(JL,JK))*1.E3_JPRB*ZAVGDRO/(ZGRAVIT*ZAMM*(1.0_JPRB+PWKL(JL,1,JK))) + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + DO J2=1,KLEV + DO J1=1,JPXSEC + DO JL = KIDIA, KFDIA + PWX(JL,J1,J2)=0.0_JPRB + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP SEQ + DO JK = 1, KLEV +!$ACC LOOP GANG VECTOR PRIVATE (ZSUMMOL) +DO JL = KIDIA, KFDIA +!- Set cross section molecule amounts from ECRT; convert to vmr + PWX(JL,1,JK) = PCL4(JL,KLEV-JK+1) * ZAMD/ZAMCL4 + PWX(JL,2,JK) = PC11(JL,KLEV-JK+1) * ZAMD/ZAMC11 + PWX(JL,3,JK) = PC12(JL,KLEV-JK+1) * ZAMD/ZAMC12 + PWX(JL,4,JK) = PC22(JL,KLEV-JK+1) * ZAMD/ZAMC22 + PWX(JL,1,JK) = PCOLDRY(JL,JK) * PWX(JL,1,JK) * 1.E-20_JPRB + PWX(JL,2,JK) = PCOLDRY(JL,JK) * PWX(JL,2,JK) * 1.E-20_JPRB + PWX(JL,3,JK) = PCOLDRY(JL,JK) * PWX(JL,3,JK) * 1.E-20_JPRB + PWX(JL,4,JK) = PCOLDRY(JL,JK) * PWX(JL,4,JK) * 1.E-20_JPRB + +!- Here, all molecules in WKL and WX are in volume mixing ratio; convert to +! molec/cm2 based on COLDRY for use in RRTM + +!CDIR UNROLL=6 +ZSUMMOL = 0.0_JPRB +!AB broadening gases + !$ACC LOOP SEQ + DO JMOL = 2, ITMOL + ZSUMMOL = ZSUMMOL + PWKL(JL,JMOL,JK) + ENDDO + PWBRODL(JL,JK) = PCOLDRY(JL,JK) * (1._JPRB - ZSUMMOL) + !$ACC LOOP SEQ + DO JMOL = 1, ITMOL + PWKL(JL,JMOL,JK) = PCOLDRY(JL,JK) * PWKL(JL,JMOL,JK) + ENDDO + ENDDO +ENDDO +!$ACC END PARALLEL +!$ACC WAIT +!$ACC END DATA + +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('RRTM_PREPARE_GASES',1,ZHOOK_HANDLE) + +END SUBROUTINE RRTM_PREPARE_GASES Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_rrtm_140gp_mcica.F90.erase =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_rrtm_140gp_mcica.F90.erase (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_rrtm_140gp_mcica.F90.erase (revision 6016) @@ -0,0 +1,304 @@ +SUBROUTINE RRTM_RRTM_140GP_MCICA & + &( KIDIA , KFDIA , KLON , KLEV, KCOLS, KCLDCOL,& + & PAER , PAPH , PAP , PAERTAUL, PAERASYL, PAEROMGL, & + & PTS , PTH , PT , & + & PEMIS , PEMIW ,& + & PQ , PCO2 , PCH4 , PN2O, PNO2 , PC11, PC12, PC22, PCL4, POZN ,& + & PCLDF , PTAUCLD, PCLFR,& + & PEMIT , PFLUX , PFLUC, & + & PLwDerivative) + +! *** This program is the driver for the McICA version of RRTM_LW, +! the AER rapid model. + +! For each atmosphere the user wishes to analyze, this routine +! a) calls ECRTATM to read in the atmospheric profile +! b) calls SETCOEF to calculate various quantities needed for +! the radiative transfer algorithm +! c) calls RTRN to do the radiative transfer calculation for +! clear or cloudy sky +! d) writes out the upward, downward, and net flux for each +! level and the heating rate for each layer + +! JJMorcrette 20050110 McICA version revisited (changes in RRTM_ECRT, RRTM_RTRN) +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20080424 3D fields of CO2, CH4, N2O, NO2, CFC11, 12, 22 and CCL4 +! JJMorcrette 20110613 flexible number of g-points +! P Bechtold 14/05/2012 replace ZHEATF by core constants RG*RDAY/RCPD +! and put arrays to scalars +! R Hogan 20/05/2014 pass partial derivatives back to calling function +!----------------------------------------------------------------------- + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARRRTM , ONLY : JPBAND, JPXSEC, JPINPX +USE YOERRTM , ONLY : JPGPT +USE YOMCST , ONLY : RG ! , RDAYI, RCPD + +IMPLICIT NONE + +!------------------------------Arguments-------------------------------- + +! Input arguments + +INTEGER(KIND=JPIM),INTENT(IN) :: KLON! Number of atmospheres (longitudes) +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV! Number of atmospheric layers +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA ! First atmosphere index +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA ! Last atmosphere index +INTEGER(KIND=JPIM),INTENT(IN) :: KCOLS ! Number of columns on which to perform RT + ! should be the same as number of g-points, JPGPT +INTEGER(KIND=JPIM),INTENT(IN) :: KCLDCOL(KLON) ! cloudy column index: 1=cloud, 0: clear + +REAL(KIND=JPRB) ,INTENT(IN) :: PAER(KLON,6,KLEV) ! Aerosol optical thickness +REAL(KIND=JPRB) ,INTENT(IN) :: PAERTAUL(KLON,KLEV,16), PAERASYL(KLON,KLEV,16), PAEROMGL(KLON,KLEV,16) +REAL(KIND=JPRB) ,INTENT(IN) :: PAPH(KLON,KLEV+1) ! Interface pressures (Pa) +REAL(KIND=JPRB) ,INTENT(IN) :: PAP(KLON,KLEV) ! Layer pressures (Pa) +REAL(KIND=JPRB) ,INTENT(IN) :: PTS(KLON) ! Surface temperature (JK) +REAL(KIND=JPRB) ,INTENT(IN) :: PTH(KLON,KLEV+1) ! Interface temperatures (JK) +REAL(KIND=JPRB) ,INTENT(IN) :: PT(KLON,KLEV) ! Layer temperature (JK) +REAL(KIND=JPRB) ,INTENT(IN) :: PEMIS(KLON) ! Non-window surface emissivity +REAL(KIND=JPRB) ,INTENT(IN) :: PEMIW(KLON) ! Window surface emissivity +REAL(KIND=JPRB) ,INTENT(IN) :: PQ(KLON,KLEV) ! H2O specific humidity (mmr) +REAL(KIND=JPRB) ,INTENT(IN) :: PCO2(KLON,KLEV) ! CO2 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PCH4(KLON,KLEV) ! CH4 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PN2O(KLON,KLEV) ! N2O mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PNO2(KLON,KLEV) ! NO2 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC11(KLON,KLEV) ! CFC11 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC12(KLON,KLEV) ! CFC12 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PC22(KLON,KLEV) ! CFC22 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PCL4(KLON,KLEV) ! CCL4 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: POZN(KLON,KLEV) ! O3 mass mixing ratio +REAL(KIND=JPRB) ,INTENT(IN) :: PCLFR(KLON,KLEV) + +REAL(KIND=JPRB) ,INTENT(OUT) :: PEMIT(KLON) ! Surface LW emissivity +REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUX(KLON,2,KLEV+1) ! LW total sky flux (1=up, 2=down) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUC(KLON,2,KLEV+1) ! LW clear sky flux (1=up, 2=down) + +! Partial derivative of total upward flux at each level with respect +! to upward flux at surface, used to correct heating rates at +! gridpoints/timesteps between calls to the full radiation scheme: +REAL(KIND=JPRB) ,INTENT(OUT) :: PLwDerivative(KLON,KLEV+1) + +!-- McICA ---------- +REAL(KIND=JPRB) ,INTENT(IN) :: PCLDF(KLON,KCOLS,KLEV) ! Cloud fraction +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUCLD(KLON,KLEV,KCOLS) ! Cloud optical depth + +REAL(KIND=JPRB) :: ZCLDFRAC(KIDIA:KFDIA,KCOLS,KLEV) ! Cloud fraction +REAL(KIND=JPRB) :: ZTAUCLD(KIDIA:KFDIA,KLEV,KCOLS) ! Spectral optical thickness +!-- McICA ---------- + +REAL(KIND=JPRB) :: ZATR1(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) :: ZOD(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) :: ZTF1(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) :: ZCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZWBRODL(KIDIA:KFDIA,KLEV) !BROADENING GASES,column density (mol/cm2) +REAL(KIND=JPRB) :: ZCOLBRD(KIDIA:KFDIA,KLEV) !BROADENING GASES, column amount +REAL(KIND=JPRB) :: ZWKL(KIDIA:KFDIA,JPINPX,KLEV) + +REAL(KIND=JPRB) :: ZWX(KIDIA:KFDIA,JPXSEC,KLEV) ! Amount of trace gases + +REAL(KIND=JPRB) :: ZTOTDFLUC(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) :: ZTOTDFLUX(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) :: ZTOTUFLUC(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) :: ZTOTUFLUX(KIDIA:KFDIA,0:KLEV) + +INTEGER(KIND=JPIM) :: JL, JK +INTEGER(KIND=JPIM) :: ISTART +INTEGER(KIND=JPIM) :: IEND + +REAL(KIND=JPRB) :: ZFLUXFAC, ZHEATFAC, ZPI +REAL(KIND=JPRB) :: ZEPSEC + +!- from AER +REAL(KIND=JPRB) :: ZTAUAERL(KIDIA:KFDIA,KLEV,JPBAND) + +!- from INTFAC +REAL(KIND=JPRB) :: ZFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZFAC11(KIDIA:KFDIA,KLEV) + +!- from FOR +REAL(KIND=JPRB) :: ZFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM) :: INDFOR(KIDIA:KFDIA,KLEV) + +!- from MINOR +INTEGER(KIND=JPIM) :: INDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZSCALEMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZSCALEMINORN2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZMINORFRAC(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) :: & + & ZRAT_H2OCO2(KIDIA:KFDIA,KLEV),ZRAT_H2OCO2_1(KIDIA:KFDIA,KLEV), & + & ZRAT_H2OO3(KIDIA:KFDIA,KLEV) ,ZRAT_H2OO3_1(KIDIA:KFDIA,KLEV), & + & ZRAT_H2ON2O(KIDIA:KFDIA,KLEV),ZRAT_H2ON2O_1(KIDIA:KFDIA,KLEV), & + & ZRAT_H2OCH4(KIDIA:KFDIA,KLEV),ZRAT_H2OCH4_1(KIDIA:KFDIA,KLEV), & + & ZRAT_N2OCO2(KIDIA:KFDIA,KLEV),ZRAT_N2OCO2_1(KIDIA:KFDIA,KLEV), & + & ZRAT_O3CO2(KIDIA:KFDIA,KLEV) ,ZRAT_O3CO2_1(KIDIA:KFDIA,KLEV) + +!- from INTIND +INTEGER(KIND=JPIM) :: JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM) :: JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM) :: JT1(KIDIA:KFDIA,KLEV) + +!- from PRECISE +REAL(KIND=JPRB) :: ZONEMINUS + +!- from PROFDATA +REAL(KIND=JPRB) :: ZCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCOLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCO2MULT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM) :: ILAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM) :: ILAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM) :: ILAYLOW(KIDIA:KFDIA) + +!- from PROFILE +REAL(KIND=JPRB) :: ZPAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZTAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZPZ(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) :: ZTZ(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) :: ZTBOUND(KIDIA:KFDIA) + +!- from SELF +REAL(KIND=JPRB) :: ZSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM) :: INDSELF(KIDIA:KFDIA,KLEV) + +!- from SP +REAL(KIND=JPRB) :: ZPFRAC(KIDIA:KFDIA,JPGPT,KLEV) + +!- from SURFACE +REAL(KIND=JPRB) :: ZSEMISS(KIDIA:KFDIA,JPBAND) +REAL(KIND=JPRB) :: ZSEMISLW(KIDIA:KFDIA) +INTEGER(KIND=JPIM) :: IREFLECT(KIDIA:KFDIA) + +! Local variable required in case KFDIA /= KLON +REAL(KIND=JPRB) :: ZLwDerivative(KIDIA:KFDIA,KLEV+1) + +LOGICAL :: LLPRINT + +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +#include "rrtm_ecrt_140gp_mcica.intfb.h" +#include "rrtm_gasabs1a_140gp.intfb.h" +#include "rrtm_rtrn1a_140gp_mcica.intfb.h" +#include "rrtm_setcoef_140gp.intfb.h" + +! HEATFAC is the factor by which one must multiply delta-flux/ +! delta-pressure, with flux in w/m-2 and pressure in mbar, to get +! the heating rate in units of degrees/day. It is equal to +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! = (9.8066)(86400)(1e-5)/(1.004) + +IF (LHOOK) CALL DR_HOOK('RRTM_RRTM_140GP_MCICA',0,ZHOOK_HANDLE) + +ASSOCIATE(NFLEVG=>KLEV) + +ZEPSEC = 1.E-06_JPRB +ZONEMINUS = 1.0_JPRB - ZEPSEC +ZPI = 2.0_JPRB*ASIN(1.0_JPRB) +ZFLUXFAC = ZPI * 2.E+4 +!ZHEATFAC = 8.4391_JPRB +!ZHEATFAC = RG*RDAYI/RCPD*1.E-2_JPRB + +! *** mji *** + +! For use with ECRT, this loop is over atmospheres (or longitudes) +LLPRINT=.TRUE. + +! do JK=1,KLEV +! print 9901,JK,PT(JL,JK),PQ(JL,JK),POZN(JL,JK),PCLDF(JL,JK,1),PTAUCLD(JL,JK,1) +! enddo + +! *** mji *** +!- Prepare atmospheric profile from ECRT for use in RRTM, and define +! other RRTM input parameters. Arrays are passed back through the +! existing RRTM commons and arrays. + + CALL RRTM_ECRT_140GP_MCICA & + &( KIDIA, KFDIA, KLON , KLEV, KCOLS , & + & PAER , PAPH , PAP , PAERTAUL, PAERASYL, PAEROMGL, & + & pts , PTH , PT , & + & PEMIS, PEMIW, & + & PQ , PCO2 , PCH4, PN2O, PNO2, PC11, PC12, PC22, PCL4, POZN , PCLDF, PTAUCLD, & + & ZCLDFRAC, ZTAUCLD, ZCOLDRY, ZWBRODL,ZWKL, ZWX, & + & ZTAUAERL, ZPAVEL , ZTAVEL , ZPZ , ZTZ, ZTBOUND, ZSEMISS, IREFLECT) + + ISTART = 1 + IEND = 16 + +! 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 RRTM_SETCOEF_140GP & + &( KIDIA , KFDIA , KLEV , ZCOLDRY , ZWBRODL , ZWKL , & + & ZFAC00 , ZFAC01 , ZFAC10 , ZFAC11 , ZFORFAC,ZFORFRAC,INDFOR, JP, JT, JT1 , & + & ZCOLH2O, ZCOLCO2 , ZCOLO3 , ZCOLN2O, ZCOLCH4, ZCOLO2,ZCO2MULT , ZCOLBRD, & + & ILAYTROP,ILAYSWTCH, ILAYLOW, ZPAVEL , ZTAVEL , ZSELFFAC, ZSELFFRAC, INDSELF, & + & INDMINOR,ZSCALEMINOR,ZSCALEMINORN2,ZMINORFRAC,& + & ZRAT_H2OCO2, ZRAT_H2OCO2_1, ZRAT_H2OO3, ZRAT_H2OO3_1, & + & ZRAT_H2ON2O, ZRAT_H2ON2O_1, ZRAT_H2OCH4, ZRAT_H2OCH4_1, & + & ZRAT_N2OCO2, ZRAT_N2OCO2_1, ZRAT_O3CO2, ZRAT_O3CO2_1) + + CALL RRTM_GASABS1A_140GP & + &( KIDIA , KFDIA , KLEV, ZATR1, ZOD, ZTF1, ZPAVEL, ZCOLDRY, ZCOLBRD, ZWX ,& + & ZTAUAERL, ZFAC00 , ZFAC01, ZFAC10 , ZFAC11 , ZFORFAC,ZFORFRAC,INDFOR, JP, JT, JT1, ZONEMINUS ,& + & ZCOLH2O , ZCOLCO2, ZCOLO3, ZCOLN2O, ZCOLCH4, ZCOLO2,ZCO2MULT ,& + & ILAYTROP, ILAYSWTCH,ILAYLOW, ZSELFFAC, ZSELFFRAC, INDSELF, ZPFRAC, & + & INDMINOR,ZSCALEMINOR,ZSCALEMINORN2,ZMINORFRAC,& + & ZRAT_H2OCO2, ZRAT_H2OCO2_1, ZRAT_H2OO3, ZRAT_H2OO3_1, & + & ZRAT_H2ON2O, ZRAT_H2ON2O_1, ZRAT_H2OCH4, ZRAT_H2OCH4_1, & + & ZRAT_N2OCO2, ZRAT_N2OCO2_1, ZRAT_O3CO2, ZRAT_O3CO2_1) + +!- Call the radiative transfer routine. + +! Clear and cloudy parts of column are treated together in RTRN. + +! print 9901,JL,ZTBOUND + + CALL RRTM_RTRN1A_140GP_MCICA & + &( KIDIA, KFDIA, KLEV, ISTART, IEND, KCOLS ,& + & ZCLDFRAC, ZTAUCLD, ZATR1 ,& + & ZOD , ZTF1 , & + & ZTOTDFLUC, ZTOTDFLUX, ZTOTUFLUC, ZTOTUFLUX ,& + & ZTAVEL, ZTZ, ZTBOUND, ZPFRAC, ZSEMISS, ZSEMISLW ,& + & ZLwDerivative ) + +! *** Pass clear sky and total sky up and down flux profiles to ECRT +! output arrays (zflux, zfluc). Array indexing from bottom to top +! is preserved for ECRT. +! Invert down flux arrays for consistency with ECRT sign conventions. + +DO JL = KIDIA,KFDIA + + PEMIT(JL) = ZSEMISLW(JL) + DO JK = 0, KLEV + PFLUC(JL,1,JK+1) = ZTOTUFLUC(JL,JK)*ZFLUXFAC + PFLUC(JL,2,JK+1) = -ZTOTDFLUC(JL,JK)*ZFLUXFAC + PFLUX(JL,1,JK+1) = ZTOTUFLUX(JL,JK)*ZFLUXFAC + PFLUX(JL,2,JK+1) = -ZTOTDFLUX(JL,JK)*ZFLUXFAC + ENDDO + + ! Copy to output array, noting that they may be dimensioned + ! differently + PLwDerivative(JL,:) = ZLwDerivative(JL,:) + +ENDDO + +9901 FORMAT(1X,'rrtm:',I4,12E12.5) + +!------------------------------------------------------------------------ +END ASSOCIATE + +IF (LHOOK) CALL DR_HOOK('RRTM_RRTM_140GP_MCICA',1,ZHOOK_HANDLE) +END SUBROUTINE RRTM_RRTM_140GP_MCICA Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_setcoef_140gp.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_setcoef_140gp.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_setcoef_140gp.F90 (revision 6016) @@ -0,0 +1,290 @@ +! This file has been modified for the use in ICON + +SUBROUTINE RRTM_SETCOEF_140GP (KIDIA,KFDIA,KLEV,P_COLDRY,P_WBROAD,P_WKL,& + & P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLH2O,P_COLCO2,P_COLO3,P_COLN2O,P_COLCH4, P_COLO2,P_CO2MULT, P_COLBRD, & + & K_LAYTROP,K_LAYSWTCH,K_LAYLOW,PAVEL,P_TAVEL,P_SELFFAC,P_SELFFRAC,K_INDSELF,& + & K_INDMINOR,P_SCALEMINOR,P_SCALEMINORN2,P_MINORFRAC,& + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_H2OO3, PRAT_H2OO3_1, & + & PRAT_H2ON2O, PRAT_H2ON2O_1, PRAT_H2OCH4, PRAT_H2OCH4_1, & + & PRAT_N2OCO2, PRAT_N2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) + +! Reformatted for F90 by JJMorcrette, ECMWF, 980714 +! NEC 25-Oct-2007 Optimisations +! 201305 ABozzo updated to rrtmg_lw_v4.85 +! 201507 RHogan Bug fix: swapped P_COLO2 & P_CO2MULT in argument list + + +! 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. + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE PARRRTM , ONLY : JPINPX +USE YOERRTRF , ONLY : PREFLOG ,TREF, CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_WBROAD(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLBRD(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_WKL(KIDIA:KFDIA,JPINPX,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_CO2MULT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYLOW(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDSELF(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDFOR(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_SCALEMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_SCALEMINORN2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_MINORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: & ! + & PRAT_H2OCO2(KIDIA:KFDIA,KLEV),PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV), & + & PRAT_H2OO3(KIDIA:KFDIA,KLEV) ,PRAT_H2OO3_1(KIDIA:KFDIA,KLEV), & + & PRAT_H2ON2O(KIDIA:KFDIA,KLEV),PRAT_H2ON2O_1(KIDIA:KFDIA,KLEV), & + & PRAT_H2OCH4(KIDIA:KFDIA,KLEV),PRAT_H2OCH4_1(KIDIA:KFDIA,KLEV), & + & PRAT_N2OCO2(KIDIA:KFDIA,KLEV),PRAT_N2OCO2_1(KIDIA:KFDIA,KLEV), & + & PRAT_O3CO2(KIDIA:KFDIA,KLEV) ,PRAT_O3CO2_1(KIDIA:KFDIA,KLEV) +!- from INTFAC +!- from INTIND +!- from PROFDATA +!- from PROFILE +!- from SELF +INTEGER(KIND=JPIM) :: JP1, JLAY +INTEGER(KIND=JPIM) :: JLON + +REAL(KIND=JPRB) :: Z_CO2REG, Z_COMPFP, Z_FACTOR, Z_FP, Z_FT, Z_FT1, Z_PLOG, Z_SCALEFAC, Z_STPFAC, Z_WATER +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +IF (LHOOK) CALL DR_HOOK('RRTM_SETCOEF_140GP',0,ZHOOK_HANDLE) + +!$ACC PARALLEL DEFAULT(NONE) PRESENT(P_COLDRY, P_WBROAD, P_COLBRD, P_WKL, P_FAC00, P_FAC01, P_FAC10, P_FAC11, & +!$ACC P_FORFAC, P_FORFRAC, K_JP, K_JT, K_JT1, P_COLH2O, P_COLCO2, P_COLO3, P_COLN2O, P_COLCH4, P_COLO2, P_CO2MULT, & +!$ACC K_LAYTROP, K_LAYSWTCH, K_LAYLOW, PAVEL, P_TAVEL, P_SELFFAC, P_SELFFRAC, K_INDSELF, K_INDFOR, K_INDMINOR, & +!$ACC P_SCALEMINOR, P_SCALEMINORN2, P_MINORFRAC, PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_H2OO3, PRAT_H2OO3_1, PRAT_H2ON2O, & +!$ACC PRAT_H2ON2O_1, PRAT_H2OCH4, PRAT_H2OCH4_1, PRAT_N2OCO2, PRAT_N2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) ASYNC(1) +!$ACC LOOP GANG VECTOR +DO JLON = KIDIA, KFDIA + Z_STPFAC = 296._JPRB/1013._JPRB + + K_LAYTROP(JLON) = 0 + K_LAYSWTCH(JLON) = 0 + K_LAYLOW(JLON) = 0 + !$ACC LOOP SEQ + DO JLAY = 1, 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. + Z_PLOG = LOG(PAVEL(JLON,JLAY)) + K_JP(JLON,JLAY) = INT(36._JPRB - 5*(Z_PLOG+0.04_JPRB)) + IF (K_JP(JLON,JLAY) < 1) THEN + K_JP(JLON,JLAY) = 1 + ELSEIF (K_JP(JLON,JLAY) > 58) THEN + K_JP(JLON,JLAY) = 58 + ENDIF + JP1 = K_JP(JLON,JLAY) + 1 + Z_FP = 5._JPRB * (PREFLOG(K_JP(JLON,JLAY)) - Z_PLOG) +! bound Z_FP in case Z_PLOG is outside range of ref. pressure PREFLOG +! (in LVERTFE, pressure at last full level is known, but not in finite diff (NH) + Z_FP = MAX(-1.0_JPRB, MIN(1.0_JPRB, Z_FP)) +! 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. + + K_JT(JLON,JLAY) = INT(3._JPRB + (P_TAVEL(JLON,JLAY)-TREF(K_JP(JLON,JLAY)))/15._JPRB) + IF (K_JT(JLON,JLAY) < 1) THEN + K_JT(JLON,JLAY) = 1 + ELSEIF (K_JT(JLON,JLAY) > 4) THEN + K_JT(JLON,JLAY) = 4 + ENDIF + Z_FT = ((P_TAVEL(JLON,JLAY)-TREF(K_JP(JLON,JLAY)))/15._JPRB) - REAL(K_JT(JLON,JLAY)-3) + K_JT1(JLON,JLAY) = INT(3._JPRB + (P_TAVEL(JLON,JLAY)-TREF(JP1))/15._JPRB) + IF (K_JT1(JLON,JLAY) < 1) THEN + K_JT1(JLON,JLAY) = 1 + ELSEIF (K_JT1(JLON,JLAY) > 4) THEN + K_JT1(JLON,JLAY) = 4 + ENDIF + Z_FT1 = ((P_TAVEL(JLON,JLAY)-TREF(JP1))/15._JPRB) - REAL(K_JT1(JLON,JLAY)-3) + + Z_WATER = P_WKL(JLON,1,JLAY)/P_COLDRY(JLON,JLAY) + Z_SCALEFAC = PAVEL(JLON,JLAY) * Z_STPFAC / P_TAVEL(JLON,JLAY) + +! If the pressure is less than ~100mb, perform a different +! set of species interpolations. +! IF (PLOG .LE. 4.56) GO TO 5300 +!-------------------------------------- + IF (Z_PLOG > 4.56_JPRB) THEN + K_LAYTROP(JLON) = K_LAYTROP(JLON) + 1 +! For one band, the "switch" occurs at ~300 mb. +! IF (Z_PLOG >= 5.76_JPRB) K_LAYSWTCH(JLON) = K_LAYSWTCH(JLON) + 1 +! IF (Z_PLOG >= 6.62_JPRB) K_LAYLOW(JLON) = K_LAYLOW(JLON) + 1 + + +! water vapor foreign continuum + P_FORFAC(JLON,JLAY) = Z_SCALEFAC / (1.0_JPRB+Z_WATER) + Z_FACTOR = (332.0_JPRB-P_TAVEL(JLON,JLAY))/36.0_JPRB + K_INDFOR(JLON,JLAY) = MIN(2, MAX(1, INT(Z_FACTOR))) + P_FORFRAC(JLON,JLAY) = Z_FACTOR - REAL(K_INDFOR(JLON,JLAY)) + +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. +!C SELFFAC(LAY) = WATER * SCALEFAC / (1.+WATER) + P_SELFFAC(JLON,JLAY) = Z_WATER * P_FORFAC(JLON,JLAY) + Z_FACTOR = (P_TAVEL(JLON,JLAY)-188.0_JPRB)/7.2_JPRB + K_INDSELF(JLON,JLAY) = MIN(9, MAX(1, INT(Z_FACTOR)-7)) + P_SELFFRAC(JLON,JLAY) = Z_FACTOR - REAL(K_INDSELF(JLON,JLAY) + 7) + +! Set up factors needed to separately include the minor gases +! in the calculation of absorption coefficient + P_SCALEMINOR(JLON,JLAY) = PAVEL(JLON,JLAY)/P_TAVEL(JLON,JLAY) + P_SCALEMINORN2(JLON,JLAY) = (PAVEL(JLON,JLAY)/P_TAVEL(JLON,JLAY)) & + & *(P_WBROAD(JLON,JLAY)/(P_COLDRY(JLON,JLAY)+P_WKL(JLON,1,JLAY))) + Z_FACTOR = (P_TAVEL(JLON,JLAY)-180.8_JPRB)/7.2_JPRB + K_INDMINOR(JLON,JLAY) = MIN(18, MAX(1, INT(Z_FACTOR))) + P_MINORFRAC(JLON,JLAY) = Z_FACTOR - REAL(K_INDMINOR(JLON,JLAY)) + +! Setup reference ratio to be used in calculation of binary +! species parameter in lower atmosphere. + PRAT_H2OCO2(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(2,K_JP(JLON,JLAY)) + PRAT_H2OCO2_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(2,K_JP(JLON,JLAY)+1) + + PRAT_H2OO3(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(3,K_JP(JLON,JLAY)) + PRAT_H2OO3_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(3,K_JP(JLON,JLAY)+1) + + PRAT_H2ON2O(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(4,K_JP(JLON,JLAY)) + PRAT_H2ON2O_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(4,K_JP(JLON,JLAY)+1) + + PRAT_H2OCH4(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(6,K_JP(JLON,JLAY)) + PRAT_H2OCH4_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(6,K_JP(JLON,JLAY)+1) + + PRAT_N2OCO2(JLON,JLAY)=CHI_MLS(4,K_JP(JLON,JLAY))/CHI_MLS(2,K_JP(JLON,JLAY)) + PRAT_N2OCO2_1(JLON,JLAY)=CHI_MLS(4,K_JP(JLON,JLAY)+1)/CHI_MLS(2,K_JP(JLON,JLAY)+1) + + + +! Calculate needed column amounts. + P_COLH2O(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,1,JLAY) + P_COLCO2(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,2,JLAY) + P_COLO3(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,3,JLAY) + P_COLN2O(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,4,JLAY) + P_COLCH4(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,6,JLAY) + P_COLO2(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,7,JLAY) + P_COLBRD(JLON,JLAY) = 1.E-20_JPRB * P_WBROAD(JLON,JLAY) + IF (P_COLCO2(JLON,JLAY) == 0.0_JPRB) P_COLCO2(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) + IF (P_COLN2O(JLON,JLAY) == 0.0_JPRB) P_COLN2O(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) + IF (P_COLCH4(JLON,JLAY) == 0.0_JPRB) P_COLCH4(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) +! Using E = 1334.2 cm-1. + Z_CO2REG = 3.55E-24_JPRB * P_COLDRY(JLON,JLAY) + P_CO2MULT(JLON,JLAY)= (P_COLCO2(JLON,JLAY) - Z_CO2REG) *& + & 272.63_JPRB*EXP(-1919.4_JPRB/P_TAVEL(JLON,JLAY))/(8.7604E-4_JPRB*P_TAVEL(JLON,JLAY)) +! GO TO 5400 +!------------------ + ELSE +! Above LAYTROP. +! 5300 CONTINUE + +! Calculate needed column amounts. + P_FORFAC(JLON,JLAY) = Z_SCALEFAC / (1.0_JPRB+Z_WATER) + Z_FACTOR = (P_TAVEL(JLON,JLAY)-188.0_JPRB)/36.0_JPRB + K_INDFOR(JLON,JLAY) = 3 + P_FORFRAC(JLON,JLAY) = Z_FACTOR - 1.0_JPRB + +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + P_SELFFAC(JLON,JLAY) = Z_WATER * P_FORFAC(JLON,JLAY) + +! Set up factors needed to separately include the minor gases +! in the calculation of absorption coefficient + P_SCALEMINOR(JLON,JLAY) = PAVEL(JLON,JLAY)/P_TAVEL(JLON,JLAY) + P_SCALEMINORN2(JLON,JLAY) = (PAVEL(JLON,JLAY)/P_TAVEL(JLON,JLAY)) & + & * (P_WBROAD(JLON,JLAY)/(P_COLDRY(JLON,JLAY)+P_WKL(JLON,1,JLAY))) + Z_FACTOR = (P_TAVEL(JLON,JLAY)-180.8_JPRB)/7.2_JPRB + K_INDMINOR(JLON,JLAY) = MIN(18, MAX(1, INT(Z_FACTOR))) + P_MINORFRAC(JLON,JLAY) = Z_FACTOR - REAL(K_INDMINOR(JLON,JLAY)) + +! Setup reference ratio to be used in calculation of binary +! species parameter in upper atmosphere. + PRAT_H2OCO2(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(2,K_JP(JLON,JLAY)) + PRAT_H2OCO2_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(2,K_JP(JLON,JLAY)+1) + + PRAT_O3CO2(JLON,JLAY)=CHI_MLS(3,K_JP(JLON,JLAY))/CHI_MLS(2,K_JP(JLON,JLAY)) + PRAT_O3CO2_1(JLON,JLAY)=CHI_MLS(3,K_JP(JLON,JLAY)+1)/CHI_MLS(2,K_JP(JLON,JLAY)+1) + + +! Calculate needed column amounts. + P_COLH2O(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,1,JLAY) + P_COLCO2(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,2,JLAY) + P_COLO3(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,3,JLAY) + P_COLN2O(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,4,JLAY) + P_COLCH4(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,6,JLAY) + P_COLO2(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,7,JLAY) + P_COLBRD(JLON,JLAY) = 1.E-20_JPRB * P_WBROAD(JLON,JLAY) + IF (P_COLCO2(JLON,JLAY) == 0.0_JPRB) P_COLCO2(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) + IF (P_COLN2O(JLON,JLAY) == 0.0_JPRB) P_COLN2O(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) + IF (P_COLCH4(JLON,JLAY) == 0.0_JPRB) P_COLCH4(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) + Z_CO2REG = 3.55E-24_JPRB * P_COLDRY(JLON,JLAY) + P_CO2MULT(JLON,JLAY)= (P_COLCO2(JLON,JLAY) - Z_CO2REG) *& + & 272.63_JPRB*EXP(-1919.4_JPRB/P_TAVEL(JLON,JLAY))/(8.7604E-4_JPRB*P_TAVEL(JLON,JLAY)) +!---------------- + ENDIF +! 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). + + Z_COMPFP = 1.0_JPRB - Z_FP + P_FAC10(JLON,JLAY) = Z_COMPFP * Z_FT + P_FAC00(JLON,JLAY) = Z_COMPFP * (1.0_JPRB - Z_FT) + P_FAC11(JLON,JLAY) = Z_FP * Z_FT1 + P_FAC01(JLON,JLAY) = Z_FP * (1.0_JPRB - Z_FT1) + +! Rescale selffac and forfac for use in taumol + P_SELFFAC(JLON,JLAY) = P_COLH2O(JLON,JLAY)*P_SELFFAC(JLON,JLAY) + P_FORFAC(JLON,JLAY) = P_COLH2O(JLON,JLAY)*P_FORFAC(JLON,JLAY) + + + ENDDO + +! MT 981104 +!-- Set LAYLOW for profiles with surface pressure less than 750 hPa. + IF (K_LAYLOW(JLON) == 0) K_LAYLOW(JLON)=1 +ENDDO +!$ACC END PARALLEL + +IF (LHOOK) CALL DR_HOOK('RRTM_SETCOEF_140GP',1,ZHOOK_HANDLE) + +END SUBROUTINE RRTM_SETCOEF_140GP Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol1.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol1.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol1.F90 (revision 6016) @@ -0,0 +1,409 @@ +! This file has been modified for the use in ICON + +SUBROUTINE RRTM_TAUMOL1 (KIDIA,KFDIA,KLEV,taug,PAVEL,& + & P_TAUAERL,FAC00,FAC01,FAC10,FAC11,FORFAC,FORFRAC,INDFOR,JP,JT,jt1,& + & COLH2O,LAYTROP,SELFFAC,SELFFRAC,INDSELF,fracs,MINORFRAC,INDMINOR,& + & SCALEMINORN2,COLBRD) + +!****************************************************************************** +! * +! Optical depths developed for the * +! * +! RAPID RADIATIVE TRANSFER MODEL (RRTM) * +! * +! ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * +! 840 MEMORIAL DRIVE * +! CAMBRIDGE, MA 02139 * +! * +! ELI J. MLAWER * +! STEVEN J. TAUBMAN * +! SHEPARD A. CLOUGH * +! * +! email: mlawer@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 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/ KLEV,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(KIDIA:KFDIA,MXLAY),jt1(KIDIA:KFDIA,MXLAY) * +! COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(KIDIA:KFDIA,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) * +! * +!****************************************************************************** + +! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF, from +! Eli J. Mlawer, Atmospheric & Environmental Research. +! (Revised by Michael J. Iacono, Atmospheric & Environmental Research.) + +! MODIFICATIONS. +! -------------- +! D Salmond 2000-05-15 speed-up +! JJMorcrette 2000-05-17 speed-up +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 200130517 updated to rrtmg_lw_v4.85: +!********* +! 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) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG1 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA1 , ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,& + & FORREF ,SELFREF, KA_MN2, KB_MN2 + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) ! Layer pressures (hPa) +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FAC11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: COLH2O(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: SELFFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: MINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +INTEGER(KIND=JPIM),INTENT(IN) :: INDFOR(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: INDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: SCALEMINORN2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: COLBRD(KIDIA:KFDIA,KLEV) +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: IND0,IND1,INDS +INTEGER(KIND=JPIM) :: INDF,INDM + +INTEGER(KIND=JPIM) :: IG, LAY +REAL(KIND=JPRB) :: taufor,tauself,corradj,pp,scalen2, taun2 + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + + !$ACC DATA PRESENT(PAVEL, taug, P_TAUAERL, FAC00, FAC01, FAC10, FAC11, & + !$ACC FORFAC, FORFRAC, JP, JT, jt1, COLH2O, LAYTROP, SELFFAC, & + !$ACC SELFFRAC, MINORFRAC, INDSELF, fracs, & + !$ACC INDFOR, INDMINOR, SCALEMINORN2, COLBRD) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + + +! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, indm, pp, corradj) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(1) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(1) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + pp = pavel(jl,lay) + corradj = 1.0_JPRB + if (pp .lt. 250._JPRB) then + corradj = 1._JPRB - 0.15_JPRB * (250._JPRB-pp) / 154.4_JPRB + endif + + scalen2 = colbrd(jl,lay) * scaleminorn2(jl,lay) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, taun2) +!$NEC unroll(NG1) + do ig = 1, ng1 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taun2 = scalen2*(ka_mn2(indm,ig) + & + minorfrac(jl,lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,ig))) + taug(jl,ig,lay) = corradj * (colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor + taun2) + fracs(jl,ig,lay) = fracrefa(ig) + enddo + enddo + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, indf, indm, pp, corradj, scalen2) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(1) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(1) + 1 + indf = indfor(jl,lay) + indm = indminor(jl,lay) + pp = pavel(jl,lay) + corradj = 1._JPRB - 0.15_JPRB * (pp / 95.6_JPRB) + + scalen2 = colbrd(jl,lay) * scaleminorn2(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor, taun2) +!$NEC unroll(NG1) + do ig = 1, ng1 + taufor = forfac(jl,lay) * (forref(indf,ig) + & + forfrac(jl,lay) * (forref(indf+1,ig) - forref(indf,ig))) + taun2 = scalen2*(kb_mn2(indm,ig) + & + minorfrac(jl,lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,ig))) + taug(jl,ig,lay) = corradj * (colh2o(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + taufor + taun2) + fracs(jl,ig,lay) = fracrefb(ig) + enddo + enddo + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, indm, pp, corradj, scalen2) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(1) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(1) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + pp = pavel(jl,lay) + corradj = 1.0_JPRB + if (pp .lt. 250._JPRB) then + corradj = 1._JPRB - 0.15_JPRB * (250._JPRB-pp) / 154.4_JPRB + endif + + scalen2 = colbrd(jl,lay) * scaleminorn2(jl,lay) +!$NEC unroll(NG1) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, taun2) + do ig = 1, ng1 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taun2 = scalen2*(ka_mn2(indm,ig) + & + minorfrac(jl,lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,ig))) + taug(jl,ig,lay) = corradj * (colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor + taun2) + fracs(jl,ig,lay) = fracrefa(ig) + enddo +#ifdef _OPENACC + else +#else + enddo + + + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(1) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(1) + 1 + indf = indfor(jl,lay) + indm = indminor(jl,lay) + pp = pavel(jl,lay) + corradj = 1._JPRB - 0.15_JPRB * (pp / 95.6_JPRB) + + scalen2 = colbrd(jl,lay) * scaleminorn2(jl,lay) +!$NEC unroll(NG1) + !$ACC LOOP SEQ PRIVATE(taufor, taun2) + do ig = 1, ng1 + taufor = forfac(jl,lay) * (forref(indf,ig) + & + forfrac(jl,lay) * (forref(indf+1,ig) - forref(indf,ig))) + taun2 = scalen2*(kb_mn2(indm,ig) + & + minorfrac(jl,lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,ig))) + taug(jl,ig,lay) = corradj * (colh2o(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + taufor + taun2) + fracs(jl,ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL1 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol10.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol10.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol10.F90 (revision 6016) @@ -0,0 +1,241 @@ +! This file has been modified for the use in ICON + +!******************************************************************************* +SUBROUTINE RRTM_TAUMOL10 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,& + & colh2o,laytrop,selffac,selffrac,indself,fracs) + +! BAND 10: 1390-1480 cm-1 (low - H2O; high - H2O) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG10 ,NGS9 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA10, ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB, FORREF ,SELFREF + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: ind0,ind1 +INTEGER(KIND=JPIM) :: inds,indf + +INTEGER(KIND=JPIM) :: IG, lay +REAL(KIND=JPRB) :: taufor,tauself + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colh2o, laytrop, fracs, selffac, selffrac, indself, & + !$ACC indfor, forfrac, forfac) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. + + ! Lower atmosphere loop + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(10) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(10) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + !$ACC LOOP SEQ PRIVATE(tauself, taufor) +!$NEC unroll(NG10) + do ig = 1, ng10 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs9+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor + fracs(jl,ngs9+ig,lay) = fracrefa(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, indf) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(10) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(10) + 1 + indf = indfor(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor) +!$NEC unroll(NG10) + do ig = 1, ng10 + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs9+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + taufor + fracs(jl,ngs9+ig,lay) = fracrefb(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(10) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(10) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) +!$NEC unroll(NG10) + !$ACC LOOP SEQ PRIVATE(tauself, taufor) + do ig = 1, ng10 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs9+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor + fracs(jl,ngs9+ig,lay) = fracrefa(ig) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(10) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(10) + 1 + indf = indfor(jl,lay) +!$NEC unroll(NG10) + !$ACC LOOP SEQ PRIVATE (taufor) + do ig = 1, ng10 + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs9+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + taufor + fracs(jl,ngs9+ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL10 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol11.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol11.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol11.F90 (revision 6016) @@ -0,0 +1,274 @@ +! This file has been modified for the use in ICON + +!****************************************************************************** +SUBROUTINE RRTM_TAUMOL11 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,& + & colh2o,colo2,laytrop,selffac,selffrac,indself,fracs,minorfrac, & + & indminor,scaleminor) + +! BAND 11: 1480-1800 cm-1 (low - H2O; high - H2O) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo updated to rrtmg v4.85 +! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +! (high key - h2o; high minor - o2) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG11 ,NGS10 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA11, ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,SELFREF,FORREF, & + & KA_MO2, KB_MO2 + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colo2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: minorfrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indminor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: scaleminor(KIDIA:KFDIA,KLEV) +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: ind0,ind1 +INTEGER(KIND=JPIM) :: inds,indf,indm + +INTEGER(KIND=JPIM) :: IG, lay +REAL(KIND=JPRB) :: taufor,tauself,scaleO2, tauO2 + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colh2o, colo2, laytrop, selffac, selffrac, indself, fracs, & + !$ACC indfor, forfac, forfrac, minorfrac, indminor, scaleminor) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + +! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, indm) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(11) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(11) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + scaleo2 = colo2(jl,lay)*scaleminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor, tauself, tauo2) +!$NEC unroll(NG11) + do ig = 1, ng11 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(jl,lay) * & + (ka_mo2(indm+1,ig) - ka_mo2(indm,ig))) + taug(jl,ngs10+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + tauo2 + fracs(jl,ngs10+ig,lay) = fracrefa(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, indf, indm, scaleo2) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(11) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(11) + 1 + indf = indfor(jl,lay) + indm = indminor(jl,lay) + scaleo2 = colo2(jl,lay)*scaleminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor, tauo2) +!$NEC unroll(NG11) + do ig = 1, ng11 + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(jl,lay) * & + (kb_mo2(indm+1,ig) - kb_mo2(indm,ig))) + taug(jl,ngs10+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + taufor & + + tauo2 + fracs(jl,ngs10+ig,lay) = fracrefb(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, indm, scaleo2) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(11) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(11) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + scaleo2 = colo2(jl,lay)*scaleminor(jl,lay) +!$NEC unroll(NG11) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, tauo2) + do ig = 1, ng11 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(jl,lay) * & + (ka_mo2(indm+1,ig) - ka_mo2(indm,ig))) + taug(jl,ngs10+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + tauo2 + fracs(jl,ngs10+ig,lay) = fracrefa(ig) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(11) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(11) + 1 + indf = indfor(jl,lay) + indm = indminor(jl,lay) + scaleo2 = colo2(jl,lay)*scaleminor(jl,lay) +!$NEC unroll(NG11) + !$ACC LOOP SEQ PRIVATE(taufor, tauo2) + do ig = 1, ng11 + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(jl,lay) * & + (kb_mo2(indm+1,ig) - kb_mo2(indm,ig))) + taug(jl,ngs10+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + taufor & + + tauo2 + fracs(jl,ngs10+ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL11 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol12.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol12.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol12.F90 (revision 6016) @@ -0,0 +1,532 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL12 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,oneminus,& + & colh2o,colco2,laytrop,selffac,selffrac,indself,fracs, & + & rat_h2oco2, rat_h2oco2_1) + +! BAND 12: 1800-2080 cm-1 (low - H2O,CO2; high - nothing) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo updated to rrtmg v4.85 +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG12 ,NGS11 +USE YOERRTWN , ONLY : NSPA +USE YOERRTA12, ONLY : ABSA ,FRACREFA,SELFREF,FORREF +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: oneminus +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2oco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2oco2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) + + +! --------------------------------------------------------------------------- + +REAL(KIND=JPRB) :: speccomb,speccomb1,speccomb_planck +INTEGER(KIND=JPIM) :: ind0,ind1,inds,indf + +INTEGER(KIND=JPIM) :: IG, JS, lay,JS1, JPL + +! REAL(KIND=JPRB) :: fac000, fac001, fac010, fac011, fac100, fac101,& +! & fac110, fac111 +REAL(KIND=JPRB) :: fs, specmult, specparm, & +& fs1, specmult1, specparm1, & +& fpl, specmult_PLANCK, specparm_PLANCK + +REAL(KIND=JPRB) :: fac000, fac100, fac200,& + & fac010, fac110, fac210, & + & fac001, fac101, fac201, & + & fac011, fac111, fac211 +REAL(KIND=JPRB) :: p, p4, fk0, fk1, fk2 +REAL(KIND=JPRB) :: taufor,tauself,tau_major(ng12),tau_major1(ng12) +REAL(KIND=JPRB) :: refrat_planck_a + + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + +#define MOD1(x) ((x) - AINT((x))) + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colh2o, colco2, laytrop, selffac, selffrac, indself, fracs, & + !$ACC rat_h2oco2, rat_h2oco2_1, indfor, forfrac, forfac) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + +! ---------------------------------------------------------- + + ! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, speccomb1, speccomb_planck, ind0,ind1,inds,indf, js, js1, & + !$ACC jpl, fs, specmult, specparm, fs1, specmult1, specparm1, fpl, specmult_PLANCK, specparm_PLANCK, fac000, & + !$ACC fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, fac011, fac111, fac211, p, p4, fk0, fk1, & + !$ACC fk2, tau_major, tau_major1) + DO lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(12) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(12) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG12) + tau_major(1:ng12) = speccomb * & + (fac000 * absa(ind0,1:ng12) + & + fac100 * absa(ind0+1,1:ng12) + & + fac200 * absa(ind0+2,1:ng12) + & + fac010 * absa(ind0+9,1:ng12) + & + fac110 * absa(ind0+10,1:ng12) + & + fac210 * absa(ind0+11,1:ng12)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG12) + tau_major(1:ng12) = speccomb * & + (fac200 * absa(ind0-1,1:ng12) + & + fac100 * absa(ind0,1:ng12) + & + fac000 * absa(ind0+1,1:ng12) + & + fac210 * absa(ind0+8,1:ng12) + & + fac110 * absa(ind0+9,1:ng12) + & + fac010 * absa(ind0+10,1:ng12)) + else +!$NEC unroll(NG12) + tau_major(1:ng12) = speccomb * & + (fac000 * absa(ind0,1:ng12) + & + fac100 * absa(ind0+1,1:ng12) + & + fac010 * absa(ind0+9,1:ng12) + & + fac110 * absa(ind0+10,1:ng12)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG12) + tau_major1(1:ng12) = speccomb1 * & + (fac001 * absa(ind1,1:ng12) + & + fac101 * absa(ind1+1,1:ng12) + & + fac201 * absa(ind1+2,1:ng12) + & + fac011 * absa(ind1+9,1:ng12) + & + fac111 * absa(ind1+10,1:ng12) + & + fac211 * absa(ind1+11,1:ng12)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG12) + tau_major1(1:ng12) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng12) + & + fac101 * absa(ind1,1:ng12) + & + fac001 * absa(ind1+1,1:ng12) + & + fac211 * absa(ind1+8,1:ng12) + & + fac111 * absa(ind1+9,1:ng12) + & + fac011 * absa(ind1+10,1:ng12)) + else +!$NEC unroll(NG12) + tau_major1(1:ng12) = speccomb1 * & + (fac001 * absa(ind1,1:ng12) + & + fac101 * absa(ind1+1,1:ng12) + & + fac011 * absa(ind1+9,1:ng12) + & + fac111 * absa(ind1+10,1:ng12)) + endif + + !$ACC LOOP SEQ PRIVATE(taufor, tauself) +!$NEC unroll(NG12) + do ig = 1, ng12 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + taug(jl,ngs11+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor + fracs(jl,ngs11+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + + ENDDO + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + do ig = 1, ng12 + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + taug(jl,ngs11+ig,lay) = 0.0_JPRB + fracs(jl,ngs11+ig,lay) = 0.0_JPRB + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_planck, specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, & + !$ACC indf, p, p4, fk0, fk1, fk2, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, & + !$ACC fac011, fac111, fac211, tau_major, tau_major1) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(12) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(12) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG12) + tau_major(1:ng12) = speccomb * & + (fac000 * absa(ind0,1:ng12) + & + fac100 * absa(ind0+1,1:ng12) + & + fac200 * absa(ind0+2,1:ng12) + & + fac010 * absa(ind0+9,1:ng12) + & + fac110 * absa(ind0+10,1:ng12) + & + fac210 * absa(ind0+11,1:ng12)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG12) + tau_major(1:ng12) = speccomb * & + (fac200 * absa(ind0-1,1:ng12) + & + fac100 * absa(ind0,1:ng12) + & + fac000 * absa(ind0+1,1:ng12) + & + fac210 * absa(ind0+8,1:ng12) + & + fac110 * absa(ind0+9,1:ng12) + & + fac010 * absa(ind0+10,1:ng12)) + else +!$NEC unroll(NG12) + tau_major(1:ng12) = speccomb * & + (fac000 * absa(ind0,1:ng12) + & + fac100 * absa(ind0+1,1:ng12) + & + fac010 * absa(ind0+9,1:ng12) + & + fac110 * absa(ind0+10,1:ng12)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG12) + tau_major1(1:ng12) = speccomb1 * & + (fac001 * absa(ind1,1:ng12) + & + fac101 * absa(ind1+1,1:ng12) + & + fac201 * absa(ind1+2,1:ng12) + & + fac011 * absa(ind1+9,1:ng12) + & + fac111 * absa(ind1+10,1:ng12) + & + fac211 * absa(ind1+11,1:ng12)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG12) + tau_major1(1:ng12) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng12) + & + fac101 * absa(ind1,1:ng12) + & + fac001 * absa(ind1+1,1:ng12) + & + fac211 * absa(ind1+8,1:ng12) + & + fac111 * absa(ind1+9,1:ng12) + & + fac011 * absa(ind1+10,1:ng12)) + else +!$NEC unroll(NG12) + tau_major1(1:ng12) = speccomb1 * & + (fac001 * absa(ind1,1:ng12) + & + fac101 * absa(ind1+1,1:ng12) + & + fac011 * absa(ind1+9,1:ng12) + & + fac111 * absa(ind1+10,1:ng12)) + endif + +!$NEC unroll(NG12) + !$ACC LOOP SEQ PRIVATE(tauself, taufor) + do ig = 1, ng12 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + taug(jl,ngs11+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor + fracs(jl,ngs11+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +#endif + + !$ACC LOOP SEQ + do ig = 1, ng12 +#ifndef _OPENACC +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + taug(jl,ngs11+ig,lay) = 0.0_JPRB + fracs(jl,ngs11+ig,lay) = 0.0_JPRB + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL12 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol13.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol13.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol13.F90 (revision 6016) @@ -0,0 +1,646 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL13 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,oneminus,& + & colh2o,coln2o,colco2,colo3,coldry,laytrop,selffac,selffrac,indself,fracs, & + & rat_h2on2o, rat_h2on2o_1,minorfrac,indminor) + +! BAND 13: 2080-2250 cm-1 (low - H2O,N2O; high - nothing) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + + ! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG13 ,NGS12 +USE YOERRTWN , ONLY : NSPA +USE YOERRTA13, ONLY : ABSA ,FRACREFA,FRACREFB,SELFREF,FORREF,KA_MCO2, KA_MCO, KB_MO3 +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: oneminus +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coln2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colo3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coldry(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2on2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2on2o_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: minorfrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indminor(KIDIA:KFDIA,KLEV) + +! --------------------------------------------------------------------------- + + +REAL(KIND=JPRB) :: speccomb,speccomb1, speccomb_planck, & + & speccomb_mco2, speccomb_mco +INTEGER(KIND=JPIM) :: ind0,ind1,inds,indf,indm +INTEGER(KIND=JPIM) :: IG, JS, lay, JS1, JPL, JMCO2, JMCO + +REAL(KIND=JPRB) :: refrat_planck_a, refrat_m_a, refrat_m_a3 +REAL(KIND=JPRB) :: fac000, fac100, fac200,& + & fac010, fac110, fac210, & + & fac001, fac101, fac201, & + & fac011, fac111, fac211 +REAL(KIND=JPRB) :: p, p4, fk0, fk1, fk2 + +REAL(KIND=JPRB) :: taufor,tauself,tau_major(ng13),tau_major1(ng13), co2m1, co2m2, absco2 +REAL(KIND=JPRB) :: com1, com2, absco, abso3 +REAL(KIND=JPRB) :: chi_co2, ratco2, adjfac, adjcolco2 + +REAL(KIND=JPRB) :: fs, specmult, specparm, & +& fs1, specmult1, specparm1, & +& fmco2, specmult_mco2, specparm_mco2, & +& fmco , specmult_mco , specparm_mco , & +& fpl, specmult_planck, specparm_planck + +REAL(KIND=JPRB) :: colco(KIDIA:KFDIA,KLEV) !left =0 for now,not passed from rrtm_gasbas1a + + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + + +#define MOD1(x) ((x) - AINT((x))) + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colh2o, coln2o, colco2, colo3, coldry, laytrop, selffac, & + !$ACC selffrac, indself, fracs, rat_h2on2o, rat_h2on2o_1, & + !$ACC indfor, forfac, forfrac, minorfrac, indminor) & + !$ACC CREATE(colco) + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do lay = 1,KLEV + do jc = KIDIA, KFDIA + colco(jc,lay) = 0._JPRB + end do + end do + !$ACC END PARALLEL + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + + ! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, speccomb1, speccomb_planck, speccomb_mco2, speccomb_mco, & + !$ACC ind0, ind1, & + !$ACC inds, indf, indm, js, js1, jpl, jmco2, jmco, fac000, fac100, fac200, fac010, & + !$ACC fac110, fac210, fac001, fac101, fac201, fac011, fac111, fac211, p, p4, fk0, fk1, fk2, chi_co2, ratco2, & + !$ACC adjfac, adjcolco2, fs, specmult, specparm, fs1, specmult1, specparm1, fmco2, specmult_mco2, & + !$ACC specparm_mco2, fmco, specmult_mco, specparm_mco, fpl, specmult_planck, specparm_planck, tau_major, & + !$ACC tau_major1) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2on2o(jl,lay)*coln2o(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2on2o_1(jl,lay)*coln2o(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mco2 = colh2o(jl,lay) + refrat_m_a*coln2o(jl,lay) + specparm_mco2 = MIN(colh2o(jl,lay)/speccomb_mco2,oneminus) + specmult_mco2 = 8._JPRB*specparm_mco2 + jmco2 = 1 + int(specmult_mco2) + fmco2 = MOD1(specmult_mco2) + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/3.55e-4_JPRB + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.68_JPRB + adjcolco2 = adjfac*3.55e-4_JPRB*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + speccomb_mco = colh2o(jl,lay) + refrat_m_a3*coln2o(jl,lay) + specparm_mco = MIN(colh2o(jl,lay)/speccomb_mco,oneminus) + specmult_mco = 8._JPRB*specparm_mco + jmco = 1 + int(specmult_mco) + fmco = MOD1(specmult_mco) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*coln2o(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(13) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(13) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG13) + tau_major(1:ng13) = speccomb * & + (fac000 * absa(ind0,1:ng13) + & + fac100 * absa(ind0+1,1:ng13) + & + fac200 * absa(ind0+2,1:ng13) + & + fac010 * absa(ind0+9,1:ng13) + & + fac110 * absa(ind0+10,1:ng13) + & + fac210 * absa(ind0+11,1:ng13)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG13) + tau_major(1:ng13) = speccomb * & + (fac200 * absa(ind0-1,1:ng13) + & + fac100 * absa(ind0,1:ng13) + & + fac000 * absa(ind0+1,1:ng13) + & + fac210 * absa(ind0+8,1:ng13) + & + fac110 * absa(ind0+9,1:ng13) + & + fac010 * absa(ind0+10,1:ng13)) + else +!$NEC unroll(NG13) + tau_major(1:ng13) = speccomb * & + (fac000 * absa(ind0,1:ng13) + & + fac100 * absa(ind0+1,1:ng13) + & + fac010 * absa(ind0+9,1:ng13) + & + fac110 * absa(ind0+10,1:ng13)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG13) + tau_major1(1:ng13) = speccomb1 * & + (fac001 * absa(ind1,1:ng13) + & + fac101 * absa(ind1+1,1:ng13) + & + fac201 * absa(ind1+2,1:ng13) + & + fac011 * absa(ind1+9,1:ng13) + & + fac111 * absa(ind1+10,1:ng13) + & + fac211 * absa(ind1+11,1:ng13)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG13) + tau_major1(1:ng13) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng13) + & + fac101 * absa(ind1,1:ng13) + & + fac001 * absa(ind1+1,1:ng13) + & + fac211 * absa(ind1+8,1:ng13) + & + fac111 * absa(ind1+9,1:ng13) + & + fac011 * absa(ind1+10,1:ng13)) + else +!$NEC unroll(NG13) + tau_major1(1:ng13) = speccomb1 * & + (fac001 * absa(ind1,1:ng13) + & + fac101 * absa(ind1+1,1:ng13) + & + fac011 * absa(ind1+9,1:ng13) + & + fac111 * absa(ind1+10,1:ng13)) + endif + + !$ACC LOOP SEQ PRIVATE(taufor, tauself, co2m1, co2m2, absco2, & + !$ACC com1, com2, absco) +!$NEC unroll(NG13) + do ig = 1, ng13 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,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(jl,lay) * (com2 - com1) + + taug(jl,ngs12+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + adjcolco2*absco2 & + + colco(jl,lay)*absco + fracs(jl,ngs12+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(indm) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + indm = indminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(abso3) +!$NEC unroll(NG13) + do ig = 1, ng13 + abso3 = kb_mo3(indm,ig) + minorfrac(jl,lay) * & + (kb_mo3(indm+1,ig) - kb_mo3(indm,ig)) + taug(jl,ngs12+ig,lay) = colo3(jl,lay)*abso3 + fracs(jl,ngs12+ig,lay) = fracrefb(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_mco2, specparm_mco2, specmult_mco2, jmco2, fmco2, chi_co2, ratco2, adjfac, & + !$ACC adjcolco2, speccomb_mco, specparm_mco, specmult_mco, jmco, fmco, speccomb_planck, specparm_planck, & + !$ACC specmult_planck, jpl, fpl, ind0, ind1, inds, indf, indm, p, p4, fk0, fk1, fk2, fac000, fac100, fac200, & + !$ACC fac010, fac110, fac210, fac001, fac101, fac201, fac011, fac111, fac211, tau_major, tau_major1) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2on2o(jl,lay)*coln2o(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2on2o_1(jl,lay)*coln2o(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mco2 = colh2o(jl,lay) + refrat_m_a*coln2o(jl,lay) + specparm_mco2 = MIN(colh2o(jl,lay)/speccomb_mco2,oneminus) + specmult_mco2 = 8._JPRB*specparm_mco2 + jmco2 = 1 + int(specmult_mco2) + fmco2 = MOD1(specmult_mco2) + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/3.55e-4_JPRB + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.68_JPRB + adjcolco2 = adjfac*3.55e-4_JPRB*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + speccomb_mco = colh2o(jl,lay) + refrat_m_a3*coln2o(jl,lay) + specparm_mco = MIN(colh2o(jl,lay)/speccomb_mco,oneminus) + specmult_mco = 8._JPRB*specparm_mco + jmco = 1 + int(specmult_mco) + fmco = MOD1(specmult_mco) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*coln2o(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(13) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(13) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG13) + tau_major(1:ng13) = speccomb * & + (fac000 * absa(ind0,1:ng13) + & + fac100 * absa(ind0+1,1:ng13) + & + fac200 * absa(ind0+2,1:ng13) + & + fac010 * absa(ind0+9,1:ng13) + & + fac110 * absa(ind0+10,1:ng13) + & + fac210 * absa(ind0+11,1:ng13)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG13) + tau_major(1:ng13) = speccomb * & + (fac200 * absa(ind0-1,1:ng13) + & + fac100 * absa(ind0,1:ng13) + & + fac000 * absa(ind0+1,1:ng13) + & + fac210 * absa(ind0+8,1:ng13) + & + fac110 * absa(ind0+9,1:ng13) + & + fac010 * absa(ind0+10,1:ng13)) + else +!$NEC unroll(NG13) + tau_major(1:ng13) = speccomb * & + (fac000 * absa(ind0,1:ng13) + & + fac100 * absa(ind0+1,1:ng13) + & + fac010 * absa(ind0+9,1:ng13) + & + fac110 * absa(ind0+10,1:ng13)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG13) + tau_major1(1:ng13) = speccomb1 * & + (fac001 * absa(ind1,1:ng13) + & + fac101 * absa(ind1+1,1:ng13) + & + fac201 * absa(ind1+2,1:ng13) + & + fac011 * absa(ind1+9,1:ng13) + & + fac111 * absa(ind1+10,1:ng13) + & + fac211 * absa(ind1+11,1:ng13)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG13) + tau_major1(1:ng13) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng13) + & + fac101 * absa(ind1,1:ng13) + & + fac001 * absa(ind1+1,1:ng13) + & + fac211 * absa(ind1+8,1:ng13) + & + fac111 * absa(ind1+9,1:ng13) + & + fac011 * absa(ind1+10,1:ng13)) + else +!$NEC unroll(NG13) + tau_major1(1:ng13) = speccomb1 * & + (fac001 * absa(ind1,1:ng13) + & + fac101 * absa(ind1+1,1:ng13) + & + fac011 * absa(ind1+9,1:ng13) + & + fac111 * absa(ind1+10,1:ng13)) + endif + +!$NEC unroll(NG13) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, co2m1, absco2, com1, com2, absco) + do ig = 1, ng13 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,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(jl,lay) * (com2 - com1) + + taug(jl,ngs12+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + adjcolco2*absco2 & + + colco(jl,lay)*absco + fracs(jl,ngs12+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + indm = indminor(jl,lay) +!$NEC unroll(NG13) + !$ACC LOOP SEQ PRIVATE(abso3) + do ig = 1, ng13 + abso3 = kb_mo3(indm,ig) + minorfrac(jl,lay) * & + (kb_mo3(indm+1,ig) - kb_mo3(indm,ig)) + taug(jl,ngs12+ig,lay) = colo3(jl,lay)*abso3 + fracs(jl,ngs12+ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL13 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol14.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol14.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol14.F90 (revision 6016) @@ -0,0 +1,232 @@ +! This file has been modified for the use in ICON + +!****************************************************************************** +SUBROUTINE RRTM_TAUMOL14 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,& + & colco2,laytrop,selffac,selffrac,indself,fracs) + +! BAND 14: 2250-2380 cm-1 (low - CO2; high - CO2) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NGS13 ,NG14 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA14, ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,SELFREF,FORREF + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, lay +REAL(KIND=JPRB) :: taufor,tauself + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colco2, laytrop, selffac, selffrac, indself, fracs, & + !$ACC indfor, forfac, forfrac) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + +! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(14) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(14) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor, tauself) +!$NEC unroll(NG14) + do ig = 1, ng14 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs13+ig,lay) = colco2(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor + fracs(jl,ngs13+ig,lay) = fracrefa(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(14) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(14) + 1 + !$ACC LOOP SEQ +!$NEC unroll(NG14) + do ig = 1, ng14 + taug(jl,ngs13+ig,lay) = colco2(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) + fracs(jl,ngs13+ig,lay) = fracrefb(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(14) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(14) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) +!$NEC unroll(NG14) + !$ACC LOOP SEQ PRIVATE(tauself, taufor) + do ig = 1, ng14 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs13+ig,lay) = colco2(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor + fracs(jl,ngs13+ig,lay) = fracrefa(ig) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(14) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(14) + 1 +!$NEC unroll(NG14) + !$ACC LOOP SEQ + do ig = 1, ng14 + taug(jl,ngs13+ig,lay) = colco2(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) + fracs(jl,ngs13+ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL14 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol15.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol15.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol15.F90 (revision 6016) @@ -0,0 +1,577 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL15 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,oneminus,& + & colh2o,colco2,coln2o,laytrop,selffac,selffrac,indself,fracs, & + & rat_n2oco2, rat_n2oco2_1,minorfrac,indminor,scaleminor,colbrd) + +! BAND 15: 2380-2600 cm-1 (low - N2O,CO2; high - nothing) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 2001306 updated to rrtmg v4.85 +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NGS14 ,NG15 +USE YOERRTWN , ONLY : NSPA +USE YOERRTA15, ONLY : ABSA ,KA_MN2,FRACREFA,SELFREF,FORREF +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: oneminus +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coln2o(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: rat_n2oco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_n2oco2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: minorfrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indminor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: scaleminor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colbrd(KIDIA:KFDIA,KLEV) +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS,INDF,INDM, JS,JS1,JPL,JMN2, lay +REAL(KIND=JPRB) :: refrat_planck_a, refrat_m_a +REAL(KIND=JPRB) :: taufor,tauself,tau_major(ng15),tau_major1(ng15), n2m1, n2m2, taun2,scalen2 +REAL(KIND=JPRB) :: fac000, fac100, fac200,& + & fac010, fac110, fac210, & + & fac001, fac101, fac201, & + & fac011, fac111, fac211 +REAL(KIND=JPRB) :: p, p4, fk0, fk1, fk2 + +REAL(KIND=JPRB) :: fs, specmult, specparm,speccomb, & +& fs1, specmult1, specparm1,speccomb1, & +& fmn2, specmult_mn2, specparm_mn2,speccomb_mn2, & +& fpl, specmult_planck, specparm_planck,speccomb_planck + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + +#define MOD1(x) ((x) - AINT((x))) + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colh2o, colco2, coln2o, laytrop, selffac, selffrac, & + !$ACC indself, fracs, rat_n2oco2, rat_n2oco2_1, indfor, forfac, & + !$ACC forfrac, minorfrac, indminor, scaleminor, colbrd) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + + ! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) & + !$ACC PRIVATE(ind0, ind1, inds, indf, indm, & + !$ACC js, js1, jpl, jmn2, & + !$ACC fac000, fac100, fac200, & + !$ACC fac010, fac110, fac210, & + !$ACC fac001, fac101, fac201, & + !$ACC fac011, fac111, fac211, & + !$ACC p, p4, fk0, fk1, fk2, scalen2, & + !$ACC fs, specmult, specparm,speccomb, & + !$ACC fs1, specmult1, specparm1,speccomb1, & + !$ACC fmn2, specmult_mn2, specparm_mn2,speccomb_mn2, & + !$ACC fpl, specmult_planck, & + !$ACC specparm_planck,speccomb_planck, & + !$ACC tau_major, tau_major1) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = coln2o(jl,lay) + rat_n2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(coln2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = coln2o(jl,lay) + rat_n2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(coln2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mn2 = coln2o(jl,lay) + refrat_m_a*colco2(jl,lay) + specparm_mn2 = MIN(coln2o(jl,lay)/speccomb_mn2,oneminus) + specmult_mn2 = 8._JPRB*specparm_mn2 + jmn2 = 1 + int(specmult_mn2) + fmn2 = MOD1(specmult_mn2) + + speccomb_planck = coln2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(coln2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(15) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(15) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + scalen2 = colbrd(jl,lay)*scaleminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG15) + tau_major(1:ng15) = speccomb * & + (fac000 * absa(ind0,1:ng15) + & + fac100 * absa(ind0+1,1:ng15) + & + fac200 * absa(ind0+2,1:ng15) + & + fac010 * absa(ind0+9,1:ng15) + & + fac110 * absa(ind0+10,1:ng15) + & + fac210 * absa(ind0+11,1:ng15)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG15) + tau_major(1:ng15) = speccomb * & + (fac200 * absa(ind0-1,1:ng15) + & + fac100 * absa(ind0,1:ng15) + & + fac000 * absa(ind0+1,1:ng15) + & + fac210 * absa(ind0+8,1:ng15) + & + fac110 * absa(ind0+9,1:ng15) + & + fac010 * absa(ind0+10,1:ng15)) + else +!$NEC unroll(NG15) + tau_major(1:ng15) = speccomb * & + (fac000 * absa(ind0,1:ng15) + & + fac100 * absa(ind0+1,1:ng15) + & + fac010 * absa(ind0+9,1:ng15) + & + fac110 * absa(ind0+10,1:ng15)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG15) + tau_major1(1:ng15) = speccomb1 * & + (fac001 * absa(ind1,1:ng15) + & + fac101 * absa(ind1+1,1:ng15) + & + fac201 * absa(ind1+2,1:ng15) + & + fac011 * absa(ind1+9,1:ng15) + & + fac111 * absa(ind1+10,1:ng15) + & + fac211 * absa(ind1+11,1:ng15)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG15) + tau_major1(1:ng15) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng15) + & + fac101 * absa(ind1,1:ng15) + & + fac001 * absa(ind1+1,1:ng15) + & + fac211 * absa(ind1+8,1:ng15) + & + fac111 * absa(ind1+9,1:ng15) + & + fac011 * absa(ind1+10,1:ng15)) + else +!$NEC unroll(NG15) + tau_major1(1:ng15) = speccomb1 * & + (fac001 * absa(ind1,1:ng15) + & + fac101 * absa(ind1+1,1:ng15) + & + fac011 * absa(ind1+9,1:ng15) + & + fac111 * absa(ind1+10,1:ng15)) + endif + + !$ACC LOOP SEQ PRIVATE(taufor, tauself, n2m1, n2m2, taun2) +!$NEC unroll(NG15) + do ig = 1, ng15 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay) * (n2m2 - n2m1)) + + taug(jl,ngs14+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + taun2 + fracs(jl,ngs14+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + do ig = 1, ng15 + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + taug(jl,ngs14+ig,lay) = 0.0_JPRB + fracs(jl,ngs14+ig,lay) = 0.0_JPRB + enddo + enddo + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_mn2, specparm_mn2, specmult_mn2, jmn2, fmn2, scalen2, speccomb_planck, & + !$ACC specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, indf, indm, p, p4, fk0, fk1, fk2, & + !$ACC fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, fac011, fac111, fac211, & + !$ACC tau_major, tau_major1) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = coln2o(jl,lay) + rat_n2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(coln2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = coln2o(jl,lay) + rat_n2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(coln2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mn2 = coln2o(jl,lay) + refrat_m_a*colco2(jl,lay) + specparm_mn2 = MIN(coln2o(jl,lay)/speccomb_mn2,oneminus) + specmult_mn2 = 8._JPRB*specparm_mn2 + jmn2 = 1 + int(specmult_mn2) + fmn2 = MOD1(specmult_mn2) + + speccomb_planck = coln2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(coln2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(15) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(15) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + scalen2 = colbrd(jl,lay)*scaleminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG15) + tau_major(1:ng15) = speccomb * & + (fac000 * absa(ind0,1:ng15) + & + fac100 * absa(ind0+1,1:ng15) + & + fac200 * absa(ind0+2,1:ng15) + & + fac010 * absa(ind0+9,1:ng15) + & + fac110 * absa(ind0+10,1:ng15) + & + fac210 * absa(ind0+11,1:ng15)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG15) + tau_major(1:ng15) = speccomb * & + (fac200 * absa(ind0-1,1:ng15) + & + fac100 * absa(ind0,1:ng15) + & + fac000 * absa(ind0+1,1:ng15) + & + fac210 * absa(ind0+8,1:ng15) + & + fac110 * absa(ind0+9,1:ng15) + & + fac010 * absa(ind0+10,1:ng15)) + else +!$NEC unroll(NG15) + tau_major(1:ng15) = speccomb * & + (fac000 * absa(ind0,1:ng15) + & + fac100 * absa(ind0+1,1:ng15) + & + fac010 * absa(ind0+9,1:ng15) + & + fac110 * absa(ind0+10,1:ng15)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG15) + tau_major1(1:ng15) = speccomb1 * & + (fac001 * absa(ind1,1:ng15) + & + fac101 * absa(ind1+1,1:ng15) + & + fac201 * absa(ind1+2,1:ng15) + & + fac011 * absa(ind1+9,1:ng15) + & + fac111 * absa(ind1+10,1:ng15) + & + fac211 * absa(ind1+11,1:ng15)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG15) + tau_major1(1:ng15) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng15) + & + fac101 * absa(ind1,1:ng15) + & + fac001 * absa(ind1+1,1:ng15) + & + fac211 * absa(ind1+8,1:ng15) + & + fac111 * absa(ind1+9,1:ng15) + & + fac011 * absa(ind1+10,1:ng15)) + else +!$NEC unroll(NG15) + tau_major1(1:ng15) = speccomb1 * & + (fac001 * absa(ind1,1:ng15) + & + fac101 * absa(ind1+1,1:ng15) + & + fac011 * absa(ind1+9,1:ng15) + & + fac111 * absa(ind1+10,1:ng15)) + endif + +!$NEC unroll(NG15) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, n2m1, n2m2, taun2) + do ig = 1, ng15 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay) * (n2m2 - n2m1)) + + taug(jl,ngs14+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + taun2 + fracs(jl,ngs14+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +#endif + + !$ACC LOOP SEQ + do ig = 1, ng15 +#ifndef _OPENACC +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + taug(jl,ngs14+ig,lay) = 0.0_JPRB + fracs(jl,ngs14+ig,lay) = 0.0_JPRB + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL15 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol16.F90 (revision 6016) @@ -0,0 +1,538 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL16 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,oneminus,& + & colh2o,colch4,laytrop,selffac,selffrac,indself,fracs, & + & rat_h2och4,rat_h2och4_1) + +! BAND 16: 2600-3000 cm-1 (low - H2O,CH4; high - nothing) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NGS15 ,NG16 +USE YOERRTWN , ONLY : NSPA,NSPB +USE YOERRTA16, ONLY : ABSA,ABSB,FRACREFA,FRACREFB,SELFREF,FORREF +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: oneminus +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colch4(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2och4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2och4_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) + +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS,INDF, JS,JS1,JPL,lay + +REAL(KIND=JPRB) :: fac000, fac100, fac200,& + & fac010, fac110, fac210, & + & fac001, fac101, fac201, & + & fac011, fac111, fac211 +REAL(KIND=JPRB) :: p, p4, fk0, fk1, fk2 + +REAL(KIND=JPRB) :: refrat_planck_a +REAL(KIND=JPRB) :: taufor,tauself,tau_major(ng16),tau_major1(ng16) +REAL(KIND=JPRB) :: fs, specmult, specparm,speccomb, & +& fs1, specmult1, specparm1,speccomb1, & +& fpl, specmult_planck, specparm_planck,speccomb_planck + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + +#define MOD1(x) ((x) - AINT((x))) + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colh2o, colch4, laytrop, selffac, selffrac, indself, & + !$ACC fracs, rat_h2och4, rat_h2och4_1, indfor, forfac, forfrac) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + + + ! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, js, js1, jpl, fac000, fac100, fac200, fac010, & + !$ACC fac110, fac210, fac001, fac101, fac201, fac011, fac111, fac211, p, p4, fk0, fk1, fk2, fs, specmult, & + !$ACC specparm,speccomb, fs1, specmult1, specparm1,speccomb1, fpl, specmult_planck, specparm_planck, & + !$ACC speccomb_planck, tau_major, tau_major1) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2och4(jl,lay)*colch4(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2och4_1(jl,lay)*colch4(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colch4(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(16) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(16) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG16) + tau_major(1:ng16) = speccomb * & + (fac000 * absa(ind0,1:ng16) + & + fac100 * absa(ind0+1,1:ng16) + & + fac200 * absa(ind0+2,1:ng16) + & + fac010 * absa(ind0+9,1:ng16) + & + fac110 * absa(ind0+10,1:ng16) + & + fac210 * absa(ind0+11,1:ng16)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG16) + tau_major(1:ng16) = speccomb * & + (fac200 * absa(ind0-1,1:ng16) + & + fac100 * absa(ind0,1:ng16) + & + fac000 * absa(ind0+1,1:ng16) + & + fac210 * absa(ind0+8,1:ng16) + & + fac110 * absa(ind0+9,1:ng16) + & + fac010 * absa(ind0+10,1:ng16)) + else +!$NEC unroll(NG16) + tau_major(1:ng16) = speccomb * & + (fac000 * absa(ind0,1:ng16) + & + fac100 * absa(ind0+1,1:ng16) + & + fac010 * absa(ind0+9,1:ng16) + & + fac110 * absa(ind0+10,1:ng16)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG16) + tau_major1(1:ng16) = speccomb1 * & + (fac001 * absa(ind1,1:ng16) + & + fac101 * absa(ind1+1,1:ng16) + & + fac201 * absa(ind1+2,1:ng16) + & + fac011 * absa(ind1+9,1:ng16) + & + fac111 * absa(ind1+10,1:ng16) + & + fac211 * absa(ind1+11,1:ng16)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG16) + tau_major1(1:ng16) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng16) + & + fac101 * absa(ind1,1:ng16) + & + fac001 * absa(ind1+1,1:ng16) + & + fac211 * absa(ind1+8,1:ng16) + & + fac111 * absa(ind1+9,1:ng16) + & + fac011 * absa(ind1+10,1:ng16)) + else +!$NEC unroll(NG16) + tau_major1(1:ng16) = speccomb1 * & + (fac001 * absa(ind1,1:ng16) + & + fac101 * absa(ind1+1,1:ng16) + & + fac011 * absa(ind1+9,1:ng16) + & + fac111 * absa(ind1+10,1:ng16)) + endif + + !$ACC LOOP SEQ PRIVATE(taufor,tauself) +!$NEC unroll(NG16) + do ig = 1, ng16 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + taug(jl,ngs15+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor + fracs(jl,ngs15+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(16) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(16) + 1 + !$ACC LOOP SEQ +!$NEC unroll(NG16) + do ig = 1, ng16 + taug(jl,ngs15+ig,lay) = colch4(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) + fracs(jl,ngs15+ig,lay) = fracrefb(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_planck, specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, & + !$ACC indf, p, p4, fk0, fk1, fk2, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, & + !$ACC fac011, fac111, fac211, tau_major, tau_major1) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2och4(jl,lay)*colch4(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2och4_1(jl,lay)*colch4(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colch4(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(16) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(16) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG16) + tau_major(1:ng16) = speccomb * & + (fac000 * absa(ind0,1:ng16) + & + fac100 * absa(ind0+1,1:ng16) + & + fac200 * absa(ind0+2,1:ng16) + & + fac010 * absa(ind0+9,1:ng16) + & + fac110 * absa(ind0+10,1:ng16) + & + fac210 * absa(ind0+11,1:ng16)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG16) + tau_major(1:ng16) = speccomb * & + (fac200 * absa(ind0-1,1:ng16) + & + fac100 * absa(ind0,1:ng16) + & + fac000 * absa(ind0+1,1:ng16) + & + fac210 * absa(ind0+8,1:ng16) + & + fac110 * absa(ind0+9,1:ng16) + & + fac010 * absa(ind0+10,1:ng16)) + else +!$NEC unroll(NG16) + tau_major(1:ng16) = speccomb * & + (fac000 * absa(ind0,1:ng16) + & + fac100 * absa(ind0+1,1:ng16) + & + fac010 * absa(ind0+9,1:ng16) + & + fac110 * absa(ind0+10,1:ng16)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG16) + tau_major1(1:ng16) = speccomb1 * & + (fac001 * absa(ind1,1:ng16) + & + fac101 * absa(ind1+1,1:ng16) + & + fac201 * absa(ind1+2,1:ng16) + & + fac011 * absa(ind1+9,1:ng16) + & + fac111 * absa(ind1+10,1:ng16) + & + fac211 * absa(ind1+11,1:ng16)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG16) + tau_major1(1:ng16) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng16) + & + fac101 * absa(ind1,1:ng16) + & + fac001 * absa(ind1+1,1:ng16) + & + fac211 * absa(ind1+8,1:ng16) + & + fac111 * absa(ind1+9,1:ng16) + & + fac011 * absa(ind1+10,1:ng16)) + else +!$NEC unroll(NG16) + tau_major1(1:ng16) = speccomb1 * & + (fac001 * absa(ind1,1:ng16) + & + fac101 * absa(ind1+1,1:ng16) + & + fac011 * absa(ind1+9,1:ng16) + & + fac111 * absa(ind1+10,1:ng16)) + endif + +!$NEC unroll(NG16) + !$ACC LOOP SEQ PRIVATE(tauself, taufor) + do ig = 1, ng16 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + taug(jl,ngs15+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor + fracs(jl,ngs15+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(16) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(16) + 1 +!$NEC unroll(NG16) + !$ACC LOOP SEQ + do ig = 1, ng16 + taug(jl,ngs15+ig,lay) = colch4(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) + fracs(jl,ngs15+ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL16 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol2.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol2.F90 (revision 6016) @@ -0,0 +1,255 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL2 (KIDIA,KFDIA,KLEV,taug,PAVEL,coldry,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,& + & colh2o,laytrop,selffac,selffrac,indself,fracs) + +! BAND 2: 250-500 cm-1 (low - H2O; high - H2O) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201305 updated to rrtmg_lw_v4.85: +!********* +! 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) +! +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG2 ,NGS1 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA2 , ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,& + & FORREF ,SELFREF + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) ! Layer pressures (hPa) +REAL(KIND=JPRB) ,INTENT(IN) :: coldry(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: ind0,ind1,inds, indf + +INTEGER(KIND=JPIM) :: IG, lay + +REAL(KIND=JPRB) :: taufor,tauself,corradj,pp + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + + !$ACC DATA PRESENT(taug, PAVEL, coldry, P_TAUAERL, fac00, fac01, fac10, & + !$ACC fac11, forfrac, forfac, jp, jt, jt1, colh2o, laytrop, & + !$ACC selffac, selffrac, indself, indfor, fracs) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below LAYTROP, the water vapor self-continuum is +! interpolated (in temperature) separately. + + ! Lower atmosphere loop + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, pp, corradj) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(2) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(2) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + pp = pavel(jl,lay) + corradj = 1._JPRB - .05_JPRB * (pp - 100._JPRB) / 900._JPRB + !$ACC LOOP SEQ PRIVATE(tauself, taufor) +!$NEC unroll(NG2) + do ig = 1, ng2 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs1+ig,lay) = corradj * (colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor) + fracs(jl,ngs1+ig,lay) = fracrefa(ig) + enddo + enddo + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, indf) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(2) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(2) + 1 + indf = indfor(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor) +!$NEC unroll(NG2) + do ig = 1, ng2 + taufor = forfac(jl,lay) * (forref(indf,ig) + & + forfrac(jl,lay) * (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs1+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + taufor + fracs(jl,ngs1+ig,lay) = fracrefb(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, pp, corradj) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(2) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(2) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + pp = pavel(jl,lay) + corradj = 1._JPRB - .05_JPRB * (pp - 100._JPRB) / 900._JPRB +!$NEC unroll(NG2) + !$ACC LOOP SEQ PRIVATE(tauself, taufor) + do ig = 1, ng2 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs1+ig,lay) = corradj * (colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor) + fracs(jl,ngs1+ig,lay) = fracrefa(ig) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(2) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(2) + 1 + indf = indfor(jl,lay) +!$NEC unroll(NG2) + !$ACC LOOP SEQ PRIVATE(taufor) + do ig = 1, ng2 + taufor = forfac(jl,lay) * (forref(indf,ig) + & + forfrac(jl,lay) * (forref(indf+1,ig) - forref(indf,ig))) + taug(jl,ngs1+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + taufor + fracs(jl,ngs1+ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL2 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol3.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol3.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol3.F90 (revision 6016) @@ -0,0 +1,742 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL3 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,FAC00,FAC01,FAC10,FAC11,FORFAC,FORFRAC,INDFOR,JP,JT,jt1,ONEMINUS,& + & COLH2O,COLCO2,COLN2O,COLDRY,LAYTROP,SELFFAC,SELFFRAC,INDSELF,FRACS, & + & RAT_H2OCO2, RAT_H2OCO2_1,MINORFRAC,INDMINOR) + +! BAND 3: 500-630 cm-1 (low - H2O,CO2; high - H2O,CO2) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 20130517 updated to rrtmg_lw_v4.85: +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) +! (high key - h2o,co2; high minor - n2o) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG3 ,NGS2 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA3 , ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,& + & FORREF ,SELFREF , KA_MN2O , KB_MN2O +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FAC11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FORFAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: COLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: COLDRY(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: FRACS(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: RAT_H2OCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: RAT_H2OCO2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: MINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: INDMINOR(KIDIA:KFDIA,KLEV) +! --------------------------------------------------------------------------- + +REAL(KIND=JPRB) :: SPECCOMB,SPECCOMB1,SPECCOMB_MN2O, & +& SPECCOMB_PLANCK +REAL(KIND=JPRB) :: REFRAT_PLANCK_A, REFRAT_PLANCK_B, REFRAT_M_A, REFRAT_M_B + +INTEGER(KIND=JPIM) :: IND0,IND1,INDS,INDF,INDM +INTEGER(KIND=JPIM) :: IG, JS, LAY, JS1,JMN2O,JPL + +REAL(KIND=JPRB) :: FS, SPECMULT, SPECPARM, & + & FS1, SPECMULT1, SPECPARM1, & + & FMN2O, SPECMULT_MN2O, SPECPARM_MN2O, & + & fpl, SPECMULT_PLANCK, SPECPARM_PLANCK + +REAL(KIND=JPRB) :: ADJFAC,ADJCOLN2O,RATN2O,CHI_N2O + + REAL(KIND=JPRB) :: FAC000, FAC100, FAC200,& + & FAC010, FAC110, FAC210, & + & FAC001, FAC101, FAC201, & + & FAC011, FAC111, FAC211 +REAL(KIND=JPRB) :: P, P4, FK0, FK1, FK2 +REAL(KIND=JPRB) :: TAUFOR,TAUSELF,N2OM1,N2OM2,ABSN2O,TAU_MAJOR(ng3),TAU_MAJOR1(ng3) + +REAL(KIND=JPRB) :: ZHOOK_HANDLE + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + +#define MOD1(x) ((x) - AINT((x))) + + !$ACC DATA PRESENT(taug, P_TAUAERL, FAC00, FAC01, FAC10, FAC11, FORFAC, JP, & + !$ACC JT, jt1, COLH2O, COLCO2, COLN2O, COLDRY, LAYTROP, & + !$ACC SELFFAC, SELFFRAC, INDSELF, FRACS, RAT_H2OCO2, & + !$ACC RAT_H2OCO2_1, INDFOR, FORFRAC, MINORFRAC, INDMINOR) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + +! 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. + + +! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, specmult1, & + !$ACC js1, fs1, speccomb_mn2o, specparm_mn2o, specmult_mn2o, jmn2o, fmn2o, chi_n2o, ratn2o, adjfac, adjcoln2o, & + !$ACC speccomb_planck, specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, indf, indm, p, p4, fk0, & + !$ACC fk1, fk2, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, fac011, fac111, & + !$ACC fac211, tau_major, tau_major1) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mn2o = colh2o(jl,lay) + refrat_m_a*colco2(jl,lay) + specparm_mn2o = MIN(colh2o(jl,lay)/speccomb_mn2o,oneminus) + specmult_mn2o = 8._JPRB*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = MOD1(specmult_mn2o) + ! 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(jl,lay)/coldry(jl,lay) + ratn2o = 1.e20_JPRB*chi_n2o/chi_mls(4,jp(jl,lay)+1) + if (ratn2o .gt. 1.5_JPRB) then + adjfac = 0.5_JPRB+(ratn2o-0.5_JPRB)**0.65_JPRB + adjcoln2o = adjfac*chi_mls(4,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcoln2o = coln2o(jl,lay) + endif + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(3) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(3) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG3) + tau_major(1:ng3) = speccomb * & + (fac000 * absa(ind0,1:ng3) + & + fac100 * absa(ind0+1,1:ng3) + & + fac200 * absa(ind0+2,1:ng3) + & + fac010 * absa(ind0+9,1:ng3) + & + fac110 * absa(ind0+10,1:ng3) + & + fac210 * absa(ind0+11,1:ng3)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG3) + tau_major(1:ng3) = speccomb * & + (fac200 * absa(ind0-1,1:ng3) + & + fac100 * absa(ind0,1:ng3) + & + fac000 * absa(ind0+1,1:ng3) + & + fac210 * absa(ind0+8,1:ng3) + & + fac110 * absa(ind0+9,1:ng3) + & + fac010 * absa(ind0+10,1:ng3)) + else +!$NEC unroll(NG3) + tau_major(1:ng3) = speccomb * & + (fac000 * absa(ind0,1:ng3) + & + fac100 * absa(ind0+1,1:ng3) + & + fac010 * absa(ind0+9,1:ng3) + & + fac110 * absa(ind0+10,1:ng3)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG3) + tau_major1(1:ng3) = speccomb1 * & + (fac001 * absa(ind1,1:ng3) + & + fac101 * absa(ind1+1,1:ng3) + & + fac201 * absa(ind1+2,1:ng3) + & + fac011 * absa(ind1+9,1:ng3) + & + fac111 * absa(ind1+10,1:ng3) + & + fac211 * absa(ind1+11,1:ng3)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG3) + tau_major1(1:ng3) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng3) + & + fac101 * absa(ind1,1:ng3) + & + fac001 * absa(ind1+1,1:ng3) + & + fac211 * absa(ind1+8,1:ng3) + & + fac111 * absa(ind1+9,1:ng3) + & + fac011 * absa(ind1+10,1:ng3)) + else +!$NEC unroll(NG3) + tau_major1(1:ng3) = speccomb1 * & + (fac001 * absa(ind1,1:ng3) + & + fac101 * absa(ind1+1,1:ng3) + & + fac011 * absa(ind1+9,1:ng3) + & + fac111 * absa(ind1+10,1:ng3)) + endif + + !$ACC LOOP SEQ PRIVATE(tauself, taufor, n2om1, n2om2, absn2o) +!$NEC unroll(NG3) + do ig = 1, ng3 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay) * (n2om2 - n2om1) + + taug(jl,ngs2+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + adjcoln2o*absn2o + fracs(jl,ngs2+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, specmult1, & + !$ACC js1, fs1, speccomb_mn2o, specparm_mn2o, specmult_mn2o, jmn2o, fmn2o, chi_n2o, ratn2o, adjfac, adjcoln2o, & + !$ACC speccomb_planck, specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, indf, indm, fac000, fac100, & + !$ACC fac010, fac110, fac001, fac101, fac011, fac111) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 4._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 4._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + + speccomb_mn2o = colh2o(jl,lay) + refrat_m_b*colco2(jl,lay) + specparm_mn2o = MIN(colh2o(jl,lay)/speccomb_mn2o,oneminus) + specmult_mn2o = 4._JPRB*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = MOD1(specmult_mn2o) + ! 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(jl,lay)/coldry(jl,lay) + ratn2o = 1.e20_JPRB*chi_n2o/chi_mls(4,jp(jl,lay)+1) + if (ratn2o .gt. 1.5_JPRB) then + adjfac = 0.5_JPRB+(ratn2o-0.5_JPRB)**0.65_JPRB + adjcoln2o = adjfac*chi_mls(4,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcoln2o = coln2o(jl,lay) + endif + + speccomb_planck = colh2o(jl,lay)+refrat_planck_b*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 4._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(3) + js + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(3) + js1 + indf = indfor(jl,lay) + indm = indminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor, n2om1, n2om2, absn2o) +!$NEC unroll(NG3) + do ig = 1, ng3 + taufor = forfac(jl,lay) * (forref(indf,ig) + & + forfrac(jl,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(jl,lay) * (n2om2 - n2om1) + taug(jl,ngs2+ig,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(jl,ngs2+ig,lay) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_mn2o, specparm_mn2o, specmult_mn2o, jmn2o, fmn2o, chi_n2o, ratn2o, adjfac,& + !$ACC adjcoln2o, speccomb_planck, specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, indf, indm, p,& + !$ACC p4, fk0, & + !$ACC fk1, fk2, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, & + !$ACC fac011, fac111, fac211, tau_major, tau_major1) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mn2o = colh2o(jl,lay) + refrat_m_a*colco2(jl,lay) + specparm_mn2o = MIN(colh2o(jl,lay)/speccomb_mn2o,oneminus) + specmult_mn2o = 8._JPRB*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = MOD1(specmult_mn2o) + ! 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(jl,lay)/coldry(jl,lay) + ratn2o = 1.e20_JPRB*chi_n2o/chi_mls(4,jp(jl,lay)+1) + if (ratn2o .gt. 1.5_JPRB) then + adjfac = 0.5_JPRB+(ratn2o-0.5_JPRB)**0.65_JPRB + adjcoln2o = adjfac*chi_mls(4,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcoln2o = coln2o(jl,lay) + endif + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(3) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(3) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG3) + tau_major(1:ng3) = speccomb * & + (fac000 * absa(ind0,1:ng3) + & + fac100 * absa(ind0+1,1:ng3) + & + fac200 * absa(ind0+2,1:ng3) + & + fac010 * absa(ind0+9,1:ng3) + & + fac110 * absa(ind0+10,1:ng3) + & + fac210 * absa(ind0+11,1:ng3)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG3) + tau_major(1:ng3) = speccomb * & + (fac200 * absa(ind0-1,1:ng3) + & + fac100 * absa(ind0,1:ng3) + & + fac000 * absa(ind0+1,1:ng3) + & + fac210 * absa(ind0+8,1:ng3) + & + fac110 * absa(ind0+9,1:ng3) + & + fac010 * absa(ind0+10,1:ng3)) + else +!$NEC unroll(NG3) + tau_major(1:ng3) = speccomb * & + (fac000 * absa(ind0,1:ng3) + & + fac100 * absa(ind0+1,1:ng3) + & + fac010 * absa(ind0+9,1:ng3) + & + fac110 * absa(ind0+10,1:ng3)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG3) + tau_major1(1:ng3) = speccomb1 * & + (fac001 * absa(ind1,1:ng3) + & + fac101 * absa(ind1+1,1:ng3) + & + fac201 * absa(ind1+2,1:ng3) + & + fac011 * absa(ind1+9,1:ng3) + & + fac111 * absa(ind1+10,1:ng3) + & + fac211 * absa(ind1+11,1:ng3)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG3) + tau_major1(1:ng3) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng3) + & + fac101 * absa(ind1,1:ng3) + & + fac001 * absa(ind1+1,1:ng3) + & + fac211 * absa(ind1+8,1:ng3) + & + fac111 * absa(ind1+9,1:ng3) + & + fac011 * absa(ind1+10,1:ng3)) + else +!$NEC unroll(NG3) + tau_major1(1:ng3) = speccomb1 * & + (fac001 * absa(ind1,1:ng3) + & + fac101 * absa(ind1+1,1:ng3) + & + fac011 * absa(ind1+9,1:ng3) + & + fac111 * absa(ind1+10,1:ng3)) + endif + +!$NEC unroll(NG3) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, n2om1, n2om2, absn2o) + do ig = 1, ng3 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay) * (n2om2 - n2om1) + + taug(jl,ngs2+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + adjcoln2o*absn2o + fracs(jl,ngs2+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 4._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 4._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + + speccomb_mn2o = colh2o(jl,lay) + refrat_m_b*colco2(jl,lay) + specparm_mn2o = MIN(colh2o(jl,lay)/speccomb_mn2o,oneminus) + specmult_mn2o = 4._JPRB*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = MOD1(specmult_mn2o) + ! 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(jl,lay)/coldry(jl,lay) + ratn2o = 1.e20_JPRB*chi_n2o/chi_mls(4,jp(jl,lay)+1) + if (ratn2o .gt. 1.5_JPRB) then + adjfac = 0.5_JPRB+(ratn2o-0.5_JPRB)**0.65_JPRB + adjcoln2o = adjfac*chi_mls(4,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcoln2o = coln2o(jl,lay) + endif + + speccomb_planck = colh2o(jl,lay)+refrat_planck_b*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 4._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(3) + js + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(3) + js1 + indf = indfor(jl,lay) + indm = indminor(jl,lay) +!$NEC unroll(NG3) + !$ACC LOOP SEQ PRIVATE(taufor, n2om1, n2om2, absn2o) + do ig = 1, ng3 + taufor = forfac(jl,lay) * (forref(indf,ig) + & + forfrac(jl,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(jl,lay) * (n2om2 - n2om1) + taug(jl,ngs2+ig,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(jl,ngs2+ig,lay) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL3 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol4.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol4.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol4.F90 (revision 6016) @@ -0,0 +1,653 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL4 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,oneminus,& + & colh2o,colco2,colo3,laytrop,selffac,selffrac,indself,fracs, & + & rat_h2oco2, rat_h2oco2_1, rat_o3co2, rat_o3co2_1) + +! BAND 4: 630-700 cm-1 (low - H2O,CO2; high - O3,CO2) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG4 ,NGS3 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA4 , ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,SELFREF,FORREF +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: oneminus +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colo3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2oco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2oco2_1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_o3co2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_o3co2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +! --------------------------------------------------------------------------- + +REAL(KIND=JPRB) :: speccomb,speccomb1, speccomb_planck +INTEGER(KIND=JPIM) :: ind0,ind1,inds,indf + +INTEGER(KIND=JPIM) :: IG, JS, lay, JS1, JPL + + +REAL(KIND=JPRB) :: refrat_planck_a, refrat_planck_b + REAL(KIND=JPRB) :: fac000, fac100, fac200,& + & fac010, fac110, fac210, & + & fac001, fac101, fac201, & + & fac011, fac111, fac211 +REAL(KIND=JPRB) :: p, p4, fk0, fk1, fk2 +REAL(KIND=JPRB) :: taufor,tauself,tau_major(ng4),tau_major1(ng4) +REAL(KIND=JPRB) :: fs, specmult, specparm, & + & fs1, specmult1, specparm1, & + & fpl, specmult_PLANCK, specparm_PLANCK + + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + +#define MOD1(x) ((x) - AINT((x))) + +!$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & +!$ACC colh2o, colco2, colo3, laytrop, selffac, selffrac, indself, & +!$ACC fracs, rat_h2oco2, rat_h2oco2_1, rat_o3co2, rat_o3co2_1, & +!$ACC indfor, forfac, forfrac) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + + +! 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. + + ! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb,speccomb1, speccomb_planck, ind0, ind1, inds, indf, js, js1, & + !$ACC jpl, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, fac011, fac111, fac211, p, & + !$ACC p4, fk0, fk1, fk2, fs, specmult, specparm, fs1, specmult1, specparm1, fpl, specmult_PLANCK, & + !$ACC specparm_PLANCK, tau_major, tau_major1) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(4) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(4) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG4) + tau_major(1:ng4) = speccomb * & + (fac000 * absa(ind0,1:ng4) + & + fac100 * absa(ind0+1,1:ng4) + & + fac200 * absa(ind0+2,1:ng4) + & + fac010 * absa(ind0+9,1:ng4) + & + fac110 * absa(ind0+10,1:ng4) + & + fac210 * absa(ind0+11,1:ng4)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG4) + tau_major(1:ng4) = speccomb * & + (fac200 * absa(ind0-1,1:ng4) + & + fac100 * absa(ind0,1:ng4) + & + fac000 * absa(ind0+1,1:ng4) + & + fac210 * absa(ind0+8,1:ng4) + & + fac110 * absa(ind0+9,1:ng4) + & + fac010 * absa(ind0+10,1:ng4)) + else +!$NEC unroll(NG4) + tau_major(1:ng4) = speccomb * & + (fac000 * absa(ind0,1:ng4) + & + fac100 * absa(ind0+1,1:ng4) + & + fac010 * absa(ind0+9,1:ng4) + & + fac110 * absa(ind0+10,1:ng4)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG4) + tau_major1(1:ng4) = speccomb1 * & + (fac001 * absa(ind1,1:ng4) + & + fac101 * absa(ind1+1,1:ng4) + & + fac201 * absa(ind1+2,1:ng4) + & + fac011 * absa(ind1+9,1:ng4) + & + fac111 * absa(ind1+10,1:ng4) + & + fac211 * absa(ind1+11,1:ng4)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG4) + tau_major1(1:ng4) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng4) + & + fac101 * absa(ind1,1:ng4) + & + fac001 * absa(ind1+1,1:ng4) + & + fac211 * absa(ind1+8,1:ng4) + & + fac111 * absa(ind1+9,1:ng4) + & + fac011 * absa(ind1+10,1:ng4)) + else +!$NEC unroll(NG4) + tau_major1(1:ng4) = speccomb1 * & + (fac001 * absa(ind1,1:ng4) + & + fac101 * absa(ind1+1,1:ng4) + & + fac011 * absa(ind1+9,1:ng4) + & + fac111 * absa(ind1+10,1:ng4)) + endif + + !$ACC LOOP SEQ PRIVATE(taufor, tauself) +!$NEC unroll(NG4) + do ig = 1, ng4 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + taug(jl,ngs3+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor + fracs(jl,ngs3+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, speccomb1, speccomb_planck, ind0, ind1, js, js1, jpl, & + !$ACC fac000, fac100, fac010, fac110, fac001, fac101, fac011, fac111, p4, fs, specmult, specparm, fs1, & + !$ACC specmult1, specparm1, fpl, specmult_PLANCK, specparm_PLANCK) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + speccomb = colo3(jl,lay) + rat_o3co2(jl,lay)*colco2(jl,lay) + specparm = MIN(colo3(jl,lay)/speccomb,oneminus) + specmult = 4._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colo3(jl,lay) + rat_o3co2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colo3(jl,lay)/speccomb1,oneminus) + specmult1 = 4._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + + speccomb_planck = colo3(jl,lay)+refrat_planck_b*colco2(jl,lay) + specparm_planck = MIN(colo3(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 4._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(4) + js + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(4) + js1 + !$ACC LOOP SEQ +!$NEC unroll(NG4) + do ig = 1, ng4 + taug(jl,ngs3+ig,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(jl,ngs3+ig,lay) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo + enddo + enddo + !$ACC END PARALLEL + !$ACC WAIT + + ! Empirical modification to code to improve stratospheric cooling rates + ! for co2. Revised to apply weighting for g-point reduction in this band. + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + taug(jl,ngs3+8,lay)=taug(jl,ngs3+8,lay)*0.92_JPRB + taug(jl,ngs3+9,lay)=taug(jl,ngs3+9,lay)*0.88_JPRB + taug(jl,ngs3+10,lay)=taug(jl,ngs3+10,lay)*1.07_JPRB + taug(jl,ngs3+11,lay)=taug(jl,ngs3+11,lay)*1.1_JPRB + taug(jl,ngs3+12,lay)=taug(jl,ngs3+12,lay)*0.99_JPRB + taug(jl,ngs3+13,lay)=taug(jl,ngs3+13,lay)*0.88_JPRB + taug(jl,ngs3+14,lay)=taug(jl,ngs3+14,lay)*0.943_JPRB + enddo + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_planck, specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, & + !$ACC indf, p, p4, fk0, fk1, fk2, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, & + !$ACC fac011, fac111, fac211, tau_major, tau_major1) + DO lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(4) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(4) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG4) + tau_major(1:ng4) = speccomb * & + (fac000 * absa(ind0,1:ng4) + & + fac100 * absa(ind0+1,1:ng4) + & + fac200 * absa(ind0+2,1:ng4) + & + fac010 * absa(ind0+9,1:ng4) + & + fac110 * absa(ind0+10,1:ng4) + & + fac210 * absa(ind0+11,1:ng4)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG4) + tau_major(1:ng4) = speccomb * & + (fac200 * absa(ind0-1,1:ng4) + & + fac100 * absa(ind0,1:ng4) + & + fac000 * absa(ind0+1,1:ng4) + & + fac210 * absa(ind0+8,1:ng4) + & + fac110 * absa(ind0+9,1:ng4) + & + fac010 * absa(ind0+10,1:ng4)) + else +!$NEC unroll(NG4) + tau_major(1:ng4) = speccomb * & + (fac000 * absa(ind0,1:ng4) + & + fac100 * absa(ind0+1,1:ng4) + & + fac010 * absa(ind0+9,1:ng4) + & + fac110 * absa(ind0+10,1:ng4)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG4) + tau_major1(1:ng4) = speccomb1 * & + (fac001 * absa(ind1,1:ng4) + & + fac101 * absa(ind1+1,1:ng4) + & + fac201 * absa(ind1+2,1:ng4) + & + fac011 * absa(ind1+9,1:ng4) + & + fac111 * absa(ind1+10,1:ng4) + & + fac211 * absa(ind1+11,1:ng4)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG4) + tau_major1(1:ng4) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng4) + & + fac101 * absa(ind1,1:ng4) + & + fac001 * absa(ind1+1,1:ng4) + & + fac211 * absa(ind1+8,1:ng4) + & + fac111 * absa(ind1+9,1:ng4) + & + fac011 * absa(ind1+10,1:ng4)) + else +!$NEC unroll(NG4) + tau_major1(1:ng4) = speccomb1 * & + (fac001 * absa(ind1,1:ng4) + & + fac101 * absa(ind1+1,1:ng4) + & + fac011 * absa(ind1+9,1:ng4) + & + fac111 * absa(ind1+10,1:ng4)) + endif + +!$NEC unroll(NG4) + !$ACC LOOP SEQ PRIVATE(tauself, taufor) + do ig = 1, ng4 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + taug(jl,ngs3+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor + fracs(jl,ngs3+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + speccomb = colo3(jl,lay) + rat_o3co2(jl,lay)*colco2(jl,lay) + specparm = MIN(colo3(jl,lay)/speccomb,oneminus) + specmult = 4._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colo3(jl,lay) + rat_o3co2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colo3(jl,lay)/speccomb1,oneminus) + specmult1 = 4._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + + speccomb_planck = colo3(jl,lay)+refrat_planck_b*colco2(jl,lay) + specparm_planck = MIN(colo3(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 4._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(4) + js + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(4) + js1 +!$NEC unroll(NG4) + !$ACC LOOP SEQ + do ig = 1, ng4 + taug(jl,ngs3+ig,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(jl,ngs3+ig,lay) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo +#ifndef _OPENACC + enddo + + ! Empirical modification to code to improve stratospheric cooling rates + ! for co2. Revised to apply weighting for g-point reduction in this band. +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + taug(jl,ngs3+8,lay)=taug(jl,ngs3+8,lay)*0.92_JPRB + taug(jl,ngs3+9,lay)=taug(jl,ngs3+9,lay)*0.88_JPRB + taug(jl,ngs3+10,lay)=taug(jl,ngs3+10,lay)*1.07_JPRB + taug(jl,ngs3+11,lay)=taug(jl,ngs3+11,lay)*1.1_JPRB + taug(jl,ngs3+12,lay)=taug(jl,ngs3+12,lay)*0.99_JPRB + taug(jl,ngs3+13,lay)=taug(jl,ngs3+13,lay)*0.88_JPRB + taug(jl,ngs3+14,lay)=taug(jl,ngs3+14,lay)*0.943_JPRB +#ifdef _OPENACC + endif +#endif + enddo + + ENDDO + !$ACC END PARALLEL + + END IF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL4 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol5.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol5.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol5.F90 (revision 6016) @@ -0,0 +1,665 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL5 (KIDIA,KFDIA,KLEV,taug,wx,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,oneminus,& + & colh2o,colco2, colo3,laytrop,selffac,selffrac,indself,fracs, & + & rat_h2oco2, rat_h2oco2_1, rat_o3co2, rat_o3co2_1,minorfrac,indminor) + +! BAND 5: 700-820 cm-1 (low - H2O,CO2; high - O3,CO2) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) +! (high key - o3,co2) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT ,NG5 ,NGS4 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA5 , ONLY : ABSA ,ABSB ,CCL4 , FRACREFA, FRACREFB,SELFREF,FORREF, & + & KA_MO3 +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: wx(KIDIA:KFDIA,JPXSEC,KLEV) ! Amount of trace gases +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: oneminus +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colo3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2oco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2oco2_1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_o3co2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_o3co2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: minorfrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indminor(KIDIA:KFDIA,KLEV) +! --------------------------------------------------------------------------- + +REAL(KIND=JPRB) :: speccomb,speccomb1, & +& speccomb_mo3, speccomb_planck +INTEGER(KIND=JPIM) :: ind0,ind1,inds,indf,indm + +INTEGER(KIND=JPIM) :: IG, JS, lay, JS1, JPL, JMO3 + +REAL(KIND=JPRB) :: refrat_planck_a, refrat_planck_b,refrat_m_a + +REAL(KIND=JPRB) :: fac000, fac100, fac200,& + & fac010, fac110, fac210, & + & fac001, fac101, fac201, & + & fac011, fac111, fac211 +REAL(KIND=JPRB) :: p, p4, fk0, fk1, fk2 +REAL(KIND=JPRB) :: taufor,tauself,tau_major(ng5),tau_major1(ng5), o3m1, o3m2, abso3 + +REAL(KIND=JPRB) :: fs, specmult, specparm, & +& fs1, specmult1, specparm1, & +& fpl, specmult_PLANCK, specparm_PLANCK, & +& fmo3, specmult_MO3, specparm_MO3 + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + +#define MOD1(x) ((x) - AINT((x))) + + !$ACC DATA PRESENT(taug, wx, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, & + !$ACC jt1, colh2o, colco2, colo3, laytrop, selffac, selffrac, & + !$ACC indself, fracs, rat_h2oco2, rat_h2oco2_1, rat_o3co2, & + !$ACC rat_o3co2_1, indfor, forfrac, forfac, minorfrac, indminor) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + +! Minor gas mapping level : +! lower - o3, p = 317.34 mbar, t = 240.77 k +! lower - ccl4 + +! 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. + + ! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb,speccomb1, speccomb_mo3, speccomb_planck, ind0, ind1, inds, & + !$ACC indf, indm, js, js1, jpl, jmo3, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, & + !$ACC fac011, fac111, fac211, p, p4, fk0, fk1, fk2, fs, specmult, specparm, fs1, specmult1, specparm1, & + !$ACC fpl, specmult_PLANCK, specparm_PLANCK, fmo3, specmult_MO3, specparm_MO3, tau_major, tau_major1) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mo3 = colh2o(jl,lay) + refrat_m_a*colco2(jl,lay) + specparm_mo3 = MIN(colh2o(jl,lay)/speccomb_mo3,oneminus) + specmult_mo3 = 8._JPRB*specparm_mo3 + jmo3 = 1 + int(specmult_mo3) + fmo3 = MOD1(specmult_mo3) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(5) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(5) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG5) + tau_major(1:ng5) = speccomb * & + (fac000 * absa(ind0,1:ng5) + & + fac100 * absa(ind0+1,1:ng5) + & + fac200 * absa(ind0+2,1:ng5) + & + fac010 * absa(ind0+9,1:ng5) + & + fac110 * absa(ind0+10,1:ng5) + & + fac210 * absa(ind0+11,1:ng5)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG5) + tau_major(1:ng5) = speccomb * & + (fac200 * absa(ind0-1,1:ng5) + & + fac100 * absa(ind0,1:ng5) + & + fac000 * absa(ind0+1,1:ng5) + & + fac210 * absa(ind0+8,1:ng5) + & + fac110 * absa(ind0+9,1:ng5) + & + fac010 * absa(ind0+10,1:ng5)) + else +!$NEC unroll(NG5) + tau_major(1:ng5) = speccomb * & + (fac000 * absa(ind0,1:ng5) + & + fac100 * absa(ind0+1,1:ng5) + & + fac010 * absa(ind0+9,1:ng5) + & + fac110 * absa(ind0+10,1:ng5)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG5) + tau_major1(1:ng5) = speccomb1 * & + (fac001 * absa(ind1,1:ng5) + & + fac101 * absa(ind1+1,1:ng5) + & + fac201 * absa(ind1+2,1:ng5) + & + fac011 * absa(ind1+9,1:ng5) + & + fac111 * absa(ind1+10,1:ng5) + & + fac211 * absa(ind1+11,1:ng5)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG5) + tau_major1(1:ng5) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng5) + & + fac101 * absa(ind1,1:ng5) + & + fac001 * absa(ind1+1,1:ng5) + & + fac211 * absa(ind1+8,1:ng5) + & + fac111 * absa(ind1+9,1:ng5) + & + fac011 * absa(ind1+10,1:ng5)) + else +!$NEC unroll(NG5) + tau_major1(1:ng5) = speccomb1 * & + (fac001 * absa(ind1,1:ng5) + & + fac101 * absa(ind1+1,1:ng5) + & + fac011 * absa(ind1+9,1:ng5) + & + fac111 * absa(ind1+10,1:ng5)) + endif + + !$ACC LOOP SEQ PRIVATE(taufor,tauself, o3m1, o3m2, abso3) +!$NEC unroll(NG5) + do ig = 1, ng5 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay)*(o3m2-o3m1) + + taug(jl,ngs4+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + abso3*colo3(jl,lay) & + + wx(jl,1,lay) * ccl4(ig) + fracs(jl,ngs4+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, speccomb1, speccomb_planck, ind0, ind1, indf, indm, js, & + !$ACC js1, jpl, fac000, fac100, fac010, fac110, fac001, fac101, fac011, fac111, fs, specmult, specparm, fs1, & + !$ACC specmult1, specparm1, fpl, specmult_PLANCK, specparm_PLANCK) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + speccomb = colo3(jl,lay) + rat_o3co2(jl,lay)*colco2(jl,lay) + specparm = MIN(colo3(jl,lay)/speccomb,oneminus) + specmult = 4._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colo3(jl,lay) + rat_o3co2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colo3(jl,lay)/speccomb1,oneminus) + specmult1 = 4._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + + speccomb_planck = colo3(jl,lay)+refrat_planck_b*colco2(jl,lay) + specparm_planck = MIN(colo3(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 4._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(5) + js + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(5) + js1 + !$ACC LOOP SEQ +!$NEC unroll(NG5) + do ig = 1, ng5 + taug(jl,ngs4+ig,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(jl,1,lay) * ccl4(ig) + fracs(jl,ngs4+ig,lay) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_mo3, specparm_mo3, specmult_mo3, jmo3, fmo3, speccomb_planck, & + !$ACC specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, indf, indm, p, p4, fk0, fac000, fac100, & + !$ACC fac010, fac110, fac001, fac101, fac011, fac111, fac200, fac201, fac210, fac211, tau_major, tau_major1) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2oco2(jl,lay)*colco2(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oco2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mo3 = colh2o(jl,lay) + refrat_m_a*colco2(jl,lay) + specparm_mo3 = MIN(colh2o(jl,lay)/speccomb_mo3,oneminus) + specmult_mo3 = 8._JPRB*specparm_mo3 + jmo3 = 1 + int(specmult_mo3) + fmo3 = MOD1(specmult_mo3) + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colco2(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(5) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(5) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG5) + tau_major(1:ng5) = speccomb * & + (fac000 * absa(ind0,1:ng5) + & + fac100 * absa(ind0+1,1:ng5) + & + fac200 * absa(ind0+2,1:ng5) + & + fac010 * absa(ind0+9,1:ng5) + & + fac110 * absa(ind0+10,1:ng5) + & + fac210 * absa(ind0+11,1:ng5)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG5) + tau_major(1:ng5) = speccomb * & + (fac200 * absa(ind0-1,1:ng5) + & + fac100 * absa(ind0,1:ng5) + & + fac000 * absa(ind0+1,1:ng5) + & + fac210 * absa(ind0+8,1:ng5) + & + fac110 * absa(ind0+9,1:ng5) + & + fac010 * absa(ind0+10,1:ng5)) + else +!$NEC unroll(NG5) + tau_major(1:ng5) = speccomb * & + (fac000 * absa(ind0,1:ng5) + & + fac100 * absa(ind0+1,1:ng5) + & + fac010 * absa(ind0+9,1:ng5) + & + fac110 * absa(ind0+10,1:ng5)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG5) + tau_major1(1:ng5) = speccomb1 * & + (fac001 * absa(ind1,1:ng5) + & + fac101 * absa(ind1+1,1:ng5) + & + fac201 * absa(ind1+2,1:ng5) + & + fac011 * absa(ind1+9,1:ng5) + & + fac111 * absa(ind1+10,1:ng5) + & + fac211 * absa(ind1+11,1:ng5)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG5) + tau_major1(1:ng5) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng5) + & + fac101 * absa(ind1,1:ng5) + & + fac001 * absa(ind1+1,1:ng5) + & + fac211 * absa(ind1+8,1:ng5) + & + fac111 * absa(ind1+9,1:ng5) + & + fac011 * absa(ind1+10,1:ng5)) + else +!$NEC unroll(NG5) + tau_major1(1:ng5) = speccomb1 * & + (fac001 * absa(ind1,1:ng5) + & + fac101 * absa(ind1+1,1:ng5) + & + fac011 * absa(ind1+9,1:ng5) + & + fac111 * absa(ind1+10,1:ng5)) + endif + +!$NEC unroll(NG5) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, o3m1, o3m2, abso3) + do ig = 1, ng5 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay)*(o3m2-o3m1) + + taug(jl,ngs4+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + abso3*colo3(jl,lay) & + + wx(jl,1,lay) * ccl4(ig) + fracs(jl,ngs4+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + speccomb = colo3(jl,lay) + rat_o3co2(jl,lay)*colco2(jl,lay) + specparm = MIN(colo3(jl,lay)/speccomb,oneminus) + specmult = 4._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colo3(jl,lay) + rat_o3co2_1(jl,lay)*colco2(jl,lay) + specparm1 = MIN(colo3(jl,lay)/speccomb1,oneminus) + specmult1 = 4._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + + speccomb_planck = colo3(jl,lay)+refrat_planck_b*colco2(jl,lay) + specparm_planck = MIN(colo3(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 4._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(5) + js + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(5) + js1 +!$NEC unroll(NG5) + !$ACC LOOP SEQ + do ig = 1, ng5 + taug(jl,ngs4+ig,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(jl,1,lay) * ccl4(ig) + fracs(jl,ngs4+ig,lay) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + END IF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL5 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol6.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol6.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol6.F90 (revision 6016) @@ -0,0 +1,277 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL6 (KIDIA,KFDIA,KLEV,taug,wx,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,& + & colh2o,colco2,coldry,laytrop,selffac,selffrac,indself,fracs,minorfrac,indminor) + +! BAND 6: 820-980 cm-1 (low - H2O; high - nothing) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) +! (high key - nothing; high minor - cfc11, cfc12) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT ,NG6 ,NGS5 +USE YOERRTWN , ONLY : NSPA +USE YOERRTA6 , ONLY : ABSA ,KA_MCO2 ,CFC11ADJ , CFC12 ,& + & FRACREFA,SELFREF,FORREF +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: wx(KIDIA:KFDIA,JPXSEC,KLEV) ! Amount of trace gases +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coldry(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: minorfrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indminor(KIDIA:KFDIA,KLEV) + +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: ind0,ind1,inds,indf,indm + +INTEGER(KIND=JPIM) :: IG, lay + +REAL(KIND=JPRB) :: adjfac,adjcolco2,ratco2,chi_co2 +REAL(KIND=JPRB) :: taufor,tauself,absco2 + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + + !$ACC DATA PRESENT(taug, wx, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, & + !$ACC jt1, colh2o, colco2, coldry, laytrop, selffac, selffrac , & + !$ACC indself, fracs, indfor, forfac, forfrac, minorfrac, & + !$ACC indminor) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + +! 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- and foreign- continuum is interpolated +! (in temperature) separately. + + ! Lower atmosphere loop + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, indm, adjfac, adjcolco2, ratco2,chi_co2) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.77_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(6) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(6) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor, tauself, absco2) +!$NEC unroll(NG6) + do ig = 1, ng6 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + absco2 = (ka_mco2(indm,ig) + minorfrac(jl,lay) * & + (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))) + taug(jl,ngs5+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + adjcolco2 * absco2 & + + wx(jl,2,lay) * cfc11adj(ig) & + + wx(jl,3,lay) * cfc12(ig) + fracs(jl,ngs5+ig,lay) = fracrefa(ig) + enddo + enddo + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + ! Nothing important goes on above laytrop in this band. + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + do ig = 1, ng6 + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + taug(jl,ngs5+ig,lay) = 0.0_JPRB & + + wx(jl,2,lay) * cfc11adj(ig) & + + wx(jl,3,lay) * cfc12(ig) + fracs(jl,ngs5+ig,lay) = fracrefa(ig) + enddo + enddo + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(chi_co2, ratco2, adjfac, adjcolco2, ind0, ind1, inds, indf, indm) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.77_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(6) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(6) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) +!$NEC unroll(NG6) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, absco2) + do ig = 1, ng6 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + absco2 = (ka_mco2(indm,ig) + minorfrac(jl,lay) * & + (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))) + taug(jl,ngs5+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + adjcolco2 * absco2 & + + wx(jl,2,lay) * cfc11adj(ig) & + + wx(jl,3,lay) * cfc12(ig) + fracs(jl,ngs5+ig,lay) = fracrefa(ig) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ! Nothing important goes on above laytrop in this band. + ixc0 = KFDIA - KIDIA + 1 - ixc0 +#endif + + !$ACC LOOP SEQ + do ig = 1, ng6 +#ifndef _OPENACC +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + taug(jl,ngs5+ig,lay) = 0.0_JPRB & + + wx(jl,2,lay) * cfc11adj(ig) & + + wx(jl,3,lay) * cfc12(ig) + fracs(jl,ngs5+ig,lay) = fracrefa(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL6 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol7.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol7.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol7.F90 (revision 6016) @@ -0,0 +1,673 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL7 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,oneminus,& + & colh2o,colo3,colco2,coldry,laytrop,selffac,selffrac,indself,fracs, & + & rat_h2oo3, rat_h2oo3_1,minorfrac,indminor) + +! BAND 7: 980-1080 cm-1 (low - H2O,O3; high - O3) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) +! (high key - o3; high minor - co2) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG7 ,NGS6 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA7 , ONLY : ABSA ,ABSB ,KA_MCO2,KB_MCO2 ,FRACREFA ,FRACREFB,SELFREF,FORREF +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: oneminus +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colo3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coldry(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2oo3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2oo3_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: minorfrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indminor(KIDIA:KFDIA,KLEV) + + +! --------------------------------------------------------------------------- + +REAL(KIND=JPRB) :: speccomb,speccomb1, & +& speccomb_mco2, speccomb_planck +INTEGER(KIND=JPIM) :: ind0,ind1,inds,indf,indm + +INTEGER(KIND=JPIM) :: IG, JS, lay, JS1, JPL, JMCO2 + +REAL(KIND=JPRB) :: refrat_planck_a, refrat_m_a +REAL(KIND=JPRB) :: chi_co2, ratco2, adjfac, adjcolco2 +REAL(KIND=JPRB) :: fac000, fac100, fac200,& + & fac010, fac110, fac210, & + & fac001, fac101, fac201, & + & fac011, fac111, fac211 +REAL(KIND=JPRB) :: p, p4, fk0, fk1, fk2 +REAL(KIND=JPRB) :: taufor,tauself,tau_major(ng7),tau_major1(ng7), co2m1, co2m2, absco2 + + +REAL(KIND=JPRB) :: fs, specmult, specparm, & +& fs1, specmult1, specparm1, & +& fpl, specmult_PLANCK, specparm_PLANCK, & +& fmco2, specmult_mco2, specparm_mco2 + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + +#define MOD1(x) ((x) - AINT((x))) + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colh2o, colo3, colco2, coldry, laytrop, selffac, selffrac, indself, fracs, & + !$ACC rat_h2oo3, rat_h2oo3_1, indfor, forfrac, forfac, & + !$ACC minorfrac, indminor) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + + + ! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, speccomb1, speccomb_mco2, speccomb_planck, ind0, ind1, & + !$ACC inds, indf, indm, js, js1, jpl, jmco2, chi_co2, ratco2, adjfac, adjcolco2, fac000, fac100, fac200, & + !$ACC fac010, fac110, fac210, fac001, fac101, fac201, fac011, fac111, fac211, p, p4, fk0, fk1, fk2, fs, & + !$ACC specmult, specparm, fs1, specmult1, specparm1, fpl, specmult_PLANCK, specparm_PLANCK, fmco2, & + !$ACC specmult_mco2, specparm_mco2, tau_major, tau_major1) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2oo3(jl,lay)*colo3(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oo3_1(jl,lay)*colo3(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mco2 = colh2o(jl,lay) + refrat_m_a*colo3(jl,lay) + specparm_mco2 = MIN(colh2o(jl,lay)/speccomb_mco2,oneminus) + specmult_mco2 = 8._JPRB*specparm_mco2 + + jmco2 = 1 + int(specmult_mco2) + fmco2 = MOD1(specmult_mco2) + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 3.0_JPRB+(ratco2-3.0_JPRB)**0.79_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colo3(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(7) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(7) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG7) + tau_major(1:ng7) = speccomb * & + (fac000 * absa(ind0,1:ng7) + & + fac100 * absa(ind0+1,1:ng7) + & + fac200 * absa(ind0+2,1:ng7) + & + fac010 * absa(ind0+9,1:ng7) + & + fac110 * absa(ind0+10,1:ng7) + & + fac210 * absa(ind0+11,1:ng7)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG7) + tau_major(1:ng7) = speccomb * & + (fac200 * absa(ind0-1,1:ng7) + & + fac100 * absa(ind0,1:ng7) + & + fac000 * absa(ind0+1,1:ng7) + & + fac210 * absa(ind0+8,1:ng7) + & + fac110 * absa(ind0+9,1:ng7) + & + fac010 * absa(ind0+10,1:ng7)) + else +!$NEC unroll(NG7) + tau_major(1:ng7) = speccomb * & + (fac000 * absa(ind0,1:ng7) + & + fac100 * absa(ind0+1,1:ng7) + & + fac010 * absa(ind0+9,1:ng7) + & + fac110 * absa(ind0+10,1:ng7)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG7) + tau_major1(1:ng7) = speccomb1 * & + (fac001 * absa(ind1,1:ng7) + & + fac101 * absa(ind1+1,1:ng7) + & + fac201 * absa(ind1+2,1:ng7) + & + fac011 * absa(ind1+9,1:ng7) + & + fac111 * absa(ind1+10,1:ng7) + & + fac211 * absa(ind1+11,1:ng7)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG7) + tau_major1(1:ng7) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng7) + & + fac101 * absa(ind1,1:ng7) + & + fac001 * absa(ind1+1,1:ng7) + & + fac211 * absa(ind1+8,1:ng7) + & + fac111 * absa(ind1+9,1:ng7) + & + fac011 * absa(ind1+10,1:ng7)) + else +!$NEC unroll(NG7) + tau_major1(1:ng7) = speccomb1 * & + (fac001 * absa(ind1,1:ng7) + & + fac101 * absa(ind1+1,1:ng7) + & + fac011 * absa(ind1+9,1:ng7) + & + fac111 * absa(ind1+10,1:ng7)) + endif + + !$ACC LOOP SEQ PRIVATE(taufor, tauself, co2m1, co2m2, absco2) +!$NEC unroll(NG7) + do ig = 1, ng7 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay) * (co2m2 - co2m1) + + taug(jl,ngs6+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + adjcolco2*absco2 + fracs(jl,ngs6+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, indm, chi_co2, ratco2, adjfac, adjcolco2) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.79_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(7) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(7) + 1 + indm = indminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(absco2) +!$NEC unroll(NG7) + do ig = 1, ng7 + absco2 = kb_mco2(indm,ig) + minorfrac(jl,lay) * & + (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)) + taug(jl,ngs6+ig,lay) = colo3(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + adjcolco2 * absco2 + fracs(jl,ngs6+ig,lay) = fracrefb(ig) + enddo + enddo + enddo + !$ACC END PARALLEL + !$ACC WAIT + + ! Empirical modification to code to improve stratospheric cooling rates + ! for o3. Revised to apply weighting for g-point reduction in this band. + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + taug(jl,ngs6+6,lay)=taug(jl,ngs6+6,lay)*0.92_JPRB + taug(jl,ngs6+7,lay)=taug(jl,ngs6+7,lay)*0.88_JPRB + taug(jl,ngs6+8,lay)=taug(jl,ngs6+8,lay)*1.07_JPRB + taug(jl,ngs6+9,lay)=taug(jl,ngs6+9,lay)*1.1_JPRB + taug(jl,ngs6+10,lay)=taug(jl,ngs6+10,lay)*0.99_JPRB + taug(jl,ngs6+11,lay)=taug(jl,ngs6+11,lay)*0.855_JPRB + enddo + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_mco2, specparm_mco2, specmult_mco2, jmco2, fmco2, adjfac, chi_co2, & + !$ACC ratco2, adjcolco2, speccomb_planck, specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, & + !$ACC indf, indm, p, p4, fk0, fk1, fk2, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, & + !$ACC fac201, fac011, fac111, fac211, tau_major, tau_major1) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2oo3(jl,lay)*colo3(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2oo3_1(jl,lay)*colo3(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mco2 = colh2o(jl,lay) + refrat_m_a*colo3(jl,lay) + specparm_mco2 = MIN(colh2o(jl,lay)/speccomb_mco2,oneminus) + specmult_mco2 = 8._JPRB*specparm_mco2 + + jmco2 = 1 + int(specmult_mco2) + fmco2 = MOD1(specmult_mco2) + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 3.0_JPRB+(ratco2-3.0_JPRB)**0.79_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colo3(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl = 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(7) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(7) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG7) + tau_major(1:ng7) = speccomb * & + (fac000 * absa(ind0,1:ng7) + & + fac100 * absa(ind0+1,1:ng7) + & + fac200 * absa(ind0+2,1:ng7) + & + fac010 * absa(ind0+9,1:ng7) + & + fac110 * absa(ind0+10,1:ng7) + & + fac210 * absa(ind0+11,1:ng7)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG7) + tau_major(1:ng7) = speccomb * & + (fac200 * absa(ind0-1,1:ng7) + & + fac100 * absa(ind0,1:ng7) + & + fac000 * absa(ind0+1,1:ng7) + & + fac210 * absa(ind0+8,1:ng7) + & + fac110 * absa(ind0+9,1:ng7) + & + fac010 * absa(ind0+10,1:ng7)) + else +!$NEC unroll(NG7) + tau_major(1:ng7) = speccomb * & + (fac000 * absa(ind0,1:ng7) + & + fac100 * absa(ind0+1,1:ng7) + & + fac010 * absa(ind0+9,1:ng7) + & + fac110 * absa(ind0+10,1:ng7)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG7) + tau_major1(1:ng7) = speccomb1 * & + (fac001 * absa(ind1,1:ng7) + & + fac101 * absa(ind1+1,1:ng7) + & + fac201 * absa(ind1+2,1:ng7) + & + fac011 * absa(ind1+9,1:ng7) + & + fac111 * absa(ind1+10,1:ng7) + & + fac211 * absa(ind1+11,1:ng7)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG7) + tau_major1(1:ng7) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng7) + & + fac101 * absa(ind1,1:ng7) + & + fac001 * absa(ind1+1,1:ng7) + & + fac211 * absa(ind1+8,1:ng7) + & + fac111 * absa(ind1+9,1:ng7) + & + fac011 * absa(ind1+10,1:ng7)) + else +!$NEC unroll(NG7) + tau_major1(1:ng7) = speccomb1 * & + (fac001 * absa(ind1,1:ng7) + & + fac101 * absa(ind1+1,1:ng7) + & + fac011 * absa(ind1+9,1:ng7) + & + fac111 * absa(ind1+10,1:ng7)) + endif + +!$NEC unroll(NG7) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, co2m1, co2m2, absco2) + do ig = 1, ng7 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay) * (co2m2 - co2m1) + + taug(jl,ngs6+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + adjcolco2*absco2 + fracs(jl,ngs6+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.79_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(7) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(7) + 1 + indm = indminor(jl,lay) +!$NEC unroll(NG7) + !$ACC LOOP SEQ PRIVATE (absco2) + do ig = 1, ng7 + absco2 = kb_mco2(indm,ig) + minorfrac(jl,lay) * & + (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)) + taug(jl,ngs6+ig,lay) = colo3(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + adjcolco2 * absco2 + fracs(jl,ngs6+ig,lay) = fracrefb(ig) + enddo +#ifndef _OPENACC + enddo + + ! Empirical modification to code to improve stratospheric cooling rates + ! for o3. Revised to apply weighting for g-point reduction in this band. + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + taug(jl,ngs6+6,lay)=taug(jl,ngs6+6,lay)*0.92_JPRB + taug(jl,ngs6+7,lay)=taug(jl,ngs6+7,lay)*0.88_JPRB + taug(jl,ngs6+8,lay)=taug(jl,ngs6+8,lay)*1.07_JPRB + taug(jl,ngs6+9,lay)=taug(jl,ngs6+9,lay)*1.1_JPRB + taug(jl,ngs6+10,lay)=taug(jl,ngs6+10,lay)*0.99_JPRB + taug(jl,ngs6+11,lay)=taug(jl,ngs6+11,lay)*0.855_JPRB +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL7 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol8.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol8.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol8.F90 (revision 6016) @@ -0,0 +1,348 @@ +! This file has been modified for the use in ICON + +!******************************************************************************* +SUBROUTINE RRTM_TAUMOL8 (KIDIA,KFDIA,KLEV,taug,wx,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,& + & colh2o,colo3,coln2o,colco2,coldry,laytrop,selffac,selffrac,indself,fracs, & + & minorfrac,indminor) + +! BAND 8: 1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! ABozzo 201306 updated to rrtmg v4.85 +! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) +! (high key - o3; high minor - co2, n2o) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT ,NG8 ,NGS7 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA8 , ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,SELFREF,KA_MCO2 ,KB_MCO2 ,& + & KA_MN2O , KB_MN2O,KA_MO3,CFC12 ,CFC22ADJ,FORREF +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: wx(KIDIA:KFDIA,JPXSEC,KLEV) ! Amount of trace gases +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colo3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coln2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colco2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coldry(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: minorfrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indminor(KIDIA:KFDIA,KLEV) + +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: ind0,ind1,inds,indf,indm + +INTEGER(KIND=JPIM) :: IG, lay + +REAL(KIND=JPRB) :: chi_co2, ratco2, adjfac, adjcolco2 +REAL(KIND=JPRB) :: taufor,tauself, abso3, absco2, absn2o + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + + !$ACC DATA PRESENT(taug, wx, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, & + !$ACC jt1, colh2o, colo3, coln2o, colco2, coldry, laytrop, & + !$ACC selffac, selffrac, indself, fracs, indfor, forfrac, forfac, & + !$ACC minorfrac, indminor) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + +! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, indm, chi_co2, ratco2, adjfac, adjcolco2) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.65_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(8) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(8) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(taufor, tauself, abso3, absco2, absn2o) +!$NEC unroll(NG8) + do ig = 1, ng8 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + absco2 = (ka_mco2(indm,ig) + minorfrac(jl,lay) * & + (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))) + abso3 = (ka_mo3(indm,ig) + minorfrac(jl,lay) * & + (ka_mo3(indm+1,ig) - ka_mo3(indm,ig))) + absn2o = (ka_mn2o(indm,ig) + minorfrac(jl,lay) * & + (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig))) + taug(jl,ngs7+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + adjcolco2*absco2 & + + colo3(jl,lay) * abso3 & + + coln2o(jl,lay) * absn2o & + + wx(jl,3,lay) * cfc12(ig) & + + wx(jl,4,lay) * cfc22adj(ig) + fracs(jl,ngs7+ig,lay) = fracrefa(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, indm, chi_co2, ratco2, adjfac, adjcolco2) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ! 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(jl,lay)/coldry(jl,lay) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.65_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1) * coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(8) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(8) + 1 + indm = indminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(absco2, absn2o) +!$NEC unroll(NG8) + do ig = 1, ng8 + absco2 = (kb_mco2(indm,ig) + minorfrac(jl,lay) * & + (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))) + absn2o = (kb_mn2o(indm,ig) + minorfrac(jl,lay) * & + (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))) + taug(jl,ngs7+ig,lay) = colo3(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + adjcolco2*absco2 & + + coln2o(jl,lay)*absn2o & + + wx(jl,3,lay) * cfc12(ig) & + + wx(jl,4,lay) * cfc22adj(ig) + fracs(jl,ngs7+ig,lay) = fracrefb(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(chi_co2, ratco2, adjfac, adjcolco2, ind0, ind1, inds, indf, indm) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + ! 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(jl,lay)/(coldry(jl,lay)) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.65_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(8) + 1 + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(8) + 1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) +!$NEC unroll(NG8) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, absco2, abso3, absn2o) + do ig = 1, ng8 + tauself = selffac(jl,lay) * (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + absco2 = (ka_mco2(indm,ig) + minorfrac(jl,lay) * & + (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))) + abso3 = (ka_mo3(indm,ig) + minorfrac(jl,lay) * & + (ka_mo3(indm+1,ig) - ka_mo3(indm,ig))) + absn2o = (ka_mn2o(indm,ig) + minorfrac(jl,lay) * & + (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig))) + taug(jl,ngs7+ig,lay) = colh2o(jl,lay) * & + (fac00(jl,lay) * absa(ind0,ig) + & + fac10(jl,lay) * absa(ind0+1,ig) + & + fac01(jl,lay) * absa(ind1,ig) + & + fac11(jl,lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + adjcolco2*absco2 & + + colo3(jl,lay) * abso3 & + + coln2o(jl,lay) * absn2o & + + wx(jl,3,lay) * cfc12(ig) & + + wx(jl,4,lay) * cfc22adj(ig) + fracs(jl,ngs7+ig,lay) = fracrefa(ig) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere loop + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ! 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(jl,lay)/coldry(jl,lay) + ratco2 = 1.e20_JPRB*chi_co2/chi_mls(2,jp(jl,lay)+1) + if (ratco2 .gt. 3.0_JPRB) then + adjfac = 2.0_JPRB+(ratco2-2.0_JPRB)**0.65_JPRB + adjcolco2 = adjfac*chi_mls(2,jp(jl,lay)+1) * coldry(jl,lay)*1.e-20_JPRB + else + adjcolco2 = colco2(jl,lay) + endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(8) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(8) + 1 + indm = indminor(jl,lay) +!$NEC unroll(NG8) + !$ACC LOOP SEQ PRIVATE(absco2, absn2o) + do ig = 1, ng8 + absco2 = (kb_mco2(indm,ig) + minorfrac(jl,lay) * & + (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))) + absn2o = (kb_mn2o(indm,ig) + minorfrac(jl,lay) * & + (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))) + taug(jl,ngs7+ig,lay) = colo3(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + adjcolco2*absco2 & + + coln2o(jl,lay)*absn2o & + + wx(jl,3,lay) * cfc12(ig) & + + wx(jl,4,lay) * cfc22adj(ig) + fracs(jl,ngs7+ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL8 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol9.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol9.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/rrtm_taumol9.F90 (revision 6016) @@ -0,0 +1,642 @@ +! This file has been modified for the use in ICON + +!---------------------------------------------------------------------------- +SUBROUTINE RRTM_TAUMOL9 (KIDIA,KFDIA,KLEV,taug,& + & P_TAUAERL,fac00,fac01,fac10,fac11,forfac,forfrac,indfor,jp,jt,jt1,oneminus,& + & colh2o,coln2o,colch4,coldry,laytrop,K_LAYSWTCH,K_LAYLOW,selffac,selffrac,indself,fracs, & + & rat_h2och4,rat_h2och4_1,minorfrac,indminor) + +! BAND 9: 1180-1390 cm-1 (low - H2O,CH4; high - CH4) + +! AUTHOR. +! ------- +! JJMorcrette, ECMWF + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! NEC 25-Oct-2007 Optimisations +! JJMorcrette 20110613 flexible number of g-points +! 201306 ABozzo updated to rrtmg v4.85 +! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) +! (high key - ch4; high minor - n2o) +! --------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG9 ,NGS8 +USE YOERRTWN , ONLY : NSPA ,NSPB +USE YOERRTA9 , ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,SELFREF,FORREF,KA_MN2O, KB_MN2O +USE YOERRTRF, ONLY : CHI_MLS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: taug(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: fac00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: fac11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jp(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: jt1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: oneminus +REAL(KIND=JPRB) ,INTENT(IN) :: colh2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coln2o(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: colch4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: coldry(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: laytrop(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYLOW(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: selffac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: selffrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indself(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: fracs(KIDIA:KFDIA,JPGPT,KLEV) + +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2och4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: rat_h2och4_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indfor(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: forfrac(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: minorfrac(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: indminor(KIDIA:KFDIA,KLEV) + + + +! --------------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: ind0,ind1,inds,indf,indm +INTEGER(KIND=JPIM) :: IG, JS, lay, JS1, JMN2O, JPL + +REAL(KIND=JPRB) :: speccomb,speccomb1,speccomb_mn2o, & +& speccomb_planck +REAL(KIND=JPRB) :: refrat_planck_a, refrat_m_a + +REAL(KIND=JPRB) :: fs, specmult, specparm, & + & fs1, specmult1, specparm1, & + & fmn2o, specmult_mn2o, specparm_mn2o, & + & fpl, specmult_planck, specparm_planck + +REAL(KIND=JPRB) :: adjfac,adjcoln2o,ratn2o,chi_n2o +REAL(KIND=JPRB) :: fac000, fac100, fac200,& + & fac010, fac110, fac210, & + & fac001, fac101, fac201, & + & fac011, fac111, fac211 +REAL(KIND=JPRB) :: p, p4, fk0, fk1, fk2 +REAL(KIND=JPRB) :: taufor,tauself,n2om1,n2om2,absn2o,tau_major(ng9),tau_major1(ng9) + + ! local integer arrays + INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + integer(KIND=JPIM) :: ixc(KLEV), ixlow(KFDIA,KLEV), ixhigh(KFDIA,KLEV) + INTEGER(KIND=JPIM) :: ich, icl, ixc0, ixp, jc, jl + +#define MOD1(x) ((x) - AINT((x))) + + !$ACC DATA PRESENT(taug, P_TAUAERL, fac00, fac01, fac10, fac11, jp, jt, jt1, & + !$ACC colh2o, coln2o, colch4, coldry, laytrop, K_LAYSWTCH, & + !$ACC K_LAYLOW, selffac, selffrac, indself, fracs, rat_h2och4, & + !$ACC rat_h2och4_1, indfor, forfac, forfrac, minorfrac, indminor) + +#ifndef _OPENACC + laytrop_min = MINVAL(laytrop) + laytrop_max = MAXVAL(laytrop) + + ixlow = 0 + ixhigh = 0 + ixc = 0 + + ! create index lists for mixed layers + do lay = laytrop_min+1, laytrop_max + icl = 0 + ich = 0 + do jc = KIDIA, KFDIA + if ( lay <= laytrop(jc) ) then + icl = icl + 1 + ixlow(icl,lay) = jc + else + ich = ich + 1 + ixhigh(ich,lay) = jc + endif + enddo + ixc(lay) = icl + enddo +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do jc = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, laytrop(jc)) + laytrop_max = MAX(laytrop_max, laytrop(jc)) + end do + !$ACC END PARALLEL +#endif + + + ! 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 + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, indm, js, js1, jmn2o, jpl, speccomb, & + !$ACC speccomb1, speccomb_mn2o, speccomb_planck, fs, specmult, specparm, fs1, specmult1, specparm1, fmn2o, & + !$ACC specmult_mn2o, specparm_mn2o, fpl, specmult_planck, specparm_planck, adjfac, adjcoln2o, ratn2o, & + !$ACC chi_n2o, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, fac201, fac011, fac111, & + !$ACC fac211, p, p4, fk0, fk1, fk2, tau_major, tau_major1) + do lay = 1, laytrop_min + do jl = KIDIA, KFDIA + + speccomb = colh2o(jl,lay) + rat_h2och4(jl,lay)*colch4(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2och4_1(jl,lay)*colch4(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mn2o = colh2o(jl,lay) + refrat_m_a*colch4(jl,lay) + specparm_mn2o = MIN(colh2o(jl,lay)/speccomb_mn2o,oneminus) + specmult_mn2o = 8._JPRB*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = MOD1(specmult_mn2o) + + ! 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(jl,lay)/(coldry(jl,lay)) + ratn2o = 1.e20_JPRB*chi_n2o/chi_mls(4,jp(jl,lay)+1) + if (ratn2o .gt. 1.5_JPRB) then + adjfac = 0.5_JPRB+(ratn2o-0.5_JPRB)**0.65_JPRB + adjcoln2o = adjfac*chi_mls(4,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcoln2o = coln2o(jl,lay) + endif + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colch4(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(9) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(9) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG9) + tau_major(1:ng9) = speccomb * & + (fac000 * absa(ind0,1:ng9) + & + fac100 * absa(ind0+1,1:ng9) + & + fac200 * absa(ind0+2,1:ng9) + & + fac010 * absa(ind0+9,1:ng9) + & + fac110 * absa(ind0+10,1:ng9) + & + fac210 * absa(ind0+11,1:ng9)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG9) + tau_major(1:ng9) = speccomb * & + (fac200 * absa(ind0-1,1:ng9) + & + fac100 * absa(ind0,1:ng9) + & + fac000 * absa(ind0+1,1:ng9) + & + fac210 * absa(ind0+8,1:ng9) + & + fac110 * absa(ind0+9,1:ng9) + & + fac010 * absa(ind0+10,1:ng9)) + else +!$NEC unroll(NG9) + tau_major(1:ng9) = speccomb * & + (fac000 * absa(ind0,1:ng9) + & + fac100 * absa(ind0+1,1:ng9) + & + fac010 * absa(ind0+9,1:ng9) + & + fac110 * absa(ind0+10,1:ng9)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG9) + tau_major1(1:ng9) = speccomb1 * & + (fac001 * absa(ind1,1:ng9) + & + fac101 * absa(ind1+1,1:ng9) + & + fac201 * absa(ind1+2,1:ng9) + & + fac011 * absa(ind1+9,1:ng9) + & + fac111 * absa(ind1+10,1:ng9) + & + fac211 * absa(ind1+11,1:ng9)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG9) + tau_major1(1:ng9) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng9) + & + fac101 * absa(ind1,1:ng9) + & + fac001 * absa(ind1+1,1:ng9) + & + fac211 * absa(ind1+8,1:ng9) + & + fac111 * absa(ind1+9,1:ng9) + & + fac011 * absa(ind1+10,1:ng9)) + else +!$NEC unroll(NG9) + tau_major1(1:ng9) = speccomb1 * & + (fac001 * absa(ind1,1:ng9) + & + fac101 * absa(ind1+1,1:ng9) + & + fac011 * absa(ind1+9,1:ng9) + & + fac111 * absa(ind1+10,1:ng9)) + endif + + !$ACC LOOP SEQ PRIVATE(taufor, tauself, n2om1, n2om2, absn2o) +!$NEC unroll(NG9) + do ig = 1, ng9 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay) * (n2om2 - n2om1) + + taug(jl,ngs8+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + adjcoln2o*absn2o + fracs(jl,ngs8+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + + enddo + !$ACC END PARALLEL + + ! Upper atmosphere loop + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, indm, adjfac, adjcoln2o, ratn2o, chi_n2o) + do lay = laytrop_max+1, KLEV + do jl = KIDIA, KFDIA + + ! 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(jl,lay)/(coldry(jl,lay)) + ratn2o = 1.e20_JPRB*chi_n2o/chi_mls(4,jp(jl,lay)+1) + if (ratn2o .gt. 1.5_JPRB) then + adjfac = 0.5_JPRB+(ratn2o-0.5_JPRB)**0.65_JPRB + adjcoln2o = adjfac*chi_mls(4,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcoln2o = coln2o(jl,lay) + endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(9) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(9) + 1 + indm = indminor(jl,lay) + !$ACC LOOP SEQ PRIVATE(absn2o) +!$NEC unroll(NG9) + do ig = 1, ng9 + absn2o = kb_mn2o(indm,ig) + minorfrac(jl,lay) * & + (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)) + taug(jl,ngs8+ig,lay) = colch4(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + adjcoln2o*absn2o + fracs(jl,ngs8+ig,lay) = fracrefb(ig) + enddo + enddo + + enddo + !$ACC END PARALLEL + + IF (laytrop_max /= laytrop_min) THEN + ! Mixed loop + ! Lower atmosphere part + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(speccomb, specparm, specmult, js, fs, speccomb1, specparm1, & + !$ACC specmult1, js1, fs1, speccomb_mn2o, specparm_mn2o, specmult_mn2o, jmn2o, fmn2o, chi_n2o, ratn2o, & + !$ACC adjfac, adjcoln2o, speccomb_planck, specparm_planck, specmult_planck, jpl, fpl, ind0, ind1, inds, & + !$ACC indf, indm, p, p4, fk0, fk1, fk2, fac000, fac100, fac200, fac010, fac110, fac210, fac001, fac101, & + !$ACC fac201, fac011, fac111, fac211, tau_major, tau_major1) + do lay = laytrop_min+1, laytrop_max +#ifdef _OPENACC + do jl = KIDIA, KFDIA + if ( lay <= laytrop(jl) ) then +#else + ixc0 = ixc(lay) + +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixlow(ixp,lay) +#endif + + speccomb = colh2o(jl,lay) + rat_h2och4(jl,lay)*colch4(jl,lay) + specparm = MIN(colh2o(jl,lay)/speccomb,oneminus) + specmult = 8._JPRB*(specparm) + js = 1 + int(specmult) + fs = MOD1(specmult) + + speccomb1 = colh2o(jl,lay) + rat_h2och4_1(jl,lay)*colch4(jl,lay) + specparm1 = MIN(colh2o(jl,lay)/speccomb1,oneminus) + specmult1 = 8._JPRB*(specparm1) + js1 = 1 + int(specmult1) + fs1 = MOD1(specmult1) + + speccomb_mn2o = colh2o(jl,lay) + refrat_m_a*colch4(jl,lay) + specparm_mn2o = MIN(colh2o(jl,lay)/speccomb_mn2o,oneminus) + specmult_mn2o = 8._JPRB*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = MOD1(specmult_mn2o) + + ! 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(jl,lay)/(coldry(jl,lay)) + ratn2o = 1.e20_JPRB*chi_n2o/chi_mls(4,jp(jl,lay)+1) + if (ratn2o .gt. 1.5_JPRB) then + adjfac = 0.5_JPRB+(ratn2o-0.5_JPRB)**0.65_JPRB + adjcoln2o = adjfac*chi_mls(4,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcoln2o = coln2o(jl,lay) + endif + + speccomb_planck = colh2o(jl,lay)+refrat_planck_a*colch4(jl,lay) + specparm_planck = MIN(colh2o(jl,lay)/speccomb_planck,oneminus) + specmult_planck = 8._JPRB*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = MOD1(specmult_planck) + + ind0 = ((jp(jl,lay)-1)*5+(jt(jl,lay)-1))*nspa(9) + js + ind1 = (jp(jl,lay)*5+(jt1(jl,lay)-1))*nspa(9) + js1 + inds = indself(jl,lay) + indf = indfor(jl,lay) + indm = indminor(jl,lay) + + if (specparm .lt. 0.125_JPRB) then + p = fs - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else if (specparm .gt. 0.875_JPRB) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac000 = fk0*fac00(jl,lay) + fac100 = fk1*fac00(jl,lay) + fac200 = fk2*fac00(jl,lay) + fac010 = fk0*fac10(jl,lay) + fac110 = fk1*fac10(jl,lay) + fac210 = fk2*fac10(jl,lay) + else + fac000 = (1._JPRB - fs) * fac00(jl,lay) + fac010 = (1._JPRB - fs) * fac10(jl,lay) + fac100 = fs * fac00(jl,lay) + fac110 = fs * fac10(jl,lay) + fac200 = 0._JPRB + fac210 = 0._JPRB + endif + + if (specparm1 .lt. 0.125_JPRB) then + p = fs1 - 1._JPRB + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else if (specparm1 .gt. 0.875_JPRB) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1._JPRB - p - 2.0_JPRB*p4 + fk2 = p + p4 + fac001 = fk0*fac01(jl,lay) + fac101 = fk1*fac01(jl,lay) + fac201 = fk2*fac01(jl,lay) + fac011 = fk0*fac11(jl,lay) + fac111 = fk1*fac11(jl,lay) + fac211 = fk2*fac11(jl,lay) + else + fac001 = (1._JPRB - fs1) * fac01(jl,lay) + fac011 = (1._JPRB - fs1) * fac11(jl,lay) + fac101 = fs1 * fac01(jl,lay) + fac111 = fs1 * fac11(jl,lay) + fac201 = 0._JPRB + fac211 = 0._JPRB + endif + + if (specparm .lt. 0.125_JPRB) then +!$NEC unroll(NG9) + tau_major(1:ng9) = speccomb * & + (fac000 * absa(ind0,1:ng9) + & + fac100 * absa(ind0+1,1:ng9) + & + fac200 * absa(ind0+2,1:ng9) + & + fac010 * absa(ind0+9,1:ng9) + & + fac110 * absa(ind0+10,1:ng9) + & + fac210 * absa(ind0+11,1:ng9)) + else if (specparm .gt. 0.875_JPRB) then +!$NEC unroll(NG9) + tau_major(1:ng9) = speccomb * & + (fac200 * absa(ind0-1,1:ng9) + & + fac100 * absa(ind0,1:ng9) + & + fac000 * absa(ind0+1,1:ng9) + & + fac210 * absa(ind0+8,1:ng9) + & + fac110 * absa(ind0+9,1:ng9) + & + fac010 * absa(ind0+10,1:ng9)) + else +!$NEC unroll(NG9) + tau_major(1:ng9) = speccomb * & + (fac000 * absa(ind0,1:ng9) + & + fac100 * absa(ind0+1,1:ng9) + & + fac010 * absa(ind0+9,1:ng9) + & + fac110 * absa(ind0+10,1:ng9)) + endif + + if (specparm1 .lt. 0.125_JPRB) then +!$NEC unroll(NG9) + tau_major1(1:ng9) = speccomb1 * & + (fac001 * absa(ind1,1:ng9) + & + fac101 * absa(ind1+1,1:ng9) + & + fac201 * absa(ind1+2,1:ng9) + & + fac011 * absa(ind1+9,1:ng9) + & + fac111 * absa(ind1+10,1:ng9) + & + fac211 * absa(ind1+11,1:ng9)) + else if (specparm1 .gt. 0.875_JPRB) then +!$NEC unroll(NG9) + tau_major1(1:ng9) = speccomb1 * & + (fac201 * absa(ind1-1,1:ng9) + & + fac101 * absa(ind1,1:ng9) + & + fac001 * absa(ind1+1,1:ng9) + & + fac211 * absa(ind1+8,1:ng9) + & + fac111 * absa(ind1+9,1:ng9) + & + fac011 * absa(ind1+10,1:ng9)) + else +!$NEC unroll(NG9) + tau_major1(1:ng9) = speccomb1 * & + (fac001 * absa(ind1,1:ng9) + & + fac101 * absa(ind1+1,1:ng9) + & + fac011 * absa(ind1+9,1:ng9) + & + fac111 * absa(ind1+10,1:ng9)) + endif + +!$NEC unroll(NG9) + !$ACC LOOP SEQ PRIVATE(tauself, taufor, n2om1, n2om2, absn2o) + do ig = 1, ng9 + tauself = selffac(jl,lay)* (selfref(inds,ig) + selffrac(jl,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(jl,lay) * (forref(indf,ig) + forfrac(jl,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(jl,lay) * (n2om2 - n2om1) + + taug(jl,ngs8+ig,lay) = tau_major(ig) + tau_major1(ig) & + + tauself + taufor & + + adjcoln2o*absn2o + fracs(jl,ngs8+ig,lay) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo +#ifdef _OPENACC + else +#else + enddo + + ! Upper atmosphere part + ixc0 = KFDIA - KIDIA + 1 - ixc0 +!$NEC ivdep + do ixp = 1, ixc0 + jl = ixhigh(ixp,lay) +#endif + + ! 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(jl,lay)/(coldry(jl,lay)) + ratn2o = 1.e20_JPRB*chi_n2o/chi_mls(4,jp(jl,lay)+1) + if (ratn2o .gt. 1.5_JPRB) then + adjfac = 0.5_JPRB+(ratn2o-0.5_JPRB)**0.65_JPRB + adjcoln2o = adjfac*chi_mls(4,jp(jl,lay)+1)*coldry(jl,lay)*1.e-20_JPRB + else + adjcoln2o = coln2o(jl,lay) + endif + + ind0 = ((jp(jl,lay)-13)*5+(jt(jl,lay)-1))*nspb(9) + 1 + ind1 = ((jp(jl,lay)-12)*5+(jt1(jl,lay)-1))*nspb(9) + 1 + indm = indminor(jl,lay) +!$NEC unroll(NG9) + !$ACC LOOP SEQ PRIVATE(absn2o) + do ig = 1, ng9 + absn2o = kb_mn2o(indm,ig) + minorfrac(jl,lay) * & + (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)) + taug(jl,ngs8+ig,lay) = colch4(jl,lay) * & + (fac00(jl,lay) * absb(ind0,ig) + & + fac10(jl,lay) * absb(ind0+1,ig) + & + fac01(jl,lay) * absb(ind1,ig) + & + fac11(jl,lay) * absb(ind1+1,ig)) & + + adjcoln2o*absn2o + fracs(jl,ngs8+ig,lay) = fracrefb(ig) + enddo +#ifdef _OPENACC + endif +#endif + enddo + + enddo + !$ACC END PARALLEL + + ENDIF + + !$ACC END DATA + +END SUBROUTINE RRTM_TAUMOL9 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb16.F90 (revision 6016) @@ -0,0 +1,109 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB16 + + +! Original version: Michael J. Iacono; July, 1998 +! Revision for RRTM_SW: Michael J. Iacono; November, 2002 +! Revision for RRTMG_SW: Michael J. Iacono; December, 2003 + +! The subroutines CMBGB16->CMBGB29 input the absorption coefficient +! data for each band, which are defined for 16 g-points and 14 spectral +! bands. The data are combined with appropriate weighting following the +! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source +! function data in array SFLUXREF are combined without weighting. All +! g-point reduced data are put into new arrays for use in RRTMG_SW. + +! BAND 16: 2600-3250 cm-1 (low key- H2O,CH4; high key - CH4) + +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, RWGT +!USE YOESRTWN , ONLY : NGC, NGN, RWGT +USE YOESRTA16, ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, & + & KAC, KBC, SELFREFC, FORREFC, SFLUXREFC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB16',0,ZHOOK_HANDLE) + +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(1) + ZSUMK = 0. + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JN,JT,JP,IPRSM)*RWGT(IPRSM) + ENDDO + KAC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(1) + ZSUMK = 0. + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JT,JP,IPRSM)*RWGT(IPRSM) + ENDDO + KBC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(1) + ZSUMK = 0. + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,3 + IPRSM = 0 + DO IGC = 1,NGC(1) + ZSUMK = 0. + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(1) + ZSUMF = 0. + DO IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + ZSUMF = ZSUMF + SFLUXREF(IPRSM) + ENDDO + SFLUXREFC(IGC) = ZSUMF +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB16',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB16 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb17.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb17.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb17.F90 (revision 6016) @@ -0,0 +1,100 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB17 + +! BAND 17: 3250-4000 cm-1 (low - H2O,CO2; high - H2O,CO2) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA17, ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, & + & KAC, KBC, SELFREFC, FORREFC, SFLUXREFC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB17',0,ZHOOK_HANDLE) + +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(2) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JN,JT,JP,IPRSM)*RWGT(IPRSM+16) + ENDDO + KAC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JN = 1,5 + DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(2) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JN,JT,JP,IPRSM)*RWGT(IPRSM+16) + ENDDO + KBC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(2) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+16) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(2) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+16) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JP = 1,5 + IPRSM = 0 + DO IGC = 1,NGC(2) + ZSUMF = 0. + DO IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + ZSUMF = ZSUMF + SFLUXREF(IPRSM,JP) + ENDDO + SFLUXREFC(IGC,JP) = ZSUMF + ENDDO +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB17',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB17 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb18.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb18.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb18.F90 (revision 6016) @@ -0,0 +1,98 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB18 + +! BAND 18: 4000-4650 cm-1 (low - H2O,CH4; high - CH4) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA18, ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, & + & KAC, KBC, SELFREFC, FORREFC, SFLUXREFC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB18',0,ZHOOK_HANDLE) + +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(3) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JN,JT,JP,IPRSM)*RWGT(IPRSM+32) + ENDDO + KAC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(3) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JT,JP,IPRSM)*RWGT(IPRSM+32) + ENDDO + KBC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(3) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+32) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,3 + IPRSM = 0 + DO IGC = 1,NGC(3) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+32) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(3) + ZSUMF = 0. + DO IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + ZSUMF = ZSUMF + SFLUXREF(IPRSM,JP) + ENDDO + SFLUXREFC(IGC,JP) = ZSUMF + ENDDO +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB18',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB18 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb19.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb19.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb19.F90 (revision 6016) @@ -0,0 +1,98 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB19 + +! BAND 19: 4650-5150 cm-1 (low - H2O,CO2; high - CO2) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA19, ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, & + & KAC, KBC, SELFREFC, FORREFC, SFLUXREFC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB19',0,ZHOOK_HANDLE) + +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(4) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JN,JT,JP,IPRSM)*RWGT(IPRSM+48) + ENDDO + KAC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(4) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JT,JP,IPRSM)*RWGT(IPRSM+48) + ENDDO + KBC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(4) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+48) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,3 + IPRSM = 0 + DO IGC = 1,NGC(4) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+48) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(4) + ZSUMF = 0. + DO IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + ZSUMF = ZSUMF + SFLUXREF(IPRSM,JP) + ENDDO + SFLUXREFC(IGC,JP) = ZSUMF + ENDDO +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB19',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB19 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb20.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb20.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb20.F90 (revision 6016) @@ -0,0 +1,95 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB20 + +! BAND 20: 5150-6150 cm-1 (low - H2O; high - H2O) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA20, ONLY : KA, KB, SELFREF, FORREF, ABSCH4, SFLUXREF, & + & KAC, KBC, SELFREFC, FORREFC, ABSCH4C, SFLUXREFC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF1, ZSUMF2 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB20',0,ZHOOK_HANDLE) + +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(5) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JT,JP,IPRSM)*RWGT(IPRSM+64) + ENDDO + KAC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(5) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JT,JP,IPRSM)*RWGT(IPRSM+64) + ENDDO + KBC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(5) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+64) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(5) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+64) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(5) + ZSUMF1 = 0. + ZSUMF2 = 0. + DO IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + ZSUMF1 = ZSUMF1 + SFLUXREF(IPRSM) + ZSUMF2 = ZSUMF2 + ABSCH4(IPRSM)*RWGT(IPRSM+64) + ENDDO + SFLUXREFC(IGC) = ZSUMF1 + ABSCH4C(IGC) = ZSUMF2 +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC, ABSCH4C) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB20',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB20 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb21.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb21.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb21.F90 (revision 6016) @@ -0,0 +1,100 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB21 + +! BAND 21: 6150-7700 cm-1 (low - H2O,CO2; high - H2O,CO2) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA21, ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, & + & KAC, KBC, SELFREFC, FORREFC, SFLUXREFC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB21',0,ZHOOK_HANDLE) + +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(6) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JN,JT,JP,IPRSM)*RWGT(IPRSM+80) + ENDDO + KAC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JN = 1,5 + DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(6) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JN,JT,JP,IPRSM)*RWGT(IPRSM+80) + ENDDO + KBC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(6) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+80) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(6) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+80) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(6) + ZSUMF = 0. + DO IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + ZSUMF = ZSUMF + SFLUXREF(IPRSM,JP) + ENDDO + SFLUXREFC(IGC,JP) = ZSUMF + ENDDO +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB21',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB21 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb22.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb22.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb22.F90 (revision 6016) @@ -0,0 +1,98 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB22 + +! BAND 22: 7700-8050 cm-1 (low - H2O,O2; high - O2) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA22, ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, & + & KAC, KBC, SELFREFC, FORREFC, SFLUXREFC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB22',0,ZHOOK_HANDLE) + +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(7) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JN,JT,JP,IPRSM)*RWGT(IPRSM+96) + ENDDO + KAC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(7) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JT,JP,IPRSM)*RWGT(IPRSM+96) + ENDDO + KBC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(7) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+96) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,3 + IPRSM = 0 + DO IGC = 1,NGC(7) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+96) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(7) + ZSUMF = 0. + DO IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + ZSUMF = ZSUMF + SFLUXREF(IPRSM,JP) + ENDDO + SFLUXREFC(IGC,JP) = ZSUMF + ENDDO +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB22',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB22 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb23.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb23.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb23.F90 (revision 6016) @@ -0,0 +1,83 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB23 + +! BAND 23: 8050-12850 cm-1 (low - H2O; high - nothing) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA23, ONLY : KA, SELFREF, FORREF, SFLUXREF, RAYL, & + & KAC, SELFREFC, FORREFC, SFLUXREFC, RAYLC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF1, ZSUMF2 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB23',0,ZHOOK_HANDLE) + +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(8) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JT,JP,IPRSM)*RWGT(IPRSM+112) + ENDDO + KAC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(8) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+112) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,3 + IPRSM = 0 + DO IGC = 1,NGC(8) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+112) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(8) + ZSUMF1 = 0. + ZSUMF2 = 0. + DO IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + ZSUMF1 = ZSUMF1 + SFLUXREF(IPRSM) + ZSUMF2 = ZSUMF2 + RAYL(IPRSM)*RWGT(IPRSM+112) + ENDDO + SFLUXREFC(IGC) = ZSUMF1 + RAYLC(IGC) = ZSUMF2 +ENDDO + +!$ACC UPDATE DEVICE(KAC, SELFREFC, FORREFC, SFLUXREFC, RAYLC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB23',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB23 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb24.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb24.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb24.F90 (revision 6016) @@ -0,0 +1,120 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB24 + +! BAND 24: 12850-16000 cm-1 (low - H2O,O2; high - O2) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA24, ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, & + & ABSO3A, ABSO3B, RAYLA, RAYLB, & + & KAC, KBC, SELFREFC, FORREFC, SFLUXREFC, & + & ABSO3AC, ABSO3BC, RAYLAC, RAYLBC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF1, ZSUMF2, ZSUMF3 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB24',0,ZHOOK_HANDLE) + +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(9) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JN,JT,JP,IPRSM)*RWGT(IPRSM+128) + ENDDO + KAC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(9) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JT,JP,IPRSM)*RWGT(IPRSM+128) + ENDDO + KBC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(9) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+128) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,3 + IPRSM = 0 + DO IGC = 1,NGC(9) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+128) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(9) + ZSUMF1 = 0. + ZSUMF2 = 0. + ZSUMF3 = 0. + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + ZSUMF1 = ZSUMF1 + RAYLB(IPRSM)*RWGT(IPRSM+128) + ZSUMF2 = ZSUMF2 + ABSO3A(IPRSM)*RWGT(IPRSM+128) + ZSUMF3 = ZSUMF3 + ABSO3B(IPRSM)*RWGT(IPRSM+128) + ENDDO + RAYLBC(IGC) = ZSUMF1 + ABSO3AC(IGC) = ZSUMF2 + ABSO3BC(IGC) = ZSUMF3 +ENDDO + +DO JP = 1,9 + IPRSM = 0 + DO IGC = 1,NGC(9) + ZSUMF1 = 0. + ZSUMF2 = 0. + DO IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + ZSUMF1 = ZSUMF1 + SFLUXREF(IPRSM,JP) + ZSUMF2 = ZSUMF2 + RAYLA(IPRSM,JP)*RWGT(IPRSM+128) + ENDDO + SFLUXREFC(IGC,JP) = ZSUMF1 + RAYLAC(IGC,JP) = ZSUMF2 + ENDDO +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC, ABSO3AC, ABSO3BC, & +!$ACC RAYLAC, RAYLBC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB24',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB24 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb25.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb25.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb25.F90 (revision 6016) @@ -0,0 +1,65 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB25 + +! BAND 25: 16000-22650 cm-1 (low - H2O; high - nothing) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA25, ONLY : KA, SFLUXREF, ABSO3A, ABSO3B, RAYL, & + & KAC, SFLUXREFC, ABSO3AC, ABSO3BC, RAYLC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF1, ZSUMF2, ZSUMF3, ZSUMF4 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB25',0,ZHOOK_HANDLE) + +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(10) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JT,JP,IPRSM)*RWGT(IPRSM+144) + ENDDO + KAC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(10) + ZSUMF1 = 0. + ZSUMF2 = 0. + ZSUMF3 = 0. + ZSUMF4 = 0. + DO IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + ZSUMF1 = ZSUMF1 + SFLUXREF(IPRSM) + ZSUMF2 = ZSUMF2 + ABSO3A(IPRSM)*RWGT(IPRSM+144) + ZSUMF3 = ZSUMF3 + ABSO3B(IPRSM)*RWGT(IPRSM+144) + ZSUMF4 = ZSUMF4 + RAYL(IPRSM)*RWGT(IPRSM+144) + ENDDO + SFLUXREFC(IGC) = ZSUMF1 + ABSO3AC(IGC) = ZSUMF2 + ABSO3BC(IGC) = ZSUMF3 + RAYLC(IGC) = ZSUMF4 +ENDDO + +!$ACC UPDATE DEVICE(KAC, SFLUXREFC, RAYLC, ABSO3AC, ABSO3BC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB25',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB25 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb26.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb26.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb26.F90 (revision 6016) @@ -0,0 +1,45 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB26 + +! BAND 26: 22650-29000 cm-1 (low - nothing; high - nothing) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA26, ONLY : SFLUXREF, RAYL, & + & SFLUXREFC, RAYLC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMF1, ZSUMF2 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB26',0,ZHOOK_HANDLE) + +IPRSM = 0 +DO IGC = 1,NGC(11) + ZSUMF1 = 0. + ZSUMF2 = 0. + DO IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + ZSUMF1 = ZSUMF1 + RAYL(IPRSM)*RWGT(IPRSM+160) + ZSUMF2 = ZSUMF2 + SFLUXREF(IPRSM) + ENDDO + RAYLC(IGC) = ZSUMF1 + SFLUXREFC(IGC) = ZSUMF2 +ENDDO + +!$ACC UPDATE DEVICE(SFLUXREFC, RAYLC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB26',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB26 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb27.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb27.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb27.F90 (revision 6016) @@ -0,0 +1,71 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB27 + +! BAND 27: 29000-38000 cm-1 (low - O3; high - O3) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA27, ONLY : KA, KB, SFLUXREF, RAYL, & + & KAC, KBC, SFLUXREFC, RAYLC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF1, ZSUMF2 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB27',0,ZHOOK_HANDLE) + +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(12) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JT,JP,IPRSM)*RWGT(IPRSM+176) + ENDDO + KAC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(12) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JT,JP,IPRSM)*RWGT(IPRSM+176) + ENDDO + KBC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(12) + ZSUMF1 = 0. + ZSUMF2 = 0. + DO IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + ZSUMF1 = ZSUMF1 + SFLUXREF(IPRSM) + ZSUMF2 = ZSUMF2 + RAYL(IPRSM)*RWGT(IPRSM+176) + ENDDO + SFLUXREFC(IGC) = ZSUMF1 + RAYLC(IGC) = ZSUMF2 +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SFLUXREFC, RAYLC) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB27',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB27 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb28.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb28.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb28.F90 (revision 6016) @@ -0,0 +1,77 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB28 + +! BAND 28: 38000-50000 cm-1 (low - O3,O2; high - O3,O2) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA28, ONLY : KA, KB, SFLUXREF, & + & KAC, KBC, SFLUXREFC + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB28',0,ZHOOK_HANDLE) + +DO JN = 1,9 + DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(13) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JN,JT,JP,IPRSM)*RWGT(IPRSM+192) + ENDDO + KAC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JN = 1,5 + DO JT = 1,5 + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(13) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JN,JT,JP,IPRSM)*RWGT(IPRSM+192) + ENDDO + KBC(JN,JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + ENDDO +ENDDO + +DO JP = 1,5 + IPRSM = 0 + DO IGC = 1,NGC(13) + ZSUMF = 0. + DO IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + ZSUMF = ZSUMF + SFLUXREF(IPRSM,JP) + ENDDO + SFLUXREFC(IGC,JP) = ZSUMF + ENDDO +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SFLUXREFC) + + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB28',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB28 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb29.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb29.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_cmbgb29.F90 (revision 6016) @@ -0,0 +1,100 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_CMBGB29 + +! BAND 29: 820-2600 cm-1 (low - H2O; high - CO2) +!----------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NGC, NGS, RWGT +!USE YOESRTWN , ONLY : NGC, NGS, NGN, RWGT +USE YOESRTA29, ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, & + & ABSH2O, ABSCO2, & + & KAC, KBC, SELFREFC, FORREFC, SFLUXREFC, & + & ABSH2OC, ABSCO2C + +IMPLICIT NONE + +! Local variables +INTEGER(KIND=JPIM) :: JT, JP, IGC, IPR, IPRSM +REAL(KIND=JPRB) :: ZSUMK, ZSUMF1, ZSUMF2, ZSUMF3 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB29',0,ZHOOK_HANDLE) + +DO JT = 1,5 + DO JP = 1,13 + IPRSM = 0 + DO IGC = 1,NGC(14) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KA(JT,JP,IPRSM)*RWGT(IPRSM+208) + ENDDO + KAC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO + + DO JP = 13,59 + IPRSM = 0 + DO IGC = 1,NGC(14) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + KB(JT,JP,IPRSM)*RWGT(IPRSM+208) + ENDDO + KBC(JT,JP,IGC) = ZSUMK + ENDDO + ENDDO +ENDDO + +DO JT = 1,10 + IPRSM = 0 + DO IGC = 1,NGC(14) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + SELFREF(JT,IPRSM)*RWGT(IPRSM+208) + ENDDO + SELFREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +DO JT = 1,4 + IPRSM = 0 + DO IGC = 1,NGC(14) + ZSUMK = 0. + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + ZSUMK = ZSUMK + FORREF(JT,IPRSM)*RWGT(IPRSM+208) + ENDDO + FORREFC(JT,IGC) = ZSUMK + ENDDO +ENDDO + +IPRSM = 0 +DO IGC = 1,NGC(14) + ZSUMF1 = 0. + ZSUMF2 = 0. + ZSUMF3 = 0. + DO IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + ZSUMF1 = ZSUMF1 + SFLUXREF(IPRSM) + ZSUMF2 = ZSUMF2 + ABSCO2(IPRSM)*RWGT(IPRSM+208) + ZSUMF3 = ZSUMF3 + ABSH2O(IPRSM)*RWGT(IPRSM+208) + ENDDO + SFLUXREFC(IGC) = ZSUMF1 + ABSCO2C(IGC) = ZSUMF2 + ABSH2OC(IGC) = ZSUMF3 +ENDDO + +!$ACC UPDATE DEVICE(KAC, KBC, SELFREFC, FORREFC, SFLUXREFC, ABSH2OC, ABSCO2C) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_CMBGB29',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_CMBGB29 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_gas_optical_depth.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_gas_optical_depth.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_gas_optical_depth.F90 (revision 6016) @@ -0,0 +1,343 @@ +! This file has been modified for the use in ICON + +#ifdef RS6K +@PROCESS HOT(NOVECTOR) NOSTRICT +#endif +SUBROUTINE SRTM_GAS_OPTICAL_DEPTH & + & ( KIDIA , KFDIA , KLEV , PONEMINUS, & + & PRMU0, & + & KLAYTROP,& + & PCOLCH4 , PCOLCO2 , PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& + & PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + !-- output arrays + & POD, PSSA, PINCSOL) + + +!**** *SRTM_GAS_OPTICAL_DEPTH* - SPECTRAL LOOP TO COMPUTE THE SHORTWAVE RADIATION FLUXES. + +! PURPOSE. +! -------- + +! COMPUTE THE GAS OPTICAL DEPTH AT EACH SHORTWAVE G POINT + +!** INTERFACE. +! ---------- + +! *SRTM_GAS_OPTICAL_DEPTH* IS CALLED FROM THE NEW RADIATION SCHEME + +! IMPLICIT ARGUMENTS : +! -------------------- + +! ==== INPUTS === +! ==== OUTPUTS === + +! METHOD. +! ------- + +! EXTERNALS. +! ---------- + +! REFERENCE. +! ---------- + +! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +! DOCUMENTATION +! AUTHOR. +! ------- +! ADAPTED FROM SRTM_SPCVRT_MCICA (BY JEAN-JACQUES MORCRETTE) BY +! ROBIN HOGAN +! +! MODIFICATIONS. +! -------------- +! ORIGINAL : 2015-07-16 + +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE PARSRTM , ONLY : JPB1, JPB2 +USE YOESRTM , ONLY : JPGPT +USE YOESRTWN , ONLY : NGC + +IMPLICIT NONE + +! ------------------------------------------------------------------ + +!* 0.1 ARGUMENTS +! --------- + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: POD(KIDIA:KFDIA,KLEV,JPGPT) ! Optical depth +REAL(KIND=JPRB) ,INTENT(INOUT) :: PSSA(KIDIA:KFDIA,KLEV,JPGPT) ! Single scattering albedo +REAL(KIND=JPRB) ,INTENT(INOUT) :: PINCSOL(KIDIA:KFDIA,JPGPT) ! Incoming solar flux + + +! ------------------------------------------------------------------ + +INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IW(KIDIA:KFDIA), JB, JG, JK, JL, ICOUNT + +!-- Output of SRTM_TAUMOLn routines +REAL(KIND=JPRB) :: ZTAUG(KIDIA:KFDIA,KLEV,16) ! Absorption optical depth +REAL(KIND=JPRB) :: ZTAUR(KIDIA:KFDIA,KLEV,16) ! Rayleigh optical depth +REAL(KIND=JPRB) :: ZSFLXZEN(KIDIA:KFDIA,16) ! Incoming solar flux + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + +#include "srtm_taumol16.intfb.h" +#include "srtm_taumol17.intfb.h" +#include "srtm_taumol18.intfb.h" +#include "srtm_taumol19.intfb.h" +#include "srtm_taumol20.intfb.h" +#include "srtm_taumol21.intfb.h" +#include "srtm_taumol22.intfb.h" +#include "srtm_taumol23.intfb.h" +#include "srtm_taumol24.intfb.h" +#include "srtm_taumol25.intfb.h" +#include "srtm_taumol26.intfb.h" +#include "srtm_taumol27.intfb.h" +#include "srtm_taumol28.intfb.h" +#include "srtm_taumol29.intfb.h" + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('SRTM_GAS_OPTICAL_DEPTH',0,ZHOOK_HANDLE) + +!$ACC DATA CREATE(IW, ZTAUG, ZTAUR, ZSFLXZEN) & +!$ACC PRESENT(PONEMINUS, PRMU0, KLAYTROP, PCOLCH4, PCOLCO2, PCOLH2O, & +!$ACC PCOLMOL, PCOLO2, PCOLO3, PFORFAC, PFORFRAC, KINDFOR, PSELFFAC, & +!$ACC PSELFFRAC, KINDSELF, PFAC00, PFAC01, PFAC10, PFAC11, KJP, & +!$ACC KJT, KJT1, POD, PSSA, PINCSOL) + +IB1=JPB1 +IB2=JPB2 + +ICOUNT=0 +!$ACC WAIT +!$ACC PARALLEL LOOP GANG VECTOR DEFAULT(NONE) REDUCTION(+:ICOUNT) +DO JL = KIDIA, KFDIA + IF (PRMU0(JL) > 0.0_JPRB) THEN + ICOUNT=ICOUNT+1 + IW(JL)=0 + ENDIF +ENDDO +!$ACC END PARALLEL LOOP + +IF (ICOUNT/=0) THEN + + DO JB = IB1, IB2 + IBM = JB-15 + IGT = NGC(IBM) + + !-- for each band, computes the gaseous and Rayleigh optical thickness + ! for all g-points within the band + + IF (JB == 16) THEN + CALL SRTM_TAUMOL16 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS,& + & PCOLH2O , PCOLCH4 , PCOLMOL ,& + & KLAYTROP, PSELFFAC , PSELFFRAC, KINDSELF, PFORFAC , PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 17) THEN + CALL SRTM_TAUMOL17 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLCO2 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 18) THEN + CALL SRTM_TAUMOL18 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLCH4 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 19) THEN + CALL SRTM_TAUMOL19 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLCO2 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 20) THEN + CALL SRTM_TAUMOL20 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLH2O , PCOLCH4 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 21) THEN + CALL SRTM_TAUMOL21 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLCO2 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 22) THEN + CALL SRTM_TAUMOL22 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLMOL , PCOLO2 ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 23) THEN + CALL SRTM_TAUMOL23 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLH2O , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 24) THEN + CALL SRTM_TAUMOL24 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 25) THEN + !--- visible 16000-22650 cm-1 0.4415 - 0.6250 um + CALL SRTM_TAUMOL25 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLH2O , PCOLMOL , PCOLO3 ,& + & KLAYTROP ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 26) THEN + !--- UV-A 22650-29000 cm-1 0.3448 - 0.4415 um + CALL SRTM_TAUMOL26 & + & ( KIDIA , KFDIA , KLEV ,& + & PCOLMOL ,KLAYTROP,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 27) THEN + !--- UV-B 29000-38000 cm-1 0.2632 - 0.3448 um + CALL SRTM_TAUMOL27 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLMOL , PCOLO3 ,& + & KLAYTROP ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 28) THEN + !--- UV-C 38000-50000 cm-1 0.2000 - 0.2632 um + CALL SRTM_TAUMOL28 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLMOL , PCOLO2 , PCOLO3 ,& + & KLAYTROP ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 29) THEN + CALL SRTM_TAUMOL29 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLH2O , PCOLCO2 , PCOLMOL ,& + & KLAYTROP , PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN , ZTAUG , ZTAUR , PRMU0 & + & ) + + ENDIF + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP SEQ + DO JG=1,IGT +! Added for DWD (2020) +!NEC$ ivdep + !$ACC LOOP GANG(STATIC:1) VECTOR + DO JL = KIDIA, KFDIA + IF (PRMU0(JL) > 0.0_JPRB) THEN + IW(JL)=IW(JL)+1 + ! Incoming solar flux into plane perp to incoming radiation + PINCSOL(JL,IW(JL)) = ZSFLXZEN(JL,JG) + ENDIF + ENDDO + + !$ACC LOOP SEQ + DO JK=1,KLEV + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(JL) + DO JL = KIDIA, KFDIA + IF (PRMU0(JL) > 0.0_JPRB) THEN + POD (JL,JK,IW(JL)) = ZTAUR(JL,JK,JG) + ZTAUG(JL,JK,JG) + PSSA(JL,JK,IW(JL)) = ZTAUR(JL,JK,JG) / POD(JL,JK,IW(JL)) + ENDIF + ENDDO + ENDDO + + ENDDO !-- end loop on JG (g point) + !$ACC END PARALLEL + + ENDDO !-- end loop on JB (band) + +ENDIF + +!$ACC WAIT +!$ACC END DATA + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('SRTM_GAS_OPTICAL_DEPTH',1,ZHOOK_HANDLE) + +END SUBROUTINE SRTM_GAS_OPTICAL_DEPTH Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_init.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_init.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_init.F90 (revision 6016) @@ -0,0 +1,153 @@ +SUBROUTINE SRTM_INIT(CDIRECTORY, NWVCONTINUUM) + +!-- read in the basic coefficients to configure RRTM_SW +!- creates module YOESRTWN with BG, NSPA, NSPB, WAVENUM1, WAVENUM2, +! DELWAVE, PREF, PREFLOG, TREF + +USE PARKIND1 ,ONLY : JPIM , JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE PARSRTM , ONLY : JPG, JPSW +USE YOESRTM , ONLY : NGN +USE YOESRTWN , ONLY : NG, NGM, WT, NGC, RWGT, WTSM +!USE YOESRTWN , ONLY : NG, NGM, WT, NGC, NGN, RWGT, WTSM +!USE YOMLUN , ONLY : NULOUT + +IMPLICIT NONE + +CHARACTER(LEN=*), INTENT(IN) :: CDIRECTORY + +! Water vapour continuum model (0=default MT_CKD2.5, 1=CAVIAR) +INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NWVCONTINUUM + +! Local variables +INTEGER(KIND=JPIM) :: IGC, IGCSM, IBND, IG, IND, IPR, IPRSM +REAL(KIND=JPRB) :: ZWTSUM + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +!#include "susrtmcf.intfb.h" +#include "susrtm.intfb.h" +#include "srtm_kgb16.intfb.h" +#include "srtm_kgb17.intfb.h" +#include "srtm_kgb18.intfb.h" +#include "srtm_kgb19.intfb.h" +#include "srtm_kgb20.intfb.h" +#include "srtm_kgb21.intfb.h" +#include "srtm_kgb22.intfb.h" +#include "srtm_kgb23.intfb.h" +#include "srtm_kgb24.intfb.h" +#include "srtm_kgb25.intfb.h" +#include "srtm_kgb26.intfb.h" +#include "srtm_kgb27.intfb.h" +#include "srtm_kgb28.intfb.h" +#include "srtm_kgb29.intfb.h" +!#include "susrtop.intfb.h" + +#include "modify_wv_continuum.intfb.h" + +#include "srtm_cmbgb16.intfb.h" +#include "srtm_cmbgb17.intfb.h" +#include "srtm_cmbgb18.intfb.h" +#include "srtm_cmbgb19.intfb.h" +#include "srtm_cmbgb20.intfb.h" +#include "srtm_cmbgb21.intfb.h" +#include "srtm_cmbgb22.intfb.h" +#include "srtm_cmbgb23.intfb.h" +#include "srtm_cmbgb24.intfb.h" +#include "srtm_cmbgb25.intfb.h" +#include "srtm_cmbgb26.intfb.h" +#include "srtm_cmbgb27.intfb.h" +#include "srtm_cmbgb28.intfb.h" +#include "srtm_cmbgb29.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_INIT',0,ZHOOK_HANDLE) + +!CALL SUSRTMCF +CALL SUSRTM + +!-- read in the molecular absorption coefficients + +CALL SRTM_KGB16(CDIRECTORY) +CALL SRTM_KGB17 +CALL SRTM_KGB18 +CALL SRTM_KGB19 +CALL SRTM_KGB20 +CALL SRTM_KGB21 +CALL SRTM_KGB22 +CALL SRTM_KGB23 +CALL SRTM_KGB24 +CALL SRTM_KGB25 +CALL SRTM_KGB26 +CALL SRTM_KGB27 +CALL SRTM_KGB28 +CALL SRTM_KGB29 + +IF (PRESENT(NWVCONTINUUM)) THEN + ! Modify the shortwave water vapour continuum, if requested + CALL MODIFY_WV_CONTINUUM(NWVCONTINUUM) +END IF + +!-- read in the cloud optical properties +!- creates module YOESRTOP with EXTLIQ1, SSALIQ1, ASYLIQ1, +! EXTICE3, SSAICE3, ASYICE3, FDLICE3 + +!-- RRTM_SW cloud optical properties are not used +! SRTM_CLDPROP is not called +! no need to call SUSRTOP + +!CALL SUSRTOP ( -1 ) + + +!Mike Iacono 20050804 +!-- Perform g-point reduction from 16 per band (224 total points) to +!-- a band dependent number (112 total points) for all absorption +!-- coefficient input data and Planck fraction input data. +!-- Compute relative weighting for new g-point combinations. + +IGCSM = 0 +DO IBND = 1,JPSW + IPRSM = 0 + IF (NGC(IBND) < JPG) THEN + DO IGC = 1,NGC(IBND) + IGCSM = IGCSM + 1 + ZWTSUM = 0. + DO IPR = 1, NGN(IGCSM) + IPRSM = IPRSM + 1 + ZWTSUM = ZWTSUM + WT(IPRSM) + ENDDO + WTSM(IGC) = ZWTSUM + ENDDO + + DO IG = 1,NG(IBND+15) + IND = (IBND-1)*JPG + IG + RWGT(IND) = WT(IG)/WTSM(NGM(IND)) + ENDDO + ELSE + DO IG = 1,NG(IBND+15) + IGCSM = IGCSM + 1 + IND = (IBND-1)*JPG + IG + RWGT(IND) = 1.0 + ENDDO + ENDIF +ENDDO + +CALL SRTM_CMBGB16 +CALL SRTM_CMBGB17 +CALL SRTM_CMBGB18 +CALL SRTM_CMBGB19 +CALL SRTM_CMBGB20 +CALL SRTM_CMBGB21 +CALL SRTM_CMBGB22 +CALL SRTM_CMBGB23 +CALL SRTM_CMBGB24 +CALL SRTM_CMBGB25 +CALL SRTM_CMBGB26 +CALL SRTM_CMBGB27 +CALL SRTM_CMBGB28 +CALL SRTM_CMBGB29 + +!----------------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_INIT',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_INIT + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb16.F90 (revision 6016) @@ -0,0 +1,187 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_KGB16(DIRECTORY) + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 16: 2600-3000 cm-1 (low - H2O,CH4; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA16 , ONLY : KA, KB, KA_D, KB_D, SELFREF, FORREF, SFLUXREF, RAYL, STRRAT1, LAYREFFR + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +CHARACTER(LEN=*), INTENT(IN) :: DIRECTORY + +! KURUCZ +!CHARACTER(LEN = 80) :: CLZZZ +CHARACTER(LEN = 255) :: CLF1 +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB16',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + !CALL GETENV("DATA",CLZZZ) + !IF(CLZZZ /= " ") THEN + ! CLF1=TRIM(CLZZZ)//"/RADSRTM" + CLF1 = DIRECTORY // "/RADSRTM" +#ifdef __ECRAD_LITTLE_ENDIAN + OPEN(NULRAD,FILE=TRIM(CLF1),CONVERT="BIG_ENDIAN",FORM="UNFORMATTED",ACTION="READ",ERR=1000) +#else + WRITE(0,'(A,A)') 'Reading ',TRIM(CLF1) + OPEN(NULRAD,FILE=TRIM(CLF1),FORM="UNFORMATTED",ACTION="READ",ERR=1000) +#endif + !ELSE + ! OPEN(NULRAD,FILE='RADSRTM',FORM="UNFORMATTED",ACTION="READ",ERR=1000) + !ENDIF + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB16:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB16:') +ENDIF + +SFLUXREF = (/ & + & 1.92269_JPRB , 1.72844_JPRB , 1.64326_JPRB , 1.58451_JPRB & + & , 1.44031_JPRB , 1.25108_JPRB , 1.02724_JPRB , 0.776759_JPRB & + & , 0.534444_JPRB , 5.87755E-02_JPRB, 4.86706E-02_JPRB, 3.87989E-02_JPRB & + & , 2.84532E-02_JPRB, 1.82431E-02_JPRB, 6.92320E-03_JPRB, 9.70770E-04_JPRB /) + +! Rayleigh extinction coefficient at v = 2925 cm-1. +RAYL = 2.91E-10_JPRB + +STRRAT1 = 252.131_JPRB + +LAYREFFR = 18 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +FORREF(:, 1) = (/ 0.525585E-05_JPRB, 0.527618E-05_JPRB, 0.746929E-04_JPRB /) +FORREF(:, 2) = (/ 0.794660E-05_JPRB, 0.136902E-04_JPRB, 0.849878E-04_JPRB /) +FORREF(:, 3) = (/ 0.197099E-04_JPRB, 0.733094E-04_JPRB, 0.121687E-03_JPRB /) +FORREF(:, 4) = (/ 0.148274E-03_JPRB, 0.169776E-03_JPRB, 0.164848E-03_JPRB /) +FORREF(:, 5) = (/ 0.230296E-03_JPRB, 0.210384E-03_JPRB, 0.182028E-03_JPRB /) +FORREF(:, 6) = (/ 0.280575E-03_JPRB, 0.259217E-03_JPRB, 0.196080E-03_JPRB /) +FORREF(:, 7) = (/ 0.329034E-03_JPRB, 0.291575E-03_JPRB, 0.207044E-03_JPRB /) +FORREF(:, 8) = (/ 0.349989E-03_JPRB, 0.323471E-03_JPRB, 0.225712E-03_JPRB /) +FORREF(:, 9) = (/ 0.366097E-03_JPRB, 0.321519E-03_JPRB, 0.253150E-03_JPRB /) +FORREF(:,10) = (/ 0.383589E-03_JPRB, 0.355314E-03_JPRB, 0.262555E-03_JPRB /) +FORREF(:,11) = (/ 0.375933E-03_JPRB, 0.372443E-03_JPRB, 0.261313E-03_JPRB /) +FORREF(:,12) = (/ 0.370652E-03_JPRB, 0.382366E-03_JPRB, 0.250070E-03_JPRB /) +FORREF(:,13) = (/ 0.375092E-03_JPRB, 0.379542E-03_JPRB, 0.265794E-03_JPRB /) +FORREF(:,14) = (/ 0.389705E-03_JPRB, 0.384274E-03_JPRB, 0.322135E-03_JPRB /) +FORREF(:,15) = (/ 0.372084E-03_JPRB, 0.390422E-03_JPRB, 0.370035E-03_JPRB /) +FORREF(:,16) = (/ 0.437802E-03_JPRB, 0.373406E-03_JPRB, 0.373222E-03_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.126758E-02_JPRB, 0.105253E-02_JPRB, 0.873963E-03_JPRB, 0.725690E-03_JPRB, 0.602573E-03_JPRB, & + & 0.500344E-03_JPRB, 0.415458E-03_JPRB, 0.344973E-03_JPRB, 0.286447E-03_JPRB, 0.237849E-03_JPRB /) +SELFREF(:, 2) = (/ & + & 0.144006E-02_JPRB, 0.118514E-02_JPRB, 0.975351E-03_JPRB, 0.802697E-03_JPRB, 0.660606E-03_JPRB, & + & 0.543667E-03_JPRB, 0.447429E-03_JPRB, 0.368226E-03_JPRB, 0.303044E-03_JPRB, 0.249400E-03_JPRB /) +SELFREF(:, 3) = (/ & + & 0.294018E-02_JPRB, 0.227428E-02_JPRB, 0.175920E-02_JPRB, 0.136077E-02_JPRB, 0.105258E-02_JPRB, & + & 0.814189E-03_JPRB, 0.629789E-03_JPRB, 0.487153E-03_JPRB, 0.376821E-03_JPRB, 0.291478E-03_JPRB /) +SELFREF(:, 4) = (/ & + & 0.395290E-02_JPRB, 0.348405E-02_JPRB, 0.307081E-02_JPRB, 0.270658E-02_JPRB, 0.238556E-02_JPRB, & + & 0.210261E-02_JPRB, 0.185322E-02_JPRB, 0.163341E-02_JPRB, 0.143967E-02_JPRB, 0.126891E-02_JPRB /) +SELFREF(:, 5) = (/ & + & 0.419122E-02_JPRB, 0.385638E-02_JPRB, 0.354829E-02_JPRB, 0.326481E-02_JPRB, 0.300398E-02_JPRB, & + & 0.276399E-02_JPRB, 0.254317E-02_JPRB, 0.234000E-02_JPRB, 0.215305E-02_JPRB, 0.198104E-02_JPRB /) +SELFREF(:, 6) = (/ & + & 0.495659E-02_JPRB, 0.456777E-02_JPRB, 0.420945E-02_JPRB, 0.387924E-02_JPRB, 0.357494E-02_JPRB, & + & 0.329450E-02_JPRB, 0.303606E-02_JPRB, 0.279790E-02_JPRB, 0.257842E-02_JPRB, 0.237615E-02_JPRB /) +SELFREF(:, 7) = (/ & + & 0.526981E-02_JPRB, 0.490687E-02_JPRB, 0.456893E-02_JPRB, 0.425426E-02_JPRB, 0.396126E-02_JPRB, & + & 0.368844E-02_JPRB, 0.343441E-02_JPRB, 0.319788E-02_JPRB, 0.297764E-02_JPRB, 0.277256E-02_JPRB /) +SELFREF(:, 8) = (/ & + & 0.575426E-02_JPRB, 0.531597E-02_JPRB, 0.491106E-02_JPRB, 0.453699E-02_JPRB, 0.419141E-02_JPRB, & + & 0.387216E-02_JPRB, 0.357722E-02_JPRB, 0.330475E-02_JPRB, 0.305303E-02_JPRB, 0.282048E-02_JPRB /) +SELFREF(:, 9) = (/ & + & 0.549881E-02_JPRB, 0.514328E-02_JPRB, 0.481074E-02_JPRB, 0.449970E-02_JPRB, 0.420877E-02_JPRB, & + & 0.393665E-02_JPRB, 0.368213E-02_JPRB, 0.344406E-02_JPRB, 0.322138E-02_JPRB, 0.301310E-02_JPRB /) +SELFREF(:,10) = (/ & + & 0.605357E-02_JPRB, 0.561246E-02_JPRB, 0.520349E-02_JPRB, 0.482432E-02_JPRB, 0.447278E-02_JPRB, & + & 0.414686E-02_JPRB, 0.384469E-02_JPRB, 0.356453E-02_JPRB, 0.330479E-02_JPRB, 0.306398E-02_JPRB /) +SELFREF(:,11) = (/ & + & 0.640504E-02_JPRB, 0.587858E-02_JPRB, 0.539540E-02_JPRB, 0.495194E-02_JPRB, 0.454492E-02_JPRB, & + & 0.417136E-02_JPRB, 0.382850E-02_JPRB, 0.351382E-02_JPRB, 0.322501E-02_JPRB, 0.295993E-02_JPRB /) +SELFREF(:,12) = (/ & + & 0.677803E-02_JPRB, 0.615625E-02_JPRB, 0.559152E-02_JPRB, 0.507859E-02_JPRB, 0.461271E-02_JPRB, & + & 0.418957E-02_JPRB, 0.380524E-02_JPRB, 0.345617E-02_JPRB, 0.313913E-02_JPRB, 0.285116E-02_JPRB /) +SELFREF(:,13) = (/ & + & 0.690347E-02_JPRB, 0.627003E-02_JPRB, 0.569472E-02_JPRB, 0.517219E-02_JPRB, 0.469761E-02_JPRB, & + & 0.426658E-02_JPRB, 0.387509E-02_JPRB, 0.351953E-02_JPRB, 0.319659E-02_JPRB, 0.290328E-02_JPRB /) +SELFREF(:,14) = (/ & + & 0.692680E-02_JPRB, 0.632795E-02_JPRB, 0.578087E-02_JPRB, 0.528109E-02_JPRB, 0.482452E-02_JPRB, & + & 0.440742E-02_JPRB, 0.402638E-02_JPRB, 0.367828E-02_JPRB, 0.336028E-02_JPRB, 0.306977E-02_JPRB /) +SELFREF(:,15) = (/ & + & 0.754894E-02_JPRB, 0.681481E-02_JPRB, 0.615207E-02_JPRB, 0.555378E-02_JPRB, 0.501367E-02_JPRB, & + & 0.452609E-02_JPRB, 0.408593E-02_JPRB, 0.368857E-02_JPRB, 0.332986E-02_JPRB, 0.300603E-02_JPRB /) +SELFREF(:,16) = (/ & + & 0.760689E-02_JPRB, 0.709755E-02_JPRB, 0.662232E-02_JPRB, 0.617891E-02_JPRB, 0.576519E-02_JPRB, & + & 0.537917E-02_JPRB, 0.501899E-02_JPRB, 0.468293E-02_JPRB, 0.436938E-02_JPRB, 0.407682E-02_JPRB /) + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB16',1,ZHOOK_HANDLE) +RETURN + +1000 CONTINUE +CALL ABOR1("SRTM_KGB16:ERROR OPENING FILE RADSRTM") +1001 CONTINUE +CALL ABOR1("SRTM_KGB16:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB16 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb17.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb17.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb17.F90 (revision 6016) @@ -0,0 +1,193 @@ +SUBROUTINE SRTM_KGB17 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 17: 3250-4000 cm-1 (low - H2O,CO2; high - H2O, CO2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA17 , ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, RAYL, STRRAT, LAYREFFR, & + & KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB17',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB17:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB17:') +ENDIF + +SFLUXREF(:,1) = (/ & + & 3.15613_JPRB , 3.03449_JPRB , 2.92069_JPRB , 2.63874_JPRB , & + & 2.34581_JPRB , 2.06999_JPRB , 1.70906_JPRB , 1.29085_JPRB , & + & 0.874851_JPRB , 0.0955392_JPRB, 0.0787813_JPRB, 0.0621951_JPRB , & + & 0.0459076_JPRB, 0.0294129_JPRB, 0.0110387_JPRB, 0.00159668_JPRB /) + +SFLUXREF(:,2) = (/ & + & 2.83147_JPRB , 2.95919_JPRB , 2.96674_JPRB , 2.77677_JPRB , & + & 2.46826_JPRB , 2.11481_JPRB , 1.73243_JPRB , 1.30279_JPRB , & + & 0.882714_JPRB , 0.0962350_JPRB, 0.0802122_JPRB, 0.0636194_JPRB , & + & 0.0472620_JPRB, 0.0299051_JPRB, 0.0110785_JPRB, 0.00159668_JPRB /) + +SFLUXREF(:,3) = (/ & + & 2.82300_JPRB , 2.94845_JPRB , 2.95887_JPRB , 2.77593_JPRB , & + & 2.47096_JPRB , 2.12596_JPRB , 1.73847_JPRB , 1.30796_JPRB , & + & 0.884395_JPRB , 0.0966936_JPRB, 0.0801996_JPRB, 0.0640199_JPRB , & + & 0.0472803_JPRB, 0.0300515_JPRB, 0.0112366_JPRB, 0.00160814_JPRB /) + +SFLUXREF(:,4) = (/ & + & 2.81715_JPRB , 2.93789_JPRB , 2.95091_JPRB , 2.77046_JPRB , & + & 2.47716_JPRB , 2.13591_JPRB , 1.74365_JPRB , 1.31277_JPRB , & + & 0.887443_JPRB , 0.0967016_JPRB, 0.0803391_JPRB, 0.0642442_JPRB , & + & 0.0472909_JPRB, 0.0300720_JPRB, 0.0114817_JPRB, 0.00161875_JPRB /) + +SFLUXREF(:,5) = (/ & + & 2.82335_JPRB , 2.93168_JPRB , 2.91455_JPRB , 2.75213_JPRB , & + & 2.49168_JPRB , 2.14408_JPRB , 1.75726_JPRB , 1.32401_JPRB , & + & 0.893644_JPRB , 0.0969523_JPRB, 0.0805197_JPRB, 0.0639936_JPRB , & + & 0.0475099_JPRB, 0.0305667_JPRB, 0.0115372_JPRB, 0.00161875_JPRB /) + +! Rayleigh extinction coefficient at v = 3625 cm-1. +RAYL = 6.86E-10_JPRB + +STRRAT = 0.364641_JPRB + +LAYREFFR = 30 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +FORREF(:, 1) = (/ 0.553258E-03_JPRB, 0.555486E-03_JPRB, 0.601339E-03_JPRB, 0.708280E-03_JPRB /) +FORREF(:, 2) = (/ 0.158558E-02_JPRB, 0.162957E-02_JPRB, 0.204991E-02_JPRB, 0.475881E-02_JPRB /) +FORREF(:, 3) = (/ 0.772542E-02_JPRB, 0.784562E-02_JPRB, 0.111979E-01_JPRB, 0.229016E-01_JPRB /) +FORREF(:, 4) = (/ 0.255097E-01_JPRB, 0.256272E-01_JPRB, 0.270691E-01_JPRB, 0.259505E-01_JPRB /) +FORREF(:, 5) = (/ 0.323263E-01_JPRB, 0.324495E-01_JPRB, 0.305535E-01_JPRB, 0.263993E-01_JPRB /) +FORREF(:, 6) = (/ 0.346920E-01_JPRB, 0.348255E-01_JPRB, 0.323586E-01_JPRB, 0.276357E-01_JPRB /) +FORREF(:, 7) = (/ 0.366509E-01_JPRB, 0.366412E-01_JPRB, 0.344434E-01_JPRB, 0.319223E-01_JPRB /) +FORREF(:, 8) = (/ 0.378451E-01_JPRB, 0.375341E-01_JPRB, 0.374369E-01_JPRB, 0.320334E-01_JPRB /) +FORREF(:, 9) = (/ 0.407348E-01_JPRB, 0.396203E-01_JPRB, 0.393988E-01_JPRB, 0.318343E-01_JPRB /) +FORREF(:,10) = (/ 0.433035E-01_JPRB, 0.426488E-01_JPRB, 0.408085E-01_JPRB, 0.332749E-01_JPRB /) +FORREF(:,11) = (/ 0.428254E-01_JPRB, 0.441151E-01_JPRB, 0.408887E-01_JPRB, 0.327077E-01_JPRB /) +FORREF(:,12) = (/ 0.443226E-01_JPRB, 0.446690E-01_JPRB, 0.404676E-01_JPRB, 0.350492E-01_JPRB /) +FORREF(:,13) = (/ 0.466103E-01_JPRB, 0.460809E-01_JPRB, 0.401286E-01_JPRB, 0.370427E-01_JPRB /) +FORREF(:,14) = (/ 0.483928E-01_JPRB, 0.477284E-01_JPRB, 0.380684E-01_JPRB, 0.387940E-01_JPRB /) +FORREF(:,15) = (/ 0.506987E-01_JPRB, 0.490016E-01_JPRB, 0.467069E-01_JPRB, 0.368998E-01_JPRB /) +FORREF(:,16) = (/ 0.510836E-01_JPRB, 0.522771E-01_JPRB, 0.500130E-01_JPRB, 0.483406E-01_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.160537E-01_JPRB, 0.149038E-01_JPRB, 0.138363E-01_JPRB, 0.128452E-01_JPRB, 0.119251E-01_JPRB, & + & 0.110709E-01_JPRB, 0.102779E-01_JPRB, 0.954175E-02_JPRB, 0.885829E-02_JPRB, 0.822379E-02_JPRB /) +SELFREF(:, 2) = (/ & + & 0.365753E-01_JPRB, 0.342267E-01_JPRB, 0.320288E-01_JPRB, 0.299720E-01_JPRB, 0.280474E-01_JPRB, & + & 0.262463E-01_JPRB, 0.245609E-01_JPRB, 0.229837E-01_JPRB, 0.215078E-01_JPRB, 0.201267E-01_JPRB /) +SELFREF(:, 3) = (/ & + & 0.127419E+00_JPRB, 0.118553E+00_JPRB, 0.110304E+00_JPRB, 0.102629E+00_JPRB, 0.954883E-01_JPRB, & + & 0.888442E-01_JPRB, 0.826624E-01_JPRB, 0.769107E-01_JPRB, 0.715593E-01_JPRB, 0.665802E-01_JPRB /) +SELFREF(:, 4) = (/ & + & 0.378687E+00_JPRB, 0.348961E+00_JPRB, 0.321568E+00_JPRB, 0.296325E+00_JPRB, 0.273064E+00_JPRB, & + & 0.251629E+00_JPRB, 0.231876E+00_JPRB, 0.213674E+00_JPRB, 0.196901E+00_JPRB, 0.181444E+00_JPRB /) +SELFREF(:, 5) = (/ & + & 0.472822E+00_JPRB, 0.435018E+00_JPRB, 0.400236E+00_JPRB, 0.368236E+00_JPRB, 0.338794E+00_JPRB, & + & 0.311706E+00_JPRB, 0.286783E+00_JPRB, 0.263854E+00_JPRB, 0.242757E+00_JPRB, 0.223348E+00_JPRB /) +SELFREF(:, 6) = (/ & + & 0.505620E+00_JPRB, 0.465050E+00_JPRB, 0.427736E+00_JPRB, 0.393416E+00_JPRB, 0.361849E+00_JPRB, & + & 0.332815E+00_JPRB, 0.306111E+00_JPRB, 0.281550E+00_JPRB, 0.258959E+00_JPRB, 0.238181E+00_JPRB /) +SELFREF(:, 7) = (/ & + & 0.530488E+00_JPRB, 0.487993E+00_JPRB, 0.448902E+00_JPRB, 0.412943E+00_JPRB, 0.379864E+00_JPRB, & + & 0.349434E+00_JPRB, 0.321443E+00_JPRB, 0.295694E+00_JPRB, 0.272007E+00_JPRB, 0.250218E+00_JPRB /) +SELFREF(:, 8) = (/ & + & 0.540222E+00_JPRB, 0.497746E+00_JPRB, 0.458610E+00_JPRB, 0.422551E+00_JPRB, 0.389327E+00_JPRB, & + & 0.358716E+00_JPRB, 0.330511E+00_JPRB, 0.304524E+00_JPRB, 0.280580E+00_JPRB, 0.258519E+00_JPRB /) +SELFREF(:, 9) = (/ & + & 0.565727E+00_JPRB, 0.522899E+00_JPRB, 0.483313E+00_JPRB, 0.446724E+00_JPRB, 0.412905E+00_JPRB, & + & 0.381646E+00_JPRB, 0.352753E+00_JPRB, 0.326048E+00_JPRB, 0.301365E+00_JPRB, 0.278550E+00_JPRB /) +SELFREF(:,10) = (/ & + & 0.610122E+00_JPRB, 0.562337E+00_JPRB, 0.518295E+00_JPRB, 0.477702E+00_JPRB, 0.440289E+00_JPRB, & + & 0.405806E+00_JPRB, 0.374023E+00_JPRB, 0.344730E+00_JPRB, 0.317730E+00_JPRB, 0.292846E+00_JPRB /) +SELFREF(:,11) = (/ & + & 0.645176E+00_JPRB, 0.588957E+00_JPRB, 0.537636E+00_JPRB, 0.490788E+00_JPRB, 0.448022E+00_JPRB, & + & 0.408982E+00_JPRB, 0.373344E+00_JPRB, 0.340812E+00_JPRB, 0.311114E+00_JPRB, 0.284004E+00_JPRB /) +SELFREF(:,12) = (/ & + & 0.651737E+00_JPRB, 0.596547E+00_JPRB, 0.546031E+00_JPRB, 0.499792E+00_JPRB, 0.457469E+00_JPRB, & + & 0.418730E+00_JPRB, 0.383272E+00_JPRB, 0.350816E+00_JPRB, 0.321108E+00_JPRB, 0.293916E+00_JPRB /) +SELFREF(:,13) = (/ & + & 0.661086E+00_JPRB, 0.607954E+00_JPRB, 0.559093E+00_JPRB, 0.514159E+00_JPRB, 0.472836E+00_JPRB, & + & 0.434834E+00_JPRB, 0.399886E+00_JPRB, 0.367747E+00_JPRB, 0.338191E+00_JPRB, 0.311011E+00_JPRB /) +SELFREF(:,14) = (/ & + & 0.692554E+00_JPRB, 0.635574E+00_JPRB, 0.583282E+00_JPRB, 0.535293E+00_JPRB, 0.491251E+00_JPRB, & + & 0.450834E+00_JPRB, 0.413741E+00_JPRB, 0.379701E+00_JPRB, 0.348461E+00_JPRB, 0.319791E+00_JPRB /) +SELFREF(:,15) = (/ & + & 0.714646E+00_JPRB, 0.657179E+00_JPRB, 0.604334E+00_JPRB, 0.555737E+00_JPRB, 0.511049E+00_JPRB, & + & 0.469954E+00_JPRB, 0.432164E+00_JPRB, 0.397412E+00_JPRB, 0.365455E+00_JPRB, 0.336068E+00_JPRB /) +SELFREF(:,16) = (/ & + & 0.782126E+00_JPRB, 0.710682E+00_JPRB, 0.645764E+00_JPRB, 0.586776E+00_JPRB, 0.533177E+00_JPRB, & + & 0.484473E+00_JPRB, 0.440219E+00_JPRB, 0.400007E+00_JPRB, 0.363468E+00_JPRB, 0.330266E+00_JPRB /) + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB17',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB17:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB17 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb18.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb18.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb18.F90 (revision 6016) @@ -0,0 +1,209 @@ +SUBROUTINE SRTM_KGB18 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 18: 4000-4650 cm-1 (low - H2O,CH4; high - CH4) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA18 , ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, RAYL, STRRAT, LAYREFFR, & + & KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB18',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB18:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB18:') +ENDIF + +SFLUXREF(:,1) = (/ & + & 3.65840_JPRB , 3.54375_JPRB , 3.34481_JPRB , 3.10534_JPRB , & + & 2.79879_JPRB , 2.42841_JPRB , 1.98748_JPRB , 1.49377_JPRB , & + & 1.00196_JPRB , 0.108342_JPRB , 8.95099E-02_JPRB, 7.05199E-02_JPRB, & + & 5.16432E-02_JPRB, 3.27635E-02_JPRB, 1.25133E-02_JPRB, 1.73001E-03_JPRB /) +SFLUXREF(:,2) = (/ & + & 3.86372_JPRB , 3.48521_JPRB , 3.30790_JPRB , 3.08103_JPRB , & + & 2.77552_JPRB , 2.40722_JPRB , 1.97307_JPRB , 1.48023_JPRB , & + & 0.993055_JPRB , 0.107691_JPRB , 8.84430E-02_JPRB, 6.99354E-02_JPRB, & + & 5.07881E-02_JPRB, 3.24121E-02_JPRB, 1.19442E-02_JPRB, 1.57612E-03_JPRB /) +SFLUXREF(:,3) = (/ & + & 3.90370_JPRB , 3.50657_JPRB , 3.30629_JPRB , 3.06046_JPRB , & + & 2.76982_JPRB , 2.39907_JPRB , 1.96358_JPRB , 1.47458_JPRB , & + & 0.988475_JPRB , 0.106698_JPRB , 8.75242E-02_JPRB, 6.85898E-02_JPRB, & + & 5.04798E-02_JPRB, 3.13718E-02_JPRB, 1.09533E-02_JPRB, 1.57612E-03_JPRB /) +SFLUXREF(:,4) = (/ & + & 3.93165_JPRB , 3.52058_JPRB , 3.31346_JPRB , 3.04944_JPRB , & + & 2.76074_JPRB , 2.39433_JPRB , 1.95556_JPRB , 1.46712_JPRB , & + & 0.984056_JPRB , 0.105885_JPRB , 8.73062E-02_JPRB, 6.84054E-02_JPRB, & + & 4.87443E-02_JPRB, 2.99295E-02_JPRB, 1.09533E-02_JPRB, 1.57612E-03_JPRB /) +SFLUXREF(:,5) = (/ & + & 3.94082_JPRB , 3.55221_JPRB , 3.31863_JPRB , 3.04730_JPRB , & + & 2.74918_JPRB , 2.38328_JPRB , 1.95212_JPRB , 1.45889_JPRB , & + & 0.978888_JPRB , 0.105102_JPRB , 8.65732E-02_JPRB, 6.74563E-02_JPRB, & + & 4.76592E-02_JPRB, 2.91017E-02_JPRB, 1.09533E-02_JPRB, 1.57612E-03_JPRB /) +SFLUXREF(:,6) = (/ & + & 3.94198_JPRB , 3.58743_JPRB , 3.32106_JPRB , 3.05866_JPRB , & + & 2.74115_JPRB , 2.36939_JPRB , 1.94305_JPRB , 1.45180_JPRB , & + & 0.971784_JPRB , 1.04045E-01_JPRB, 8.53731E-02_JPRB, 6.60654E-02_JPRB, & + & 4.63228E-02_JPRB, 2.91016E-02_JPRB, 1.09552E-02_JPRB, 1.57612E-03_JPRB /) +SFLUXREF(:,7) = (/ & + & 3.93596_JPRB , 3.63366_JPRB , 3.33144_JPRB , 3.06252_JPRB , & + & 2.74054_JPRB , 2.35492_JPRB , 1.92769_JPRB , 1.44300_JPRB , & + & 0.961809_JPRB , 1.02867E-01_JPRB, 8.34164E-02_JPRB, 6.41005E-02_JPRB, & + & 4.61826E-02_JPRB, 2.91006E-02_JPRB, 1.09553E-02_JPRB, 1.57612E-03_JPRB /) +SFLUXREF(:,8) = (/ & + & 3.92520_JPRB , 3.69078_JPRB , 3.35656_JPRB , 3.07055_JPRB , & + & 2.73862_JPRB , 2.34430_JPRB , 1.90187_JPRB , 1.42242_JPRB , & + & 0.946676_JPRB , 9.96302E-02_JPRB, 8.14421E-02_JPRB, 6.38622E-02_JPRB, & + & 4.61794E-02_JPRB, 2.91017E-02_JPRB, 1.09553E-02_JPRB, 1.57612E-03_JPRB /) +SFLUXREF(:,9) = (/ & + & 3.80721_JPRB , 3.74437_JPRB , 3.50205_JPRB , 3.18009_JPRB , & + & 2.75757_JPRB , 2.29188_JPRB , 1.84382_JPRB , 1.35694_JPRB , & + & 0.914040_JPRB , 9.86811E-02_JPRB, 8.14321E-02_JPRB, 6.38541E-02_JPRB, & + & 4.61795E-02_JPRB, 2.90960E-02_JPRB, 1.09613E-02_JPRB, 1.57612E-03_JPRB /) + +! Rayleigh extinction coefficient at v = 4325 cm-1. +RAYL = 1.39E-09_JPRB + +STRRAT = 38.9589_JPRB + +LAYREFFR = 6 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +FORREF(:, 1) = (/ 0.860560E-06_JPRB, 0.130439E-05_JPRB, 0.382378E-05_JPRB /) +FORREF(:, 2) = (/ 0.817926E-06_JPRB, 0.158599E-05_JPRB, 0.658771E-04_JPRB /) +FORREF(:, 3) = (/ 0.129369E-05_JPRB, 0.824406E-05_JPRB, 0.952778E-04_JPRB /) +FORREF(:, 4) = (/ 0.438918E-05_JPRB, 0.375356E-04_JPRB, 0.119111E-03_JPRB /) +FORREF(:, 5) = (/ 0.306057E-04_JPRB, 0.622798E-04_JPRB, 0.100740E-03_JPRB /) +FORREF(:, 6) = (/ 0.891934E-04_JPRB, 0.856393E-04_JPRB, 0.635583E-04_JPRB /) +FORREF(:, 7) = (/ 0.171959E-03_JPRB, 0.173431E-03_JPRB, 0.611721E-04_JPRB /) +FORREF(:, 8) = (/ 0.357795E-03_JPRB, 0.247261E-03_JPRB, 0.488864E-04_JPRB /) +FORREF(:, 9) = (/ 0.326623E-03_JPRB, 0.289471E-03_JPRB, 0.548834E-04_JPRB /) +FORREF(:,10) = (/ 0.345103E-03_JPRB, 0.320898E-03_JPRB, 0.633214E-04_JPRB /) +FORREF(:,11) = (/ 0.392567E-03_JPRB, 0.325153E-03_JPRB, 0.744479E-04_JPRB /) +FORREF(:,12) = (/ 0.349277E-03_JPRB, 0.345610E-03_JPRB, 0.916479E-04_JPRB /) +FORREF(:,13) = (/ 0.425161E-03_JPRB, 0.348452E-03_JPRB, 0.125788E-03_JPRB /) +FORREF(:,14) = (/ 0.407594E-03_JPRB, 0.435836E-03_JPRB, 0.287583E-03_JPRB /) +FORREF(:,15) = (/ 0.521605E-03_JPRB, 0.486596E-03_JPRB, 0.483511E-03_JPRB /) +FORREF(:,16) = (/ 0.773790E-03_JPRB, 0.737247E-03_JPRB, 0.665939E-03_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.750370E-03_JPRB, 0.644938E-03_JPRB, 0.554321E-03_JPRB, 0.476436E-03_JPRB, 0.409494E-03_JPRB, & + & 0.351957E-03_JPRB, 0.302505E-03_JPRB, 0.260002E-03_JPRB, 0.223470E-03_JPRB, 0.192071E-03_JPRB /) +SELFREF(:, 2) = (/ & + & 0.136135E-02_JPRB, 0.113187E-02_JPRB, 0.941076E-03_JPRB, 0.782440E-03_JPRB, 0.650546E-03_JPRB, & + & 0.540885E-03_JPRB, 0.449709E-03_JPRB, 0.373902E-03_JPRB, 0.310874E-03_JPRB, 0.258471E-03_JPRB /) +SELFREF(:, 3) = (/ & + & 0.333950E-02_JPRB, 0.256391E-02_JPRB, 0.196845E-02_JPRB, 0.151129E-02_JPRB, 0.116030E-02_JPRB, & + & 0.890824E-03_JPRB, 0.683934E-03_JPRB, 0.525093E-03_JPRB, 0.403143E-03_JPRB, 0.309515E-03_JPRB /) +SELFREF(:, 4) = (/ & + & 0.793392E-02_JPRB, 0.589865E-02_JPRB, 0.438548E-02_JPRB, 0.326048E-02_JPRB, 0.242408E-02_JPRB, & + & 0.180223E-02_JPRB, 0.133991E-02_JPRB, 0.996186E-03_JPRB, 0.740636E-03_JPRB, 0.550642E-03_JPRB /) +SELFREF(:, 5) = (/ & + & 0.828169E-02_JPRB, 0.703139E-02_JPRB, 0.596984E-02_JPRB, 0.506856E-02_JPRB, 0.430335E-02_JPRB, & + & 0.365366E-02_JPRB, 0.310206E-02_JPRB, 0.263374E-02_JPRB, 0.223612E-02_JPRB, 0.189852E-02_JPRB /) +SELFREF(:, 6) = (/ & + & 0.834190E-02_JPRB, 0.780225E-02_JPRB, 0.729750E-02_JPRB, 0.682541E-02_JPRB, 0.638386E-02_JPRB, & + & 0.597087E-02_JPRB, 0.558460E-02_JPRB, 0.522332E-02_JPRB, 0.488541E-02_JPRB, 0.456936E-02_JPRB /) +SELFREF(:, 7) = (/ & + & 0.119082E-01_JPRB, 0.112566E-01_JPRB, 0.106406E-01_JPRB, 0.100583E-01_JPRB, 0.950785E-02_JPRB, & + & 0.898755E-02_JPRB, 0.849571E-02_JPRB, 0.803080E-02_JPRB, 0.759132E-02_JPRB, 0.717590E-02_JPRB /) +SELFREF(:, 8) = (/ & + & 0.144004E-01_JPRB, 0.141762E-01_JPRB, 0.139554E-01_JPRB, 0.137381E-01_JPRB, 0.135241E-01_JPRB, & + & 0.133135E-01_JPRB, 0.131062E-01_JPRB, 0.129021E-01_JPRB, 0.127011E-01_JPRB, 0.125033E-01_JPRB /) +SELFREF(:, 9) = (/ & + & 0.186171E-01_JPRB, 0.175281E-01_JPRB, 0.165027E-01_JPRB, 0.155373E-01_JPRB, 0.146284E-01_JPRB, & + & 0.137726E-01_JPRB, 0.129670E-01_JPRB, 0.122084E-01_JPRB, 0.114942E-01_JPRB, 0.108218E-01_JPRB /) +SELFREF(:,10) = (/ & + & 0.209396E-01_JPRB, 0.195077E-01_JPRB, 0.181737E-01_JPRB, 0.169309E-01_JPRB, 0.157731E-01_JPRB, & + & 0.146945E-01_JPRB, 0.136897E-01_JPRB, 0.127535E-01_JPRB, 0.118814E-01_JPRB, 0.110689E-01_JPRB /) +SELFREF(:,11) = (/ & + & 0.203661E-01_JPRB, 0.193311E-01_JPRB, 0.183487E-01_JPRB, 0.174163E-01_JPRB, 0.165312E-01_JPRB, & + & 0.156911E-01_JPRB, 0.148937E-01_JPRB, 0.141368E-01_JPRB, 0.134184E-01_JPRB, 0.127365E-01_JPRB /) +SELFREF(:,12) = (/ & + & 0.226784E-01_JPRB, 0.210210E-01_JPRB, 0.194848E-01_JPRB, 0.180608E-01_JPRB, 0.167409E-01_JPRB, & + & 0.155174E-01_JPRB, 0.143834E-01_JPRB, 0.133322E-01_JPRB, 0.123579E-01_JPRB, 0.114547E-01_JPRB /) +SELFREF(:,13) = (/ & + & 0.221773E-01_JPRB, 0.210306E-01_JPRB, 0.199433E-01_JPRB, 0.189122E-01_JPRB, 0.179344E-01_JPRB, & + & 0.170071E-01_JPRB, 0.161278E-01_JPRB, 0.152939E-01_JPRB, 0.145032E-01_JPRB, 0.137533E-01_JPRB /) +SELFREF(:,14) = (/ & + & 0.275920E-01_JPRB, 0.252595E-01_JPRB, 0.231241E-01_JPRB, 0.211693E-01_JPRB, 0.193797E-01_JPRB, & + & 0.177415E-01_JPRB, 0.162417E-01_JPRB, 0.148687E-01_JPRB, 0.136117E-01_JPRB, 0.124610E-01_JPRB /) +SELFREF(:,15) = (/ & + & 0.288687E-01_JPRB, 0.269968E-01_JPRB, 0.252462E-01_JPRB, 0.236092E-01_JPRB, 0.220783E-01_JPRB, & + & 0.206466E-01_JPRB, 0.193078E-01_JPRB, 0.180559E-01_JPRB, 0.168851E-01_JPRB, 0.157902E-01_JPRB /) +SELFREF(:,16) = (/ & + & 0.371842E-01_JPRB, 0.347595E-01_JPRB, 0.324929E-01_JPRB, 0.303741E-01_JPRB, 0.283934E-01_JPRB, & + & 0.265419E-01_JPRB, 0.248112E-01_JPRB, 0.231933E-01_JPRB, 0.216809E-01_JPRB, 0.202671E-01_JPRB /) + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB18',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB18:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB18 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb19.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb19.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb19.F90 (revision 6016) @@ -0,0 +1,209 @@ +SUBROUTINE SRTM_KGB19 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 16: 4650-5150 cm-1 (low - H2O,CO2; high - CO2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA19 , ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, RAYL, STRRAT, LAYREFFR, & + & KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB19',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB19:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB19:') +ENDIF + +SFLUXREF(:,1) = (/ & + & 3.25791_JPRB , 3.29697_JPRB , 3.16031_JPRB , 2.96115_JPRB , & + & 2.69238_JPRB , 2.33819_JPRB , 1.92760_JPRB , 1.44918_JPRB , & + & 0.979764_JPRB , 0.107336_JPRB , 8.94523E-02_JPRB, 6.98325E-02_JPRB, & + & 5.12051E-02_JPRB, 3.23645E-02_JPRB, 1.23401E-02_JPRB, 1.71339E-03_JPRB /) +SFLUXREF(:,2) = (/ & + & 3.22769_JPRB , 3.28817_JPRB , 3.16687_JPRB , 2.97662_JPRB , & + & 2.69495_JPRB , 2.34392_JPRB , 1.92900_JPRB , 1.45391_JPRB , & + & 0.982522_JPRB , 0.107638_JPRB , 8.92458E-02_JPRB, 6.99885E-02_JPRB, & + & 5.09679E-02_JPRB, 3.23789E-02_JPRB, 1.22673E-02_JPRB, 1.56040E-03_JPRB /) +SFLUXREF(:,3) = (/ & + & 3.22294_JPRB , 3.27780_JPRB , 3.17424_JPRB , 2.97143_JPRB , & + & 2.69785_JPRB , 2.34993_JPRB , 1.93155_JPRB , 1.45196_JPRB , & + & 0.985329_JPRB , 0.108027_JPRB , 8.93552E-02_JPRB, 6.99937E-02_JPRB, & + & 5.11678E-02_JPRB, 3.24846E-02_JPRB, 1.20636E-02_JPRB, 1.56040E-03_JPRB /) +SFLUXREF(:,4) = (/ & + & 3.22445_JPRB , 3.26113_JPRB , 3.18438_JPRB , 2.96921_JPRB , & + & 2.69579_JPRB , 2.35586_JPRB , 1.93454_JPRB , 1.44949_JPRB , & + & 0.987347_JPRB , 0.108611_JPRB , 8.91643E-02_JPRB, 7.02236E-02_JPRB, & + & 5.12980E-02_JPRB, 3.25282E-02_JPRB, 1.21189E-02_JPRB, 1.56040E-03_JPRB /) +SFLUXREF(:,5) = (/ & + & 3.22497_JPRB , 3.25109_JPRB , 3.18741_JPRB , 2.96970_JPRB , & + & 2.69460_JPRB , 2.36020_JPRB , 1.93301_JPRB , 1.45224_JPRB , & + & 0.988564_JPRB , 0.108255_JPRB , 8.93830E-02_JPRB, 7.03655E-02_JPRB, & + & 5.13017E-02_JPRB, 3.29414E-02_JPRB, 1.21189E-02_JPRB, 1.56040E-03_JPRB /) +SFLUXREF(:,6) = (/ & + & 3.22632_JPRB , 3.24174_JPRB , 3.18524_JPRB , 2.97402_JPRB , & + & 2.69807_JPRB , 2.35742_JPRB , 1.93377_JPRB , 1.45621_JPRB , & + & 0.988132_JPRB , 0.108344_JPRB , 8.93188E-02_JPRB, 7.04907E-02_JPRB, & + & 5.17938E-02_JPRB, 3.31465E-02_JPRB, 1.21155E-02_JPRB, 1.56040E-03_JPRB /) +SFLUXREF(:,7) = (/ & + & 3.22793_JPRB , 3.23589_JPRB , 3.17720_JPRB , 2.97869_JPRB , & + & 2.70293_JPRB , 2.35436_JPRB , 1.93557_JPRB , 1.45868_JPRB , & + & 0.988654_JPRB , 0.108198_JPRB , 8.93375E-02_JPRB, 7.09790E-02_JPRB, & + & 5.24733E-02_JPRB, 3.31298E-02_JPRB, 1.21126E-02_JPRB, 1.56040E-03_JPRB /) +SFLUXREF(:,8) = (/ & + & 3.22966_JPRB , 3.24087_JPRB , 3.15676_JPRB , 2.98171_JPRB , & + & 2.70894_JPRB , 2.34975_JPRB , 1.93855_JPRB , 1.46354_JPRB , & + & 0.988544_JPRB , 0.108574_JPRB , 9.02522E-02_JPRB, 7.12908E-02_JPRB, & + & 5.24844E-02_JPRB, 3.31084E-02_JPRB, 1.21060E-02_JPRB, 1.56040E-03_JPRB /) +SFLUXREF(:,9) = (/ & + & 3.27240_JPRB , 3.24666_JPRB , 3.13886_JPRB , 2.95238_JPRB , & + & 2.70190_JPRB , 2.34460_JPRB , 1.93948_JPRB , 1.47111_JPRB , & + & 0.990821_JPRB , 0.108730_JPRB , 9.01625E-02_JPRB, 7.13261E-02_JPRB, & + & 5.24813E-02_JPRB, 3.31083E-02_JPRB, 1.21126E-02_JPRB, 1.56040E-03_JPRB /) + +! Rayleigh extinction coefficient at v = 4900 cm-1. +RAYL = 2.29E-09_JPRB + +STRRAT = 5.49281_JPRB + +LAYREFFR = 3 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +FORREF(:, 1) = (/ 0.106275E-05_JPRB, 0.104185E-05_JPRB, 0.420154E-05_JPRB /) +FORREF(:, 2) = (/ 0.154343E-05_JPRB, 0.653193E-05_JPRB, 0.174596E-04_JPRB /) +FORREF(:, 3) = (/ 0.348917E-05_JPRB, 0.108420E-04_JPRB, 0.540849E-04_JPRB /) +FORREF(:, 4) = (/ 0.145822E-04_JPRB, 0.156027E-04_JPRB, 0.881263E-04_JPRB /) +FORREF(:, 5) = (/ 0.220204E-04_JPRB, 0.819892E-04_JPRB, 0.817937E-04_JPRB /) +FORREF(:, 6) = (/ 0.447840E-04_JPRB, 0.121116E-03_JPRB, 0.932635E-04_JPRB /) +FORREF(:, 7) = (/ 0.166516E-03_JPRB, 0.147640E-03_JPRB, 0.754029E-04_JPRB /) +FORREF(:, 8) = (/ 0.234756E-03_JPRB, 0.145934E-03_JPRB, 0.771734E-04_JPRB /) +FORREF(:, 9) = (/ 0.289207E-03_JPRB, 0.146768E-03_JPRB, 0.677806E-04_JPRB /) +FORREF(:,10) = (/ 0.334959E-03_JPRB, 0.125513E-03_JPRB, 0.636648E-04_JPRB /) +FORREF(:,11) = (/ 0.333755E-03_JPRB, 0.136575E-03_JPRB, 0.593651E-04_JPRB /) +FORREF(:,12) = (/ 0.340042E-03_JPRB, 0.116259E-03_JPRB, 0.595192E-04_JPRB /) +FORREF(:,13) = (/ 0.422470E-03_JPRB, 0.148691E-03_JPRB, 0.630266E-04_JPRB /) +FORREF(:,14) = (/ 0.440655E-03_JPRB, 0.461917E-04_JPRB, 0.108222E-04_JPRB /) +FORREF(:,15) = (/ 0.486207E-03_JPRB, 0.428458E-03_JPRB, 0.108086E-04_JPRB /) +FORREF(:,16) = (/ 0.657463E-03_JPRB, 0.657446E-03_JPRB, 0.126190E-04_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.331728E-03_JPRB, 0.287480E-03_JPRB, 0.249135E-03_JPRB, 0.215904E-03_JPRB, 0.187106E-03_JPRB, & + & 0.162149E-03_JPRB, 0.140520E-03_JPRB, 0.121777E-03_JPRB, 0.105534E-03_JPRB, 0.914573E-04_JPRB /) +SELFREF(:, 2) = (/ & + & 0.882628E-03_JPRB, 0.698914E-03_JPRB, 0.553439E-03_JPRB, 0.438244E-03_JPRB, 0.347026E-03_JPRB, & + & 0.274795E-03_JPRB, 0.217598E-03_JPRB, 0.172306E-03_JPRB, 0.136442E-03_JPRB, 0.108042E-03_JPRB /) +SELFREF(:, 3) = (/ & + & 0.115461E-02_JPRB, 0.937203E-03_JPRB, 0.760730E-03_JPRB, 0.617486E-03_JPRB, 0.501215E-03_JPRB, & + & 0.406837E-03_JPRB, 0.330231E-03_JPRB, 0.268049E-03_JPRB, 0.217576E-03_JPRB, 0.176607E-03_JPRB /) +SELFREF(:, 4) = (/ & + & 0.103450E-02_JPRB, 0.960268E-03_JPRB, 0.891360E-03_JPRB, 0.827397E-03_JPRB, 0.768024E-03_JPRB, & + & 0.712911E-03_JPRB, 0.661754E-03_JPRB, 0.614267E-03_JPRB, 0.570188E-03_JPRB, 0.529272E-03_JPRB /) +SELFREF(:, 5) = (/ & + & 0.289040E-02_JPRB, 0.240129E-02_JPRB, 0.199495E-02_JPRB, 0.165737E-02_JPRB, 0.137692E-02_JPRB, & + & 0.114392E-02_JPRB, 0.950351E-03_JPRB, 0.789535E-03_JPRB, 0.655933E-03_JPRB, 0.544938E-03_JPRB /) +SELFREF(:, 6) = (/ & + & 0.361772E-02_JPRB, 0.306611E-02_JPRB, 0.259861E-02_JPRB, 0.220239E-02_JPRB, 0.186659E-02_JPRB, & + & 0.158198E-02_JPRB, 0.134077E-02_JPRB, 0.113634E-02_JPRB, 0.963078E-03_JPRB, 0.816234E-03_JPRB /) +SELFREF(:, 7) = (/ & + & 0.329878E-02_JPRB, 0.318245E-02_JPRB, 0.307021E-02_JPRB, 0.296194E-02_JPRB, 0.285749E-02_JPRB, & + & 0.275671E-02_JPRB, 0.265950E-02_JPRB, 0.256571E-02_JPRB, 0.247522E-02_JPRB, 0.238793E-02_JPRB /) +SELFREF(:, 8) = (/ & + & 0.293562E-02_JPRB, 0.300077E-02_JPRB, 0.306737E-02_JPRB, 0.313544E-02_JPRB, 0.320503E-02_JPRB, & + & 0.327615E-02_JPRB, 0.334886E-02_JPRB, 0.342318E-02_JPRB, 0.349915E-02_JPRB, 0.357680E-02_JPRB /) +SELFREF(:, 9) = (/ & + & 0.281453E-02_JPRB, 0.295894E-02_JPRB, 0.311076E-02_JPRB, 0.327038E-02_JPRB, 0.343818E-02_JPRB, & + & 0.361459E-02_JPRB, 0.380006E-02_JPRB, 0.399504E-02_JPRB, 0.420002E-02_JPRB, 0.441553E-02_JPRB /) +SELFREF(:,10) = (/ & + & 0.239488E-02_JPRB, 0.262487E-02_JPRB, 0.287696E-02_JPRB, 0.315325E-02_JPRB, 0.345607E-02_JPRB, & + & 0.378798E-02_JPRB, 0.415176E-02_JPRB, 0.455048E-02_JPRB, 0.498749E-02_JPRB, 0.546647E-02_JPRB /) +SELFREF(:,11) = (/ & + & 0.271001E-02_JPRB, 0.292235E-02_JPRB, 0.315134E-02_JPRB, 0.339826E-02_JPRB, 0.366453E-02_JPRB, & + & 0.395167E-02_JPRB, 0.426131E-02_JPRB, 0.459521E-02_JPRB, 0.495527E-02_JPRB, 0.534354E-02_JPRB /) +SELFREF(:,12) = (/ & + & 0.206702E-02_JPRB, 0.232254E-02_JPRB, 0.260966E-02_JPRB, 0.293226E-02_JPRB, 0.329475E-02_JPRB, & + & 0.370204E-02_JPRB, 0.415969E-02_JPRB, 0.467391E-02_JPRB, 0.525169E-02_JPRB, 0.590090E-02_JPRB /) +SELFREF(:,13) = (/ & + & 0.227023E-02_JPRB, 0.257331E-02_JPRB, 0.291685E-02_JPRB, 0.330626E-02_JPRB, 0.374766E-02_JPRB, & + & 0.424799E-02_JPRB, 0.481511E-02_JPRB, 0.545794E-02_JPRB, 0.618660E-02_JPRB, 0.701253E-02_JPRB /) +SELFREF(:,14) = (/ & + & 0.851078E-03_JPRB, 0.111512E-02_JPRB, 0.146109E-02_JPRB, 0.191439E-02_JPRB, 0.250832E-02_JPRB, & + & 0.328653E-02_JPRB, 0.430617E-02_JPRB, 0.564215E-02_JPRB, 0.739261E-02_JPRB, 0.968616E-02_JPRB /) +SELFREF(:,15) = (/ & + & 0.742711E-02_JPRB, 0.721347E-02_JPRB, 0.700598E-02_JPRB, 0.680446E-02_JPRB, 0.660873E-02_JPRB, & + & 0.641863E-02_JPRB, 0.623400E-02_JPRB, 0.605468E-02_JPRB, 0.588052E-02_JPRB, 0.571137E-02_JPRB /) +SELFREF(:,16) = (/ & + & 0.107170E-01_JPRB, 0.101913E-01_JPRB, 0.969138E-02_JPRB, 0.921599E-02_JPRB, 0.876392E-02_JPRB, & + & 0.833402E-02_JPRB, 0.792521E-02_JPRB, 0.753646E-02_JPRB, 0.716677E-02_JPRB, 0.681522E-02_JPRB /) + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB19',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB19:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB19 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb20.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb20.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb20.F90 (revision 6016) @@ -0,0 +1,174 @@ +SUBROUTINE SRTM_KGB20 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 20: 5150-6150 cm-1 (low - H2O; high - H2O) +! Reformatted for F90 by JJMorcrette, ECMWF +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA20 , ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, RAYL, ABSCH4, LAYREFFR ,& + & KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB20',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB20:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB20:') +ENDIF + +SFLUXREF = (/ & + & 9.34081_JPRB , 8.93720_JPRB , 8.19346_JPRB , 7.39196_JPRB , & + & 6.12127_JPRB , 5.23956_JPRB , 4.24941_JPRB , 3.20013_JPRB , & + & 2.16047_JPRB , 0.234509_JPRB , 0.194593_JPRB , 0.151512_JPRB , & + & 0.110315_JPRB, 7.09959E-02_JPRB, 2.70573E-02_JPRB, 3.36042E-03_JPRB /) + +ABSCH4 = (/ & + & 1.01381E-03_JPRB,6.33692E-03_JPRB,1.94185E-02_JPRB,4.83210E-02_JPRB, & + & 2.36574E-03_JPRB,6.61973E-04_JPRB,5.64552E-04_JPRB,2.83183E-04_JPRB, & + & 7.43623E-05_JPRB,8.90159E-07_JPRB,6.98728E-07_JPRB,6.51832E-08_JPRB, & + & 2.96619E-08_JPRB, 0._JPRB, 0._JPRB, 0._JPRB /) + +! Rayleigh extinction coefficient at v = 5670 cm-1. +RAYL = 4.12E-09_JPRB + +LAYREFFR = 3 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +FORREF(:, 1) = (/ 0.214504E-06_JPRB, 0.460418E-06_JPRB, 0.357608E-05_JPRB, 0.192037E-05_JPRB /) +FORREF(:, 2) = (/ 0.142576E-05_JPRB, 0.364463E-05_JPRB, 0.117033E-04_JPRB, 0.112085E-04_JPRB /) +FORREF(:, 3) = (/ 0.101536E-04_JPRB, 0.124096E-04_JPRB, 0.509190E-04_JPRB, 0.565282E-04_JPRB /) +FORREF(:, 4) = (/ 0.143394E-03_JPRB, 0.154700E-03_JPRB, 0.466498E-03_JPRB, 0.918829E-03_JPRB /) +FORREF(:, 5) = (/ 0.251631E-02_JPRB, 0.241729E-02_JPRB, 0.240057E-02_JPRB, 0.350408E-02_JPRB /) +FORREF(:, 6) = (/ 0.410309E-02_JPRB, 0.416851E-02_JPRB, 0.390925E-02_JPRB, 0.383694E-02_JPRB /) +FORREF(:, 7) = (/ 0.445387E-02_JPRB, 0.448657E-02_JPRB, 0.432310E-02_JPRB, 0.370739E-02_JPRB /) +FORREF(:, 8) = (/ 0.458150E-02_JPRB, 0.460014E-02_JPRB, 0.450245E-02_JPRB, 0.336718E-02_JPRB /) +FORREF(:, 9) = (/ 0.465423E-02_JPRB, 0.465595E-02_JPRB, 0.467006E-02_JPRB, 0.368061E-02_JPRB /) +FORREF(:,10) = (/ 0.493955E-02_JPRB, 0.490181E-02_JPRB, 0.481941E-02_JPRB, 0.367577E-02_JPRB /) +FORREF(:,11) = (/ 0.511876E-02_JPRB, 0.490981E-02_JPRB, 0.493303E-02_JPRB, 0.357423E-02_JPRB /) +FORREF(:,12) = (/ 0.509845E-02_JPRB, 0.511556E-02_JPRB, 0.504031E-02_JPRB, 0.355915E-02_JPRB /) +FORREF(:,13) = (/ 0.523822E-02_JPRB, 0.530473E-02_JPRB, 0.523811E-02_JPRB, 0.414259E-02_JPRB /) +FORREF(:,14) = (/ 0.551133E-02_JPRB, 0.535831E-02_JPRB, 0.546702E-02_JPRB, 0.473875E-02_JPRB /) +FORREF(:,15) = (/ 0.609781E-02_JPRB, 0.589859E-02_JPRB, 0.561187E-02_JPRB, 0.528981E-02_JPRB /) +FORREF(:,16) = (/ 0.644958E-02_JPRB, 0.631718E-02_JPRB, 0.625201E-02_JPRB, 0.600448E-02_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.217058E-03_JPRB, 0.176391E-03_JPRB, 0.143342E-03_JPRB, 0.116486E-03_JPRB, 0.946614E-04_JPRB, & + & 0.769257E-04_JPRB, 0.625131E-04_JPRB, 0.508007E-04_JPRB, 0.412828E-04_JPRB, 0.335481E-04_JPRB /) +SELFREF(:, 2) = (/ & + & 0.598055E-03_JPRB, 0.484805E-03_JPRB, 0.393000E-03_JPRB, 0.318580E-03_JPRB, 0.258252E-03_JPRB, & + & 0.209348E-03_JPRB, 0.169705E-03_JPRB, 0.137569E-03_JPRB, 0.111518E-03_JPRB, 0.904008E-04_JPRB /) +SELFREF(:, 3) = (/ & + & 0.102691E-02_JPRB, 0.930281E-03_JPRB, 0.842740E-03_JPRB, 0.763437E-03_JPRB, 0.691596E-03_JPRB, & + & 0.626516E-03_JPRB, 0.567560E-03_JPRB, 0.514152E-03_JPRB, 0.465769E-03_JPRB, 0.421940E-03_JPRB /) +SELFREF(:, 4) = (/ & + & 0.388569E-02_JPRB, 0.365098E-02_JPRB, 0.343045E-02_JPRB, 0.322324E-02_JPRB, 0.302854E-02_JPRB, & + & 0.284561E-02_JPRB, 0.267372E-02_JPRB, 0.251222E-02_JPRB, 0.236047E-02_JPRB, 0.221789E-02_JPRB /) +SELFREF(:, 5) = (/ & + & 0.349845E-01_JPRB, 0.326678E-01_JPRB, 0.305045E-01_JPRB, 0.284845E-01_JPRB, 0.265982E-01_JPRB, & + & 0.248369E-01_JPRB, 0.231921E-01_JPRB, 0.216563E-01_JPRB, 0.202222E-01_JPRB, 0.188831E-01_JPRB /) +SELFREF(:, 6) = (/ & + & 0.613705E-01_JPRB, 0.562676E-01_JPRB, 0.515890E-01_JPRB, 0.472994E-01_JPRB, 0.433665E-01_JPRB, & + & 0.397606E-01_JPRB, 0.364545E-01_JPRB, 0.334233E-01_JPRB, 0.306442E-01_JPRB, 0.280961E-01_JPRB /) +SELFREF(:, 7) = (/ & + & 0.656981E-01_JPRB, 0.602660E-01_JPRB, 0.552830E-01_JPRB, 0.507120E-01_JPRB, 0.465190E-01_JPRB, & + & 0.426726E-01_JPRB, 0.391443E-01_JPRB, 0.359077E-01_JPRB, 0.329387E-01_JPRB, 0.302153E-01_JPRB /) +SELFREF(:, 8) = (/ & + & 0.671782E-01_JPRB, 0.616461E-01_JPRB, 0.565695E-01_JPRB, 0.519110E-01_JPRB, 0.476361E-01_JPRB, & + & 0.437132E-01_JPRB, 0.401134E-01_JPRB, 0.368100E-01_JPRB, 0.337787E-01_JPRB, 0.309970E-01_JPRB /) +SELFREF(:, 9) = (/ & + & 0.675902E-01_JPRB, 0.620888E-01_JPRB, 0.570351E-01_JPRB, 0.523928E-01_JPRB, 0.481284E-01_JPRB, & + & 0.442110E-01_JPRB, 0.406125E-01_JPRB, 0.373069E-01_JPRB, 0.342703E-01_JPRB, 0.314809E-01_JPRB /) +SELFREF(:,10) = (/ & + & 0.708308E-01_JPRB, 0.651419E-01_JPRB, 0.599099E-01_JPRB, 0.550981E-01_JPRB, 0.506728E-01_JPRB, & + & 0.466030E-01_JPRB, 0.428600E-01_JPRB, 0.394176E-01_JPRB, 0.362517E-01_JPRB, 0.333401E-01_JPRB /) +SELFREF(:,11) = (/ & + & 0.698445E-01_JPRB, 0.646584E-01_JPRB, 0.598573E-01_JPRB, 0.554128E-01_JPRB, 0.512982E-01_JPRB, & + & 0.474892E-01_JPRB, 0.439630E-01_JPRB, 0.406986E-01_JPRB, 0.376766E-01_JPRB, 0.348791E-01_JPRB /) +SELFREF(:,12) = (/ & + & 0.743921E-01_JPRB, 0.682057E-01_JPRB, 0.625337E-01_JPRB, 0.573334E-01_JPRB, 0.525655E-01_JPRB, & + & 0.481942E-01_JPRB, 0.441863E-01_JPRB, 0.405118E-01_JPRB, 0.371428E-01_JPRB, 0.340540E-01_JPRB /) +SELFREF(:,13) = (/ & + & 0.775758E-01_JPRB, 0.709818E-01_JPRB, 0.649484E-01_JPRB, 0.594277E-01_JPRB, 0.543764E-01_JPRB, & + & 0.497544E-01_JPRB, 0.455253E-01_JPRB, 0.416556E-01_JPRB, 0.381149E-01_JPRB, 0.348751E-01_JPRB /) +SELFREF(:,14) = (/ & + & 0.776545E-01_JPRB, 0.714761E-01_JPRB, 0.657894E-01_JPRB, 0.605550E-01_JPRB, 0.557372E-01_JPRB, & + & 0.513026E-01_JPRB, 0.472209E-01_JPRB, 0.434639E-01_JPRB, 0.400058E-01_JPRB, 0.368229E-01_JPRB /) +SELFREF(:,15) = (/ & + & 0.855675E-01_JPRB, 0.787337E-01_JPRB, 0.724456E-01_JPRB, 0.666598E-01_JPRB, 0.613360E-01_JPRB, & + & 0.564374E-01_JPRB, 0.519301E-01_JPRB, 0.477827E-01_JPRB, 0.439666E-01_JPRB, 0.404552E-01_JPRB /) +SELFREF(:,16) = (/ & + & 0.934781E-01_JPRB, 0.855190E-01_JPRB, 0.782376E-01_JPRB, 0.715761E-01_JPRB, 0.654819E-01_JPRB, & + & 0.599065E-01_JPRB, 0.548058E-01_JPRB, 0.501394E-01_JPRB, 0.458704E-01_JPRB, 0.419648E-01_JPRB /) + +! ----------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB20',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB20:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB20 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb21.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb21.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb21.F90 (revision 6016) @@ -0,0 +1,209 @@ +SUBROUTINE SRTM_KGB21 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 21: 6150-7700 cm-1 (low - H2O,CO2; high - H2O,CO2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA21 , ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, RAYL, STRRAT, LAYREFFR ,& + & KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB21',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB21:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB21:') +ENDIF + +SFLUXREF(:, 1) = (/ & + & 16.1643_JPRB , 15.5806_JPRB, 14.7254_JPRB , 13.5541_JPRB , & + & 11.9519_JPRB ,10.44410_JPRB, 8.37884_JPRB , 6.26384_JPRB , & + & 4.28435_JPRB ,0.465228_JPRB, 0.385095_JPRB ,0.304226_JPRB , & + & 0.222479_JPRB,0.143286_JPRB, 5.58046E-02_JPRB, 7.84856E-03_JPRB /) +SFLUXREF(:, 2) = (/ & + & 15.6451_JPRB , 15.3170_JPRB, 14.6987_JPRB , 13.7350_JPRB , & + & 12.2267_JPRB ,10.51646_JPRB, 8.47150_JPRB , 6.38873_JPRB , & + & 4.33536_JPRB ,0.470610_JPRB,0.389426_JPRB ,0.306461_JPRB , & + & 0.223537_JPRB,0.143273_JPRB, 5.58179E-02_JPRB, 7.84856E-03_JPRB /) +SFLUXREF(:, 3) = (/ & + & 15.6092_JPRB , 15.3293_JPRB, 14.6881_JPRB , 13.6693_JPRB , & + & 12.2342_JPRB ,10.52010_JPRB, 8.49442_JPRB , 6.42138_JPRB , & + & 4.35865_JPRB ,0.473349_JPRB,0.391349_JPRB ,0.308861_JPRB , & + & 0.224666_JPRB,0.144799_JPRB, 5.58176E-02_JPRB, 7.84881E-03_JPRB /) +SFLUXREF(:, 4) = (/ & + & 15.5786_JPRB , 15.3422_JPRB, 14.6894_JPRB , 13.6040_JPRB , & + & 12.2567_JPRB ,10.49400_JPRB, 8.53521_JPRB , 6.44427_JPRB , & + & 4.37208_JPRB ,0.475709_JPRB,0.392956_JPRB ,0.309737_JPRB , & + & 0.226274_JPRB,0.146483_JPRB, 5.59325E-02_JPRB, 7.84881E-03_JPRB /) +SFLUXREF(:, 5) = (/ & + & 15.5380_JPRB , 15.3826_JPRB, 14.6575_JPRB , 13.5722_JPRB , & + & 12.2646_JPRB ,10.47672_JPRB, 8.57158_JPRB , 6.46343_JPRB , & + & 4.38259_JPRB ,0.477647_JPRB,0.393982_JPRB ,0.310686_JPRB , & + & 0.227620_JPRB,0.148376_JPRB, 5.60398E-02_JPRB, 7.83925E-03_JPRB /) +SFLUXREF(:, 6) = (/ & + & 15.5124_JPRB , 15.3986_JPRB, 14.6240_JPRB , 13.5535_JPRB , & + & 12.2468_JPRB ,10.48891_JPRB, 8.60434_JPRB , 6.47985_JPRB , & + & 4.39448_JPRB ,0.478267_JPRB,0.395618_JPRB ,0.311043_JPRB , & + & 0.230927_JPRB,0.148774_JPRB, 5.61189E-02_JPRB, 7.83925E-03_JPRB /) +SFLUXREF(:, 7) = (/ & + & 15.4910_JPRB , 15.4028_JPRB, 14.5772_JPRB , 13.5507_JPRB , & + & 12.2122_JPRB ,10.52735_JPRB, 8.62650_JPRB , 6.49644_JPRB , & + & 4.41173_JPRB ,0.478627_JPRB,0.396433_JPRB ,0.314199_JPRB , & + & 0.233125_JPRB,0.149052_JPRB, 5.62309E-02_JPRB, 7.83925E-03_JPRB /) +SFLUXREF(:, 8) = (/ & + & 15.4562_JPRB , 15.3928_JPRB, 14.5510_JPRB , 13.5122_JPRB , & + & 12.1890_JPRB , 10.5826_JPRB, 8.65842_JPRB , 6.51558_JPRB , & + & 4.42747_JPRB ,0.480669_JPRB,0.400143_JPRB ,0.318144_JPRB , & + & 0.233937_JPRB,0.149119_JPRB, 5.62309E-02_JPRB, 7.83925E-03_JPRB /) +SFLUXREF(:, 9) = (/ & + & 15.0069_JPRB , 15.1479_JPRB, 14.7802_JPRB , 13.6085_JPRB , & + & 12.2793_JPRB , 10.6929_JPRB, 8.72723_JPRB , 6.57114_JPRB , & + & 4.46330_JPRB ,0.486724_JPRB,0.401446_JPRB ,0.318879_JPRB , & + & 0.233959_JPRB,0.149119_JPRB, 5.62309E-02_JPRB, 7.83925E-03_JPRB /) + +! Rayleigh extinction coefficient at v = 6925 cm-1. +RAYL = 9.41E-09_JPRB + +STRRAT = 0.0045321_JPRB + +LAYREFFR = 8 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +FORREF(:, 1) = (/ 0.110008E-06_JPRB, 0.630912E-06_JPRB, 0.363159E-05_JPRB, 0.616892E-05_JPRB /) +FORREF(:, 2) = (/ 0.429709E-05_JPRB, 0.789174E-05_JPRB, 0.217416E-04_JPRB, 0.639393E-04_JPRB /) +FORREF(:, 3) = (/ 0.436283E-04_JPRB, 0.526247E-04_JPRB, 0.116341E-03_JPRB, 0.205616E-03_JPRB /) +FORREF(:, 4) = (/ 0.215627E-03_JPRB, 0.234522E-03_JPRB, 0.280497E-03_JPRB, 0.838668E-03_JPRB /) +FORREF(:, 5) = (/ 0.529283E-03_JPRB, 0.620848E-03_JPRB, 0.935561E-03_JPRB, 0.171252E-02_JPRB /) +FORREF(:, 6) = (/ 0.212267E-02_JPRB, 0.218564E-02_JPRB, 0.222227E-02_JPRB, 0.199650E-02_JPRB /) +FORREF(:, 7) = (/ 0.291120E-02_JPRB, 0.281168E-02_JPRB, 0.259543E-02_JPRB, 0.210159E-02_JPRB /) +FORREF(:, 8) = (/ 0.316249E-02_JPRB, 0.310695E-02_JPRB, 0.279501E-02_JPRB, 0.208076E-02_JPRB /) +FORREF(:, 9) = (/ 0.354993E-02_JPRB, 0.336989E-02_JPRB, 0.298930E-02_JPRB, 0.180424E-02_JPRB /) +FORREF(:,10) = (/ 0.397729E-02_JPRB, 0.367409E-02_JPRB, 0.328982E-02_JPRB, 0.177807E-02_JPRB /) +FORREF(:,11) = (/ 0.408831E-02_JPRB, 0.398792E-02_JPRB, 0.352727E-02_JPRB, 0.192470E-02_JPRB /) +FORREF(:,12) = (/ 0.433926E-02_JPRB, 0.420667E-02_JPRB, 0.383894E-02_JPRB, 0.220836E-02_JPRB /) +FORREF(:,13) = (/ 0.436397E-02_JPRB, 0.433769E-02_JPRB, 0.425752E-02_JPRB, 0.237343E-02_JPRB /) +FORREF(:,14) = (/ 0.440525E-02_JPRB, 0.449018E-02_JPRB, 0.451881E-02_JPRB, 0.269169E-02_JPRB /) +FORREF(:,15) = (/ 0.491350E-02_JPRB, 0.481760E-02_JPRB, 0.475799E-02_JPRB, 0.362666E-02_JPRB /) +FORREF(:,16) = (/ 0.561641E-02_JPRB, 0.524553E-02_JPRB, 0.512473E-02_JPRB, 0.493802E-02_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.115887E-03_JPRB, 0.926537E-04_JPRB, 0.740783E-04_JPRB, 0.592270E-04_JPRB, 0.473530E-04_JPRB, & + & 0.378596E-04_JPRB, 0.302694E-04_JPRB, 0.242010E-04_JPRB, 0.193491E-04_JPRB, 0.154700E-04_JPRB /) +SELFREF(:, 2) = (/ & + & 0.459557E-03_JPRB, 0.381962E-03_JPRB, 0.317469E-03_JPRB, 0.263866E-03_JPRB, 0.219313E-03_JPRB, & + & 0.182283E-03_JPRB, 0.151505E-03_JPRB, 0.125924E-03_JPRB, 0.104662E-03_JPRB, 0.869904E-04_JPRB /) +SELFREF(:, 3) = (/ & + & 0.166821E-02_JPRB, 0.151103E-02_JPRB, 0.136866E-02_JPRB, 0.123970E-02_JPRB, 0.112290E-02_JPRB, & + & 0.101710E-02_JPRB, 0.921266E-03_JPRB, 0.834463E-03_JPRB, 0.755839E-03_JPRB, 0.684623E-03_JPRB /) +SELFREF(:, 4) = (/ & + & 0.460175E-02_JPRB, 0.421372E-02_JPRB, 0.385842E-02_JPRB, 0.353307E-02_JPRB, 0.323516E-02_JPRB, & + & 0.296236E-02_JPRB, 0.271257E-02_JPRB, 0.248385E-02_JPRB, 0.227440E-02_JPRB, 0.208262E-02_JPRB /) +SELFREF(:, 5) = (/ & + & 0.101589E-01_JPRB, 0.924742E-02_JPRB, 0.841772E-02_JPRB, 0.766247E-02_JPRB, 0.697497E-02_JPRB, & + & 0.634917E-02_JPRB, 0.577951E-02_JPRB, 0.526096E-02_JPRB, 0.478893E-02_JPRB, 0.435926E-02_JPRB /) +SELFREF(:, 6) = (/ & + & 0.328043E-01_JPRB, 0.300853E-01_JPRB, 0.275917E-01_JPRB, 0.253048E-01_JPRB, 0.232075E-01_JPRB, & + & 0.212839E-01_JPRB, 0.195198E-01_JPRB, 0.179020E-01_JPRB, 0.164182E-01_JPRB, 0.150574E-01_JPRB /) +SELFREF(:, 7) = (/ & + & 0.405936E-01_JPRB, 0.376032E-01_JPRB, 0.348331E-01_JPRB, 0.322671E-01_JPRB, 0.298901E-01_JPRB, & + & 0.276883E-01_JPRB, 0.256486E-01_JPRB, 0.237591E-01_JPRB, 0.220089E-01_JPRB, 0.203876E-01_JPRB /) +SELFREF(:, 8) = (/ & + & 0.448362E-01_JPRB, 0.413811E-01_JPRB, 0.381923E-01_JPRB, 0.352492E-01_JPRB, 0.325329E-01_JPRB, & + & 0.300259E-01_JPRB, 0.277121E-01_JPRB, 0.255766E-01_JPRB, 0.236056E-01_JPRB, 0.217866E-01_JPRB /) +SELFREF(:, 9) = (/ & + & 0.479741E-01_JPRB, 0.445389E-01_JPRB, 0.413497E-01_JPRB, 0.383889E-01_JPRB, 0.356400E-01_JPRB, & + & 0.330880E-01_JPRB, 0.307188E-01_JPRB, 0.285191E-01_JPRB, 0.264770E-01_JPRB, 0.245812E-01_JPRB /) +SELFREF(:,10) = (/ & + & 0.519308E-01_JPRB, 0.484130E-01_JPRB, 0.451335E-01_JPRB, 0.420761E-01_JPRB, 0.392259E-01_JPRB, & + & 0.365687E-01_JPRB, 0.340916E-01_JPRB, 0.317822E-01_JPRB, 0.296293E-01_JPRB, 0.276222E-01_JPRB /) +SELFREF(:,11) = (/ & + & 0.572039E-01_JPRB, 0.527780E-01_JPRB, 0.486945E-01_JPRB, 0.449270E-01_JPRB, 0.414510E-01_JPRB, & + & 0.382439E-01_JPRB, 0.352849E-01_JPRB, 0.325549E-01_JPRB, 0.300361E-01_JPRB, 0.277122E-01_JPRB /) +SELFREF(:,12) = (/ & + & 0.601046E-01_JPRB, 0.554411E-01_JPRB, 0.511395E-01_JPRB, 0.471716E-01_JPRB, 0.435116E-01_JPRB, & + & 0.401356E-01_JPRB, 0.370215E-01_JPRB, 0.341490E-01_JPRB, 0.314994E-01_JPRB, 0.290554E-01_JPRB /) +SELFREF(:,13) = (/ & + & 0.616595E-01_JPRB, 0.567145E-01_JPRB, 0.521662E-01_JPRB, 0.479826E-01_JPRB, 0.441346E-01_JPRB, & + & 0.405951E-01_JPRB, 0.373395E-01_JPRB, 0.343450E-01_JPRB, 0.315906E-01_JPRB, 0.290571E-01_JPRB /) +SELFREF(:,14) = (/ & + & 0.647916E-01_JPRB, 0.592493E-01_JPRB, 0.541811E-01_JPRB, 0.495465E-01_JPRB, 0.453083E-01_JPRB, & + & 0.414326E-01_JPRB, 0.378885E-01_JPRB, 0.346475E-01_JPRB, 0.316837E-01_JPRB, 0.289735E-01_JPRB /) +SELFREF(:,15) = (/ & + & 0.694231E-01_JPRB, 0.637703E-01_JPRB, 0.585777E-01_JPRB, 0.538079E-01_JPRB, 0.494265E-01_JPRB, & + & 0.454019E-01_JPRB, 0.417050E-01_JPRB, 0.383091E-01_JPRB, 0.351897E-01_JPRB, 0.323244E-01_JPRB /) +SELFREF(:,16) = (/ & + & 0.761764E-01_JPRB, 0.701815E-01_JPRB, 0.646584E-01_JPRB, 0.595700E-01_JPRB, 0.548820E-01_JPRB, & + & 0.505629E-01_JPRB, 0.465838E-01_JPRB, 0.429178E-01_JPRB, 0.395403E-01_JPRB, 0.364286E-01_JPRB /) + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB21',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB21:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB21 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb22.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb22.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb22.F90 (revision 6016) @@ -0,0 +1,209 @@ +SUBROUTINE SRTM_KGB22 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 16: 7700-8050 cm-1 (low - H2O,O2; high - O2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA22 , ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, RAYL, STRRAT, LAYREFFR ,& + & KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB22',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB22:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB22:') +ENDIF + +SFLUXREF(:, 1) = (/ & + & 3.71641_JPRB ,3.63190_JPRB ,3.44795_JPRB ,3.17936_JPRB , & + & 2.86071_JPRB ,2.48490_JPRB ,2.02471_JPRB ,1.52475_JPRB , & + & 1.03811_JPRB ,0.113272_JPRB ,9.37115E-02_JPRB,7.38969E-02_JPRB, & + & 5.44713E-02_JPRB,3.45905E-02_JPRB,1.30293E-02_JPRB,1.84198E-03_JPRB /) +SFLUXREF(:, 2) = (/ & + & 3.73933_JPRB ,3.60360_JPRB ,3.43370_JPRB ,3.19749_JPRB , & + & 2.87747_JPRB ,2.47926_JPRB ,2.02175_JPRB ,1.52010_JPRB , & + & 1.03612_JPRB ,0.113265_JPRB ,9.37145E-02_JPRB,7.38951E-02_JPRB, & + & 5.44714E-02_JPRB,3.45906E-02_JPRB,1.30293E-02_JPRB,1.84198E-03_JPRB /) +SFLUXREF(:, 3) = (/ & + & 3.73889_JPRB ,3.60279_JPRB ,3.43404_JPRB ,3.20560_JPRB , & + & 2.87367_JPRB ,2.47515_JPRB ,2.02412_JPRB ,1.52315_JPRB , & + & 1.03146_JPRB ,0.113272_JPRB ,9.36707E-02_JPRB,7.39080E-02_JPRB, & + & 5.44598E-02_JPRB,3.45906E-02_JPRB,1.30293E-02_JPRB,1.84198E-03_JPRB /) +SFLUXREF(:, 4) = (/ & + & 3.73801_JPRB ,3.60530_JPRB ,3.43659_JPRB ,3.20640_JPRB , & + & 2.87039_JPRB ,2.47330_JPRB ,2.02428_JPRB ,1.52509_JPRB , & + & 1.03037_JPRB ,0.112553_JPRB ,9.35352E-02_JPRB,7.39675E-02_JPRB, & + & 5.43951E-02_JPRB,3.45669E-02_JPRB,1.30292E-02_JPRB,1.84198E-03_JPRB /) +SFLUXREF(:, 5) = (/ & + & 3.73809_JPRB ,3.60996_JPRB ,3.43602_JPRB ,3.20364_JPRB , & + & 2.87005_JPRB ,2.47343_JPRB ,2.02353_JPRB ,1.52617_JPRB , & + & 1.03138_JPRB ,0.111172_JPRB ,9.29885E-02_JPRB,7.35034E-02_JPRB, & + & 5.42427E-02_JPRB,3.45732E-02_JPRB,1.30169E-02_JPRB,1.84550E-03_JPRB /) +SFLUXREF(:, 6) = (/ & + & 3.73872_JPRB ,3.62054_JPRB ,3.42934_JPRB ,3.20110_JPRB , & + & 2.86886_JPRB ,2.47379_JPRB ,2.02237_JPRB ,1.52754_JPRB , & + & 1.03228_JPRB ,0.111597_JPRB ,9.12252E-02_JPRB,7.33115E-02_JPRB, & + & 5.35600E-02_JPRB,3.45187E-02_JPRB,1.30184E-02_JPRB,1.84551E-03_JPRB /) +SFLUXREF(:, 7) = (/ & + & 3.73969_JPRB ,3.65461_JPRB ,3.40646_JPRB ,3.19082_JPRB , & + & 2.86919_JPRB ,2.47289_JPRB ,2.02312_JPRB ,1.52629_JPRB , & + & 1.03329_JPRB ,0.111611_JPRB ,9.16275E-02_JPRB,7.14731E-02_JPRB, & + & 5.31771E-02_JPRB,3.44980E-02_JPRB,1.30190E-02_JPRB,1.84551E-03_JPRB /) +SFLUXREF(:, 8) = (/ & + & 3.73995_JPRB ,3.65348_JPRB ,3.43707_JPRB ,3.16351_JPRB , & + & 2.87003_JPRB ,2.47392_JPRB ,2.02114_JPRB ,1.52548_JPRB , & + & 1.03306_JPRB ,0.111088_JPRB ,9.12422E-02_JPRB,7.11146E-02_JPRB, & + & 5.31333E-02_JPRB,3.45302E-02_JPRB,1.30209E-02_JPRB,1.84554E-03_JPRB /) +SFLUXREF(:, 9) = (/ & + & 3.73788_JPRB ,3.65004_JPRB ,3.46938_JPRB ,3.15236_JPRB , & + & 2.86381_JPRB ,2.47393_JPRB ,2.01715_JPRB ,1.52134_JPRB , & + & 1.03163_JPRB ,0.111259_JPRB ,9.12948E-02_JPRB,7.09999E-02_JPRB, & + & 5.31792E-02_JPRB,3.44955E-02_JPRB,1.30189E-02_JPRB,1.84551E-03_JPRB /) + +! Rayleigh extinction coefficient at v = 8000 cm-1. +RAYL = 1.54E-08_JPRB + +STRRAT = 0.022708_JPRB + +LAYREFFR = 2 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +FORREF(:, 1) = (/ 0.351362E-07_JPRB, 0.341136E-07_JPRB, 0.181317E-06_JPRB /) +FORREF(:, 2) = (/ 0.109648E-06_JPRB, 0.344240E-06_JPRB, 0.139709E-05_JPRB /) +FORREF(:, 3) = (/ 0.374823E-06_JPRB, 0.103424E-05_JPRB, 0.188717E-05_JPRB /) +FORREF(:, 4) = (/ 0.580041E-06_JPRB, 0.116876E-05_JPRB, 0.121183E-05_JPRB /) +FORREF(:, 5) = (/ 0.115608E-05_JPRB, 0.148110E-05_JPRB, 0.836083E-06_JPRB /) +FORREF(:, 6) = (/ 0.181460E-05_JPRB, 0.133313E-05_JPRB, 0.500167E-06_JPRB /) +FORREF(:, 7) = (/ 0.199096E-05_JPRB, 0.115276E-05_JPRB, 0.432994E-06_JPRB /) +FORREF(:, 8) = (/ 0.183730E-05_JPRB, 0.122260E-05_JPRB, 0.433248E-06_JPRB /) +FORREF(:, 9) = (/ 0.198386E-05_JPRB, 0.100130E-05_JPRB, 0.269712E-06_JPRB /) +FORREF(:,10) = (/ 0.276382E-05_JPRB, 0.749215E-06_JPRB, 0.236919E-06_JPRB /) +FORREF(:,11) = (/ 0.298202E-05_JPRB, 0.629688E-06_JPRB, 0.228388E-06_JPRB /) +FORREF(:,12) = (/ 0.364604E-05_JPRB, 0.455336E-06_JPRB, 0.206130E-06_JPRB /) +FORREF(:,13) = (/ 0.373339E-05_JPRB, 0.245210E-06_JPRB, 0.201987E-06_JPRB /) +FORREF(:,14) = (/ 0.480378E-05_JPRB, 0.177591E-06_JPRB, 0.171458E-06_JPRB /) +FORREF(:,15) = (/ 0.521700E-05_JPRB, 0.203358E-06_JPRB, 0.189559E-06_JPRB /) +FORREF(:,16) = (/ 0.542717E-05_JPRB, 0.219022E-06_JPRB, 0.218271E-06_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.538526E-04_JPRB, 0.464603E-04_JPRB, 0.400828E-04_JPRB, 0.345807E-04_JPRB, 0.298339E-04_JPRB, & + & 0.257386E-04_JPRB, 0.222055E-04_JPRB, 0.191574E-04_JPRB, 0.165277E-04_JPRB, 0.142590E-04_JPRB /) +SELFREF(:, 2) = (/ & + & 0.162409E-03_JPRB, 0.128347E-03_JPRB, 0.101430E-03_JPRB, 0.801571E-04_JPRB, 0.633460E-04_JPRB, & + & 0.500607E-04_JPRB, 0.395616E-04_JPRB, 0.312645E-04_JPRB, 0.247075E-04_JPRB, 0.195257E-04_JPRB /) +SELFREF(:, 3) = (/ & + & 0.262882E-03_JPRB, 0.212793E-03_JPRB, 0.172247E-03_JPRB, 0.139427E-03_JPRB, 0.112860E-03_JPRB, & + & 0.913557E-04_JPRB, 0.739487E-04_JPRB, 0.598584E-04_JPRB, 0.484529E-04_JPRB, 0.392206E-04_JPRB /) +SELFREF(:, 4) = (/ & + & 0.242873E-03_JPRB, 0.204225E-03_JPRB, 0.171726E-03_JPRB, 0.144399E-03_JPRB, 0.121421E-03_JPRB, & + & 0.102099E-03_JPRB, 0.858516E-04_JPRB, 0.721899E-04_JPRB, 0.607022E-04_JPRB, 0.510426E-04_JPRB /) +SELFREF(:, 5) = (/ & + & 0.235614E-03_JPRB, 0.207814E-03_JPRB, 0.183293E-03_JPRB, 0.161666E-03_JPRB, 0.142591E-03_JPRB, & + & 0.125766E-03_JPRB, 0.110927E-03_JPRB, 0.978381E-04_JPRB, 0.862939E-04_JPRB, 0.761119E-04_JPRB /) +SELFREF(:, 6) = (/ & + & 0.205508E-03_JPRB, 0.190174E-03_JPRB, 0.175985E-03_JPRB, 0.162854E-03_JPRB, 0.150702E-03_JPRB, & + & 0.139458E-03_JPRB, 0.129052E-03_JPRB, 0.119423E-03_JPRB, 0.110513E-03_JPRB, 0.102267E-03_JPRB /) +SELFREF(:, 7) = (/ & + & 0.185027E-03_JPRB, 0.175148E-03_JPRB, 0.165796E-03_JPRB, 0.156944E-03_JPRB, 0.148565E-03_JPRB, & + & 0.140633E-03_JPRB, 0.133124E-03_JPRB, 0.126016E-03_JPRB, 0.119288E-03_JPRB, 0.112919E-03_JPRB /) +SELFREF(:, 8) = (/ & + & 0.192634E-03_JPRB, 0.180192E-03_JPRB, 0.168554E-03_JPRB, 0.157668E-03_JPRB, 0.147484E-03_JPRB, & + & 0.137959E-03_JPRB, 0.129048E-03_JPRB, 0.120713E-03_JPRB, 0.112917E-03_JPRB, 0.105624E-03_JPRB /) +SELFREF(:, 9) = (/ & + & 0.161632E-03_JPRB, 0.155919E-03_JPRB, 0.150408E-03_JPRB, 0.145092E-03_JPRB, 0.139963E-03_JPRB, & + & 0.135016E-03_JPRB, 0.130244E-03_JPRB, 0.125640E-03_JPRB, 0.121199E-03_JPRB, 0.116915E-03_JPRB /) +SELFREF(:,10) = (/ & + & 0.120880E-03_JPRB, 0.125265E-03_JPRB, 0.129810E-03_JPRB, 0.134520E-03_JPRB, 0.139400E-03_JPRB, & + & 0.144458E-03_JPRB, 0.149699E-03_JPRB, 0.155130E-03_JPRB, 0.160758E-03_JPRB, 0.166591E-03_JPRB /) +SELFREF(:,11) = (/ & + & 0.104705E-03_JPRB, 0.111761E-03_JPRB, 0.119291E-03_JPRB, 0.127330E-03_JPRB, 0.135910E-03_JPRB, & + & 0.145068E-03_JPRB, 0.154843E-03_JPRB, 0.165277E-03_JPRB, 0.176414E-03_JPRB, 0.188302E-03_JPRB /) +SELFREF(:,12) = (/ & + & 0.846335E-04_JPRB, 0.951236E-04_JPRB, 0.106914E-03_JPRB, 0.120166E-03_JPRB, 0.135060E-03_JPRB, & + & 0.151800E-03_JPRB, 0.170616E-03_JPRB, 0.191763E-03_JPRB, 0.215532E-03_JPRB, 0.242246E-03_JPRB /) +SELFREF(:,13) = (/ & + & 0.669754E-04_JPRB, 0.781902E-04_JPRB, 0.912829E-04_JPRB, 0.106568E-03_JPRB, 0.124413E-03_JPRB, & + & 0.145245E-03_JPRB, 0.169566E-03_JPRB, 0.197959E-03_JPRB, 0.231107E-03_JPRB, 0.269805E-03_JPRB /) +SELFREF(:,14) = (/ & + & 0.597091E-04_JPRB, 0.722265E-04_JPRB, 0.873679E-04_JPRB, 0.105684E-03_JPRB, 0.127839E-03_JPRB, & + & 0.154639E-03_JPRB, 0.187057E-03_JPRB, 0.226272E-03_JPRB, 0.273707E-03_JPRB, 0.331087E-03_JPRB /) +SELFREF(:,15) = (/ & + & 0.640410E-04_JPRB, 0.771879E-04_JPRB, 0.930338E-04_JPRB, 0.112133E-03_JPRB, 0.135152E-03_JPRB, & + & 0.162897E-03_JPRB, 0.196338E-03_JPRB, 0.236644E-03_JPRB, 0.285225E-03_JPRB, 0.343778E-03_JPRB /) +SELFREF(:,16) = (/ & + & 0.666420E-04_JPRB, 0.801056E-04_JPRB, 0.962892E-04_JPRB, 0.115742E-03_JPRB, 0.139126E-03_JPRB, & + & 0.167233E-03_JPRB, 0.201019E-03_JPRB, 0.241630E-03_JPRB, 0.290446E-03_JPRB, 0.349125E-03_JPRB /) + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB22',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB22:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB22 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb23.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb23.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb23.F90 (revision 6016) @@ -0,0 +1,157 @@ +SUBROUTINE SRTM_KGB23 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 16: 8050-12850 cm-1 (low - H2O; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA23 , ONLY : KA, SELFREF, FORREF, SFLUXREF, RAYL, GIVFAC, LAYREFFR ,& + & KA_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB23',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D + KA = REAL(KA_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB23:') +ENDIF + +SFLUXREF = (/ & + & 53.2101_JPRB , 51.4143_JPRB, 49.3348_JPRB, 45.4612_JPRB , & + & 40.8294_JPRB , 35.1801_JPRB, 28.6947_JPRB, 21.5751_JPRB , & + & 14.6388_JPRB , 1.59111_JPRB, 1.31860_JPRB, 1.04018_JPRB , & + & 0.762140_JPRB,0.484214_JPRB,0.182275_JPRB, 2.54948E-02_JPRB /) + +! Rayleigh extinction coefficient at all v +RAYL = (/ & + & 5.94837E-08_JPRB,5.70593E-08_JPRB,6.27845E-08_JPRB,5.56602E-08_JPRB, & + & 5.25571E-08_JPRB,4.73388E-08_JPRB,4.17466E-08_JPRB,3.98097E-08_JPRB, & + & 4.00786E-08_JPRB,3.67478E-08_JPRB,3.45186E-08_JPRB,3.46156E-08_JPRB, & + & 3.32155E-08_JPRB,3.23642E-08_JPRB,2.72590E-08_JPRB,2.96813E-08_JPRB /) + +! Average Giver et al. correction factor for this band. +GIVFAC = 1.029_JPRB + +LAYREFFR = 6 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +FORREF(:, 1) = (/ 0.315770E-07_JPRB, 0.671978E-07_JPRB, 0.440649E-06_JPRB /) +FORREF(:, 2) = (/ 0.313674E-06_JPRB, 0.285252E-06_JPRB, 0.421024E-05_JPRB /) +FORREF(:, 3) = (/ 0.135818E-05_JPRB, 0.145071E-05_JPRB, 0.611285E-05_JPRB /) +FORREF(:, 4) = (/ 0.534065E-05_JPRB, 0.586268E-05_JPRB, 0.933970E-05_JPRB /) +FORREF(:, 5) = (/ 0.964007E-05_JPRB, 0.107110E-04_JPRB, 0.104486E-04_JPRB /) +FORREF(:, 6) = (/ 0.302775E-04_JPRB, 0.357530E-04_JPRB, 0.340724E-04_JPRB /) +FORREF(:, 7) = (/ 0.102437E-03_JPRB, 0.108475E-03_JPRB, 0.105245E-03_JPRB /) +FORREF(:, 8) = (/ 0.146054E-03_JPRB, 0.141490E-03_JPRB, 0.133071E-03_JPRB /) +FORREF(:, 9) = (/ 0.163978E-03_JPRB, 0.150208E-03_JPRB, 0.142864E-03_JPRB /) +FORREF(:,10) = (/ 0.220412E-03_JPRB, 0.182943E-03_JPRB, 0.150941E-03_JPRB /) +FORREF(:,11) = (/ 0.228877E-03_JPRB, 0.197679E-03_JPRB, 0.163220E-03_JPRB /) +FORREF(:,12) = (/ 0.234177E-03_JPRB, 0.217734E-03_JPRB, 0.185038E-03_JPRB /) +FORREF(:,13) = (/ 0.257187E-03_JPRB, 0.241570E-03_JPRB, 0.221178E-03_JPRB /) +FORREF(:,14) = (/ 0.272455E-03_JPRB, 0.270637E-03_JPRB, 0.256269E-03_JPRB /) +FORREF(:,15) = (/ 0.339445E-03_JPRB, 0.300268E-03_JPRB, 0.286574E-03_JPRB /) +FORREF(:,16) = (/ 0.338841E-03_JPRB, 0.355428E-03_JPRB, 0.353794E-03_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.100945E-04_JPRB, 0.801113E-05_JPRB, 0.635771E-05_JPRB, 0.504554E-05_JPRB, 0.400419E-05_JPRB, & + & 0.317777E-05_JPRB, 0.252191E-05_JPRB, 0.200141E-05_JPRB, 0.158834E-05_JPRB, 0.126052E-05_JPRB /) +SELFREF(:, 2) = (/ & + & 0.107573E-04_JPRB, 0.999809E-05_JPRB, 0.929245E-05_JPRB, 0.863661E-05_JPRB, 0.802706E-05_JPRB, & + & 0.746053E-05_JPRB, 0.693399E-05_JPRB, 0.644460E-05_JPRB, 0.598976E-05_JPRB, 0.556702E-05_JPRB /) +SELFREF(:, 3) = (/ & + & 0.350389E-04_JPRB, 0.319234E-04_JPRB, 0.290850E-04_JPRB, 0.264989E-04_JPRB, 0.241428E-04_JPRB, & + & 0.219962E-04_JPRB, 0.200404E-04_JPRB, 0.182586E-04_JPRB, 0.166351E-04_JPRB, 0.151560E-04_JPRB /) +SELFREF(:, 4) = (/ & + & 0.122993E-03_JPRB, 0.110885E-03_JPRB, 0.999691E-04_JPRB, 0.901277E-04_JPRB, 0.812551E-04_JPRB, & + & 0.732559E-04_JPRB, 0.660443E-04_JPRB, 0.595426E-04_JPRB, 0.536809E-04_JPRB, 0.483963E-04_JPRB /) +SELFREF(:, 5) = (/ & + & 0.206434E-03_JPRB, 0.187435E-03_JPRB, 0.170185E-03_JPRB, 0.154522E-03_JPRB, 0.140301E-03_JPRB, & + & 0.127388E-03_JPRB, 0.115664E-03_JPRB, 0.105019E-03_JPRB, 0.953540E-04_JPRB, 0.865783E-04_JPRB /) +SELFREF(:, 6) = (/ & + & 0.590645E-03_JPRB, 0.533109E-03_JPRB, 0.481177E-03_JPRB, 0.434305E-03_JPRB, 0.391998E-03_JPRB, & + & 0.353812E-03_JPRB, 0.319346E-03_JPRB, 0.288238E-03_JPRB, 0.260160E-03_JPRB, 0.234817E-03_JPRB /) +SELFREF(:, 7) = (/ & + & 0.163029E-02_JPRB, 0.148773E-02_JPRB, 0.135763E-02_JPRB, 0.123891E-02_JPRB, 0.113057E-02_JPRB, & + & 0.103170E-02_JPRB, 0.941483E-03_JPRB, 0.859153E-03_JPRB, 0.784023E-03_JPRB, 0.715462E-03_JPRB /) +SELFREF(:, 8) = (/ & + & 0.204528E-02_JPRB, 0.189258E-02_JPRB, 0.175128E-02_JPRB, 0.162053E-02_JPRB, 0.149954E-02_JPRB, & + & 0.138758E-02_JPRB, 0.128398E-02_JPRB, 0.118812E-02_JPRB, 0.109941E-02_JPRB, 0.101733E-02_JPRB /) +SELFREF(:, 9) = (/ & + & 0.210589E-02_JPRB, 0.197078E-02_JPRB, 0.184434E-02_JPRB, 0.172601E-02_JPRB, 0.161528E-02_JPRB, & + & 0.151164E-02_JPRB, 0.141466E-02_JPRB, 0.132390E-02_JPRB, 0.123896E-02_JPRB, 0.115947E-02_JPRB /) +SELFREF(:,10) = (/ & + & 0.245098E-02_JPRB, 0.233745E-02_JPRB, 0.222918E-02_JPRB, 0.212592E-02_JPRB, 0.202745E-02_JPRB, & + & 0.193353E-02_JPRB, 0.184397E-02_JPRB, 0.175856E-02_JPRB, 0.167710E-02_JPRB, 0.159941E-02_JPRB /) +SELFREF(:,11) = (/ & + & 0.267460E-02_JPRB, 0.253325E-02_JPRB, 0.239936E-02_JPRB, 0.227255E-02_JPRB, 0.215244E-02_JPRB, & + & 0.203868E-02_JPRB, 0.193093E-02_JPRB, 0.182888E-02_JPRB, 0.173222E-02_JPRB, 0.164067E-02_JPRB /) +SELFREF(:,12) = (/ & + & 0.304510E-02_JPRB, 0.283919E-02_JPRB, 0.264720E-02_JPRB, 0.246820E-02_JPRB, 0.230130E-02_JPRB, & + & 0.214568E-02_JPRB, 0.200059E-02_JPRB, 0.186531E-02_JPRB, 0.173918E-02_JPRB, 0.162157E-02_JPRB /) +SELFREF(:,13) = (/ & + & 0.338445E-02_JPRB, 0.314719E-02_JPRB, 0.292655E-02_JPRB, 0.272139E-02_JPRB, 0.253060E-02_JPRB, & + & 0.235319E-02_JPRB, 0.218822E-02_JPRB, 0.203482E-02_JPRB, 0.189217E-02_JPRB, 0.175952E-02_JPRB /) +SELFREF(:,14) = (/ & + & 0.388649E-02_JPRB, 0.357018E-02_JPRB, 0.327961E-02_JPRB, 0.301269E-02_JPRB, 0.276750E-02_JPRB, & + & 0.254226E-02_JPRB, 0.233535E-02_JPRB, 0.214528E-02_JPRB, 0.197068E-02_JPRB, 0.181029E-02_JPRB /) +SELFREF(:,15) = (/ & + & 0.412547E-02_JPRB, 0.387413E-02_JPRB, 0.363810E-02_JPRB, 0.341646E-02_JPRB, 0.320831E-02_JPRB, & + & 0.301285E-02_JPRB, 0.282930E-02_JPRB, 0.265693E-02_JPRB, 0.249506E-02_JPRB, 0.234305E-02_JPRB /) +SELFREF(:,16) = (/ & + & 0.534327E-02_JPRB, 0.482967E-02_JPRB, 0.436544E-02_JPRB, 0.394583E-02_JPRB, 0.356655E-02_JPRB, & + & 0.322373E-02_JPRB, 0.291387E-02_JPRB, 0.263378E-02_JPRB, 0.238062E-02_JPRB, 0.215179E-02_JPRB /) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_KGB23',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB23:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB23 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb24.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb24.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb24.F90 (revision 6016) @@ -0,0 +1,271 @@ +SUBROUTINE SRTM_KGB24 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 24: 12850-16000 cm-1 (low - H2O,O2; high - O2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA24 , ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, RAYLA, RAYLB, & + & ABSO3A, ABSO3B, STRRAT, LAYREFFR , KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB24',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB24:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB24:') +ENDIF + +SFLUXREF(:,1) = (/ & + & 34.3610_JPRB , 33.1240_JPRB, 31.3948_JPRB, 28.7248_JPRB, & + & 24.7884_JPRB , 21.4892_JPRB, 17.3972_JPRB, 13.7928_JPRB, & + & 9.54462_JPRB , 1.05002_JPRB,0.867332_JPRB,0.685753_JPRB, & + & 0.504718_JPRB,0.323112_JPRB,0.122183_JPRB, 1.70288E-02_JPRB /) +SFLUXREF(:,2) = (/ & + & 34.2367_JPRB , 32.4327_JPRB, 30.0863_JPRB, 28.2085_JPRB, & + & 25.6533_JPRB , 22.3412_JPRB, 18.3112_JPRB, 13.8521_JPRB, & + & 9.51035_JPRB , 1.04138_JPRB,0.863493_JPRB,0.682790_JPRB, & + & 0.504721_JPRB,0.323102_JPRB,0.122193_JPRB, 1.70288E-02_JPRB /) +SFLUXREF(:,3) = (/ & + & 34.1883_JPRB , 32.2479_JPRB, 30.2650_JPRB, 28.2914_JPRB, & + & 25.6626_JPRB , 22.3163_JPRB, 18.3327_JPRB, 13.8508_JPRB, & + & 9.49190_JPRB , 1.03672_JPRB,0.858272_JPRB,0.681485_JPRB, & + & 0.501363_JPRB,0.323110_JPRB,0.122183_JPRB, 1.70288E-02_JPRB /) +SFLUXREF(:,4) = (/ & + & 34.1365_JPRB , 32.2316_JPRB, 30.3325_JPRB, 28.3305_JPRB, & + & 25.6420_JPRB , 22.3223_JPRB, 18.3411_JPRB, 13.8471_JPRB, & + & 9.47492_JPRB , 1.03376_JPRB,0.855380_JPRB,0.679085_JPRB, & + & 0.497998_JPRB,0.323053_JPRB,0.122183_JPRB, 1.70288E-02_JPRB /) +SFLUXREF(:,5) = (/ & + & 34.0460_JPRB , 32.2795_JPRB, 30.4147_JPRB, 28.3123_JPRB, & + & 25.6438_JPRB , 22.3238_JPRB, 18.3441_JPRB, 13.8528_JPRB, & + & 9.45222_JPRB , 1.03058_JPRB,0.854037_JPRB,0.675554_JPRB, & + & 0.498344_JPRB,0.320072_JPRB,0.122193_JPRB, 1.70288E-02_JPRB /) +SFLUXREF(:,6) = (/ & + & 33.9909_JPRB , 32.3127_JPRB, 30.4854_JPRB, 28.3005_JPRB, & + & 25.6310_JPRB , 22.3294_JPRB, 18.3459_JPRB, 13.8488_JPRB, & + & 9.43336_JPRB , 1.02901_JPRB,0.852728_JPRB,0.672322_JPRB, & + & 0.498056_JPRB,0.317753_JPRB,0.122183_JPRB, 1.70288E-02_JPRB /) +SFLUXREF(:,7) = (/ & + & 33.9225_JPRB , 32.4097_JPRB, 30.5125_JPRB, 28.2810_JPRB, & + & 25.6387_JPRB , 22.3080_JPRB, 18.3715_JPRB, 13.8248_JPRB, & + & 9.41834_JPRB , 1.02735_JPRB,0.850807_JPRB,0.671379_JPRB, & + & 0.496975_JPRB,0.317158_JPRB,0.119297_JPRB, 1.70207E-02_JPRB /) +SFLUXREF(:,8) = (/ & + & 33.8940_JPRB , 32.4951_JPRB, 30.5494_JPRB, 28.2788_JPRB, & + & 25.5975_JPRB , 22.3225_JPRB, 18.3358_JPRB, 13.8199_JPRB, & + & 9.40283_JPRB , 1.02751_JPRB,0.850729_JPRB,0.670152_JPRB, & + & 0.494294_JPRB,0.315829_JPRB,0.116195_JPRB, 1.64138E-02_JPRB /) +SFLUXREF(:,9) = (/ & + & 34.6501_JPRB , 32.6690_JPRB, 30.2872_JPRB, 28.0955_JPRB, & + & 25.4662_JPRB , 22.1446_JPRB, 18.2754_JPRB, 13.7573_JPRB, & + & 9.36645_JPRB , 1.02356_JPRB,0.847154_JPRB,0.668519_JPRB, & + & 0.489186_JPRB,0.313790_JPRB,0.117074_JPRB, 1.60943E-02_JPRB /) + +! Rayleigh extinction coefficient at all v +RAYLA(:,1) = (/ & + & 1.28405E-07_JPRB,1.45501E-07_JPRB,1.67272E-07_JPRB,1.94856E-07_JPRB, & + & 2.15248E-07_JPRB,2.34920E-07_JPRB,2.48558E-07_JPRB,1.80004E-07_JPRB, & + & 1.46504E-07_JPRB,1.31355E-07_JPRB,1.33562E-07_JPRB,1.35618E-07_JPRB, & + & 1.22412E-07_JPRB,1.19842E-07_JPRB,1.19924E-07_JPRB,1.20264E-07_JPRB /) +RAYLA(:,2) = (/ & + & 1.41622E-07_JPRB,1.93436E-07_JPRB,2.25057E-07_JPRB,2.01025E-07_JPRB, & + & 1.85138E-07_JPRB,1.72672E-07_JPRB,1.64771E-07_JPRB,1.59312E-07_JPRB, & + & 1.44961E-07_JPRB,1.37448E-07_JPRB,1.37506E-07_JPRB,1.38081E-07_JPRB, & + & 1.22432E-07_JPRB,1.19844E-07_JPRB,1.19921E-07_JPRB,1.20287E-07_JPRB /) +RAYLA(:,3) = (/ & + & 1.45382E-07_JPRB,1.97020E-07_JPRB,2.22781E-07_JPRB,1.96062E-07_JPRB, & + & 1.83495E-07_JPRB,1.72495E-07_JPRB,1.64910E-07_JPRB,1.58797E-07_JPRB, & + & 1.46208E-07_JPRB,1.42274E-07_JPRB,1.40445E-07_JPRB,1.39496E-07_JPRB, & + & 1.26940E-07_JPRB,1.19844E-07_JPRB,1.19921E-07_JPRB,1.20287E-07_JPRB /) +RAYLA(:,4) = (/ & + & 1.48247E-07_JPRB,1.99958E-07_JPRB,2.18048E-07_JPRB,1.93896E-07_JPRB, & + & 1.83125E-07_JPRB,1.73244E-07_JPRB,1.64320E-07_JPRB,1.58298E-07_JPRB, & + & 1.48428E-07_JPRB,1.44769E-07_JPRB,1.43704E-07_JPRB,1.38498E-07_JPRB, & + & 1.31732E-07_JPRB,1.22299E-07_JPRB,1.19921E-07_JPRB,1.20287E-07_JPRB /) +RAYLA(:,5) = (/ & + & 1.51343E-07_JPRB,1.99621E-07_JPRB,2.14563E-07_JPRB,1.93824E-07_JPRB, & + & 1.82992E-07_JPRB,1.73143E-07_JPRB,1.64587E-07_JPRB,1.57355E-07_JPRB, & + & 1.51198E-07_JPRB,1.46373E-07_JPRB,1.45438E-07_JPRB,1.38095E-07_JPRB, & + & 1.35026E-07_JPRB,1.27504E-07_JPRB,1.19921E-07_JPRB,1.20287E-07_JPRB /) +RAYLA(:,6) = (/ & + & 1.54462E-07_JPRB,1.97610E-07_JPRB,2.11992E-07_JPRB,1.93831E-07_JPRB, & + & 1.83900E-07_JPRB,1.73125E-07_JPRB,1.64093E-07_JPRB,1.57651E-07_JPRB, & + & 1.53158E-07_JPRB,1.46843E-07_JPRB,1.44733E-07_JPRB,1.40611E-07_JPRB, & + & 1.37320E-07_JPRB,1.33932E-07_JPRB,1.20423E-07_JPRB,1.20287E-07_JPRB /) +RAYLA(:,7) = (/ & + & 1.59068E-07_JPRB,1.92757E-07_JPRB,2.09865E-07_JPRB,1.95132E-07_JPRB, & + & 1.83641E-07_JPRB,1.73778E-07_JPRB,1.63215E-07_JPRB,1.59462E-07_JPRB, & + & 1.54331E-07_JPRB,1.46177E-07_JPRB,1.45819E-07_JPRB,1.43177E-07_JPRB, & + & 1.39797E-07_JPRB,1.36780E-07_JPRB,1.33385E-07_JPRB,1.20287E-07_JPRB /) +RAYLA(:,8) = (/ & + & 1.62066E-07_JPRB,1.87529E-07_JPRB,2.07191E-07_JPRB,1.97788E-07_JPRB, & + & 1.84920E-07_JPRB,1.72951E-07_JPRB,1.65450E-07_JPRB,1.60344E-07_JPRB, & + & 1.54403E-07_JPRB,1.47679E-07_JPRB,1.47287E-07_JPRB,1.44951E-07_JPRB, & + & 1.42517E-07_JPRB,1.41107E-07_JPRB,1.48688E-07_JPRB,1.51127E-07_JPRB /) +RAYLA(:,9) = (/ & + & 1.19177E-07_JPRB,1.86522E-07_JPRB,2.20324E-07_JPRB,2.13543E-07_JPRB, & + & 1.92198E-07_JPRB,1.81641E-07_JPRB,1.70092E-07_JPRB,1.65072E-07_JPRB, & + & 1.59804E-07_JPRB,1.56745E-07_JPRB,1.51235E-07_JPRB,1.51400E-07_JPRB, & + & 1.49635E-07_JPRB,1.48056E-07_JPRB,1.49046E-07_JPRB,1.51010E-07_JPRB /) + +RAYLB = (/ & + & 1.23766E-07_JPRB,1.40524E-07_JPRB,1.61610E-07_JPRB,1.83232E-07_JPRB, & + & 2.02951E-07_JPRB,2.21367E-07_JPRB,2.38367E-07_JPRB,2.53019E-07_JPRB, & + & 2.12202E-07_JPRB,1.36977E-07_JPRB,1.39118E-07_JPRB,1.37097E-07_JPRB, & + & 1.33223E-07_JPRB,1.38695E-07_JPRB,1.19868E-07_JPRB,1.20062E-07_JPRB /) + +ABSO3A = (/ & + & 8.03067E-02_JPRB,0.180926_JPRB ,0.227484_JPRB ,0.168015_JPRB , & + & 0.138284_JPRB ,0.114537_JPRB ,9.50114E-02_JPRB,8.06816E-02_JPRB, & + & 6.76406E-02_JPRB,5.69802E-02_JPRB,5.63283E-02_JPRB,4.57592E-02_JPRB, & + & 4.21862E-02_JPRB,3.47949E-02_JPRB,2.65731E-02_JPRB,2.67628E-02_JPRB /) + +ABSO3B = (/ & + & 2.94848E-02_JPRB,4.33642E-02_JPRB,6.70197E-02_JPRB,0.104990_JPRB , & + & 0.156180_JPRB ,0.214638_JPRB ,0.266281_JPRB ,0.317941_JPRB , & + & 0.355327_JPRB ,0.371241_JPRB ,0.374396_JPRB ,0.326847_JPRB , & + & 0.126497_JPRB ,6.95264E-02_JPRB,2.58175E-02_JPRB,2.52862E-02_JPRB /) + +STRRAT = 0.124692_JPRB + +LAYREFFR = 1 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +FORREF(:, 1) = (/ 0.515619E-08_JPRB, 0.131078E-06_JPRB, 0.349038E-06_JPRB /) +FORREF(:, 2) = (/ 0.329605E-07_JPRB, 0.430497E-06_JPRB, 0.458569E-05_JPRB /) +FORREF(:, 3) = (/ 0.188244E-06_JPRB, 0.792931E-06_JPRB, 0.267176E-05_JPRB /) +FORREF(:, 4) = (/ 0.611237E-06_JPRB, 0.798868E-06_JPRB, 0.411583E-06_JPRB /) +FORREF(:, 5) = (/ 0.111903E-05_JPRB, 0.914895E-06_JPRB, 0.444828E-06_JPRB /) +FORREF(:, 6) = (/ 0.235399E-05_JPRB, 0.269099E-05_JPRB, 0.739855E-06_JPRB /) +FORREF(:, 7) = (/ 0.400131E-05_JPRB, 0.378135E-05_JPRB, 0.231265E-06_JPRB /) +FORREF(:, 8) = (/ 0.464257E-05_JPRB, 0.371927E-05_JPRB, 0.460611E-06_JPRB /) +FORREF(:, 9) = (/ 0.476792E-05_JPRB, 0.311841E-05_JPRB, 0.934811E-06_JPRB /) +FORREF(:,10) = (/ 0.555683E-05_JPRB, 0.238129E-05_JPRB, 0.400334E-07_JPRB /) +FORREF(:,11) = (/ 0.569068E-05_JPRB, 0.196039E-05_JPRB, 0.374476E-07_JPRB /) +FORREF(:,12) = (/ 0.554154E-05_JPRB, 0.131724E-05_JPRB, 0.399720E-07_JPRB /) +FORREF(:,13) = (/ 0.462684E-05_JPRB, 0.238826E-07_JPRB, 0.325793E-07_JPRB /) +FORREF(:,14) = (/ 0.808644E-06_JPRB, 0.105126E-11_JPRB, 0.148691E-07_JPRB /) +FORREF(:,15) = (/ 0.865024E-12_JPRB, 0.822434E-12_JPRB, 0.825756E-12_JPRB /) +FORREF(:,16) = (/ 0.945747E-12_JPRB, 0.802065E-12_JPRB, 0.724732E-12_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.637755E-05_JPRB, 0.403921E-05_JPRB, 0.255823E-05_JPRB, 0.162025E-05_JPRB, 0.102618E-05_JPRB, & + & 0.649930E-06_JPRB, 0.411632E-06_JPRB, 0.260707E-06_JPRB, 0.165118E-06_JPRB, 0.104577E-06_JPRB /) +SELFREF(:, 2) = (/ & + & 0.180887E-04_JPRB, 0.108890E-04_JPRB, 0.655493E-05_JPRB, 0.394592E-05_JPRB, 0.237536E-05_JPRB, & + & 0.142991E-05_JPRB, 0.860774E-06_JPRB, 0.518167E-06_JPRB, 0.311925E-06_JPRB, 0.187772E-06_JPRB /) +SELFREF(:, 3) = (/ & + & 0.212261E-04_JPRB, 0.150697E-04_JPRB, 0.106989E-04_JPRB, 0.759581E-05_JPRB, 0.539274E-05_JPRB, & + & 0.382864E-05_JPRB, 0.271819E-05_JPRB, 0.192981E-05_JPRB, 0.137009E-05_JPRB, 0.972711E-06_JPRB /) +SELFREF(:, 4) = (/ & + & 0.132497E-04_JPRB, 0.118071E-04_JPRB, 0.105216E-04_JPRB, 0.937599E-05_JPRB, 0.835516E-05_JPRB, & + & 0.744547E-05_JPRB, 0.663482E-05_JPRB, 0.591243E-05_JPRB, 0.526870E-05_JPRB, 0.469506E-05_JPRB /) +SELFREF(:, 5) = (/ & + & 0.124069E-04_JPRB, 0.120785E-04_JPRB, 0.117589E-04_JPRB, 0.114477E-04_JPRB, 0.111447E-04_JPRB, & + & 0.108498E-04_JPRB, 0.105626E-04_JPRB, 0.102831E-04_JPRB, 0.100109E-04_JPRB, 0.974601E-05_JPRB /) +SELFREF(:, 6) = (/ & + & 0.411994E-04_JPRB, 0.372560E-04_JPRB, 0.336901E-04_JPRB, 0.304654E-04_JPRB, 0.275494E-04_JPRB, & + & 0.249126E-04_JPRB, 0.225281E-04_JPRB, 0.203718E-04_JPRB, 0.184219E-04_JPRB, 0.166587E-04_JPRB /) +SELFREF(:, 7) = (/ & + & 0.537376E-04_JPRB, 0.501002E-04_JPRB, 0.467090E-04_JPRB, 0.435473E-04_JPRB, 0.405996E-04_JPRB, & + & 0.378515E-04_JPRB, 0.352893E-04_JPRB, 0.329006E-04_JPRB, 0.306736E-04_JPRB, 0.285974E-04_JPRB /) +SELFREF(:, 8) = (/ & + & 0.494279E-04_JPRB, 0.475365E-04_JPRB, 0.457175E-04_JPRB, 0.439681E-04_JPRB, 0.422857E-04_JPRB, & + & 0.406676E-04_JPRB, 0.391114E-04_JPRB, 0.376148E-04_JPRB, 0.361755E-04_JPRB, 0.347912E-04_JPRB /) +SELFREF(:, 9) = (/ & + & 0.377444E-04_JPRB, 0.378199E-04_JPRB, 0.378956E-04_JPRB, 0.379715E-04_JPRB, 0.380475E-04_JPRB, & + & 0.381236E-04_JPRB, 0.381999E-04_JPRB, 0.382763E-04_JPRB, 0.383529E-04_JPRB, 0.384297E-04_JPRB /) +SELFREF(:,10) = (/ & + & 0.245916E-04_JPRB, 0.267183E-04_JPRB, 0.290289E-04_JPRB, 0.315394E-04_JPRB, 0.342669E-04_JPRB, & + & 0.372304E-04_JPRB, 0.404501E-04_JPRB, 0.439483E-04_JPRB, 0.477490E-04_JPRB, 0.518784E-04_JPRB /) +SELFREF(:,11) = (/ & + & 0.186528E-04_JPRB, 0.211417E-04_JPRB, 0.239628E-04_JPRB, 0.271603E-04_JPRB, 0.307845E-04_JPRB, & + & 0.348923E-04_JPRB, 0.395482E-04_JPRB, 0.448254E-04_JPRB, 0.508068E-04_JPRB, 0.575863E-04_JPRB /) +SELFREF(:,12) = (/ & + & 0.109896E-04_JPRB, 0.133794E-04_JPRB, 0.162890E-04_JPRB, 0.198312E-04_JPRB, 0.241438E-04_JPRB, & + & 0.293942E-04_JPRB, 0.357864E-04_JPRB, 0.435686E-04_JPRB, 0.530432E-04_JPRB, 0.645781E-04_JPRB /) +SELFREF(:,13) = (/ & + & 0.183885E-06_JPRB, 0.391019E-06_JPRB, 0.831472E-06_JPRB, 0.176806E-05_JPRB, 0.375966E-05_JPRB, & + & 0.799463E-05_JPRB, 0.170000E-04_JPRB, 0.361492E-04_JPRB, 0.768686E-04_JPRB, 0.163455E-03_JPRB /) +SELFREF(:,14) = (/ & + & 0.466057E-07_JPRB, 0.937419E-07_JPRB, 0.188551E-06_JPRB, 0.379248E-06_JPRB, 0.762813E-06_JPRB, & + & 0.153431E-05_JPRB, 0.308608E-05_JPRB, 0.620729E-05_JPRB, 0.124852E-04_JPRB, 0.251126E-04_JPRB /) +SELFREF(:,15) = (/ & + & 0.248961E-06_JPRB, 0.216780E-06_JPRB, 0.188758E-06_JPRB, 0.164358E-06_JPRB, 0.143113E-06_JPRB, & + & 0.124613E-06_JPRB, 0.108505E-06_JPRB, 0.944795E-07_JPRB, 0.822667E-07_JPRB, 0.716326E-07_JPRB /) +SELFREF(:,16) = (/ & + & 0.252246E-06_JPRB, 0.220335E-06_JPRB, 0.192462E-06_JPRB, 0.168114E-06_JPRB, 0.146847E-06_JPRB, & + & 0.128270E-06_JPRB, 0.112043E-06_JPRB, 0.978688E-07_JPRB, 0.854878E-07_JPRB, 0.746731E-07_JPRB /) + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB24',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB24:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB24 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb25.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb25.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb25.F90 (revision 6016) @@ -0,0 +1,92 @@ +SUBROUTINE SRTM_KGB25 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 25: 16000-22650 cm-1 (low - H2O; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA25 , ONLY : KA, SFLUXREF, RAYL, ABSO3A, ABSO3B, LAYREFFR, KA_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB25',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D + KA = REAL(KA_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB25:') +ENDIF + +SFLUXREF = (/ & + & 42.6858_JPRB , 45.7720_JPRB, 44.9872_JPRB, 45.9662_JPRB , & + & 46.5458_JPRB , 41.6926_JPRB, 32.2893_JPRB, 24.0928_JPRB , & + & 16.7686_JPRB , 1.86048_JPRB, 1.54057_JPRB, 1.23503_JPRB , & + & 0.915085_JPRB,0.590099_JPRB,0.218622_JPRB, 3.21287E-02_JPRB /) + +! Rayleigh extinction coefficient at v = 2925 cm-1. +RAYL = (/ & + & 9.81132E-07_JPRB,8.25605E-07_JPRB,6.71302E-07_JPRB,5.53556E-07_JPRB, & + & 3.97383E-07_JPRB,3.68206E-07_JPRB,4.42379E-07_JPRB,4.57799E-07_JPRB, & + & 4.22683E-07_JPRB,3.87113E-07_JPRB,3.79810E-07_JPRB,3.63192E-07_JPRB, & + & 3.51921E-07_JPRB,3.34231E-07_JPRB,3.34294E-07_JPRB,3.32673E-07_JPRB /) + +ABSO3A = (/ & + & 2.32664E-02_JPRB,5.76154E-02_JPRB,0.125389_JPRB,0.250158_JPRB, & + & 0.378756_JPRB ,0.402196_JPRB ,0.352026_JPRB,0.352036_JPRB, & + & 0.386253_JPRB ,0.414598_JPRB ,0.420079_JPRB,0.435471_JPRB, & + & 0.445487_JPRB ,0.459549_JPRB ,0.452920_JPRB,0.456838_JPRB /) + +ABSO3B = (/ & + & 1.76917E-02_JPRB,4.64185E-02_JPRB,1.03640E-01_JPRB,0.189469_JPRB, & + & 0.303858_JPRB ,0.400248_JPRB ,0.447357_JPRB ,0.470009_JPRB, & + & 0.498673_JPRB ,0.515696_JPRB ,0.517053_JPRB ,0.517930_JPRB, & + & 0.518345_JPRB ,0.524952_JPRB ,0.508244_JPRB ,0.468981_JPRB /) + +LAYREFFR = 2 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_KGB25',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB25:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB25 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb26.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb26.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb26.F90 (revision 6016) @@ -0,0 +1,39 @@ +SUBROUTINE SRTM_KGB26 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 26: 22650-29000 cm-1 (low - nothing; high - nothing) +! Reformatted for F90 by JJMorcrette, ECMWF +! G.Mozdzynski March 2011 read constants from files + +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOESRTA26 , ONLY : SFLUXREF, RAYL + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +IF (LHOOK) CALL DR_HOOK('SRTM_KGB26',0,ZHOOK_HANDLE) + +SFLUXREF = (/ & + ! & 129.462_JPRB, 15*_ZERO_ /) + & 29.0079_JPRB, 28.4088_JPRB, 20.3099_JPRB, 13.0283_JPRB & + & , 11.8619_JPRB, 9.95840_JPRB, 6.68696_JPRB, 5.38987_JPRB & + & , 3.49829_JPRB, 0.407693_JPRB, 0.299027_JPRB, 0.236827_JPRB & + & , 0.188502_JPRB, 0.163489_JPRB, 4.64335E-02_JPRB, 2.72662E-03_JPRB /) + +! Rayleigh extinction coefficient at all v +RAYL = (/ & + & 1.21263E-06_JPRB,1.43428E-06_JPRB,1.67677E-06_JPRB,1.93255E-06_JPRB & + & , 2.19177E-06_JPRB,2.44195E-06_JPRB,2.66926E-06_JPRB,2.85990E-06_JPRB & + & , 3.00380E-06_JPRB,3.06996E-06_JPRB,3.08184E-06_JPRB,3.09172E-06_JPRB & + & , 3.09938E-06_JPRB,3.10456E-06_JPRB,3.10727E-06_JPRB,3.10818E-06_JPRB /) + +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_KGB26',1,ZHOOK_HANDLE) +END SUBROUTINE SRTM_KGB26 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb27.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb27.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb27.F90 (revision 6016) @@ -0,0 +1,105 @@ +SUBROUTINE SRTM_KGB27 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 16: 29000-38000 cm-1 (low - O3; high - O3) +! Reformatted for F90 by JJMorcrette, ECMWF +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA27 , ONLY : KA, KB, SFLUXREF, RAYL, SCALEKUR, LAYREFFR, & + & KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +! The following values were obtained using the "low resolution" +! version of the Kurucz solar source function. For unknown reasons, +! the total irradiance in this band differs from the corresponding +! total in the "high-resolution" version of the Kurucz function. +! Therefore, below these values are scaled by the factor SCALEKUR. +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB27',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB27:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB27:') +ENDIF + +SFLUXREF = (/ & + & 14.0526_JPRB , 11.4794_JPRB , 8.72590_JPRB , 5.56966_JPRB , & + & 3.80927_JPRB , 1.57690_JPRB , 1.15099_JPRB , 1.10012_JPRB , & + & 0.658212_JPRB , 5.86859E-02_JPRB, 5.56186E-02_JPRB, 4.68040E-02_JPRB, & + & 3.64897E-02_JPRB, 3.58053E-02_JPRB, 1.38130E-02_JPRB, 1.90193E-03_JPRB /) + +! Rayleigh extinction coefficient at v = 2925 cm-1. +RAYL = (/ & + & 3.44534E-06_JPRB,4.14480E-06_JPRB,4.95069E-06_JPRB,5.81204E-06_JPRB, & + & 6.69748E-06_JPRB,7.56488E-06_JPRB,8.36344E-06_JPRB,9.04135E-06_JPRB, & + & 9.58324E-06_JPRB,9.81542E-06_JPRB,9.75119E-06_JPRB,9.74533E-06_JPRB, & + & 9.74139E-06_JPRB,9.73525E-06_JPRB,9.73577E-06_JPRB,9.73618E-06_JPRB /) + +SCALEKUR = 50.15_JPRB/48.37_JPRB + +LAYREFFR = 32 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_KGB27',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB27:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB27 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb28.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb28.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb28.F90 (revision 6016) @@ -0,0 +1,114 @@ +SUBROUTINE SRTM_KGB28 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 28: 38000-50000 cm-1 (low - O3,O2; high - O3,O2) +! Reformatted for F90 by JJMorcrette, ECMWF +! R. Elkhatib 12-10-2005 Split for faster and more robust compilation. +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA28 , ONLY : KA, KB, SFLUXREF, RAYL, STRRAT, LAYREFFR, KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB28',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB28:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB28:') +ENDIF + +SFLUXREF(:,1) = (/ & + & 1.06156_JPRB , 0.599910_JPRB , 0.422462_JPRB , 0.400077_JPRB , & + & 0.282221_JPRB , 0.187893_JPRB , 6.77357E-02_JPRB, 3.04572E-02_JPRB, & + & 2.00442E-02_JPRB, 2.30786E-03_JPRB, 2.08824E-03_JPRB, 1.42604E-03_JPRB, & + & 9.67384E-04_JPRB, 6.35362E-04_JPRB, 1.47727E-04_JPRB, 6.87639E-06_JPRB /) +SFLUXREF(:,2) = (/ & + & 1.07598_JPRB , 0.585099_JPRB , 0.422852_JPRB , 0.400077_JPRB , & + & 0.282221_JPRB , 0.187893_JPRB , 6.69686E-02_JPRB, 3.09070E-02_JPRB, & + & 2.02400E-02_JPRB, 2.47760E-03_JPRB, 1.89411E-03_JPRB, 1.41122E-03_JPRB, & + & 1.12449E-03_JPRB, 5.73505E-04_JPRB, 2.04160E-04_JPRB, 1.58371E-05_JPRB /) +SFLUXREF(:,3) = (/ & + & 0.461647_JPRB , 0.406113_JPRB , 0.332506_JPRB , 0.307508_JPRB , & + & 0.211167_JPRB , 0.235457_JPRB , 0.495886_JPRB , 0.363921_JPRB , & + & 0.192700_JPRB , 2.04678E-02_JPRB, 1.55407E-02_JPRB, 1.03882E-02_JPRB, & + & 1.10778E-02_JPRB, 1.00504E-02_JPRB, 4.93497E-03_JPRB, 5.73410E-04_JPRB /) +SFLUXREF(:,4) = (/ & + & 0.132669_JPRB , 0.175058_JPRB , 0.359263_JPRB , 0.388142_JPRB , & + & 0.350359_JPRB , 0.475892_JPRB , 0.489593_JPRB , 0.408437_JPRB , & + & 0.221049_JPRB , 1.94514E-02_JPRB, 1.54848E-02_JPRB, 1.44999E-02_JPRB, & + & 1.44568E-02_JPRB, 1.00527E-02_JPRB, 4.95897E-03_JPRB, 5.73327E-04_JPRB /) +SFLUXREF(:,5) = (/ & + & 7.54800E-02_JPRB, 0.232246_JPRB , 0.359263_JPRB , 0.388142_JPRB , & + & 0.350359_JPRB , 0.426317_JPRB , 0.493485_JPRB , 0.432016_JPRB , & + & 0.239203_JPRB , 1.74951E-02_JPRB, 1.74477E-02_JPRB, 1.83566E-02_JPRB, & + & 1.44818E-02_JPRB, 1.01048E-02_JPRB, 4.97487E-03_JPRB, 5.66831E-04_JPRB /) + +! Rayleigh extinction coefficient at v = ????? cm-1. +RAYL = 2.02E-05_JPRB + +STRRAT = 6.67029E-07_JPRB + +LAYREFFR = 58 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB28',1,ZHOOK_HANDLE) +RETURN + +1001 CONTINUE +CALL ABOR1("SRTM_KGB28:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB28 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb29.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb29.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_kgb29.F90 (revision 6016) @@ -0,0 +1,182 @@ +SUBROUTINE SRTM_KGB29 + +! Originally by J.Delamere, Atmospheric & Environmental Research. +! Revision: 2.4 +! BAND 29: 820-2600 cm-1 (low - H2O; high - CO2) +! Reformatted for F90 by JJMorcrette, ECMWF +! G.Mozdzynski March 2011 read constants from files +! T. Wilhelmsson and K. Yessad (Oct 2013) Geometry and setup refactoring. +! F. Vana 05-Mar-2015 Support for single precision +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMLUN , ONLY : NULRAD +USE YOMMP0 , ONLY : NPROC, MYPROC +USE MPL_MODULE, ONLY : MPL_BROADCAST +USE YOMTAG , ONLY : MTAGRAD +USE YOESRTA29 , ONLY : KA, KB, SELFREF, FORREF, SFLUXREF, RAYL, & + & ABSH2O, ABSCO2, LAYREFFR , KA_D, KB_D + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +! KURUCZ +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +IF (LHOOK) CALL DR_HOOK('SRTM_KGB29',0,ZHOOK_HANDLE) + +IF( MYPROC==1 )THEN + READ(NULRAD,ERR=1001) KA_D,KB_D + CLOSE(NULRAD,ERR=1000) + KA = REAL(KA_D,JPRB) + KB = REAL(KB_D,JPRB) +ENDIF +IF( NPROC>1 )THEN + CALL MPL_BROADCAST (KA,MTAGRAD,1,CDSTRING='SRTM_KGB29:') + CALL MPL_BROADCAST (KB,MTAGRAD,1,CDSTRING='SRTM_KGB29:') +ENDIF + +SFLUXREF = (/ & + & 1.32880_JPRB , 2.14018_JPRB , 1.97612_JPRB , 1.79000_JPRB , & + & 1.51242_JPRB , 1.22977_JPRB , 1.06052_JPRB , 0.800996_JPRB , & + & 0.748053_JPRB , 8.64369E-02_JPRB, 7.10675E-02_JPRB, 5.62425E-02_JPRB, & + & 4.46988E-02_JPRB, 3.07441E-02_JPRB, 1.16728E-02_JPRB, 1.65573E-03_JPRB /) + +ABSCO2 = (/ & + & 2.90073E-06_JPRB, 2.12382E-05_JPRB, 1.03032E-04_JPRB, 1.86481E-04_JPRB, & + & 4.31997E-04_JPRB, 6.08238E-04_JPRB, 2.17603E-03_JPRB, 4.64479E-02_JPRB, & + & 2.96956_JPRB , 14.9569_JPRB , 28.4831_JPRB , 61.3998_JPRB , & + & 164.129_JPRB , 832.282_JPRB , 4995.02_JPRB , 12678.1_JPRB /) + +ABSH2O = (/ & + & 2.99508E-04_JPRB, 3.95012E-03_JPRB, 1.49316E-02_JPRB, 3.24384E-02_JPRB, & + & 6.92879E-02_JPRB, 0.123523_JPRB , 0.360985_JPRB , 1.86434_JPRB , & + & 10.38157_JPRB , 0.214129_JPRB , 0.213914_JPRB , 0.212781_JPRB , & + & 0.215562_JPRB , 0.218087_JPRB , 0.220918_JPRB , 0.218546_JPRB /) + +! Rayleigh extinction coefficient at v = 2200 cm-1. +RAYL = 9.30E-11_JPRB + +LAYREFFR = 49 + +! ------------------------------------------------------------------ + +! The array KA contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + +! ----------------------------------------------------------------- +! The array KB contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + +FORREF(:, 1) = (/ 0.299818E-05_JPRB, 0.209282E-05_JPRB, 0.988353E-04_JPRB, 0.632178E-03_JPRB /) +FORREF(:, 2) = (/ 0.633648E-05_JPRB, 0.509214E-04_JPRB, 0.650535E-03_JPRB, 0.264019E-02_JPRB /) +FORREF(:, 3) = (/ 0.636782E-04_JPRB, 0.136577E-03_JPRB, 0.166500E-02_JPRB, 0.750821E-02_JPRB /) +FORREF(:, 4) = (/ 0.472314E-03_JPRB, 0.988296E-03_JPRB, 0.585751E-02_JPRB, 0.187352E-01_JPRB /) +FORREF(:, 5) = (/ 0.558635E-02_JPRB, 0.856489E-02_JPRB, 0.157438E-01_JPRB, 0.181471E-01_JPRB /) +FORREF(:, 6) = (/ 0.217395E-01_JPRB, 0.229156E-01_JPRB, 0.230125E-01_JPRB, 0.143821E-01_JPRB /) +FORREF(:, 7) = (/ 0.277222E-01_JPRB, 0.299252E-01_JPRB, 0.208929E-01_JPRB, 0.826748E-02_JPRB /) +FORREF(:, 8) = (/ 0.252119E-01_JPRB, 0.262911E-01_JPRB, 0.187663E-01_JPRB, 0.417110E-02_JPRB /) +FORREF(:, 9) = (/ 0.304941E-01_JPRB, 0.175545E-01_JPRB, 0.971224E-02_JPRB, 0.142023E-02_JPRB /) +FORREF(:,10) = (/ 0.327200E-01_JPRB, 0.215788E-01_JPRB, 0.346831E-02_JPRB, 0.157989E-02_JPRB /) +FORREF(:,11) = (/ 0.324955E-01_JPRB, 0.228571E-01_JPRB, 0.171749E-02_JPRB, 0.226853E-02_JPRB /) +FORREF(:,12) = (/ 0.326588E-01_JPRB, 0.198544E-01_JPRB, 0.532339E-06_JPRB, 0.279086E-02_JPRB /) +FORREF(:,13) = (/ 0.345157E-01_JPRB, 0.168679E-01_JPRB, 0.505361E-06_JPRB, 0.276647E-02_JPRB /) +FORREF(:,14) = (/ 0.448765E-01_JPRB, 0.123791E-02_JPRB, 0.488367E-06_JPRB, 0.122245E-02_JPRB /) +FORREF(:,15) = (/ 0.486925E-01_JPRB, 0.464371E-06_JPRB, 0.464241E-06_JPRB, 0.753846E-06_JPRB /) +FORREF(:,16) = (/ 0.530511E-01_JPRB, 0.376234E-06_JPRB, 0.409824E-06_JPRB, 0.470650E-06_JPRB /) + +! ----------------------------------------------------------------- +! The array SELFREF contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +SELFREF(:, 1) = (/ & + & 0.118069E+00_JPRB, 0.713523E-01_JPRB, 0.431199E-01_JPRB, 0.260584E-01_JPRB, 0.157477E-01_JPRB, & + & 0.951675E-02_JPRB, 0.575121E-02_JPRB, 0.347560E-02_JPRB, 0.210039E-02_JPRB, 0.126932E-02_JPRB /) +SELFREF(:, 2) = (/ & + & 0.137081E-01_JPRB, 0.139046E-01_JPRB, 0.141040E-01_JPRB, 0.143061E-01_JPRB, 0.145112E-01_JPRB, & + & 0.147193E-01_JPRB, 0.149303E-01_JPRB, 0.151443E-01_JPRB, 0.153614E-01_JPRB, 0.155816E-01_JPRB /) +SELFREF(:, 3) = (/ & + & 0.166575E-01_JPRB, 0.164916E-01_JPRB, 0.163273E-01_JPRB, 0.161647E-01_JPRB, 0.160037E-01_JPRB, & + & 0.158443E-01_JPRB, 0.156864E-01_JPRB, 0.155302E-01_JPRB, 0.153755E-01_JPRB, 0.152224E-01_JPRB /) +SELFREF(:, 4) = (/ & + & 0.597379E-01_JPRB, 0.509517E-01_JPRB, 0.434579E-01_JPRB, 0.370662E-01_JPRB, 0.316145E-01_JPRB, & + & 0.269647E-01_JPRB, 0.229988E-01_JPRB, 0.196162E-01_JPRB, 0.167311E-01_JPRB, 0.142703E-01_JPRB /) +SELFREF(:, 5) = (/ & + & 0.227517E+00_JPRB, 0.198401E+00_JPRB, 0.173011E+00_JPRB, 0.150870E+00_JPRB, 0.131563E+00_JPRB, & + & 0.114726E+00_JPRB, 0.100044E+00_JPRB, 0.872415E-01_JPRB, 0.760769E-01_JPRB, 0.663411E-01_JPRB /) +SELFREF(:, 6) = (/ & + & 0.453235E+00_JPRB, 0.414848E+00_JPRB, 0.379712E+00_JPRB, 0.347552E+00_JPRB, 0.318116E+00_JPRB, & + & 0.291173E+00_JPRB, 0.266512E+00_JPRB, 0.243940E+00_JPRB, 0.223279E+00_JPRB, 0.204368E+00_JPRB /) +SELFREF(:, 7) = (/ & + & 0.569263E+00_JPRB, 0.516415E+00_JPRB, 0.468473E+00_JPRB, 0.424982E+00_JPRB, 0.385528E+00_JPRB, & + & 0.349737E+00_JPRB, 0.317269E+00_JPRB, 0.287815E+00_JPRB, 0.261095E+00_JPRB, 0.236856E+00_JPRB /) +SELFREF(:, 8) = (/ & + & 0.490314E+00_JPRB, 0.448042E+00_JPRB, 0.409413E+00_JPRB, 0.374116E+00_JPRB, 0.341861E+00_JPRB, & + & 0.312387E+00_JPRB, 0.285455E+00_JPRB, 0.260844E+00_JPRB, 0.238355E+00_JPRB, 0.217805E+00_JPRB /) +SELFREF(:, 9) = (/ & + & 0.258162E+00_JPRB, 0.265085E+00_JPRB, 0.272193E+00_JPRB, 0.279493E+00_JPRB, 0.286988E+00_JPRB, & + & 0.294684E+00_JPRB, 0.302586E+00_JPRB, 0.310701E+00_JPRB, 0.319033E+00_JPRB, 0.327588E+00_JPRB /) +SELFREF(:,10) = (/ & + & 0.332019E+00_JPRB, 0.331902E+00_JPRB, 0.331784E+00_JPRB, 0.331666E+00_JPRB, 0.331549E+00_JPRB, & + & 0.331431E+00_JPRB, 0.331314E+00_JPRB, 0.331197E+00_JPRB, 0.331079E+00_JPRB, 0.330962E+00_JPRB /) +SELFREF(:,11) = (/ & + & 0.357523E+00_JPRB, 0.353154E+00_JPRB, 0.348839E+00_JPRB, 0.344576E+00_JPRB, 0.340366E+00_JPRB, & + & 0.336207E+00_JPRB, 0.332099E+00_JPRB, 0.328041E+00_JPRB, 0.324032E+00_JPRB, 0.320073E+00_JPRB /) +SELFREF(:,12) = (/ & + & 0.294662E+00_JPRB, 0.299043E+00_JPRB, 0.303488E+00_JPRB, 0.308000E+00_JPRB, 0.312579E+00_JPRB, & + & 0.317226E+00_JPRB, 0.321941E+00_JPRB, 0.326727E+00_JPRB, 0.331585E+00_JPRB, 0.336514E+00_JPRB /) +SELFREF(:,13) = (/ & + & 0.227445E+00_JPRB, 0.241545E+00_JPRB, 0.256519E+00_JPRB, 0.272422E+00_JPRB, 0.289311E+00_JPRB, & + & 0.307247E+00_JPRB, 0.326294E+00_JPRB, 0.346523E+00_JPRB, 0.368005E+00_JPRB, 0.390820E+00_JPRB /) +SELFREF(:,14) = (/ & + & 0.616203E-02_JPRB, 0.113523E-01_JPRB, 0.209144E-01_JPRB, 0.385307E-01_JPRB, 0.709852E-01_JPRB, & + & 0.130776E+00_JPRB, 0.240929E+00_JPRB, 0.443865E+00_JPRB, 0.817733E+00_JPRB, 0.150651E+01_JPRB /) +SELFREF(:,15) = (/ & + & 0.279552E-03_JPRB, 0.808472E-03_JPRB, 0.233812E-02_JPRB, 0.676192E-02_JPRB, 0.195557E-01_JPRB, & + & 0.565555E-01_JPRB, 0.163560E+00_JPRB, 0.473020E+00_JPRB, 0.136799E+01_JPRB, 0.395626E+01_JPRB /) +SELFREF(:,16) = (/ & + & 0.261006E-03_JPRB, 0.771043E-03_JPRB, 0.227776E-02_JPRB, 0.672879E-02_JPRB, 0.198777E-01_JPRB, & + & 0.587212E-01_JPRB, 0.173470E+00_JPRB, 0.512452E+00_JPRB, 0.151385E+01_JPRB, 0.447209E+01_JPRB /) + +! ----------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_KGB29',1,ZHOOK_HANDLE) +RETURN + +1000 CONTINUE +CALL ABOR1("SRTM_KGB29:ERROR CLOSING FILE RADSRTM") +1001 CONTINUE +CALL ABOR1("SRTM_KGB29:ERROR READING FILE RADSRTM") + +END SUBROUTINE SRTM_KGB29 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_setcoef.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_setcoef.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_setcoef.F90 (revision 6016) @@ -0,0 +1,249 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_SETCOEF & + & ( KIDIA , KFDIA , KLEV ,& + & PAVEL , PTAVEL ,& + & PCOLDRY , PWKL ,& + & KLAYTROP,& + & PCOLCH4 , PCOLCO2 , PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& + & PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PRMU0 & + & ) + +! J. Delamere, AER, Inc. (version 2.5, 02/04/01) + +! Modifications: +! JJMorcrette 030224 rewritten / adapted to ECMWF F90 system +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC + +! Purpose: For a given atmosphere, calculate the indices and +! fractions related to the pressure and temperature interpolations. + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE YOESRTWN , ONLY : PREFLOG, TREF +!! USE YOESWN , ONLY : NDBUG + +IMPLICIT NONE + +!-- Input arguments + +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PTAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PWKL(KIDIA:KFDIA,35,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KLAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KJT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!-- Output arguments + +!-- local integers + +INTEGER(KIND=JPIM) :: I_NLAYERS, JK, JL, JP1 + +!-- local reals + +REAL(KIND=JPRB) :: Z_STPFAC, Z_PLOG +REAL(KIND=JPRB) :: Z_FP, Z_FT, Z_FT1, Z_WATER, Z_SCALEFAC +REAL(KIND=JPRB) :: Z_FACTOR, Z_CO2REG, Z_COMPFP +!REAL(KIND=JPRB) :: Z_TBNDFRAC, Z_T0FRAC +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + +ASSOCIATE(NFLEVG=>KLEV) +IF (LHOOK) CALL DR_HOOK('SRTM_SETCOEF',0,ZHOOK_HANDLE) + +Z_STPFAC = 296._JPRB/1013._JPRB +I_NLAYERS = KLEV + +!$ACC PARALLEL DEFAULT(NONE) PRESENT(PAVEL, PTAVEL, PCOLDRY, PWKL, KLAYTROP, PCOLCH4, PCOLCO2, PCOLH2O, PCOLMOL, & +!$ACC PCOLO2,PCOLO3, PFORFAC, PFORFRAC, KINDFOR, PSELFFAC, PSELFFRAC, KINDSELF, PFAC00, PFAC01, PFAC10, PFAC11, & +!$ACC KJP, KJT,KJT1, PRMU0) ASYNC(1) +!$ACC LOOP SEQ +DO JK = 1, KLEV + !$ACC LOOP GANG(STATIC:1) VECTOR + DO JL = KIDIA, KFDIA + PCOLMOL(JL,JK) = 0.0_JPRB + ENDDO +ENDDO +!$ACC LOOP GANG(STATIC:1) VECTOR +DO JL = KIDIA, KFDIA + IF (PRMU0(JL) > 0.0_JPRB) THEN + KLAYTROP(JL) = 0 + ENDIF +ENDDO + +!$ACC LOOP SEQ +DO JK = 1, I_NLAYERS + !$ACC LOOP GANG(STATIC:1) VECTOR & + !$ACC PRIVATE(Z_PLOG, Z_FP, Z_FT, Z_FT1, Z_WATER, Z_SCALEFAC, Z_FACTOR, Z_CO2REG, Z_COMPFP, JP1) + DO JL = KIDIA, KFDIA + IF (PRMU0(JL) > 0.0_JPRB) THEN + ! 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. + + Z_PLOG = LOG(PAVEL(JL,JK)) + KJP(JL,JK) = INT(36._JPRB - 5._JPRB*(Z_PLOG+0.04_JPRB)) + IF (KJP(JL,JK) < 1) THEN + KJP(JL,JK) = 1 + ELSEIF (KJP(JL,JK) > 58) THEN + KJP(JL,JK) = 58 + ENDIF + JP1 = KJP(JL,JK) + 1 + Z_FP = 5. * (PREFLOG(KJP(JL,JK)) - Z_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. + + KJT(JL,JK) = INT(3. + (PTAVEL(JL,JK)-TREF(KJP(JL,JK)))/15.) + IF (KJT(JL,JK) < 1) THEN + KJT(JL,JK) = 1 + ELSEIF (KJT(JL,JK) > 4) THEN + KJT(JL,JK) = 4 + ENDIF + Z_FT = ((PTAVEL(JL,JK)-TREF(KJP(JL,JK)))/15.) - REAL(KJT(JL,JK)-3) + KJT1(JL,JK) = INT(3. + (PTAVEL(JL,JK)-TREF(JP1))/15.) + IF (KJT1(JL,JK) < 1) THEN + KJT1(JL,JK) = 1 + ELSEIF (KJT1(JL,JK) > 4) THEN + KJT1(JL,JK) = 4 + ENDIF + Z_FT1 = ((PTAVEL(JL,JK)-TREF(JP1))/15.) - REAL(KJT1(JL,JK)-3) + + Z_WATER = PWKL(JL,1,JK)/PCOLDRY(JL,JK) + Z_SCALEFAC = PAVEL(JL,JK) * Z_STPFAC / PTAVEL(JL,JK) + + ! If the pressure is less than ~100mb, perform a different + ! set of species interpolations. + + IF (Z_PLOG <= 4.56_JPRB) GO TO 5300 + KLAYTROP(JL) = KLAYTROP(JL) + 1 + + ! Set up factors needed to separately include the water vapor + ! foreign-continuum in the calculation of absorption coefficient. + + PFORFAC(JL,JK) = Z_SCALEFAC / (1.+Z_WATER) + Z_FACTOR = (332.0-PTAVEL(JL,JK))/36.0 + KINDFOR(JL,JK) = MIN(2, MAX(1, INT(Z_FACTOR))) + PFORFRAC(JL,JK) = Z_FACTOR - REAL(KINDFOR(JL,JK)) + + ! Set up factors needed to separately include the water vapor + ! self-continuum in the calculation of absorption coefficient. + + PSELFFAC(JL,JK) = Z_WATER * PFORFAC(JL,JK) + Z_FACTOR = (PTAVEL(JL,JK)-188.0)/7.2 + KINDSELF(JL,JK) = MIN(9, MAX(1, INT(Z_FACTOR)-7)) + PSELFFRAC(JL,JK) = Z_FACTOR - REAL(KINDSELF(JL,JK) + 7) + + ! Calculate needed column amounts. + + PCOLH2O(JL,JK) = 1.E-20 * PWKL(JL,1,JK) + PCOLCO2(JL,JK) = 1.E-20 * PWKL(JL,2,JK) + PCOLO3(JL,JK) = 1.E-20 * PWKL(JL,3,JK) + ! COLO3(LAY) = 0. + ! COLO3(LAY) = colo3(lay)/1.16 + PCOLCH4(JL,JK) = 1.E-20 * PWKL(JL,6,JK) + PCOLO2(JL,JK) = 1.E-20 * PWKL(JL,7,JK) + PCOLMOL(JL,JK) = 1.E-20 * PCOLDRY(JL,JK) + PCOLH2O(JL,JK) + ! colco2(lay) = 0. + ! colo3(lay) = 0. + ! colch4(lay) = 0. + ! colo2(lay) = 0. + ! colmol(lay) = 0. + IF (PCOLCO2(JL,JK) == 0.) PCOLCO2(JL,JK) = 1.E-32 * PCOLDRY(JL,JK) + IF (PCOLCH4(JL,JK) == 0.) PCOLCH4(JL,JK) = 1.E-32 * PCOLDRY(JL,JK) + IF (PCOLO2(JL,JK) == 0.) PCOLO2(JL,JK) = 1.E-32 * PCOLDRY(JL,JK) + ! Using E = 1334.2 cm-1. + Z_CO2REG = 3.55E-24 * PCOLDRY(JL,JK) + GO TO 5400 + + ! Above LAYTROP. +5300 CONTINUE + + ! Set up factors needed to separately include the water vapor + ! foreign-continuum in the calculation of absorption coefficient. + + PFORFAC(JL,JK) = Z_SCALEFAC / (1.+Z_WATER) + Z_FACTOR = (PTAVEL(JL,JK)-188.0)/36.0 + KINDFOR(JL,JK) = 3 + PFORFRAC(JL,JK) = Z_FACTOR - 1.0 + + ! Calculate needed column amounts. + + PCOLH2O(JL,JK) = 1.E-20 * PWKL(JL,1,JK) + PCOLCO2(JL,JK) = 1.E-20 * PWKL(JL,2,JK) + PCOLO3(JL,JK) = 1.E-20 * PWKL(JL,3,JK) + PCOLCH4(JL,JK) = 1.E-20 * PWKL(JL,6,JK) + PCOLO2(JL,JK) = 1.E-20 * PWKL(JL,7,JK) + PCOLMOL(JL,JK) = 1.E-20 * PCOLDRY(JL,JK) + PCOLH2O(JL,JK) + IF (PCOLCO2(JL,JK) == 0.) PCOLCO2(JL,JK) = 1.E-32 * PCOLDRY(JL,JK) + IF (PCOLCH4(JL,JK) == 0.) PCOLCH4(JL,JK) = 1.E-32 * PCOLDRY(JL,JK) + IF (PCOLO2(JL,JK) == 0.) PCOLO2(JL,JK) = 1.E-32 * PCOLDRY(JL,JK) + Z_CO2REG = 3.55E-24 * PCOLDRY(JL,JK) + + PSELFFAC(JL,JK) =0.0_JPRB + PSELFFRAC(JL,JK)=0.0_JPRB + KINDSELF(JL,JK) = 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). + + Z_COMPFP = 1. - Z_FP + PFAC10(JL,JK) = Z_COMPFP * Z_FT + PFAC00(JL,JK) = Z_COMPFP * (1. - Z_FT) + PFAC11(JL,JK) = Z_FP * Z_FT1 + PFAC01(JL,JK) = Z_FP * (1. - Z_FT1) + + ! IF (NDBUG.LE.3) THEN + ! print 9000,LAY,LAYTROP,JP(LAY),JT(LAY),JT1(LAY),TAVEL(LAY) & + ! &,FAC00(LAY),FAC01(LAY),FAC10(LAY),FAC11(LAY) & + ! &,COLMOL(LAY),COLCH4(LAY),COLCO2(LAY),COLH2O(LAY) & + ! &,COLO2(LAY),COLO3(LAY),SELFFAC(LAY),SELFFRAC(LAY) & + ! &,FORFAC(LAY),FORFRAC(LAY),INDSELF(LAY),INDFOR(LAY) +9000 format(1x,2I3,3I4,F6.1,4F7.2,12E9.2,2I5) + ! ENDIF + + ENDIF + ENDDO +ENDDO +!$ACC END PARALLEL + +!----------------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_SETCOEF',1,ZHOOK_HANDLE) +END ASSOCIATE +END SUBROUTINE SRTM_SETCOEF Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_spcvrt_mcica.F90.erase =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_spcvrt_mcica.F90.erase (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_spcvrt_mcica.F90.erase (revision 6016) @@ -0,0 +1,699 @@ +#ifdef RS6K +@PROCESS HOT(NOVECTOR) NOSTRICT +#endif +SUBROUTINE SRTM_SPCVRT_MCICA & + & ( KIDIA , KFDIA , KLEV , KSW , KCOLS , PONEMINUS, & + & PALBD , PALBP, & + & PFRCL , PTAUC , PASYC , POMGC , PTAUA , PASYA , POMGA , PRMU0, & + & KLAYTROP,& + & PCOLCH4 , PCOLCO2 , PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& + & PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + !-- output arrays + & PBBFD , PBBFU , PBBCD, PBBCU, PFUVF, PFUVC, PPARF, PPARCF, PSUDU, & + & PBBFDIR , PBBCDIR , PSwDiffuseBand , PSwDirectBand ) + + +!**** *SRTM_SPCVRT* - SPECTRAL LOOP TO COMPUTE THE SHORTWAVE RADIATION FLUXES. + +! PURPOSE. +! -------- + +! THIS ROUTINE COMPUTES THE TWO-STREAM METHOD OF BARKER + +!** INTERFACE. +! ---------- + +! *SRTM_SPCVRT_MCICA* IS CALLED FROM *SRTM_SRTM_224GP* + +! IMPLICIT ARGUMENTS : +! -------------------- + +! ==== INPUTS === +! ==== OUTPUTS === + +! METHOD. +! ------- + +! EXTERNALS. +! ---------- + +! *SWVRTQDR* + +! REFERENCE. +! ---------- + +! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +! DOCUMENTATION +! AUTHOR. +! ------- +! from Howard Barker +! JEAN-JACQUES MORCRETTE *ECMWF* + +! MODIFICATIONS. +! -------------- +! ORIGINAL : 03-02-27 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! JJMorcrette 20050110 McICA version +! JJMorcrette 20070614 bug-fix for solar duration +! JJMorcrette 20070831 UV-B surface flux +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette/MJIacono 20080724 Look-up table replacing exponential +! JJMorcrette 20091201 Total and clear-sky downward direct flux +! RJHogan 20140627 Store downwelling surface fluxes in each band +! ------------------------------------------------------------------ + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPB1, JPB2 +USE YOESRTM , ONLY : JPGPT +USE YOESRTWN , ONLY : NGC, NMPSRTM +USE YOERDI , ONLY : REPCLC +USE YOESRTAB , ONLY : BPADE, TRANS, RODLOW, RTBLINT +USE YOERAD , ONLY : NSW, LApproxSwUpdate + +IMPLICIT NONE + +! ------------------------------------------------------------------ + +!* 0.1 ARGUMENTS +! --------- + +INTEGER(KIND=JPIM),INTENT(IN) :: KSW +INTEGER(KIND=JPIM),INTENT(IN) :: KCOLS +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PALBD(KIDIA:KFDIA,KSW) +REAL(KIND=JPRB) ,INTENT(IN) :: PALBP(KIDIA:KFDIA,KSW) +REAL(KIND=JPRB) ,INTENT(IN) :: PFRCL(KIDIA:KFDIA,KCOLS,KLEV) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUC(KIDIA:KFDIA,KLEV,KCOLS) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: PASYC(KIDIA:KFDIA,KLEV,KCOLS) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: POMGC(KIDIA:KFDIA,KLEV,KCOLS) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUA(KIDIA:KFDIA,KLEV,KSW) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: PASYA(KIDIA:KFDIA,KLEV,KSW) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: POMGA(KIDIA:KFDIA,KLEV,KSW) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBFD(KIDIA:KFDIA,KLEV+1) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBFU(KIDIA:KFDIA,KLEV+1) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBCD(KIDIA:KFDIA,KLEV+1) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBCU(KIDIA:KFDIA,KLEV+1) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFUVF(KIDIA:KFDIA), PFUVC(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(OUT) :: PPARF(KIDIA:KFDIA), PPARCF(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(OUT) :: PSUDU(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBFDIR(KIDIA:KFDIA,KLEV+1) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBCDIR(KIDIA:KFDIA,KLEV+1) + +! Surface diffuse and direct downwelling shortwave flux in each +! shortwave albedo band, used in RADINTG to update the surface fluxes +! accounting for high-resolution albedo information +REAL(KIND=JPRB) ,INTENT(OUT) :: PSwDiffuseBand(KIDIA:KFDIA,NSW) +REAL(KIND=JPRB) ,INTENT(OUT) :: PSwDirectBand(KIDIA:KFDIA,NSW) + +! ------------------------------------------------------------------ + +! ------------ + +LOGICAL :: LLRTCHK(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) :: & + & ZCLEAR(KIDIA:KFDIA) , ZCLOUD(KIDIA:KFDIA) & + & , ZDBT(KIDIA:KFDIA,KLEV+1) & + & , ZGCC(KIDIA:KFDIA,KLEV) , ZGCO(KIDIA:KFDIA,KLEV) & + & , ZOMCC(KIDIA:KFDIA,KLEV) , ZOMCO(KIDIA:KFDIA,KLEV) & + & , ZRDND(KIDIA:KFDIA,KLEV+1), ZRDNDC(KIDIA:KFDIA,KLEV+1)& + & , ZREF(KIDIA:KFDIA,KLEV+1) , ZREFC(KIDIA:KFDIA,KLEV+1) , ZREFO(KIDIA:KFDIA,KLEV+1) & + & , ZREFD(KIDIA:KFDIA,KLEV+1), ZREFDC(KIDIA:KFDIA,KLEV+1), ZREFDO(KIDIA:KFDIA,KLEV+1) & + & , ZRUP(KIDIA:KFDIA,KLEV+1) , ZRUPD(KIDIA:KFDIA,KLEV+1) & + & , ZRUPC(KIDIA:KFDIA,KLEV+1), ZRUPDC(KIDIA:KFDIA,KLEV+1)& + & , ZTAUC(KIDIA:KFDIA,KLEV) , ZTAUO(KIDIA:KFDIA,KLEV) & + & , ZTDBT(KIDIA:KFDIA,KLEV+1) & + & , ZTRA(KIDIA:KFDIA,KLEV+1) , ZTRAC(KIDIA:KFDIA,KLEV+1) , ZTRAO(KIDIA:KFDIA,KLEV+1) & + & , ZTRAD(KIDIA:KFDIA,KLEV+1), ZTRADC(KIDIA:KFDIA,KLEV+1), ZTRADO(KIDIA:KFDIA,KLEV+1) +REAL(KIND=JPRB) :: & + & ZDBTC(KIDIA:KFDIA,KLEV+1), ZTDBTC(KIDIA:KFDIA,KLEV+1), ZINCFLX(KIDIA:KFDIA,JPGPT) & + & , ZINCF14(KIDIA:KFDIA,14) , ZINCTOT(KIDIA:KFDIA) + +INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IKL, IW(KIDIA:KFDIA), JB, JG, JK, I_KMODTS, JL, IC, ICOUNT + +! An index for the 6 bands used in the original albedo data rather +! than the 14 RRTM bands +INTEGER(KIND=JPIM) :: JB_ALBEDO + +INTEGER(KIND=JPIM) :: INDEX(KIDIA:KFDIA) + +REAL(KIND=JPRB) :: ZDBTMC(KIDIA:KFDIA), ZDBTMO(KIDIA:KFDIA), ZF(KIDIA:KFDIA) +! REAL(KIND=JPRB) :: ZARG1(KIDIA:KFDIA), ZARG2(KIDIA:KFDIA) +REAL(KIND=JPRB) :: ZINCFLUX(KIDIA:KFDIA), ZWF(KIDIA:KFDIA) +REAL(KIND=JPRB) :: ZCOEFVS + +!-- Output of SRTM_TAUMOLn routines + +REAL(KIND=JPRB) :: ZTAUG(KIDIA:KFDIA,KLEV,16), ZTAUR(KIDIA:KFDIA,KLEV,16), ZSFLXZEN(KIDIA:KFDIA,16) + +!-- Output of SRTM_VRTQDR routine +REAL(KIND=JPRB) :: & + & ZCD(KIDIA:KFDIA,KLEV+1,JPGPT), ZCU(KIDIA:KFDIA,KLEV+1,JPGPT) & + & , ZFD(KIDIA:KFDIA,KLEV+1,JPGPT), ZFU(KIDIA:KFDIA,KLEV+1,JPGPT) + +REAL(KIND=JPRB) :: ZTAU, ZPAO, ZPTO +REAL(KIND=JPRB) :: ZPAOJ(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZPTOJ(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZRMU0D(KIDIA:KFDIA) + +!-- Use of exponential look-up table +REAL(KIND=JPRB) :: ZE1, ZE2, ZTBLIND +INTEGER(KIND=JPIM) :: ITIND + +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + +#include "srtm_taumol16.intfb.h" +#include "srtm_taumol17.intfb.h" +#include "srtm_taumol18.intfb.h" +#include "srtm_taumol19.intfb.h" +#include "srtm_taumol20.intfb.h" +#include "srtm_taumol21.intfb.h" +#include "srtm_taumol22.intfb.h" +#include "srtm_taumol23.intfb.h" +#include "srtm_taumol24.intfb.h" +#include "srtm_taumol25.intfb.h" +#include "srtm_taumol26.intfb.h" +#include "srtm_taumol27.intfb.h" +#include "srtm_taumol28.intfb.h" +#include "srtm_taumol29.intfb.h" +#include "srtm_reftra.intfb.h" +#include "srtm_vrtqdr.intfb.h" +! ------------------------------------------------------------------ +ASSOCIATE(NFLEVG=>KLEV) +IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',0,ZHOOK_HANDLE) + +!-- Two-stream model 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discrete ordinates + +IB1=JPB1 +IB2=JPB2 + +IC=0 +DO JL = KIDIA, KFDIA + IF (PRMU0(JL) > 0.0_JPRB) THEN + IC=IC+1 + INDEX(IC)=JL + IW(JL)=0 + ZINCFLUX(JL)=0.0_JPRB + ZINCTOT(JL)=0.0_JPRB + PFUVF(JL) = 0.0_JPRB + PFUVC(JL) = 0.0_JPRB + PPARF(JL) = 0.0_JPRB + PPARCF(JL)= 0.0_JPRB + ENDIF +ENDDO +ICOUNT=IC +IF(ICOUNT==0)THEN + IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE) + RETURN +ENDIF + +! Since the stored shortwave downwelling fluxes in bands are +! accumulated over the g-points within that band, they need to be +! initialized here +IF (LApproxSwUpdate) THEN + DO JB_ALBEDO = 1,NSW + DO JL = KIDIA, KFDIA + PSwDiffuseBand(JL,JB_ALBEDO) = 0.0_JPRB + PSwDirectBand (JL,JB_ALBEDO) = 0.0_JPRB + ENDDO + ENDDO +ENDIF + + +!-- fraction of visible (to 0.69 um) in interval 0.6250-0.7782 um +ZCOEFVS = 0.42425_JPRB + +JB=IB1-1 +DO JB = IB1, IB2 + DO IC=1,ICOUNT + JL=INDEX(IC) + IBM = JB-15 + IGT = NGC(IBM) + ZINCF14(JL,IBM)=0.0_JPRB + ENDDO + + !-- for each band, computes the gaseous and Rayleigh optical thickness + ! for all g-points within the band + + IF (JB == 16) THEN + CALL SRTM_TAUMOL16 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS,& + & PCOLH2O , PCOLCH4 , PCOLMOL ,& + & KLAYTROP, PSELFFAC , PSELFFRAC, KINDSELF, PFORFAC , PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 17) THEN + CALL SRTM_TAUMOL17 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLCO2 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 18) THEN + CALL SRTM_TAUMOL18 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLCH4 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 19) THEN + CALL SRTM_TAUMOL19 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLCO2 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 20) THEN + CALL SRTM_TAUMOL20 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLH2O , PCOLCH4 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 21) THEN + CALL SRTM_TAUMOL21 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLCO2 , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 22) THEN + CALL SRTM_TAUMOL22 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLMOL , PCOLO2 ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 23) THEN + CALL SRTM_TAUMOL23 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLH2O , PCOLMOL ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 24) THEN + CALL SRTM_TAUMOL24 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& + & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 25) THEN + !--- visible 16000-22650 cm-1 0.4415 - 0.6250 um + CALL SRTM_TAUMOL25 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLH2O , PCOLMOL , PCOLO3 ,& + & KLAYTROP ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 26) THEN + !--- UV-A 22650-29000 cm-1 0.3448 - 0.4415 um + CALL SRTM_TAUMOL26 & + & ( KIDIA , KFDIA , KLEV ,& + & PCOLMOL ,KLAYTROP,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 27) THEN + !--- UV-B 29000-38000 cm-1 0.2632 - 0.3448 um + CALL SRTM_TAUMOL27 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLMOL , PCOLO3 ,& + & KLAYTROP ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 28) THEN + !--- UV-C 38000-50000 cm-1 0.2000 - 0.2632 um + CALL SRTM_TAUMOL28 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PONEMINUS ,& + & PCOLMOL , PCOLO2 , PCOLO3 ,& + & KLAYTROP ,& + & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & + & ) + + ELSEIF (JB == 29) THEN + CALL SRTM_TAUMOL29 & + & ( KIDIA , KFDIA , KLEV ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & PCOLH2O , PCOLCO2 , PCOLMOL ,& + & KLAYTROP , PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& + & ZSFLXZEN , ZTAUG , ZTAUR , PRMU0 & + & ) + + ENDIF + +!J---Start--- + DO JK=1,KLEV + IKL=KLEV+1-JK + DO IC=1,ICOUNT + JL=INDEX(IC) + ZPAOJ(JL,JK) = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) + ZPTOJ(JL,JK) = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) + ENDDO + ENDDO +!J---End--- + + DO JG=1,IGT + DO IC=1,ICOUNT + JL=INDEX(IC) + IW(JL)=IW(JL)+1 + + ZINCFLX(JL,IW(JL)) =ZSFLXZEN(JL,JG)*PRMU0(JL) + ZINCFLUX(JL) =ZINCFLUX(JL)+ZSFLXZEN(JL,JG)*PRMU0(JL) + ZINCTOT(JL) =ZINCTOT(JL)+ZSFLXZEN(JL,JG) + ZINCF14(JL,IBM)=ZINCF14(JL,IBM)+ZSFLXZEN(JL,JG) + + !-- CALL to compute layer reflectances and transmittances for direct + ! and diffuse sources, first clear then cloudy. + ! Use direct/parallel albedo for direct radiation and diffuse albedo + ! otherwise. + + ! ZREFC(JK) direct albedo for clear + ! ZREFO(JK) direct albedo for cloud + ! ZREFDC(JK) diffuse albedo for clear + ! ZREFDO(JK) diffuse albedo for cloud + ! ZTRAC(JK) direct transmittance for clear + ! ZTRAO(JK) direct transmittance for cloudy + ! ZTRADC(JK) diffuse transmittance for clear + ! ZTRADO(JK) diffuse transmittance for cloudy + + ! ZREF(JK) direct reflectance + ! ZREFD(JK) diffuse reflectance + ! ZTRA(JK) direct transmittance + ! ZTRAD(JK) diffuse transmittance + + ! ZDBTC(JK) clear direct beam transmittance + ! ZDBTO(JK) cloudy direct beam transmittance + ! ZDBT(JK) layer mean direct beam transmittance + ! ZTDBT(JK) total direct beam transmittance at levels + + !-- clear-sky + !----- TOA direct beam + ZTDBTC(JL,1)=1._JPRB + !----- surface values + ZDBTC(JL,KLEV+1) =0.0_JPRB + ZTRAC(JL,KLEV+1) =0.0_JPRB + ZTRADC(JL,KLEV+1)=0.0_JPRB + ZREFC(JL,KLEV+1) =PALBP(JL,IBM) + ZREFDC(JL,KLEV+1)=PALBD(JL,IBM) + ZRUPC(JL,KLEV+1) =PALBP(JL,IBM) + ZRUPDC(JL,KLEV+1)=PALBD(JL,IBM) + + !-- total sky + !----- TOA direct beam + ZTDBT(JL,1)=1._JPRB + !----- surface values + ZDBT(JL,KLEV+1) =0.0_JPRB + ZTRA(JL,KLEV+1) =0.0_JPRB + ZTRAD(JL,KLEV+1)=0.0_JPRB + ZREF(JL,KLEV+1) =PALBP(JL,IBM) + ZREFD(JL,KLEV+1)=PALBD(JL,IBM) + ZRUP(JL,KLEV+1) =PALBP(JL,IBM) + ZRUPD(JL,KLEV+1)=PALBD(JL,IBM) + ENDDO + + + !-- NB: a two-stream calculations from top to bottom, but RRTM_SW quantities + ! are given bottom to top (argh!) + ! Inputs for clouds and aerosols are bottom to top as inputs + +! DO JK=1,KLEV +! IKL=KLEV+1-JK +! WRITE(NULOUT,8001) IBM,JG,IKL,(PTAUA(INDEX(IC),IKL,IBM),IC=1,ICOUNT) +8001 format(1X,'McICA_SW',3I5,30E12.5) +! ENDDO + + + + DO JK=1,KLEV + IKL=KLEV+1-JK + DO IC=1,ICOUNT + JL=INDEX(IC) + !-- clear-sky optical parameters + LLRTCHK(JL,JK)=.TRUE. + !-- clear-sky optical parameters including aerosols +!J ZTAUC(JL,JK) = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG) + PTAUA(JL,IKL,IBM) +!J ZOMCC(JL,JK) = ZTAUR(JL,IKL,JG)*1.0_JPRB + PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) +!J ZGCC(JL,JK) = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)*PTAUA(JL,IKL,IBM) / ZOMCC(JL,JK) +!J ZOMCC(JL,JK) = ZOMCC(JL,JK) / ZTAUC(JL,JK) +!J ENDDO +!J ENDDO +!J DO JK=1,KLEV +!J IKL=KLEV+1-JK +!J DO IC=1,ICOUNT +!J JL=INDEX(IC) +!J !-- total sky optical parameters +!J ZTAUO(JL,JK) = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG) + PTAUA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL)) +!J ZOMCO(JL,JK) = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL)) & +!J & + ZTAUR(JL,IKL,JG)*1.0_JPRB +!J ZGCO(JL,JK) = (PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL))*PASYC(JL,IKL,IW(JL)) & +!J & + PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)*PASYA(JL,IKL,IBM)) & +!J & / ZOMCO(JL,JK) +!J ZOMCO(JL,JK) = ZOMCO(JL,JK) / ZTAUO(JL,JK) + + ZTAU = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG) +! ZPAO = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) +! ZPTO = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) + ZPAO = ZPAOJ(JL,JK) + ZPTO = ZPTOJ(JL,JK) + ZTAUC(JL,JK) = ZTAU + PTAUA(JL,IKL,IBM) + ZOMCC(JL,JK) = ZTAUR(JL,IKL,JG) + ZPTO + ZGCC(JL,JK) = ZPAO*PTAUA(JL,IKL,IBM) / ZOMCC(JL,JK) + ZOMCC(JL,JK) = ZOMCC(JL,JK) / ZTAUC(JL,JK) + !-- total sky optical parameters + ZTAUO(JL,JK) = ZTAU + PTAUA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL)) + ZOMCO(JL,JK) = ZPTO + PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL)) + ZTAUR(JL,IKL,JG) + ZGCO(JL,JK) = (PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL))*PASYC(JL,IKL,IW(JL)) & + & + PTAUA(JL,IKL,IBM)*ZPAO) / ZOMCO(JL,JK) + ZOMCO(JL,JK) = ZOMCO(JL,JK) / ZTAUO(JL,JK) + ENDDO + ENDDO + + !-- Delta scaling for clear-sky / aerosol optical quantities + DO JK=1,KLEV + DO IC=1,ICOUNT + JL=INDEX(IC) + ZF(JL)=ZGCC(JL,JK)*ZGCC(JL,JK) + ZWF(JL)=ZOMCC(JL,JK)*ZF(JL) + ZTAUC(JL,JK)=(1._JPRB-ZWF(JL))*ZTAUC(JL,JK) + ZOMCC(JL,JK)=(ZOMCC(JL,JK)-ZWF(JL))/(1.0_JPRB-ZWF(JL)) + ZGCC(JL,JK)=(ZGCC(JL,JK)-ZF(JL))/(1.0_JPRB-ZF(JL)) + ENDDO + ENDDO + + CALL SRTM_REFTRA ( KIDIA, KFDIA, KLEV, I_KMODTS ,& + & LLRTCHK, ZGCC , PRMU0, ZTAUC , ZOMCC ,& + & ZREFC , ZREFDC, ZTRAC, ZTRADC ) + + !-- Delta scaling for cloudy quantities + DO JK=1,KLEV + IKL=KLEV+1-JK + DO IC=1,ICOUNT + JL=INDEX(IC) + LLRTCHK(JL,JK)=.FALSE. + ZF(JL)=ZGCO(JL,JK)*ZGCO(JL,JK) + ZWF(JL)=ZOMCO(JL,JK)*ZF(JL) + ZTAUO(JL,JK)=(1._JPRB-ZWF(JL))*ZTAUO(JL,JK) + ZOMCO(JL,JK)=(ZOMCO(JL,JK)-ZWF(JL))/(1._JPRB-ZWF(JL)) + ZGCO(JL,JK)=(ZGCO(JL,JK)-ZF(JL))/(1._JPRB-ZF(JL)) + LLRTCHK(JL,JK)=(PFRCL(JL,IW(JL),IKL) > REPCLC) + ENDDO + ENDDO + + CALL SRTM_REFTRA ( KIDIA, KFDIA, KLEV, I_KMODTS ,& + & LLRTCHK, ZGCO , PRMU0, ZTAUO , ZOMCO ,& + & ZREFO , ZREFDO, ZTRAO, ZTRADO ) + +!J---Start--- + DO IC=1,ICOUNT + JL=INDEX(IC) + ZRMU0D(JL)=1.0_JPRB/PRMU0(JL) + ENDDO +!J---End--- + + DO JK=1,KLEV + IKL=KLEV+1-JK + DO IC=1,ICOUNT + JL=INDEX(IC) + !-- combine clear and cloudy contributions for total sky + + ZCLEAR(JL) = 1.0_JPRB - PFRCL(JL,IW(JL),IKL) + ZCLOUD(JL) = PFRCL(JL,IW(JL),IKL) + + ZREF(JL,JK) = ZCLEAR(JL)*ZREFC(JL,JK) + ZCLOUD(JL)*ZREFO(JL,JK) + ZREFD(JL,JK)= ZCLEAR(JL)*ZREFDC(JL,JK)+ ZCLOUD(JL)*ZREFDO(JL,JK) + ZTRA(JL,JK) = ZCLEAR(JL)*ZTRAC(JL,JK) + ZCLOUD(JL)*ZTRAO(JL,JK) + ZTRAD(JL,JK)= ZCLEAR(JL)*ZTRADC(JL,JK)+ ZCLOUD(JL)*ZTRADO(JL,JK) + + !-- direct beam transmittance +! ZARG1(JL) = MIN( 200._JPRB, ZTAUC(JL,JK)/PRMU0(JL) ) +! ZARG2(JL) = MIN( 200._JPRB, ZTAUO(JL,JK)/PRMU0(JL) ) +! ZDBTMC(JL) = EXP(-ZARG1(JL) ) +! ZDBTMO(JL) = EXP(-ZARG2(JL) ) + +!-- Use exponential look-up table for transmittance, or expansion of exponential for +! low optical thickness +!J ZE1 = ZTAUC(JL,JK)/PRMU0(JL) + ZE1 = ZTAUC(JL,JK)*ZRMU0D(JL) + IF (ZE1 <= RODLOW) THEN + ZDBTMC(JL) = 1._JPRB - ZE1 + 0.5_JPRB*ZE1*ZE1 + ELSE + ZTBLIND = ZE1 / (BPADE+ZE1) + ITIND = RTBLINT * ZTBLIND + 0.5_JPRB + ZDBTMC(JL) = TRANS(ITIND) + ENDIF + +!J ZE2 = ZTAUO(JL,JK)/PRMU0(JL) + ZE2 = ZTAUO(JL,JK)*ZRMU0D(JL) + IF (ZE2 <= RODLOW) THEN + ZDBTMO(JL) = 1._JPRB - ZE2 + 0.5_JPRB*ZE2*ZE2 + ELSE + ZTBLIND = ZE2 / (BPADE+ZE2) + ITIND = RTBLINT * ZTBLIND + 0.5_JPRB + ZDBTMO(JL) = TRANS(ITIND) + ENDIF +!--- + + ZDBT(JL,JK) = ZCLEAR(JL)*ZDBTMC(JL)+ZCLOUD(JL)*ZDBTMO(JL) + ZTDBT(JL,JK+1)= ZDBT(JL,JK)*ZTDBT(JL,JK) + + !-- clear-sky + ZDBTC(JL,JK) =ZDBTMC(JL) + ZTDBTC(JL,JK+1)=ZDBTC(JL,JK)*ZTDBTC(JL,JK) + + ENDDO + ENDDO + + !-- vertical quadrature producing clear-sky fluxes + + ! print *,'SRTM_SPCVRT after 3 before SRTM_VRTQDR clear' + + CALL SRTM_VRTQDR ( KIDIA, KFDIA, KLEV, IW ,& + & ZREFC, ZREFDC, ZTRAC , ZTRADC ,& + & ZDBTC, ZRDNDC, ZRUPC , ZRUPDC, ZTDBTC ,& + & ZCD , ZCU , PRMU0 ) + + !-- vertical quadrature producing cloudy fluxes + + CALL SRTM_VRTQDR ( KIDIA, KFDIA, KLEV, IW ,& + & ZREF , ZREFD , ZTRA , ZTRAD ,& + & ZDBT , ZRDND , ZRUP , ZRUPD , ZTDBT ,& + & ZFD , ZFU , PRMU0) + + !-- up and down-welling fluxes at levels + DO JK=1,KLEV+1 + DO IC=1,ICOUNT + JL=INDEX(IC) + !-- accumulation of spectral fluxes + PBBFU(JL,JK) = PBBFU(JL,JK) + ZINCFLX(JL,IW(JL))*ZFU(JL,JK,IW(JL)) + PBBFD(JL,JK) = PBBFD(JL,JK) + ZINCFLX(JL,IW(JL))*ZFD(JL,JK,IW(JL)) + PBBCU(JL,JK) = PBBCU(JL,JK) + ZINCFLX(JL,IW(JL))*ZCU(JL,JK,IW(JL)) + PBBCD(JL,JK) = PBBCD(JL,JK) + ZINCFLX(JL,IW(JL))*ZCD(JL,JK,IW(JL)) + + PBBFDIR(JL,JK)=PBBFDIR(JL,JK)+ZINCFLX(JL,IW(JL))*ZTDBT (JL,JK) + PBBCDIR(JL,JK)=PBBCDIR(JL,JK)+ZINCFLX(JL,IW(JL))*ZTDBTC(JL,JK) + + ENDDO + ENDDO + DO IC=1,ICOUNT + JL=INDEX(IC) + IF ( JB >= 26 .AND. JB <= 28 ) THEN + PFUVF(JL) = PFUVF(JL) + ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL)) + PFUVC(JL) = PFUVC(JL) + ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL)) + ENDIF + IF ( JB == 23) THEN + PPARF(JL) = PPARF(JL)+ ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL))*ZCOEFVS + PPARCF(JL)=PPARCF(JL)+ ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL))*ZCOEFVS + ENDIF + IF ( JB == 24) THEN + PPARF(JL) = PPARF(JL)+ ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL)) + PPARCF(JL)=PPARCF(JL)+ ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL)) + ENDIF + PSUDU(JL) = PSUDU(JL) + ZINCFLX(JL,IW(JL))*ZTDBT(JL,KLEV+1) + ENDDO + + ! Store the shortwave downwelling fluxes in each band + IF (LApproxSwUpdate) THEN + JB_ALBEDO = NMPSRTM(JB-IB1+1) + DO IC = 1,ICOUNT + JL = INDEX(IC) + PSwDiffuseBand(JL,JB_ALBEDO)= PSwDiffuseBand(JL,JB_ALBEDO) & + & + ZINCFLX(JL,IW(JL)) * (ZFD(JL, KLEV+1, IW(JL))-ZTDBT(JL,KLEV+1)) + PSwDirectBand(JL,JB_ALBEDO) = PSwDirectBand(JL,JB_ALBEDO) & + & + ZINCFLX(JL,IW(JL)) * ZTDBT(JL,KLEV+1) + ENDDO + ENDIF + + ENDDO + !-- end loop on JG + +ENDDO +!-- end loop on JB + +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE) +END ASSOCIATE +END SUBROUTINE SRTM_SPCVRT_MCICA Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_srtm_224gp_mcica.F90.erase =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_srtm_224gp_mcica.F90.erase (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_srtm_224gp_mcica.F90.erase (revision 6016) @@ -0,0 +1,463 @@ +SUBROUTINE SRTM_SRTM_224GP_MCICA & + & ( KIDIA, KFDIA, KLON , KLEV , KSW , KCOLS , KCLDLY ,& + & PAER , PALBD, PALBP, PAPH , PAP , PAERTAUS, PAERASYS, PAEROMGS ,& + & PTS , PTH , PT ,& + & PQ , PCO2 , PCH4 , PN2O , PNO2 , POZN , PRMU0 ,& + & PFRCL, PTAUC, PASYC, POMGC,& + & PFSUX, PFSUC, PFUVF, PFUVC, PPARF, PPARCF, PSUDU ,& + & PFDIR, PCDIR, PFDIF, PCDIF, PSwDiffuseBand, PSwDirectBand, RII0) + +!----compiled for Cray with -h nopaattern---- + +!-- interface to RRTM_SW +! JJMorcrette 030225 +! JJMorcrette 20050110 McICA version +! JJMorcrette 20070614 bug-fix for solar duration +! JJMorcrette 20071015 3D fields of CO2, CH4, N2O and NO2 +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20091201 Total and clear-sky downward direct flux +! PBechtold+NSemane 09-Jul-2012 Gravity +! R J Hogan 20140627 Passing through PSwDn*SurfBand + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE YOMCST , ONLY : RG, RI0 +USE YOERAD , ONLY : NSW, NAER, LApproxSwUpdate +USE YOESRTAER, ONLY : RSRTAUA, RSRPIZA, RSRASYA +USE YOEAERATM, ONLY : LAERRRTM, LAERCSTR, LAERVOL +!USE YOMPHY3 , ONLY : RII0 +USE YOMDYNCORE,ONLY : RPLRG +USE YOM_YGFL , ONLY : YGFL + +IMPLICIT NONE + +!-- Input arguments + +INTEGER(KIND=JPIM),INTENT(IN) :: KLON +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +INTEGER(KIND=JPIM),INTENT(IN) :: KSW +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KCOLS +INTEGER(KIND=JPIM),INTENT(IN) :: KCLDLY(KCOLS) + +REAL(KIND=JPRB) ,INTENT(IN) :: PAER(KLON,6,KLEV) ! top to bottom +REAL(KIND=JPRB) ,INTENT(IN) :: PAERTAUS(KLON,KLEV,14), PAERASYS(KLON,KLEV,14), PAEROMGS(KLON,KLEV,14) +REAL(KIND=JPRB) ,INTENT(IN) :: PALBD(KLON,KSW) +REAL(KIND=JPRB) ,INTENT(IN) :: PALBP(KLON,KSW) +REAL(KIND=JPRB) ,INTENT(IN) :: PAPH(KLON,KLEV+1) +REAL(KIND=JPRB) ,INTENT(IN) :: PAP(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PTS(KLON) +REAL(KIND=JPRB) ,INTENT(IN) :: PTH(KLON,KLEV+1) +REAL(KIND=JPRB) ,INTENT(IN) :: PT(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PQ(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCO2(KLON,KLEV), PCH4(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PN2O(KLON,KLEV), PNO2(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: POZN(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KLON) + +REAL(KIND=JPRB) ,INTENT(IN) :: PFRCL(KLON,KCOLS,KLEV) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUC(KLON,KCOLS,KLEV) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: PASYC(KLON,KCOLS,KLEV) ! bottom to top +REAL(KIND=JPRB) ,INTENT(IN) :: POMGC(KLON,KCOLS,KLEV) ! bottom to top + +!-- Output arguments + +REAL(KIND=JPRB) ,INTENT(OUT) :: PFSUX(KLON,2,KLEV+1) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFSUC(KLON,2,KLEV+1) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFUVF(KLON), PFUVC(KLON), PPARF(KLON), PPARCF(KLON) +REAL(KIND=JPRB) ,INTENT(OUT) :: PSUDU(KLON) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFDIF(KLON,KLEV+1), PCDIF(KLON,KLEV+1) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFDIR(KLON,KLEV+1), PCDIR(KLON,KLEV+1) + +! Surface diffuse and direct downwelling shortwave flux in each +! shortwave albedo band, used in RADINTG to update the surface fluxes +! accounting for high-resolution albedo information +REAL(KIND=JPRB) ,INTENT(OUT) :: PSwDiffuseBand(KLON,NSW) +REAL(KIND=JPRB) ,INTENT(OUT) :: PSwDirectBand (KLON,NSW) + +REAL(KIND=JPRB) ,INTENT(IN) :: RII0 +!----------------------------------------------------------------------- + +!-- dummy integers + +INTEGER(KIND=JPIM) :: ICLDATM, INFLAG, ICEFLAG, I_LIQFLAG, ITMOL, I_NSTR + +INTEGER(KIND=JPIM) :: IK, IMOL, J1, J2, JAE, JL, JK, JSW, JB + +!-- dummy reals + +REAL(KIND=JPRB) :: ZPZ(KIDIA:KFDIA,0:KLEV) , ZPAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZTAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCOLDRY(KIDIA:KFDIA,KLEV) , ZCOLMOL(KIDIA:KFDIA,KLEV) , ZWKL(KIDIA:KFDIA,35,KLEV) +REAL(KIND=JPRB) :: ZCOLCH4(KIDIA:KFDIA,KLEV) , ZCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZCOLO2(KIDIA:KFDIA,KLEV) , ZCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZFORFAC(KIDIA:KFDIA,KLEV) , ZFORFRAC(KIDIA:KFDIA,KLEV), ZSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZSELFFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZFAC00(KIDIA:KFDIA,KLEV) , ZFAC01(KIDIA:KFDIA,KLEV) , ZFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZFAC11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) :: ZONEMINUS(KIDIA:KFDIA) , ZRMU0(KIDIA:KFDIA) , ZADJI0 +REAL(KIND=JPRB) :: ZALBD(KIDIA:KFDIA,KSW) , ZALBP(KIDIA:KFDIA,KSW) + +REAL(KIND=JPRB) :: ZFRCL(KIDIA:KFDIA,KCOLS,KLEV), ZTAUC(KIDIA:KFDIA,KLEV,KCOLS), & + & ZASYC(KIDIA:KFDIA,KLEV,KCOLS) +REAL(KIND=JPRB) :: ZOMGC(KIDIA:KFDIA,KLEV,KCOLS) +REAL(KIND=JPRB) :: ZTAUA(KIDIA:KFDIA,KLEV,KSW), ZASYA(KIDIA:KFDIA,KLEV,KSW), ZOMGA(KIDIA:KFDIA,KLEV,KSW) +REAL(KIND=JPRB) :: ZFUVF(KIDIA:KFDIA), ZFUVC(KIDIA:KFDIA), ZPARF(KIDIA:KFDIA), ZPARCF(KIDIA:KFDIA), ZSUDU(KIDIA:KFDIA) + +REAL(KIND=JPRB) :: ZBBCD(KIDIA:KFDIA,KLEV+1), ZBBCU(KIDIA:KFDIA,KLEV+1), ZBBFD(KIDIA:KFDIA,KLEV+1), & + & ZBBFU(KIDIA:KFDIA,KLEV+1) +REAL(KIND=JPRB) :: ZBBFDIR(KIDIA:KFDIA,KLEV+1),ZBBCDIR(KIDIA:KFDIA,KLEV+1) + +! As PSw*Band but dimensioned KIDIA:KFDIA +REAL(KIND=JPRB) :: ZSwDiffuseBand(KIDIA:KFDIA,NSW) +REAL(KIND=JPRB) :: ZSwDirectBand (KIDIA:KFDIA,NSW) + +INTEGER(KIND=JPIM) :: ILAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM) :: INDFOR(KIDIA:KFDIA,KLEV), INDSELF(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM) :: JP(KIDIA:KFDIA,KLEV), JT(KIDIA:KFDIA,KLEV), JT1(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) :: ZAMD ! Effective molecular weight of dry air (g/mol) +REAL(KIND=JPRB) :: ZAMW ! Molecular weight of water vapor (g/mol) +REAL(KIND=JPRB) :: ZAMCO2 ! Molecular weight of carbon dioxide (g/mol) +REAL(KIND=JPRB) :: ZAMO ! Molecular weight of ozone (g/mol) +REAL(KIND=JPRB) :: ZAMCH4 ! Molecular weight of methane (g/mol) +REAL(KIND=JPRB) :: ZAMN2O ! Molecular weight of nitrous oxide (g/mol) +REAL(KIND=JPRB) :: ZAMC11 ! Molecular weight of CFC11 (g/mol) - CFCL3 +REAL(KIND=JPRB) :: ZAMC12 ! Molecular weight of CFC12 (g/mol) - CF2CL2 +REAL(KIND=JPRB) :: ZAVGDRO ! Avogadro's number (molecules/mole) +REAL(KIND=JPRB) :: ZGRAVIT ! Gravitational acceleration (cm/sec2) +REAL(KIND=JPRB) :: ZAMM(KIDIA:KFDIA) + +REAL(KIND=JPRB) :: ZRAMW ! Molecular weight of water vapor (g/mol) +REAL(KIND=JPRB) :: ZRAMCO2 ! Molecular weight of carbon dioxide (g/mol) +REAL(KIND=JPRB) :: ZRAMO ! Molecular weight of ozone (g/mol) +REAL(KIND=JPRB) :: ZRAMCH4 ! Molecular weight of methane (g/mol) +REAL(KIND=JPRB) :: ZRAMN2O ! Molecular weight of nitrous oxide (g/mol) + +! Atomic weights for conversion from mass to volume mixing ratios; these +! are the same values used in ECRT to assure accurate conversion to vmr +data ZAMD / 28.970_JPRB / +data ZAMW / 18.0154_JPRB / +data ZAMCO2 / 44.011_JPRB / +data ZAMO / 47.9982_JPRB / +data ZAMCH4 / 16.043_JPRB / +data ZAMN2O / 44.013_JPRB / +data ZAMC11 / 137.3686_JPRB / +data ZAMC12 / 120.9140_JPRB / +data ZAVGDRO/ 6.02214E23_JPRB / +data ZRAMW / 0.05550_JPRB / +data ZRAMCO2 / 0.02272_JPRB / +data ZRAMO / 0.02083_JPRB / +data ZRAMCH4 / 0.06233_JPRB / +data ZRAMN2O / 0.02272_JPRB / + + +!REAL(KIND=JPRB) :: ZCLEAR, ZCLOUD, ZTOTCC +REAL(KIND=JPRB) :: ZEPSEC + +INTEGER(KIND=JPIM) :: IOVLP, IC, ICOUNT, INDEX(KIDIA:KFDIA) +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + +#include "srtm_setcoef.intfb.h" +#include "srtm_spcvrt_mcica.intfb.h" + + +!----------------------------------------------------------------------- +!-- calculate information needed ny the radiative transfer routine + +ASSOCIATE(NFLEVG=>KLEV, & + & NACTAERO=>YGFL%NACTAERO) +IF (LHOOK) CALL DR_HOOK('SRTM_SRTM_224GP_MCICA',0,ZHOOK_HANDLE) +ZGRAVIT =(RG/RPLRG)*1.E2_JPRB +ZEPSEC = 1.E-06_JPRB +ZONEMINUS=1.0_JPRB - ZEPSEC +ZADJI0 = RII0 / RI0 +!-- overlap: 1=max-ran, 2=maximum, 3=random N.B.: irrelevant in McICA version +IOVLP=3 + +IC=0 +DO JL = KIDIA, KFDIA + IF (PRMU0(JL) > 0.0_JPRB) THEN + IC=IC+1 + INDEX(IC)=JL + ENDIF +ENDDO +ICOUNT=IC + +ICLDATM = 1 +INFLAG = 2 +ICEFLAG = 3 +I_LIQFLAG= 1 +ITMOL = 7 +I_NSTR = 2 + +DO JSW=1,KCOLS + DO JK=1,KLEV + DO JL = KIDIA, KFDIA + ZFRCL(JL,JSW,JK) = PFRCL(JL,JSW,JK) + ZTAUC(JL,JK,JSW) = PTAUC(JL,JSW,JK) + ZASYC(JL,JK,JSW) = PASYC(JL,JSW,JK) + ZOMGC(JL,JK,JSW) = POMGC(JL,JSW,JK) + ENDDO + ENDDO +ENDDO + +ZRMU0(KIDIA:KFDIA)=PRMU0(KIDIA:KFDIA) +PFUVF(KIDIA:KFDIA)=0._JPRB +PFUVC(KIDIA:KFDIA)=0._JPRB +PPARF(KIDIA:KFDIA)=0._JPRB +PPARCF(KIDIA:KFDIA)=0._JPRB + +!- coefficients related to the cloud optical properties (original RRTM_SW) + +!- coefficients for the temperature and pressure dependence of the +! molecular absorption coefficients + +DO J1=1,35 + DO J2=1,KLEV + DO IC=1,ICOUNT + JL=INDEX(IC) + ZWKL(JL,J1,J2)=0.0_JPRB + ENDDO + ENDDO +ENDDO + +DO IC=1,ICOUNT + JL=INDEX(IC) + ZPZ(JL,0) = paph(JL,klev+1)*0.01_JPRB +ENDDO + +!ZCLEAR=1.0_JPRB +!ZCLOUD=0.0_JPRB +!ZTOTCC=0.0_JPRB + +DO JK = 1, KLEV + DO IC=1,ICOUNT + JL=INDEX(IC) + ZPAVEL(JL,JK) = pap(JL,KLEV-JK+1) *0.01_JPRB + ZTAVEL(JL,JK) = pt (JL,KLEV-JK+1) + ZPZ(JL,JK) = paph(JL,KLEV-JK+1) *0.01_JPRB + ZWKL(JL,1,JK) = pq(JL,KLEV-JK+1) *ZAMD*ZRAMW + ZWKL(JL,2,JK) = PCO2(JL,KLEV-JK+1)*ZAMD*ZRAMCO2 + ZWKL(JL,3,JK) = pozn(JL,KLEV-JK+1)*ZAMD*ZRAMO + ZWKL(JL,4,JK) = PN2O(JL,KLEV-JK+1)*ZAMD*ZRAMN2O + ZWKL(JL,6,JK) = PCH4(JL,KLEV-JK+1)*ZAMD*ZRAMCH4 +!O2 volume mixing ratio + ZWKL(JL,7,JK) = 0.20944_JPRB + ZAMM(JL) = (1-ZWKL(JL,1,JK))*ZAMD + ZWKL(JL,1,JK)*ZAMW + ZCOLDRY(JL,JK) = (ZPZ(JL,JK-1)-ZPZ(JL,JK))*1.E3_JPRB*ZAVGDRO/(ZGRAVIT*ZAMM(JL)*(1+ZWKL(JL,1,JK))) + ENDDO +ENDDO + +DO IMOL=1,ITMOL + DO JK=1,KLEV + DO IC=1,ICOUNT + JL=INDEX(IC) + ZWKL(JL,IMOL,JK)=ZCOLDRY(JL,JK)* ZWKL(JL,IMOL,JK) + ENDDO + ENDDO +ENDDO + +CALL SRTM_SETCOEF & + & ( KIDIA , KFDIA , KLEV,& + & ZPAVEL , ZTAVEL,& + & ZCOLDRY , ZWKL,& + & ILAYTROP,& + & ZCOLCH4 , ZCOLCO2 , ZCOLH2O , ZCOLMOL , ZCOLO2 , ZCOLO3,& + & ZFORFAC , ZFORFRAC , INDFOR , ZSELFFAC, ZSELFFRAC, INDSELF, & + & ZFAC00 , ZFAC01 , ZFAC10 , ZFAC11,& + & JP , JT , JT1 , ZRMU0 & + & ) + +!- call the radiation transfer routine + +DO JSW=1,KSW + DO IC=1,ICOUNT + JL=INDEX(IC) + ZALBD(JL,JSW)=PALBD(JL,JSW) + ZALBP(JL,JSW)=PALBP(JL,JSW) + ENDDO +ENDDO + +!- mixing of aerosols + +IF (NAER == 0) THEN + DO JSW=1,KSW + DO JK=1,KLEV + DO IC=1,ICOUNT + JL=INDEX(IC) + ZTAUA(JL,JK,JSW)= 0.0_JPRB + ZASYA(JL,JK,JSW)= 0.0_JPRB + ZOMGA(JL,JK,JSW)= 1.0_JPRB + ENDDO + ENDDO + ENDDO +ELSE + +!- If prognostic aerosols with proper RRTM optical properties, fill the RRTM aerosol arrays + + IF (LAERRRTM) THEN + IF (LAERCSTR .OR. (LAERVOL .AND. NACTAERO == 15)) THEN + DO JSW=1,KSW + DO JK=1,KLEV + IK=KLEV-JK+1 + DO IC=1,ICOUNT + JL=INDEX(IC) + ZTAUA(JL,JK,JSW)=PAERTAUS(JL,IK,JSW) + ZASYA(JL,JK,JSW)=PAERASYS(JL,IK,JSW) + ZOMGA(JL,JK,JSW)=PAEROMGS(JL,IK,JSW) + ENDDO + ENDDO + ENDDO + + ELSEIF (.NOT.LAERCSTR) THEN + DO JSW=1,KSW + DO JK=1,KLEV + IK=KLEV-JK+1 + DO IC=1,ICOUNT + JL=INDEX(IC) + ZTAUA(JL,JK,JSW)=PAERTAUS(JL,IK,JSW)+RSRTAUA(JSW,6)*PAER(JL,6,IK) + ZASYA(JL,JK,JSW)=PAERASYS(JL,IK,JSW)+RSRTAUA(JSW,6)*PAER(JL,6,IK)*RSRPIZA(JSW,6) + ZOMGA(JL,JK,JSW)=PAEROMGS(JL,IK,JSW)+RSRTAUA(JSW,6)*PAER(JL,6,IK)*RSRPIZA(JSW,6)*RSRASYA(JSW,6) + IF (ZOMGA(JL,JK,JSW) /= 0.0_JPRB) THEN + ZASYA(JL,JK,JSW)=ZASYA(JL,JK,JSW)/ZOMGA(JL,JK,JSW) + ENDIF + IF (ZTAUA(JL,JK,JSW) /= 0.0_JPRB) THEN + ZOMGA(JL,JK,JSW)=ZOMGA(JL,JK,JSW)/ZTAUA(JL,JK,JSW) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + ELSE + +!- Otherwise, fill RRTM aerosol arrays with operational ECMWF aerosols, +! do the mixing and distribute over the 14 spectral intervals + + DO JSW=1,KSW + DO JK=1,KLEV + DO IC=1,ICOUNT + JL=INDEX(IC) + IK=KLEV+1-JK + ZTAUA(JL,JK,JSW)=0.0_JPRB + ZASYA(JL,JK,JSW)=0.0_JPRB + ZOMGA(JL,JK,JSW)=0.0_JPRB +!CDIR UNROLL=6 + DO JAE=1,6 + ZTAUA(JL,JK,JSW)=ZTAUA(JL,JK,JSW)+RSRTAUA(JSW,JAE)*PAER(JL,JAE,IK) + ZOMGA(JL,JK,JSW)=ZOMGA(JL,JK,JSW)+RSRTAUA(JSW,JAE)*PAER(JL,JAE,IK) & + & *RSRPIZA(JSW,JAE) + ZASYA(JL,JK,JSW)=ZASYA(JL,JK,JSW)+RSRTAUA(JSW,JAE)*PAER(JL,JAE,IK) & + & *RSRPIZA(JSW,JAE)*RSRASYA(JSW,JAE) + ENDDO + IF (ZOMGA(JL,JK,JSW) /= 0.0_JPRB) THEN + ZASYA(JL,JK,JSW)=ZASYA(JL,JK,JSW)/ZOMGA(JL,JK,JSW) + ENDIF + IF (ZTAUA(JL,JK,JSW) /= 0.0_JPRB) THEN + ZOMGA(JL,JK,JSW)=ZOMGA(JL,JK,JSW)/ZTAUA(JL,JK,JSW) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +ENDIF + +DO JK=1,KLEV+1 + DO IC=1,ICOUNT + JL=INDEX(IC) + ZBBCU(JL,JK)=0.0_JPRB + ZBBCD(JL,JK)=0.0_JPRB + ZBBFU(JL,JK)=0.0_JPRB + ZBBFD(JL,JK)=0.0_JPRB + ZBBFDIR(JL,JK)=0.0_JPRB + ZBBCDIR(JL,JK)=0.0_JPRB + ENDDO +ENDDO + +DO IC=1,ICOUNT + JL=INDEX(IC) + ZFUVF(JL)=0.0_JPRB + ZFUVC(JL)=0.0_JPRB + ZPARF(JL)=0.0_JPRB + ZPARCF(JL)=0.0_JPRB + ZSUDU(JL)=0.0_JPRB +ENDDO + +CALL SRTM_SPCVRT_MCICA & + &( KIDIA , KFDIA , KLEV , KSW , KCOLS , ZONEMINUS,& + & ZALBD , ZALBP,& + & ZFRCL , ZTAUC , ZASYC , ZOMGC ,& + & ZTAUA , ZASYA , ZOMGA , ZRMU0,& + & ILAYTROP,& + & ZCOLCH4 , ZCOLCO2 , ZCOLH2O, ZCOLMOL , ZCOLO2 , ZCOLO3,& + & ZFORFAC , ZFORFRAC , INDFOR , ZSELFFAC, ZSELFFRAC, INDSELF,& + & ZFAC00 , ZFAC01 , ZFAC10 , ZFAC11 ,& + & JP , JT , JT1 ,& + & ZBBFD , ZBBFU , ZBBCD , ZBBCU , ZFUVF , ZFUVC, ZPARF, ZPARCF, ZSUDU,& + & ZBBFDIR , ZBBCDIR , ZSwDiffuseBand, ZSwDirectBand) + +DO JK=1,KLEV+1 + DO IC=1,ICOUNT + JL=INDEX(IC) + PFSUC(JL,1,JK)=ZADJI0 * ZBBCU(JL,JK) + PFSUC(JL,2,JK)=ZADJI0 * ZBBCD(JL,JK) + PFSUX(JL,1,JK)=ZADJI0 * ZBBFU(JL,JK) + PFSUX(JL,2,JK)=ZADJI0 * ZBBFD(JL,JK) + PFDIR(JL,JK) =ZADJI0 * ZBBFDIR(JL,JK) + PCDIR(JL,JK) =ZADJI0 * ZBBCDIR(JL,JK) + PFDIF(JL,JK) =PFSUX(JL,2,JK)-PFDIR(JL,JK) + PCDIF(JL,JK) =PFSUC(JL,2,JK)-PCDIR(JL,JK) + ENDDO +ENDDO + +IF (LApproxSwUpdate) THEN + DO JB=1,NSW + DO IC=1,ICOUNT + JL=INDEX(IC) + PSwDiffuseBand(JL,JB) = ZADJI0 * ZSwDiffuseBand(JL,JB) + PSwDirectBand (JL,JB) = ZADJI0 * ZSwDirectBand (JL,JB) + ENDDO + ENDDO +ENDIF + +DO IC=1,ICOUNT + JL=INDEX(IC) + PFUVF(JL) =ZADJI0 * ZFUVF(JL) + PFUVC(JL) =ZADJI0 * ZFUVC(JL) + PPARF(JL) =ZADJI0 * ZPARF(JL) + PPARCF(JL)=ZADJI0 * ZPARCF(JL) + PSUDU(JL) =ZADJI0 * ZSUDU(JL) +ENDDO + +DO JK=1,KLEV+1 + DO IC=1,ICOUNT + JL=INDEX(IC) + IF (PRMU0(JL) <= 0.0_JPRB) THEN + PFSUC(JL,1,JK)=0.0_JPRB + PFSUC(JL,2,JK)=0.0_JPRB + PFSUX(JL,1,JK)=0.0_JPRB + PFSUX(JL,2,JK)=0.0_JPRB + PFDIR(JL,JK) =0.0_JPRB + PCDIR(JL,JK) =0.0_JPRB + ENDIF + ENDDO +ENDDO +DO IC=1,ICOUNT + JL=INDEX(IC) + IF (PRMU0(JL) <= 0.0_JPRB) THEN + PFUVF(JL) =0.0_JPRB + PFUVC(JL) =0.0_JPRB + PPARF(JL) =0.0_JPRB + PPARCF(JL)=0.0_JPRB + PSUDU(JL)=0.0_JPRB + ENDIF +ENDDO + +!----------------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('SRTM_SRTM_224GP_MCICA',1,ZHOOK_HANDLE) +END ASSOCIATE +END SUBROUTINE SRTM_SRTM_224GP_MCICA Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol16.F90 (revision 6016) @@ -0,0 +1,235 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL16 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCH4 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC , P_SELFFRAC, K_INDSELF , P_FORFAC , P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 16: 2600-3250 cm-1 (low - H2O,CH4; high - CH4) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20010610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG16 +USE YOESRTA16, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, RAYL, LAYREFFR, STRRAT1 +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max + +REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,& + & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(I_LAYSOLFR) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_ONEMINUS, P_COLH2O, P_COLCH4, P_COLMOL, K_LAYTROP, & + !$ACC P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, & + !$ACC K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + DO iplon = KIDIA,KFDIA + i_laysolfr(iplon) = i_nlayers + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, js, z_fs, z_speccomb, z_specmult, z_specparm, & + !$ACC z_tauray) + DO i_lay = 1, laytrop_min + DO iplon = KIDIA,KFDIA + z_speccomb = p_colh2o(iplon,i_lay) + strrat1*p_colch4(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(16) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(16) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG16) + DO ig = 1, ng16 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(inds, indf, ind0, ind1, js, z_fs, z_speccomb, z_specmult, z_specparm, & + !$ACC z_tauray) + DO iplon = KIDIA,KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + z_speccomb = p_colh2o(iplon,i_lay) + strrat1*p_colch4(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(16) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(16) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG16) + !$ACC LOOP SEQ + DO ig = 1, ng16 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(16) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(16)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG16) + !$ACC LOOP SEQ + DO ig = 1, ng16 + p_taug(iplon,i_lay,ig) = p_colch4(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0 ,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1 ,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + IF (i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig) = sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, z_tauray) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(16) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(16)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl + !$ACC LOOP SEQ +!$NEC unroll(NG16) + DO ig = 1, ng16 + p_taug(iplon,i_lay,ig) = p_colch4(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0 ,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1 ,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + IF (i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig) = sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL16 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol17.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol17.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol17.F90 (revision 6016) @@ -0,0 +1,269 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL17 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCO2 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 17: 3250-4000 cm-1 (low - H2O,CO2; high - H2O,CO2) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20010610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG17 +USE YOESRTA17, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, RAYL, LAYREFFR, STRRAT +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +! REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,& +! & Z_FAC110, Z_FAC111 +REAL(KIND=JPRB) :: Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(I_LAYSOLFR) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_ONEMINUS, P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, & + !$ACC P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, & + !$ACC K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP VECTOR + DO iplon = KIDIA,KFDIA + i_laysolfr(iplon) = i_nlayers + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, js, z_fs, z_speccomb, z_specmult, z_specparm, & + !$ACC z_tauray) + DO i_lay = 1, laytrop_min + DO iplon = KIDIA, KFDIA + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(17) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(17) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG17) + !$ACC LOOP SEQ + DO ig = 1, ng17 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, z_speccomb, z_specmult, z_specparm, z_tauray) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(17) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(17) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG17) + !$ACC LOOP SEQ + DO ig = 1, ng17 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 4._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(17)+ js + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(17)+js + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG17) + !$ACC LOOP SEQ + DO ig = 1, ng17 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absb(ind0,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+5,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+5,ig) * p_fac11(iplon,i_lay))+ & + & z_fs * ( absb(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+6,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+6,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig))) + IF (i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, indf, js, z_fs, z_speccomb, z_specmult, z_specparm, z_tauray) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 4._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(17)+ js + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(17)+js + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG17) + DO ig = 1, ng17 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absb(ind0,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+5,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+5,ig) * p_fac11(iplon,i_lay))+ & + & z_fs * ( absb(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+6,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+6,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig))) + IF (i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL17 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol18.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol18.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol18.F90 (revision 6016) @@ -0,0 +1,241 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL18 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCH4 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 18: 4000-4650 cm-1 (low - H2O,CH4; high - CH4) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG18 +USE YOESRTA18, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, RAYL, LAYREFFR, STRRAT +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +INTEGER(KIND=JPIM) :: I_LAY_NEXT + +REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,& + & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(I_LAYSOLFR) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_ONEMINUS, P_COLH2O, P_COLCH4, P_COLMOL, K_LAYTROP, & + !$ACC P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, & + !$ACC K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + + !$ACC LOOP SEQ + DO i_lay = 1, laytrop_min + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, & + !$ACC z_speccomb, z_specmult, z_specparm, z_tauray) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colch4(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(18) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(18) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG18) + DO ig = 1, ng18 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, z_speccomb, z_specmult, z_specparm, & + !$ACC z_tauray) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colch4(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(18) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(18) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG18) + !$ACC LOOP SEQ + DO ig = 1, ng18 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(18) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(18)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG18) + !$ACC LOOP SEQ + DO ig = 1, ng18 + p_taug(iplon,i_lay,ig) = p_colch4(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, z_tauray) + DO iplon = KIDIA, KFDIA + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(18) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(18)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG18) + DO ig = 1, ng18 + p_taug(iplon,i_lay,ig) = p_colch4(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL18 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol19.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol19.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol19.F90 (revision 6016) @@ -0,0 +1,240 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL19 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCO2 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 19: 4650-5150 cm-1 (low - H2O,CO2; high - CO2) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG19 +USE YOESRTA19, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, RAYL, LAYREFFR, STRRAT +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +!REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,& +! & Z_FAC110, Z_FAC111 +REAL(KIND=JPRB) :: Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +INTEGER(KIND=JPIM) :: I_LAY_NEXT + + !$ACC DATA CREATE(I_LAYSOLFR) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_ONEMINUS, P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, & + !$ACC P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, & + !$ACC K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + + !$ACC LOOP SEQ + DO i_lay = 1, laytrop_min + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, z_speccomb, z_specmult, z_specparm, & + !$ACC z_tauray) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(19) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(19) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG19) + DO ig = 1 , ng19 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, z_speccomb, z_specmult, z_specparm, & + !$ACC z_tauray) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(19) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(19) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG19) + !$ACC LOOP SEQ + DO ig = 1 , ng19 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(19) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(19)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG19) + !$ACC LOOP SEQ + DO ig = 1 , ng19 + p_taug(iplon,i_lay,ig) = p_colco2(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, z_tauray) + DO iplon = KIDIA, KFDIA + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(19) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(19)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG19) + DO ig = 1 , ng19 + p_taug(iplon,i_lay,ig) = p_colco2(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL19 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol20.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol20.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol20.F90 (revision 6016) @@ -0,0 +1,214 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL20 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLH2O , P_COLCH4 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 20: 5150-6150 cm-1 (low - H2O; high - H2O) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG20 +USE YOESRTA20, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, ABSCH4C, RAYL, LAYREFFR +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +INTEGER(KIND=JPIM) :: I_LAY_NEXT + +REAL(KIND=JPRB) :: & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(i_laysolfr) & + !$ACC PRESENT(p_fac00, p_fac01, p_fac10, p_fac11, k_jp, k_jt, k_jt1, & + !$ACC p_colh2o, p_colch4, p_colmol, k_laytrop, p_selffac, & + !$ACC p_selffrac, k_indself, p_forfac, p_forfrac, k_indfor, & + !$ACC p_sfluxzen, p_taug, p_taur, prmu0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + + !$ACC LOOP SEQ + DO i_lay = 1, laytrop_min + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(IND0, IND1, INDS, INDF, Z_TAURAY) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(20) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(20) + 1 + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG20) + DO ig = 1 , ng20 + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & ((p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + & + & p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) & + & + p_colch4(iplon,i_lay) * absch4c(ig) + p_taur(iplon,i_lay,ig) = z_tauray + IF(i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig)=sfluxrefc(ig) + ENDDO + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, z_tauray) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(20) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(20) + 1 + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG20) + !$ACC LOOP SEQ + DO ig = 1 , ng20 + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & ((p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + & + & p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) & + & + p_colch4(iplon,i_lay) * absch4c(ig) + p_taur(iplon,i_lay,ig) = z_tauray + IF(i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig)=sfluxrefc(ig) + ENDDO + ELSE + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(20) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(20) +1 + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG20) + !$ACC LOOP SEQ + DO ig = 1 , ng20 + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + & + & p_colch4(iplon,i_lay) * absch4c(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(IND0, IND1, INDF, Z_TAURAY) + DO iplon = KIDIA, KFDIA + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(20) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(20) +1 + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + !$ACC LOOP SEQ +!$NEC unroll(NG20) + DO ig = 1 , ng20 + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + & + & p_colch4(iplon,i_lay) * absch4c(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL20 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol21.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol21.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol21.F90 (revision 6016) @@ -0,0 +1,273 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL21 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCO2 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 21: 6150-7700 cm-1 (low - H2O,CO2; high - H2O,CO2) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG21 +USE YOESRTA21, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, RAYL, LAYREFFR, STRRAT +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +INTEGER(KIND=JPIM) :: I_LAY_NEXT + +REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,& + & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(i_laysolfr) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_ONEMINUS, P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, & + !$ACC P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, & + !$ACC K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + + !$ACC LOOP SEQ + DO i_lay = 1, laytrop_min + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, & + !$ACC z_speccomb, z_specmult, z_specparm, z_tauray) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(21) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(21) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG21) + DO ig = 1 , ng21 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, & + !$ACC z_speccomb, z_specmult, z_specparm, z_tauray) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(21) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(21) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG21) + !$ACC LOOP SEQ + DO ig = 1 , ng21 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 4._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(21) +js + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(21)+js + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG21) + !$ACC LOOP SEQ + DO ig = 1 , ng21 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB - z_fs) * ( absb(ind0,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+5,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+5,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absb(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+6,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+6,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig))) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, indf, js, z_fs, z_speccomb, z_specmult, z_specparm, z_tauray) + DO iplon = KIDIA, KFDIA + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colco2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 4._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(21) +js + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(21)+js + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + !$ACC LOOP SEQ +!$NEC unroll(NG21) + DO ig = 1 , ng21 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB - z_fs) * ( absb(ind0,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+5,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+5,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absb(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+6,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+6,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig))) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL21 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol22.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol22.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol22.F90 (revision 6016) @@ -0,0 +1,255 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL22 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLMOL , P_COLO2,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 22: 7700-8050 cm-1 (low - H2O,O2; high - O2) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG22 +USE YOESRTA22, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, RAYL, LAYREFFR, STRRAT +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +INTEGER(KIND=JPIM) :: I_LAY_NEXT + +REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,& + & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, & + & Z_TAURAY, Z_O2ADJ , Z_O2CONT +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(I_LAYSOLFR) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_ONEMINUS, P_COLH2O, P_COLMOL, P_COLO2, K_LAYTROP, & + !$ACC P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, & + !$ACC K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + + ! 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. + z_o2adj = 1.6_JPRB + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + + !$ACC LOOP SEQ + DO i_lay = 1, laytrop_min + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, & + !$ACC z_speccomb, z_specmult, z_specparm, z_tauray, z_o2cont) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_o2cont = 4.35e-4_JPRB*p_colo2(iplon,i_lay)/(350.0_JPRB*2.0_JPRB) + z_speccomb = p_colh2o(iplon,i_lay) + & + & z_o2adj*strrat*p_colo2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(22) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(22) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + !$ACC LOOP SEQ +!$NEC unroll(NG22) + DO ig = 1 , ng22 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) & + & + z_o2cont + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, & + !$ACC z_speccomb, z_specmult, z_specparm, z_tauray, z_o2cont) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_o2cont = 4.35e-4_JPRB*p_colo2(iplon,i_lay)/(350.0_JPRB*2.0_JPRB) + z_speccomb = p_colh2o(iplon,i_lay) + & + & z_o2adj*strrat*p_colo2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(22) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(22) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG22) + !$ACC LOOP SEQ + DO ig = 1 , ng22 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) & + & + z_o2cont + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + z_o2cont = 4.35e-4_JPRB*p_colo2(iplon,i_lay)/(350.0_JPRB*2.0_JPRB) + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(22) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(22)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG22) + !$ACC LOOP SEQ + DO ig = 1 , ng22 + p_taug(iplon,i_lay,ig) = p_colo2(iplon,i_lay) * z_o2adj * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + & + & z_o2cont + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, z_tauray, z_o2cont) + DO iplon = KIDIA, KFDIA + z_o2cont = 4.35e-4_JPRB*p_colo2(iplon,i_lay)/(350.0_JPRB*2.0_JPRB) + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(22) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(22)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG22) + DO ig = 1 , ng22 + p_taug(iplon,i_lay,ig) = p_colo2(iplon,i_lay) * z_o2adj * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + & + & z_o2cont + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL22 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol23.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol23.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol23.F90 (revision 6016) @@ -0,0 +1,191 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL23 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLH2O , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 23: 8050-12850 cm-1 (low - H2O; high - nothing) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG23 +USE YOESRTA23, ONLY : ABSA, FORREFC, SELFREFC, SFLUXREFC, RAYLC, LAYREFFR, GIVFAC +USE YOESRTWN , ONLY : NSPA + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +INTEGER(KIND=JPIM) :: I_LAY_NEXT + +REAL(KIND=JPRB) :: & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(i_laysolfr) & + !$ACC PRESENT(p_fac00, p_fac01, p_fac10, p_fac11, k_jp, k_jt, k_jt1, & + !$ACC p_colh2o, p_colmol, k_laytrop, p_selffac, p_selffrac, & + !$ACC k_indself, p_forfac, p_forfrac, k_indfor, p_sfluxzen, & + !$ACC p_taug, p_taur , prmu0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + + !$ACC LOOP SEQ + DO i_lay = 1, laytrop_min + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(23) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(23) + 1 + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + + !$ACC LOOP SEQ PRIVATE(z_tauray) +!$NEC unroll(NG23) + DO ig = 1 , ng23 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & (givfac * (p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + & + & p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + p_sfluxzen(iplon,ig) = sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(23) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(23) + 1 + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + +!$NEC unroll(NG23) + !$ACC LOOP SEQ PRIVATE(z_tauray) + DO ig = 1 , ng23 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & (givfac * (p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + & + & p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + p_sfluxzen(iplon,ig) = sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE +!$NEC unroll(NG23) + !$ACC LOOP SEQ + DO ig = 1 , ng23 + p_taug(iplon,i_lay,ig) = 0.0_JPRB + p_taur(iplon,i_lay,ig) = p_colmol(iplon,i_lay) * raylc(ig) + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO ig = 1 , ng23 + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + p_taug(iplon,i_lay,ig) = 0.0_JPRB + p_taur(iplon,i_lay,ig) = p_colmol(iplon,i_lay) * raylc(ig) + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL23 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol24.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol24.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol24.F90 (revision 6016) @@ -0,0 +1,249 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL24 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLMOL , P_COLO2 , P_COLO3,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 24: 12850-16000 cm-1 (low - H2O,O2; high - O2) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG24 +USE YOESRTA24, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, & + & ABSO3AC, ABSO3BC, RAYLAC, RAYLBC, LAYREFFR, STRRAT +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +INTEGER(KIND=JPIM) :: I_LAY_NEXT + +REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,& + & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(i_laysolfr) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_ONEMINUS, P_COLH2O, P_COLMOL, P_COLO2, P_COLO3, & + !$ACC K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, & + !$ACC P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + + !$ACC LOOP SEQ + DO i_lay = 1, laytrop_min + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, & + !$ACC z_speccomb, z_specmult, z_specparm) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colo2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(24) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(24) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + + !$ACC LOOP SEQ PRIVATE(z_tauray) +!$NEC unroll(NG24) + DO ig = 1 , ng24 + z_tauray = p_colmol(iplon,i_lay) * (raylac(ig,js) + & + & z_fs * (raylac(ig,js+1) - raylac(ig,js))) + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colo3(iplon,i_lay) * abso3ac(ig) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1, inds, indf, js, z_fs, & + !$ACC z_speccomb, z_specmult, z_specparm) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + IF (k_jp(iplon,i_lay) < layreffr & + & .AND. k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + z_speccomb = p_colh2o(iplon,i_lay) + strrat*p_colo2(iplon,i_lay) + z_specparm = p_colh2o(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(24) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(24) + js + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + +!$NEC unroll(NG24) + !$ACC LOOP SEQ PRIVATE(z_tauray) + DO ig = 1 , ng24 + z_tauray = p_colmol(iplon,i_lay) * (raylac(ig,js) + & + & z_fs * (raylac(ig,js+1) - raylac(ig,js))) + p_taug(iplon,i_lay,ig) = z_speccomb * & + & ( & + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + & + & p_colo3(iplon,i_lay) * abso3ac(ig) + & + & p_colh2o(iplon,i_lay) * & + & (p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(24) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(24)+ 1 + +!$NEC unroll(NG24) + !$ACC LOOP SEQ PRIVATE(z_tauray) + DO ig = 1 , ng24 + z_tauray = p_colmol(iplon,i_lay) * raylbc(ig) + p_taug(iplon,i_lay,ig) = p_colo2(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + & + & p_colo3(iplon,i_lay) * abso3bc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1) + DO iplon = KIDIA, KFDIA + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(24) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(24)+ 1 + + !$ACC LOOP SEQ PRIVATE(z_tauray) +!$NEC unroll(NG24) + DO ig = 1 , ng24 + z_tauray = p_colmol(iplon,i_lay) * raylbc(ig) + p_taug(iplon,i_lay,ig) = p_colo2(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + & + & p_colo3(iplon,i_lay) * abso3bc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL24 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol25.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol25.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol25.F90 (revision 6016) @@ -0,0 +1,171 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL25 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLH2O , P_COLMOL , P_COLO3,& + & K_LAYTROP,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 25: 16000-22650 cm-1 (low - H2O; high - nothing) + +! PARAMETER (MG=16, MXLAY=203, NBANDS=14) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG25 +USE YOESRTA25, ONLY : ABSA, SFLUXREFC, ABSO3AC, ABSO3BC, RAYLC, LAYREFFR +USE YOESRTWN , ONLY : NSPA + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +INTEGER(KIND=JPIM) :: I_LAY_NEXT + +REAL(KIND=JPRB) :: & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(I_LAYSOLFR) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_COLH2O, P_COLMOL, P_COLO3, K_LAYTROP, P_SFLUXZEN, & + !$ACC P_TAUG, P_TAUR, PRMU0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + + !$ACC LOOP SEQ + DO i_lay = 1, laytrop_min + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1) + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay) < layreffr .AND. & + & k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(25) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(25) + 1 + !$ACC LOOP SEQ PRIVATE(z_tauray) +!$NEC unroll(NG25) + DO ig = 1 , ng25 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + & + & p_colo3(iplon,i_lay) * abso3ac(ig) + IF(i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig)=sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO i_lay = laytrop_min+1, laytrop_max + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(ind0, ind1) + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + IF (k_jp(iplon,i_lay) < layreffr .AND. & + & k_jp(iplon,i_lay+1) >= layreffr) & + & i_laysolfr(iplon) = MIN(i_lay+1,k_laytrop(iplon)) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(25) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(25) + 1 +!$NEC unroll(NG25) + !$ACC LOOP SEQ PRIVATE(z_tauray) + DO ig = 1 , ng25 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + & + & p_colo3(iplon,i_lay) * abso3ac(ig) + IF(i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig)=sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE +!$NEC unroll(NG25) + !$ACC LOOP SEQ PRIVATE(z_tauray) + DO ig = 1 , ng25 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colo3(iplon,i_lay) * abso3bc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + + !$ACC LOOP SEQ + DO ig = 1 , ng25 + !$ACC LOOP SEQ + DO i_lay = laytrop_max+1, i_nlayers + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(z_tauray) + DO iplon = KIDIA, KFDIA + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colo3(iplon,i_lay) * abso3bc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL25 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol26.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol26.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol26.F90 (revision 6016) @@ -0,0 +1,130 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL26 & + & ( KIDIA , KFDIA , KLEV,& + & P_COLMOL ,K_LAYTROP,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 26: 22650-29000 cm-1 (low - nothing; high - nothing) + +! PARAMETER (MG=16, MXLAY=203, NBANDS=14) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG26 +USE YOESRTA26, ONLY : SFLUXREFC, RAYLC + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from AER +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(i_laysolfr) & + !$ACC PRESENT(p_colmol, k_laytrop, p_sfluxzen, p_taug, p_taur, prmu0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + DO iplon = KIDIA, KFDIA + i_laysolfr(iplon) = k_laytrop(iplon) + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + DO i_lay = 1, laytrop_min + DO iplon = KIDIA, KFDIA +!$NEC unroll(NG26) + DO ig = 1 , ng26 + IF(i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig)=sfluxrefc(ig) + p_taug(iplon,i_lay,ig) = 0.0_JPRB + p_taur(iplon,i_lay,ig) = p_colmol(iplon,i_lay) * raylc(ig) + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + DO i_lay = laytrop_min+1, laytrop_max + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN +!$NEC unroll(NG26) + !$ACC LOOP SEQ + DO ig = 1 , ng26 + IF(i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig)=sfluxrefc(ig) + p_taug(iplon,i_lay,ig) = 0.0_JPRB + p_taur(iplon,i_lay,ig) = p_colmol(iplon,i_lay) * raylc(ig) + ENDDO + ELSE +!$NEC unroll(NG26) + !$ACC LOOP SEQ + DO ig = 1 , ng26 + p_taug(iplon,i_lay,ig) = 0.0_JPRB + p_taur(iplon,i_lay,ig) = p_colmol(iplon,i_lay) * raylc(ig) + ENDDO + ENDIF + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + DO ig = 1 , ng26 + DO i_lay = laytrop_max+1, i_nlayers + DO iplon = KIDIA, KFDIA + p_taug(iplon,i_lay,ig) = 0.0_JPRB + p_taur(iplon,i_lay,ig) = p_colmol(iplon,i_lay) * raylc(ig) + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL26 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol27.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol27.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol27.F90 (revision 6016) @@ -0,0 +1,180 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL27 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLMOL , P_COLO3,& + & K_LAYTROP,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 27: 29000-38000 cm-1 (low - O3; high - O3) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG27 +USE YOESRTA27, ONLY : ABSA, ABSB, SFLUXREFC, RAYLC, LAYREFFR, SCALEKUR +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +REAL(KIND=JPRB) :: & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(i_laysolfr) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_COLMOL, P_COLO3, K_LAYTROP, P_SFLUXZEN, P_TAUG, P_TAUR, & + !$ACC PRMU0) + +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA,KFDIA + i_laysolfr(iplon) = i_nlayers + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1) + DO i_lay = 1, laytrop_min + DO iplon = KIDIA, KFDIA + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(27) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(27) + 1 + !$ACC LOOP SEQ PRIVATE(z_tauray) +!$NEC unroll(NG27) + DO ig = 1 , ng27 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colo3(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1) + DO i_lay = laytrop_min+1, laytrop_max + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(27) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(27) + 1 +!$NEC unroll(NG27) + !$ACC LOOP SEQ PRIVATE(z_tauray) + DO ig = 1 , ng27 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colo3(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(27) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(27)+ 1 +!$NEC unroll(NG27) + !$ACC LOOP SEQ PRIVATE(z_tauray) + DO ig = 1 , ng27 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colo3(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = scalekur * sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1) + DO i_lay = laytrop_max+1, i_nlayers + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(27) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(27)+ 1 + !$ACC LOOP SEQ PRIVATE(z_tauray) +!$NEC unroll(NG27) + DO ig = 1 , ng27 + z_tauray = p_colmol(iplon,i_lay) * raylc(ig) + p_taug(iplon,i_lay,ig) = p_colo3(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) + IF (i_lay == i_laysolfr(iplon)) & + & p_sfluxzen(iplon,ig) = scalekur * sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL27 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol28.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol28.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol28.F90 (revision 6016) @@ -0,0 +1,235 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL28 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLMOL , P_COLO2 , P_COLO3,& + & K_LAYTROP,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 28: 38000-50000 cm-1 (low - O3,O2; high - O3,O2) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2003-02-24 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20010610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG28 +USE YOESRTA28, ONLY : ABSA, ABSB, SFLUXREFC, RAYL, LAYREFFR, STRRAT +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) + +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +INTEGER(KIND=JPIM) :: IG, IND0, IND1, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,& + & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(i_laysolfr) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_ONEMINUS, P_COLMOL, P_COLO2, P_COLO3, K_LAYTROP, & + !$ACC P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + DO iplon = KIDIA,KFDIA + i_laysolfr(iplon) = i_nlayers + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, js, z_fs, z_speccomb, z_specmult, z_specparm, z_tauray) + DO i_lay = 1, laytrop_min + DO iplon = KIDIA, KFDIA + z_speccomb = p_colo3(iplon,i_lay) + strrat*p_colo2(iplon,i_lay) + z_specparm = p_colo3(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(28) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(28) + js + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG28) + DO ig = 1 , ng28 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & (& + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, js, z_fs, z_speccomb, z_specmult, z_specparm, z_tauray) + DO i_lay = laytrop_min+1, laytrop_max + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + z_speccomb = p_colo3(iplon,i_lay) + strrat*p_colo2(iplon,i_lay) + z_specparm = p_colo3(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 8._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(28) + js + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(28) + js + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG28) + !$ACC LOOP SEQ + DO ig = 1 , ng28 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & (& + & (1._JPRB- z_fs) * ( absa(ind0,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+9,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+9,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absa(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absa(ind0+10,ig) * p_fac10(iplon,i_lay) + & + & absa(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absa(ind1+10,ig) * p_fac11(iplon,i_lay) ) & + & ) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + z_speccomb = p_colo3(iplon,i_lay) + strrat*p_colo2(iplon,i_lay) + z_specparm = p_colo3(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 4._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(28)+ js + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(28)+js + z_tauray = p_colmol(iplon,i_lay) * rayl + +!$NEC unroll(NG28) + !$ACC LOOP SEQ + DO ig = 1 , ng28 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & (& + & (1._JPRB- z_fs) * ( absb(ind0,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+5,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+5,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absb(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+6,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+6,ig) * p_fac11(iplon,i_lay) ) & + & ) + IF (i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + !$ACC END PARALLEL + + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, js, z_fs, z_speccomb, z_specmult, z_specparm, z_tauray) + DO i_lay = laytrop_max+1, i_nlayers + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + z_speccomb = p_colo3(iplon,i_lay) + strrat*p_colo2(iplon,i_lay) + z_specparm = p_colo3(iplon,i_lay)/z_speccomb + z_specparm = MIN(p_oneminus(iplon),z_specparm) + z_specmult = 4._JPRB*(z_specparm) + js = 1 + INT(z_specmult) + z_fs = z_specmult - AINT(z_specmult) + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(28)+ js + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(28)+js + z_tauray = p_colmol(iplon,i_lay) * rayl + + !$ACC LOOP SEQ +!$NEC unroll(NG28) + DO ig = 1 , ng28 + p_taug(iplon,i_lay,ig) = z_speccomb * & + & (& + & (1._JPRB- z_fs) * ( absb(ind0,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+5,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+5,ig) * p_fac11(iplon,i_lay) )+ & + & z_fs * ( absb(ind0+1,ig) * p_fac00(iplon,i_lay) + & + & absb(ind0+6,ig) * p_fac10(iplon,i_lay) + & + & absb(ind1+1,ig) * p_fac01(iplon,i_lay) + & + & absb(ind1+6,ig) * p_fac11(iplon,i_lay) ) & + & ) + IF (i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig) = sfluxrefc(ig,js) & + & + z_fs * (sfluxrefc(ig,js+1) - sfluxrefc(ig,js)) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL28 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol29.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol29.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/srtm_taumol29.F90 (revision 6016) @@ -0,0 +1,210 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SRTM_TAUMOL29 & + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLH2O , P_COLCO2 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0 & + & ) + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. + +! BAND 29: 820-2600 cm-1 (low - H2O; high - CO2) + +! Modifications +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! JJMorcrette 2002-10-03 adapted to ECMWF environment +! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC +! JJMorcrette 20110610 Flexible configuration for number of g-points + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE PARSRTM , ONLY : JPG +USE YOESRTM , ONLY : NG29 +USE YOESRTA29, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, & + & ABSH2OC, ABSCO2C, RAYL, LAYREFFR +USE YOESRTWN , ONLY : NSPA, NSPB + +IMPLICIT NONE + +!-- Output +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM) :: laytrop_min, laytrop_max +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +!- from INTFAC +!- from INTIND +!- from PRECISE +!- from PROFDATA +!- from SELF +!-- from FOREIGN +INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON + +REAL(KIND=JPRB) :: & + & Z_TAURAY +REAL(KIND=JPRB) :: ZHOOK_HANDLE + + !$ACC DATA CREATE(i_laysolfr) & + !$ACC PRESENT(P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, & + !$ACC P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, P_SELFFAC, & + !$ACC P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, & + !$ACC P_SFLUXZEN, P_TAUG, P_TAUR, PRMU0) +#ifndef _OPENACC + laytrop_min = MINVAL(k_laytrop(KIDIA:KFDIA)) + laytrop_max = MAXVAL(k_laytrop(KIDIA:KFDIA)) +#else + laytrop_min = HUGE(laytrop_min) + laytrop_max = -HUGE(laytrop_max) + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR REDUCTION(min:laytrop_min) REDUCTION(max:laytrop_max) + do iplon = KIDIA,KFDIA + laytrop_min = MIN(laytrop_min, k_laytrop(iplon)) + laytrop_max = MAX(laytrop_max, k_laytrop(iplon)) + end do + !$ACC END PARALLEL +#endif + + i_nlayers = klev + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + DO iplon = KIDIA,KFDIA + i_laysolfr(iplon) = i_nlayers + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, z_tauray) + DO i_lay = 1, laytrop_min + DO iplon = KIDIA, KFDIA + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(29) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(29) + 1 + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl + !$ACC LOOP SEQ +!$NEC unroll(NG29) + DO ig = 1, ng29 + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & ((p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + & + & p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) & + & + p_colco2(iplon,i_lay) * absco2c(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, inds, indf, z_tauray) + DO i_lay = laytrop_min+1, laytrop_max + DO iplon = KIDIA, KFDIA + IF (i_lay <= k_laytrop(iplon)) THEN + ind0 = ((k_jp(iplon,i_lay)-1)*5+(k_jt(iplon,i_lay)-1))*nspa(29) + 1 + ind1 = (k_jp(iplon,i_lay)*5+(k_jt1(iplon,i_lay)-1))*nspa(29) + 1 + inds = k_indself(iplon,i_lay) + indf = k_indfor(iplon,i_lay) + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG29) + !$ACC LOOP SEQ + DO ig = 1, ng29 + p_taug(iplon,i_lay,ig) = p_colh2o(iplon,i_lay) * & + & ((p_fac00(iplon,i_lay) * absa(ind0,ig) + & + & p_fac10(iplon,i_lay) * absa(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absa(ind1,ig) + & + & p_fac11(iplon,i_lay) * absa(ind1+1,ig)) + & + & p_selffac(iplon,i_lay) * (selfrefc(inds,ig) + & + & p_selffrac(iplon,i_lay) * & + & (selfrefc(inds+1,ig) - selfrefc(inds,ig))) + & + & p_forfac(iplon,i_lay) * (forrefc(indf,ig) + & + & p_forfrac(iplon,i_lay) * & + & (forrefc(indf+1,ig) - forrefc(indf,ig)))) & + & + p_colco2(iplon,i_lay) * absco2c(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ELSE + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(29) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(29)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl +!$NEC unroll(NG29) + !$ACC LOOP SEQ + DO ig = 1 , ng29 + p_taug(iplon,i_lay,ig) = p_colco2(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) & + & + p_colh2o(iplon,i_lay) * absh2oc(ig) + IF (i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig) = sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDIF + ENDDO + ENDDO + !$ACC END PARALLEL + + + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(ind0, ind1, z_tauray) + DO i_lay = laytrop_max+1, i_nlayers + DO iplon = KIDIA, KFDIA + IF (k_jp(iplon,i_lay-1) < layreffr & + & .AND. k_jp(iplon,i_lay) >= layreffr) i_laysolfr(iplon) = i_lay + ind0 = ((k_jp(iplon,i_lay)-13)*5+(k_jt(iplon,i_lay)-1))*nspb(29) + 1 + ind1 = ((k_jp(iplon,i_lay)-12)*5+(k_jt1(iplon,i_lay)-1))*nspb(29)+ 1 + z_tauray = p_colmol(iplon,i_lay) * rayl + !$ACC LOOP SEQ +!$NEC unroll(NG29) + DO ig = 1 , ng29 + p_taug(iplon,i_lay,ig) = p_colco2(iplon,i_lay) * & + & (p_fac00(iplon,i_lay) * absb(ind0,ig) + & + & p_fac10(iplon,i_lay) * absb(ind0+1,ig) + & + & p_fac01(iplon,i_lay) * absb(ind1,ig) + & + & p_fac11(iplon,i_lay) * absb(ind1+1,ig)) & + & + p_colh2o(iplon,i_lay) * absh2oc(ig) + IF (i_lay == i_laysolfr(iplon)) p_sfluxzen(iplon,ig) = sfluxrefc(ig) + p_taur(iplon,i_lay,ig) = z_tauray + ENDDO + ENDDO + ENDDO + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + +END SUBROUTINE SRTM_TAUMOL29 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/surdi.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/surdi.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/surdi.F90 (revision 6016) @@ -0,0 +1,133 @@ +! This file has been modified for the use in ICON + +SUBROUTINE SURDI + +!**** *SURDI* - INITIALIZE COMMON YOERDI CONTROLLING RADINT + +! PURPOSE. +! -------- +! INITIALIZE YOERDI, THE COMMON THAT CONTROLS THE +! RADIATION INTERFACE + +!** INTERFACE. +! ---------- +! CALL *SURDI* FROM *SURAD* +! ----- ----- + +! EXPLICIT ARGUMENTS : +! -------------------- +! NONE + +! IMPLICIT ARGUMENTS : +! -------------------- +! COMMON YOERDI + +! METHOD. +! ------- +! SEE DOCUMENTATION + +! EXTERNALS. +! ---------- +! NONE + +! REFERENCE. +! ---------- +! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS MODEL + +! AUTHOR. +! ------- +! Original JEAN-JACQUES MORCRETTE *ECMWF* +! ORIGINAL : 88-12-15 + +! MODIFICATIONS. +! -------------- +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! Modified P. Viterbo 24-05-2004 surf library +! JJMorcrette 2004-10-07 Gas concentrations +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE YOERDI , ONLY : RRAE ,& + & RCARDI ,RCH4 ,RN2O ,RNO2 ,RO3 ,& + & RCFC11 ,RCFC12 ,RCFC22 ,RCCL4 ,& + & REPCLC ,REPH2O ,RSUNDUR ,& + & RCCO2 ,RCCH4 ,RCN2O ,RCNO2 ,RCCFC11 ,& + & RCCFC12 ,RCCFC22 ,RCCCL4 +USE YOMDYNCORE, ONLY : LAQUA + +IMPLICIT NONE + +REAL(KIND=JPRB) :: ZAIRMWG, ZC11MWG, ZC12MWG, ZCH4MWG, ZCO2MWG,& + & ZN2OMWG, ZNO2MWG, ZO3MWG, ZC22MWG, ZCL4MWG +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------- + +!* 1. SET DEFAULT VALUES. +! ------------------- + +IF (LHOOK) CALL DR_HOOK('SURDI',0,ZHOOK_HANDLE) +RRAE = 0.1277E-02_JPRB + +!* Threshold for computing sunshine duration (W/m2) +RSUNDUR=120._JPRB + +!* For sea ice, monthly values are based on Ebert and Curry, 1993, Table 2. +! We take dry snow albedo as the representative value for non-summer +! months, and bare sea-ice as the representative value for summer +! months. The values for Antarctic are shifted six-months. +! All computations brought back to *SUSWN* + +!* Concentration of the various trace gases (IPCC/SACC values for 1990) +! CO2 CH4 N2O CFC11 CFC12 +! 353ppmv 1.72ppmv 310ppbv 280pptv 484pptv + +ZAIRMWG = 28.970_JPRB +ZCO2MWG = 44.011_JPRB +ZCH4MWG = 16.043_JPRB +ZN2OMWG = 44.013_JPRB +ZNO2MWG = 46.006_JPRB +ZO3MWG = 47.9982_JPRB +ZC11MWG = 137.3686_JPRB +ZC12MWG = 120.9140_JPRB +ZC22MWG = 86.4690_JPRB +ZCL4MWG = 153.8230_JPRB + +!RCARDI = 353.E-06_JPRB*ZCO2MWG/ZAIRMWG +!RCH4 = 1.72E-06_JPRB*ZCH4MWG/ZAIRMWG +!RN2O = 310.E-09_JPRB*ZN2OMWG/ZAIRMWG +!RNO2 = 500.E-13_JPRB*ZNO2MWG/ZAIRMWG +!RO3 = 1.E-06_JPRB*ZO3MWG /ZAIRMWG +!RCFC11 = 280.E-12_JPRB*ZC11MWG/ZAIRMWG +!RCFC12 = 484.E-12_JPRB*ZC12MWG/ZAIRMWG +!RCFC22 = 1.E-12_JPRB*ZC22MWG/ZAIRMWG +!RCCL4 = 1.E-12_JPRB*ZCL4MWG/ZAIRMWG + +!> Remove this block as the variables not used and accesses undefined values +!IF( LAQUA ) THEN +! RCARDI = 348.E-06_JPRB*ZCO2MWG/ZAIRMWG +! RCH4 = 1.65E-06_JPRB*ZCH4MWG/ZAIRMWG +! RN2O = 306.E-09_JPRB*ZN2OMWG/ZAIRMWG +!ELSE +! RCARDI = RCCO2 * ZCO2MWG/ZAIRMWG +! RCH4 = RCCH4 * ZCH4MWG/ZAIRMWG +! RN2O = RCN2O * ZN2OMWG/ZAIRMWG +!ENDIF +! +!RNO2 = RCNO2 * ZNO2MWG/ZAIRMWG +!RO3 = 1.E-06_JPRB*ZO3MWG /ZAIRMWG +!RCFC11 = RCCFC11 * ZC11MWG/ZAIRMWG +!RCFC12 = RCCFC12 * ZC12MWG/ZAIRMWG +!RCFC22 = RCCFC22 * ZC22MWG/ZAIRMWG +!RCCL4 = RCCCL4 * ZCL4MWG/ZAIRMWG +!= 1.E-15 + +! LAERCLIMG : .T. to start prognostic aerosols with geographical monthly +! mean climatology +! LAERCLIMZ : .T. to start prognostic aerosols with zonal annual mean +! climatology +! LAERCLIST : .T. to start prognostic aerosols with geographical monthly +! mean climatology for background stratospheric only +! LAERDRYDP : .T. dry deposition is active +! LAERHYDRO : .T. hygroscopic effects on BC and OM aerosols +! LAERNGAT : .T. prevents negative aerosol concentrations +! LAERSCAV : .T. in-cloud and below cloud scavenging is active +! LAERSEDIM : .T. sedimentation is active +! LAERSURF : .T. if surface emissions +! LAERELVS : .T. if "elevated" source +! LAER6SDIA : .T. if radiance diagnostics with 6S +! LAERGTOP : .T. if gas-to-particle conversion for SO2/SO4 +! LAERRAD : .T. if there is any prognostic aerosols used for RT +! LAEROPT(.) : .T. if a given aerosol type is radiatively interactive +! LAERCCN : .T. if prognostic aerosols are used to define the Re of liq.wat.clds +! LAERUVP : .T. if prognostic aerosols are used in UV-processor +! LAERCSTR : .T. if climatological stratospheric aerosols are used in radiation +! schemes with the prognostic tropospheric aerosols. +! LAERRRTM : .T. if RRTM schemes get the information from the prognostic aerosols +! LAERINIT : .T. if analysed prognostic aerosols are ONLY used as "climatological" aerosols +! LAERVOL : .T. if volcanic aerosol is considered +! NDRYDEP : dry deposition 1: a la GEMS; 2: "exp" (a la D_GRG_4.6) +! NWHTDDEP : =0 only SS+DU; =1 SS+DU+VOL; =2 SS+DU+OM+BC+SU+VOL +! NTDDEP : total number of aerosol species to be in- and below-cloud scavenged +! NINDDDEP : actual set of aerosol indices to be dry deposited +! NWHTSEDM : =0 only SS+DU; =1 SS+DU+VOL; =2 SS+DU+OM+BC+SU+VOL +! NTSEDM : total number of aerosol species to be in- and below-cloud scavenged +! NINDSEDM : actual set of aerosol indices to be sedimented +! NWHTWDEP : =0 only SS+DU; =1 SS+DU+VOL; =2 SS+DU+OM+BC+SU+VOL +! NTWDEP : total number of aerosol species to be in- and below-cloud scavenged +! NINDWDEP : actual set of aerosol indices to be scavenged +! NWHTSCAV : =0 only SS+DU; =1 SS+DU+VOL; =2 SS+DU+OM+BC+SU+VOL +! NTSCAV : total number of aerosol species to be in- and below-cloud scavenged +! NINDSCAV : actual set of aerosol indices to be scavenged +! LAERCALIP : .T. works with LAERLISI=t, store only the CALIOP-type profile at 532 nm +! ------------------------------------------------------------------ +END MODULE YOEAERATM + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerad.F90.erase =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerad.F90.erase (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerad.F90.erase (revision 6016) @@ -0,0 +1,237 @@ +MODULE YOERAD + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +! ------------------------------------------------------------------ +!* ** *YOERAD* - CONTROL OPTIONS FOR RADIATION CONFIGURATION +! ------------------------------------------------------------------ + +INTEGER(KIND=JPIM) :: NAER +INTEGER(KIND=JPIM) :: NMODE +INTEGER(KIND=JPIM) :: NOZOCL +INTEGER(KIND=JPIM) :: NRADFR +INTEGER(KIND=JPIM) :: NRADPFR +INTEGER(KIND=JPIM) :: NRADPLA +INTEGER(KIND=JPIM) :: NRADINT +INTEGER(KIND=JPIM) :: NRADRES +INTEGER(KIND=JPIM) :: NRADNFR +INTEGER(KIND=JPIM) :: NRADSFR +INTEGER(KIND=JPIM) :: NRADE1H, NRADE3H +INTEGER(KIND=JPIM) :: NRADELG +INTEGER(KIND=JPIM) :: NOVLP +INTEGER(KIND=JPIM) :: NRPROMA +INTEGER(KIND=JPIM) :: NSW +INTEGER(KIND=JPIM) :: NSWNL +INTEGER(KIND=JPIM) :: NSWTL +INTEGER(KIND=JPIM) :: NTSW +INTEGER(KIND=JPIM) :: NUV +INTEGER(KIND=JPIM) :: NCSRADF +INTEGER(KIND=JPIM) :: NICEOPT +INTEGER(KIND=JPIM) :: NLIQOPT +INTEGER(KIND=JPIM) :: NRADIP +INTEGER(KIND=JPIM) :: NRADLP +INTEGER(KIND=JPIM) :: NINHOM +INTEGER(KIND=JPIM) :: NLAYINH +INTEGER(KIND=JPIM) :: NLNGR1H +INTEGER(KIND=JPIM) :: NPERTAER +INTEGER(KIND=JPIM) :: NPERTOZ +INTEGER(KIND=JPIM) :: NSCEN +INTEGER(KIND=JPIM) :: NHINCSOL +INTEGER(KIND=JPIM) :: NMCICA +INTEGER(KIND=JPIM) :: NGHGRAD +INTEGER(KIND=JPIM) :: NDECOLAT +INTEGER(KIND=JPIM) :: NMINICE +INTEGER(KIND=JPIM) :: NVOLCVERT +INTEGER(KIND=JPIM) :: NREDGLW +INTEGER(KIND=JPIM) :: NREDGSW +INTEGER(KIND=JPIM) :: NSPMAPL(16), NSPMAPS(14) + +LOGICAL :: LERAD1H +LOGICAL :: LEPO3RA +LOGICAL :: LONEWSW +LOGICAL :: LECSRAD +LOGICAL :: LRRTM +LOGICAL :: LSRTM +LOGICAL :: LDIFFC +LOGICAL :: LHVOLCA +LOGICAL :: LNEWAER +LOGICAL :: LNOTROAER +LOGICAL :: LRAYL +LOGICAL :: LOPTRPROMA +LOGICAL :: LECO2VAR +LOGICAL :: LHGHG +LOGICAL :: LEMODAL +LOGICAL :: LESO4HIS +LOGICAL :: LETRACGMS +LOGICAL :: LAERCLIM, LAERVISI +LOGICAL :: LVOLCSPEC +LOGICAL :: LVOLCDAMP +LOGICAL :: LDIAGFORCING +LOGICAL :: LApproxLwUpdate +LOGICAL :: LApproxSwUpdate +LOGICAL :: LCentredTimeSZA + +CHARACTER (LEN = 256) :: CRTABLEDIR +CHARACTER (LEN = 32) :: CRTABLEFIL +LOGICAL :: LCCNL +LOGICAL :: LCCNO +LOGICAL :: LPERPET + +REAL(KIND=JPRB) :: RAOVLP , RBOVLP +REAL(KIND=JPRB) :: RCCNLND, RCCNSEA +LOGICAL :: LEDBUG +REAL(KIND=JPRB) :: RPERTOZ, RRe2De +REAL(KIND=JPRB) :: RLWINHF, RSWINHF +REAL(KIND=JPRB) :: RMINICE +REAL(KIND=JPRB) :: RVOLCSPEC(3) +REAL(KIND=JPRB) :: RNs, RSIGAIR + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 +! Modifications +! R J Hogan 20 May 2014: Added LApproxLwUpdate +! R J Hogan 19 June 2014: Added LApproxSwUpdate +! R J Hogan 19 Nov 2014: Added LCentredTimeSZA + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! LERAD1H: LOGICAL : .T. TO ALLOW MORE FREQUENT RADIATION CALCULATIONS +! : DURING FIRST N HOURS OF FORECAST +! NLNGR1H: INTEGER : NUMBER FORECAST HOURS DURING WHICH MORE FREQUENT +! RADIATION CALCULATIONS ARE REQUIRED +! LEPO3RA: LOGICAL : .T. IF PROGNOSTIC OZONE (EC) IS PASSED TO RADIATION +! NAER : INTEGER : CONFIGURATION INDEX FOR AEROSOLS +! NMODE : INTEGER : CONFIGURATION FOR RADIATION CODE: FLUX VS. RADIANCE +! NOZOCL : INTEGER : CHOICE OF OZONE CLIMATOLOGY (0 old, 1 new) +! NRADFR : INTEGER : FREQUENCY OF FULL RADIATION COMPUTATIONS +! IF(NRADFR.GT.0): RAD EVERY 'NRADFR' TIME-STEPS +! IF(NRADFR.LT.0): RAD EVERY '-NRADFR' HOURS +! NRADPFR: INTEGER : PRINT FREQUENCY FOR RAD.STATISTICS (in RAD.T.STEPS) +! NRADPLA: INTEGER : PRINT RAD.STATISTICS EVERY 'NRADPLA' ROWS +! NRADINT: INTEGER : RADIATION INTERPOLATION METHOD +! : 1 = SPECTRAL TRANSFORM INTERPOLATION +! : 2 = 4 POINT HORIZONTAL INTERPOLATION +! : 3 = 12 POINT HORIZONTAL INTERPOLATION +! NRADRES: INTEGER : RADIATION GRID SPECTRAL RESOLUTION +! NRADNFR: INTEGER : NORMAL FREQUENCY OF RADIATION STEPS +! NRADSFR: INTEGER : START-UP FREQUENCY OF RADIATION STEPS +! NRADE1H: INTEGER : START-UP FREQUENCY OF RADIATION STEPS FOR EPS +! NRADE3H: INTEGER : SUBSEQUENT FREQUENCY OF RADIATION STEPS FOR EPS +! NRADELG: INTEGER : LENGTH IN HOURS DURING WHICH THE FREQUENCY OF RADIATION IS INCREASED FOR EPS +! NOVLP : INTEGER : CLOUD OVERLAP CONFIGURATION +! NRPROMA: INTEGER : VECTOR LENGTH FOR RADIATION CALCULATIONS +! NSW : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS +! NSWNL : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS IN NL MODEL +! NSWTL : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS IN TL MODEL +! NTSW : INTEGER : MAXIMUM POSSIBLE NUMBER OF SW SPECTRAL INTERVALS +! NUV : INTEGER : NUMBER OF UV SPECTRAL INTERVALS FOR THE UV PROCESSOR +! LOPTRPROMA:LOGICAL: .T. NRPROMA will be optimised +! : .F. NRPROMA will not be optimised (forced +! : by negative NRPROMA in namelist) + +! NRADIP : INTEGER : INDEX FOR DIAGNOSIS OF ICE CLOUD EFFECTIVE RADIUS +! 0=EbCu/SmSh 1=EbCu/EbCu 2=FuLi/FuLi 3=Fu/Fu&al +! NRADLP : INTEGER : INDEX FOR DIAGNOSIS OF LIQ. CLOUD EFFECTIVE RADIUS +! 0=YF/SmSh 1=ASl/HSa 2=ASl/LiLi +! NICEOPT: INTEGER : INDEX FOR ICE CLOUD OPTICAL PROPERTIES +! 0=40u 1=40-130 2=30-60 3=Sun'01 +! NLIQOPT: INTEGER : INDEX FOR LIQUID WATER CLOUD OPTICAL PROPERTIES +! 0=f(P) 1=10/13 2=Martin_et_al + +! LONEWSW: LOGICAL : .T. IF NEW SW CODE IS ACTIVE +! LECSRAD: LOGICAL : .T. IF CLEAR-SKY RADIATION IS ARCHIVED AS PEXTR2 +! NCSRADF: INTEGER : 1 IF ACCUMULATED, 2 IF INSTANTANEOUS +! LRRTM : LOGICAL : .T. IF RRTM140MR IS USED FOR LW RADIATION TRANSFER + +! LHVOLCA: LOGICAL : .T. IF GISS HISTORY OF VOLCANIC AEROSOLS IS ON +! LNEWAER: LOGICAL : .T. IF AEROSOL MONTHLY DISTRIBUTIONS ARE USED +! LNOTROAER:LOGICAL: .T. IF NO TROPOSPHERIC AEROSOLS +! CRTABLEDIR: CHAR : IF NRADINT > 0 SPECIFIES DIRECTORY PATH FOR RADIATION +! : GRID RTABLE NAMELIST +! CRTABLEFIL: CHAR : IF NRADINT > 0 SPECIFIES FILE NAME OF RADIATION +! : GRID RTABLE NAMELIST +! LRAYL : LOGICAL : .T. NEW RAYLEIGH FOR SW-6 VERSION + +! RAOVLP : REAL : COEFFICIENTS FOR ALPHA1 FACTOR IN HOGAN & +! RBOVLP : REAL : ILLINGWORTH's PARAMETRIZATION + +! LCCNL : LOGICAL : .T. IF CCN CONCENTRATION OVER LAND IS DIAGNOSED +! LCCNO : LOGICAL : .T. IF CCN CONCENTRATION OVER OCEAN IS DIAGNOSED +! RCCNLND: REAL : NUMBER CONCENTRATION (CM-3) OF CCNs OVER LAND +! RCCNSEA: REAL : NUMBER CONCENTRATION (CM-3) OF CCNs OVER SEA + +! LDIFFC : LOGICAL : .T. IF SAVIJARVI'S DIFFUSIVITY CORRECTION IS ON + +! NINHOM : INTEGER : 0 IF NO INHOMOGENEITY SCALING EFFECT +! 1 IF SIMPLE 0.7 SCALING +! 2 IF BARKER, 3 IF CAIRNS ET AL. +! RLWINHF: REAL : INHOMOG. SCALING FACTOR FOR CLOUD LW OPTICAL THICKNESS +! RSWINHF: REAL : INHOMOG. SCALING FACTOR FOR CLOUD SW OPTICAL THICKNESS + +! NPERTAER : INTERGER : PERCENTAGE OF PERTURBATION FOR AEROSOL +! NPERTOZONE : INTEGER : PERCENTAGE OF PERTURBATION FOR OZONE +! NHINCSOL:INTEGER : +! = 0 NO VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR +! = 1 IF YEAR-TO-YEAR VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR +! = 2 IF MONTH-TO-MONTH VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR +! = 3 IF YEAR-TO-YEAR VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR ACCORDING TO CMIP5 RECOMMENDATIONS +! LECO2VAR: LOGICAL: .T. IF ERA-40/AMIP2 VARIABILITY OF GHG IS ON +! LHGHG : LOGICAL : .T. IF VARIABILITY OF GREENHOUSE GASES (INCLUDING CO2) IS ON +! N.B.: LHGHG supercedes LECO2VAR and allows using better specification of trace gases +! NSCEN : INTEGER : 21st CENTURY SCENARIO FOR GHG (1=A1B, 2=A2, 3=B1) +! RRe2De : REAL : CONVERSION FACTOR BETWWEN EFFECTIVE RADIUS AND PARTICLE SIZE +! RMINICE: REAL : MINIMUM SIZE FOR ICE PARTICLES (um) +! FOR ICE +! NMINICE: INTEGER : 1-6 MINIMUM ICE PARTICLE SIZE DEPENDS ON LATITUDE, 0=INDEPENDENT OF LATITUDE +! NDECOLAT:INTEGER : DECORRELATION LENGTH FOR CF AND CW +! 0: SPECIFIED INDEPENDENT OF LATITUDE, 1: SHONK-HOGAN, 2: IMPROVED +! NMCICA : INTEGER : 0: NO McICA +! 1: McICA w maximum-random in cloud generator +! 2: McICA w generalized overlap in cloud generator +! LESO4HIS: LOGICAL:.T.: Use historical/projected SO4 data per decade and month +! NGHGRAD: INTEGER : configuration of 3D GHG climatologies accounted for in radiation +! 0: global values +! 1: CO2 2: CH4 3: N2O 4: NO2 5:CFC11 6:CFC12 +! 12: CO2+CH4 13: CO2+CH4+N2O +! 16: CO2+CH4+N2O+CFC11+CFC12 +! LETRACGMS: LOGICAL : F=Cariolle climatol. T=GEMS-derived clim for CO2, CH4, O3 +! LAERCLIM : LOGICAL : .T. for output of the climatological aerosol optical depth at 550 nm +! LAERVISI : LOGICAL : .T. for output of the visibility (from diagnsotic or prognostic aerosols) +! NVOLCVERT: INTEGER : Vertical distribution of volcanic aerosol +! 0: original profile, diagnosed from T +! 1: original profile, but upper boundary at 10hPa +! 2: lower boundary diagnosed from ozone, upper boundary at 10hPa +! LVOLCSPEC: LOGICAL : T for specified volcanic aerosol +! LVOLCDAMP: LOGICAL : T for damping of specified volcanic aerosol from initial value +! RVOLCSPEC: REAL : Specified volcanic aerosol (total optical depth) in NH/Tropics/SH +! RNs : derived from Avogadro +! RSIGAIR: invariant terms in expression of Rayleigh scattering cross-section +! NREDGSW : LOGICAL : 0 full resolution for RRTM_SW (224) +! 1 ECMWF High resolution model configuration (_SW: 112) +! 2 ECMWF EPS configuration (_SW: 56) +! NREDGLW : LOGICAL : 0 full resolution for RRTM_LW (256) +! 1 ECMWF High resolution model configuration (_LW: 140) +! 2 ECMWF EPS configuration (_LW: 70) +! LDIAGFORCING : LOGICAL : T Write input ozone, ghg and aerosol forcing to 3D fields +! To be used for diagnostics only; do not use in production runs +! LApproxLwUpdate : LOGICAL : Update the longwave upwelling flux every +! timestep/gridpoint using the stored rate +! of change of the fluxes with respect to +! the surface upwelling longwave flux +! LApproxSwUpdate : LOGICAL : Update the shortwave upwelling flux +! every gridpoint to account for the local +! value of surface albedo, and every +! timestep using Manners et al. (2009) +! correction for solar zenith angle change +! LCentredTimeSZA : LOGICAL : Compute solar zenith angle in radiation +! scheme half way between calls to +! radiation scheme (rather than previous +! behaviour, which is half way between +! calls plus half a model timestep) +! ------------------------------------------------------------------ +END MODULE YOERAD Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerdi.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerdi.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerdi.F90 (revision 6016) @@ -0,0 +1,49 @@ +MODULE YOERDI + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERDI* - COEFFICIENTS WITHIN RADIATION INTERFACE +! ----------------------------------------------------------------- + +REAL(KIND=JPRB) :: RRAE +REAL(KIND=JPRB) :: RSUNDUR +REAL(KIND=JPRB) :: RCARDI +REAL(KIND=JPRB) :: RCH4 +REAL(KIND=JPRB) :: RN2O +REAL(KIND=JPRB) :: RNO2 +REAL(KIND=JPRB) :: RO3 +REAL(KIND=JPRB) :: RCCL4 +REAL(KIND=JPRB) :: RCFC11 +REAL(KIND=JPRB) :: RCFC12 +REAL(KIND=JPRB) :: RCFC22 +REAL(KIND=JPRB) :: REPCLC +REAL(KIND=JPRB) :: REPH2O +REAL(KIND=JPRB) :: RCCO2, RCCH4, RCN2O, RCNO2, RCCFC11, RCCFC12, RCCFC22, RCCCL4 +REAL(KIND=JPRB) :: RSOLINC + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! Original J.-J. MORCRETTE E.C.M.W.F. 89/07/14 +! Modified P. Viterbo 99/03/26 Surface tiling +! Modified P. Viterbo 24/05/2004 surf library +! Modified JJMorcrette 2005/01/19 GHG and Solar constant variability + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! RRAE : EFFECT OF EARTH'S CURVATURE ON COSINE SOLAR ZENITH ANGLE +! RSUNDUR: MINIMUM DIRECT SOLAR FOR COMPUTING SOLAR DURATION +! RCARDI : SPECIFIC ATMOSPHERIC CONTENT IN CO2 +! RCH4, RN2O, RNO2, RO3, RCFC11, RCFC12 MASS MIXING RATIO OF VARIOUS TRACE GASES +! RCCH4, RCN2O, ... MASS MIXING RATIO OF VARIOUS TRACE GASES IN CLIMATE MODE +! REPCLC : SECURITY TO AVOID ZERO OR ONE CLOUD COVERS +! REPH2O : SECURITY TO AVOID WATER VAPOUR CONTENT IN A LAYER +! TO BE MORE THAN THE RESPECTIVE VALUE AT SATURATION. +! ----------------------------------------------------------------- +END MODULE YOERDI Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta1.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta1.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta1.F90 (revision 6016) @@ -0,0 +1,51 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA1 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA1* - RRTM COEFFICIENTS FOR INTERVAL 1 +! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) +! ABozzo may 2013 update to last version of rrtmg +! band 1: 10-350 cm-1 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG1 = 10 + +REAL(KIND=JPRB) :: FRACREFA(NG1) , FRACREFB(NG1) +REAL(KIND=JPRB) :: KA(5,13,NG1) , ABSA(65,NG1) +REAL(KIND=JPRB) :: KB(5,13:59,NG1), ABSB(235,NG1) +REAL(KIND=JPRB) :: KA_MN2(19,NG1) , KB_MN2(19,NG1) +REAL(KIND=JPRB) :: SELFREF(10,NG1), FORREF(4,NG1) + +EQUIVALENCE (KA(1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, KA_MN2, KB_MN2, & +!$ACC SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! FORREF : REAL foreign broadening coefficient for water vapour +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self broadening coefficient for water vapour +! ----------------------------------------------------------------- +END MODULE YOERRTA1 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta10.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta10.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta10.F90 (revision 6016) @@ -0,0 +1,49 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA10 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA14* - RRTM COEFFICIENTS FOR INTERVAL 10 +! BAND 10: 1390-1480 cm-1 (low - H2O; high - H2O) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG10 = 6 + +REAL(KIND=JPRB) , DIMENSION(NG10) :: FRACREFA +REAL(KIND=JPRB) , DIMENSION(NG10) :: FRACREFB + +REAL(KIND=JPRB) :: KA(5,13,NG10) , ABSA(65,NG10) +REAL(KIND=JPRB) :: KB(5,13:59,NG10), ABSB(235,NG10) +REAL(KIND=JPRB) :: SELFREF(10,NG10) +REAL(KIND=JPRB) :: FORREF(4,NG10) + +EQUIVALENCE (KA(1,1,1),ABSA(1,1)),(KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! ----------------------------------------------------------------- +END MODULE YOERRTA10 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta11.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta11.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta11.F90 (revision 6016) @@ -0,0 +1,52 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA11 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA11* - RRTM COEFFICIENTS FOR INTERVAL 11 +! BAND 11: 1480-1800 cm-1 (low - H2O; high - H2O) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG11 = 8 + +REAL(KIND=JPRB) , DIMENSION(NG11) :: FRACREFA +REAL(KIND=JPRB) , DIMENSION(NG11) :: FRACREFB + +REAL(KIND=JPRB) :: KA(5,13,NG11) , ABSA(65,NG11) +REAL(KIND=JPRB) :: KB(5,13:59,NG11), ABSB(235,NG11) +REAL(KIND=JPRB) :: KA_MO2(19,NG11) +REAL(KIND=JPRB) :: KB_MO2(19,NG11) +REAL(KIND=JPRB) :: SELFREF(10,NG11) +REAL(KIND=JPRB) :: FORREF(4,NG11) + +EQUIVALENCE (KA(1,1,1),ABSA(1,1)),(KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, KA_MO2, KB_MO2, & +!$ACC SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! SELFREF : REAL self broadening coefficient for water vapour +! ----------------------------------------------------------------- +END MODULE YOERRTA11 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta12.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta12.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta12.F90 (revision 6016) @@ -0,0 +1,47 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA12 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA12* - RRTM COEFFICIENTS FOR INTERVAL 12 +! BAND 12: 1800-2080 cm-1 (low - H2O,CO2; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG12 = 8 + +REAL(KIND=JPRB) :: FRACREFA(NG12,9) +REAL(KIND=JPRB) :: KA(9,5,13,NG12) ,ABSA(585,NG12) +REAL(KIND=JPRB) :: SELFREF(10,NG12) +REAL(KIND=JPRB) :: FORREF(4,NG12) + +REAL(KIND=JPRB) :: STRRAT + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, KA, ABSA, SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! SELFREF : REAL self broadening coefficient for water vapour +! STRRAT : REAL weighting factors for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA12 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta13.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta13.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta13.F90 (revision 6016) @@ -0,0 +1,51 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA13 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA13* - RRTM COEFFICIENTS FOR INTERVAL 13 +! BAND 13: 2080-2250 cm-1 (low - H2O,N2O; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG13 = 4 + +REAL(KIND=JPRB) :: FRACREFA(NG13,9) +REAL(KIND=JPRB) , DIMENSION(NG13) :: FRACREFB + +REAL(KIND=JPRB) :: KA(9,5,13,NG13) ,ABSA(585,NG13) +REAL(KIND=JPRB) :: SELFREF(10,NG13) +REAL(KIND=JPRB) :: FORREF(4,NG13) +REAL(KIND=JPRB) :: KA_MCO2(9,19,NG13) +REAL(KIND=JPRB) :: KA_MCO(9,19,NG13) +REAL(KIND=JPRB) :: KB_MO3(19,NG13) + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, SELFREF, FORREF, KA_MCO2, & +!$ACC KA_MCO, KB_MO3) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! SELFREF : REAL self broadening coefficient for water vapour +! STRRAT : REAL weighting factors for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA13 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta14.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta14.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta14.F90 (revision 6016) @@ -0,0 +1,51 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA14 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA14* - RRTM COEFFICIENTS FOR INTERVAL 14 +! BAND 14: 2250-2380 cm-1 (low - CO2; high - CO2) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG14 = 2 + +REAL(KIND=JPRB) , DIMENSION(NG14) :: FRACREFA +REAL(KIND=JPRB) , DIMENSION(NG14) :: FRACREFB + +REAL(KIND=JPRB) :: KA(5,13,NG14) ,ABSA(65,NG14) +REAL(KIND=JPRB) :: KB(5,13:59,NG14),ABSB(235,NG14) +REAL(KIND=JPRB) :: SELFREF(10,NG14) +REAL(KIND=JPRB) :: FORREF(4,NG14) + +EQUIVALENCE (KA(1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/01/15 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! SELFREF : REAL self broadening coefficient for water vapour +! ----------------------------------------------------------------- +END MODULE YOERRTA14 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta15.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta15.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta15.F90 (revision 6016) @@ -0,0 +1,51 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA15 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA15* - RRTM COEFFICIENTS FOR INTERVAL 15 +! BAND 15: 2380-2600 cm-1 (low - N2O,CO2; high - nothing) +! ABozzo 2001306 updated to rrtmg v4.85 +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG15 = 2 + +REAL(KIND=JPRB) :: FRACREFA(NG15,9) + +REAL(KIND=JPRB) :: KA(9,5,13,NG15) ,ABSA(585,NG15) +REAL(KIND=JPRB) :: KA_MN2(9,19,NG15) +REAL(KIND=JPRB) :: SELFREF(10,NG15) +REAL(KIND=JPRB) :: FORREF(4,NG15) + + + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, KA, ABSA, KA_MN2, SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! SELFREF : REAL self broadening coefficient for water vapour +! STRRAT : REAL weighting factors for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA15 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta16.F90 (revision 6016) @@ -0,0 +1,49 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA16 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA16* - RRTM COEFFICIENTS FOR INTERVAL 16 +! BAND 16: 2600-3000 cm-1 (low - H2O,CH4; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG16 = 2 + +REAL(KIND=JPRB) :: FRACREFA(NG16,9) +REAL(KIND=JPRB) , DIMENSION(NG16) :: FRACREFB + +REAL(KIND=JPRB) :: KA(9,5,13,NG16) ,ABSA(585,NG16) +REAL(KIND=JPRB) :: KB(5,13:59,NG16), ABSB(235,NG16) +REAL(KIND=JPRB) :: SELFREF(10,NG16) +REAL(KIND=JPRB) :: FORREF(4,NG16) + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! SELFREF : REAL self broadening coefficient for water vapour +! STRRAT : REAL weighting factors for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA16 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta2.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta2.F90 (revision 6016) @@ -0,0 +1,53 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA2 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA2* - RRTM COEFFICIENTS FOR INTERVAL 2 +! BAND 2: 250-500 cm-1 (low - H2O; high - H2O) +! ABozzo May 2013 updated to the last rrtmg +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG2 = 12 + +! The ith set of reference fractions are from the ith reference +! pressure level. +REAL(KIND=JPRB) :: FRACREFA(NG2), FRACREFB(NG2) +REAL(KIND=JPRB) :: KA(5,13,NG2) , ABSA(65,NG2) +REAL(KIND=JPRB) :: KB(5,13:59,NG2), ABSB(235,NG2) +REAL(KIND=JPRB) :: SELFREF(10,NG2), FORREF(4,NG2) + +EQUIVALENCE (KA(1,1,1),ABSA(1,1)),(KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! FORREF : REAL foreign broadening coefficient for water vapour +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! REFPARAM: REAL reference water vapour mixing ratio for use in Planck function interpolation +! SELFREF : REAL self broadening coefficient for water vapour +! ----------------------------------------------------------------- +END MODULE YOERRTA2 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta3.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta3.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta3.F90 (revision 6016) @@ -0,0 +1,58 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA3 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA3* - RRTM COEFFICIENTS FOR INTERVAL 3 +! BAND 3: 500-630 cm-1 (low - H2O,CO2; high - H2O,CO2) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG3 = 16 + +REAL(KIND=JPRB) :: FRACREFA(NG3,9) ,FRACREFB(NG3,5) + +REAL(KIND=JPRB) :: KA_MN2O(9,19,NG3), KB_MN2O(5,19,NG3) +REAL(KIND=JPRB) :: KA(9,5,13,NG3) ,ABSA(585,NG3) +REAL(KIND=JPRB) :: KB(5,5,13:59,NG3),ABSB(1175,NG3) +REAL(KIND=JPRB) :: SELFREF(10,NG3) +REAL(KIND=JPRB) :: FORREF(4,NG3) + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)),(KB(1,1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA_MN2O, KB_MN2O, KA, ABSA, KB, ABSB, & +!$ACC SELFREF, FORREF) + +! ------------------------------------------------------------------ +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! ABSN2OA : REAL absorption coefficient for tropospheric N2O +! ABSN2OB : REAL absorption coefficient for stratospheric N2O +! CO2REF : REAL refrence CO2 profile +! ETAREF : REAL reference eta scale [0,1] +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! H2OREF : REAL reference H2O profile +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! N2OREF : REAL reference N2O profile +! SELFREF : REAL self broadening coefficient for water vapour +! STRRAT : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA3 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta4.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta4.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta4.F90 (revision 6016) @@ -0,0 +1,49 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA4 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA4* - RRTM COEFFICIENTS FOR INTERVAL 5 +! BAND 4: 630-700 cm-1 (low - H2O,CO2; high - O3,CO2) +! 201306 ABozzo updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG4 = 14 + +REAL(KIND=JPRB) :: FRACREFA(NG4,9) ,FRACREFB(NG4,5) +REAL(KIND=JPRB) :: KA(9,5,13,NG4) ,ABSA(585,NG4) +REAL(KIND=JPRB) :: KB(5,5,13:59,NG4),ABSB(1175,NG4) +REAL(KIND=JPRB) :: SELFREF(10,NG4) ,FORREF(4,NG4) + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)),(KB(1,1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, SELFREF, FORREF) + +! ------------------------------------------------------------------ +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! SELFREF : REAL self broadening coefficient for water vapour +! STRRATn : REAL weighting factors for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA4 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta5.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta5.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta5.F90 (revision 6016) @@ -0,0 +1,56 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA5 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA5* - RRTM COEFFICIENTS FOR INTERVAL 5 +! BAND 5: 700-820 cm-1 (low - H2O,CO2; high - O3,CO2) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG5 = 16 + +REAL(KIND=JPRB) :: FRACREFA(NG5,9) ,FRACREFB(NG5,5) + +REAL(KIND=JPRB) , DIMENSION(NG5) :: CCL4 + +REAL(KIND=JPRB) :: KA(9,5,13,NG5) ,ABSA(585,NG5) +REAL(KIND=JPRB) :: KB(5,5,13:59,NG5),ABSB(1175,NG5) +REAL(KIND=JPRB) :: KA_MO3(9,19,NG5) +REAL(KIND=JPRB) :: SELFREF(10,NG5) +REAL(KIND=JPRB) :: FORREF(4,NG5) + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)),(KB(1,1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, CCL4, KA, ABSA, KB, ABSB, KA_MO3, & +!$ACC SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! CCL4 : REAL absorption coefficient for CCl4 +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! SELFREF : REAL self broadening coefficient for water vapour +! STRRATn : REAL weighting factors for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA5 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta6.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta6.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta6.F90 (revision 6016) @@ -0,0 +1,53 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA6 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA6* - RRTM COEFFICIENTS FOR INTERVAL 6 +! BAND 6: 820-980 cm-1 (low - H2O; high - nothing) +! ABozzo 201306 updaten to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG6 = 8 + +REAL(KIND=JPRB) , DIMENSION(NG6) :: FRACREFA + +REAL(KIND=JPRB) , DIMENSION(NG6) :: CFC11ADJ +REAL(KIND=JPRB) , DIMENSION(NG6) :: CFC12 + + +REAL(KIND=JPRB) :: KA(5,13,NG6),ABSA(65,NG6) +REAL(KIND=JPRB) :: SELFREF(10,NG6) +REAL(KIND=JPRB) :: KA_MCO2(19,NG6) +REAL(KIND=JPRB) :: FORREF(4,NG6) + +EQUIVALENCE (KA(1,1,1),ABSA(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, CFC11ADJ, CFC12, KA, ABSA, SELFREF, KA_MCO2, & +!$ACC FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSCO2 : REAL absorption coefficient for CO2 +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! CFC11ADJ: REAL absorption coefficient for CFC-11 (adjusted) +! CFC12 : REAL absorption coefficient for CFC-12 +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! SELFREF : REAL self broadening coefficient for water vapour +! ----------------------------------------------------------------- +END MODULE YOERRTA6 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta7.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta7.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta7.F90 (revision 6016) @@ -0,0 +1,56 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA7 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA7* - RRTM COEFFICIENTS FOR INTERVAL 7 +! BAND 7: 980-1080 cm-1 (low - H2O,O3; high - O3) +! ABozzo updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG7 = 12 + +REAL(KIND=JPRB) :: FRACREFA(NG7,9) + +REAL(KIND=JPRB) , DIMENSION(NG7) :: FRACREFB +REAL(KIND=JPRB) :: KA(9,5,13,NG7) ,ABSA(585,NG7) +REAL(KIND=JPRB) :: KB(5,13:59,NG7),ABSB(235,NG7) +REAL(KIND=JPRB) :: SELFREF(10,NG7) +REAL(KIND=JPRB) :: KA_MCO2(9,19,NG7) +REAL(KIND=JPRB) :: KB_MCO2(19,NG7) +REAL(KIND=JPRB) :: FORREF(4,NG7) + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)),(KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, SELFREF, KA_MCO2, & +!$ACC KB_MCO2, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! ABSCO2 : REAL absorption coefficient for CO2 +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! SELFREF : REAL self broadening coefficient for water vapour +! STRRAT : REAL weighting factors for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA7 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta8.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta8.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta8.F90 (revision 6016) @@ -0,0 +1,72 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA8 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA8* - RRTM COEFFICIENTS FOR INTERVAL 8 +! BAND 8: 1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG8 = 8 + +REAL(KIND=JPRB) , DIMENSION(NG8) :: FRACREFA +REAL(KIND=JPRB) , DIMENSION(NG8) :: FRACREFB +REAL(KIND=JPRB) , DIMENSION(NG8) :: CFC12 +REAL(KIND=JPRB) , DIMENSION(NG8) :: CFC22ADJ + +REAL(KIND=JPRB) :: KA(5,13,NG8) ,ABSA(65,NG8) +REAL(KIND=JPRB) :: KB(5,13:59,NG8) ,ABSB(235,NG8) +REAL(KIND=JPRB) :: KA_MCO2(19,NG8) +REAL(KIND=JPRB) :: KA_MN2O(19,NG8) +REAL(KIND=JPRB) :: KA_MO3(19,NG8) +REAL(KIND=JPRB) :: KB_MCO2(19,NG8) +REAL(KIND=JPRB) :: KB_MN2O(19,NG8) +REAL(KIND=JPRB) :: SELFREF(10,NG8) +REAL(KIND=JPRB) :: FORREF(4,NG8) + + +EQUIVALENCE (KA(1,1,1),ABSA(1,1)),(KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, CFC12, CFC22ADJ, KA, ABSA, KB, ABSB, & +!$ACC KA_MCO2, KA_MN2O, KA_MO3, KB_MCO2, KB_MN2O, SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! ABSCO2A : REAL absorption coefficient for CO2 for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSCO2B : REAL absorption coefficient for CO2 for M reference stratospheric +! pressures and N reference stratospheric temperatures +! ABSN2OA : REAL absorption coefficient for N2O for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSN2OB : REAL absorption coefficient for N2O for M reference stratospheric +! pressures and N reference stratospheric temperatures +! CFC12 : REAL absorption coefficient for CFC-12 +! CFC22ADJ: REAL absorption coefficient for CFC-22 (adjusted) +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! H2OREF : REAL reference profile for H2O +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! N2OREF : REAL reference profile for N2O +! O3REF : REAL reference profile for O3 +! SELFREF : REAL self broadening coefficient for water vapour +! ----------------------------------------------------------------- +END MODULE YOERRTA8 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta9.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta9.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrta9.F90 (revision 6016) @@ -0,0 +1,60 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTA9 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTA9* - RRTM COEFFICIENTS FOR INTERVAL 9 +! BAND 9: 1180-1390 cm-1 (low - H2O,CH4; high - CH4) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NG9 = 12 + +REAL(KIND=JPRB) :: FRACREFA(NG9,9) + +REAL(KIND=JPRB) , DIMENSION(NG9) :: FRACREFB + +REAL(KIND=JPRB) :: KA(9,5,13,NG9) ,ABSA(585,NG9) +REAL(KIND=JPRB) :: KB(5,13:59,NG9) ,ABSB(235,NG9) +REAL(KIND=JPRB) :: KA_MN2O(9,19,NG9) +REAL(KIND=JPRB) :: KB_MN2O(19,NG9) +REAL(KIND=JPRB) :: SELFREF(10,NG9) +REAL(KIND=JPRB) :: FORREF(4,NG9) + +EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)),(KB(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(FRACREFA, FRACREFB, KA, ABSA, KB, ABSB, KA_MN2O, KB_MN2O, & +!$ACC SELFREF, FORREF) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSA : REAL absorption coefficient of major absorber for M reference tropospheric +! pressures and N reference tropospheric temperatures +! ABSB : REAL absorption coefficient of secondary absorber for M reference stratospheric +! pressures and N reference stratospheric temperatures +! ABSN2O : REAL absorption coefficient for N2O +! CH4REF : REAL reference profile for CH4 +! ETAREF : REAL reference eta profile +! FRACREFA: REAL distance from r and T reference tabulated points (troposphere) +! FRACREFB: REAL distance from r and T reference tabulated points (stratosphere) +! H2OREF : REAL reference profile for H2O +! KA : REAL absorption coefficient of major absorber (equiv. to ABSA) +! KB : REAL absorption coefficient of secondary absorber (equiv. to ABSB) +! N2OREF : REAL reference profile for N2O +! SELFREF : REAL self broadening coefficient for water vapour +! STRRAT : REAL weighting factors for the transition between tropospheric +! and stratospheric computations +! ----------------------------------------------------------------- +END MODULE YOERRTA9 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtab.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtab.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtab.F90 (revision 6016) @@ -0,0 +1,29 @@ +MODULE YOERRTAB + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------- + +! ------------------------------------------------------------------- + +REAL(KIND=JPRB) , DIMENSION(0:5000) :: TRANS +REAL(KIND=JPRB) :: BPADE + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! TRANS : REAL : TABULATED REFERENCE FOR LW TRANSMISSION +! BPADE : REAL : INVERSE OF PADE APPROXIMATION CONSTANT (= 1./0.278) +! ----------------------------------------------------------------- +END MODULE YOERRTAB + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtbg2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtbg2.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtbg2.F90 (revision 6016) @@ -0,0 +1,29 @@ +MODULE YOERRTBG2 + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------- + +! ------------------------------------------------------------------- + +REAL(KIND=JPRB) :: CORR1(0:200) +REAL(KIND=JPRB) :: CORR2(0:200) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! CORR1 : REAL : +! CORR2 : REAL : +! ------------------------------------------------------------------- +END MODULE YOERRTBG2 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtftr.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtftr.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtftr.F90 (revision 6016) @@ -0,0 +1,51 @@ +MODULE YOERRTFTR + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +!USE PARRRTM, ONLY : JPBAND, JPG, JPGMAX +!USE YOERRTM, ONLY : JPGPT + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------- + +! ------------------------------------------------------------------- + +INTEGER(KIND=JPIM) :: NGC(16) +INTEGER(KIND=JPIM) :: NGS(16) + +INTEGER(KIND=JPIM) :: NGN(256) +INTEGER(KIND=JPIM) :: NGB(256) + +INTEGER(KIND=JPIM) :: NGM(256) +REAL(KIND=JPRB) :: WT(16) + +!INTEGER(KIND=JPIM) :: NGC(JPBAND) +!INTEGER(KIND=JPIM) :: NGS(JPBAND) +! +!INTEGER(KIND=JPIM) :: NGN(JPGMAX) +!INTEGER(KIND=JPIM) :: NGB(JPGMAX) +! +!INTEGER(KIND=JPIM) :: NGM(JPG*JPBAND) +!REAL(KIND=JPRB) :: WT(JPG) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! NGC : INTEGER : +! NGS : INTEGER : +! NGN : INTEGER : +! NGB : INTEGER : +! NGM : INTEGER : +! WT : REAL : +! ------------------------------------------------------------------- +END MODULE YOERRTFTR + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtm.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtm.F90 (revision 6016) @@ -0,0 +1,99 @@ +MODULE YOERRTM + +USE PARKIND1 ,ONLY : JPIM +USE PARRRTM ,ONLY : JPGMAX + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------ +! Parameters relevant to AER's RRTM-LW radiation scheme: Part 2 + +! 20110613 JJMorcrette + +! Modified to allow possibilities of different g-point numbers. +! ------------------------------------------------------------------ + +!INTEGER(KIND=JPIM) :: JPGPT +!INTEGER(KIND=JPIM) :: JPGLW + +!INTEGER(KIND=JPIM) :: NG1 +!INTEGER(KIND=JPIM) :: NG2 +!INTEGER(KIND=JPIM) :: NG3 +!INTEGER(KIND=JPIM) :: NG4 +!INTEGER(KIND=JPIM) :: NG5 +!INTEGER(KIND=JPIM) :: NG6 +!INTEGER(KIND=JPIM) :: NG7 +!INTEGER(KIND=JPIM) :: NG8 +!INTEGER(KIND=JPIM) :: NG9 +!INTEGER(KIND=JPIM) :: NG10 +!INTEGER(KIND=JPIM) :: NG11 +!INTEGER(KIND=JPIM) :: NG12 +!INTEGER(KIND=JPIM) :: NG13 +!INTEGER(KIND=JPIM) :: NG14 +!INTEGER(KIND=JPIM) :: NG15 +!INTEGER(KIND=JPIM) :: NG16 + +!INTEGER(KIND=JPIM) :: NGS1 +!INTEGER(KIND=JPIM) :: NGS2 +!INTEGER(KIND=JPIM) :: NGS3 +!INTEGER(KIND=JPIM) :: NGS4 +!INTEGER(KIND=JPIM) :: NGS5 +!INTEGER(KIND=JPIM) :: NGS6 +!INTEGER(KIND=JPIM) :: NGS7 +!INTEGER(KIND=JPIM) :: NGS8 +!INTEGER(KIND=JPIM) :: NGS9 +!INTEGER(KIND=JPIM) :: NGS10 +!INTEGER(KIND=JPIM) :: NGS11 +!INTEGER(KIND=JPIM) :: NGS12 +!INTEGER(KIND=JPIM) :: NGS13 +!INTEGER(KIND=JPIM) :: NGS14 +!INTEGER(KIND=JPIM) :: NGS15 +!INTEGER(KIND=JPIM) :: NGS16 + +INTEGER(KIND=JPIM), PARAMETER :: JPGPT = 140 +INTEGER(KIND=JPIM), PARAMETER :: JPGLW = 140 + +!-- NGnn : number of g-points in each longwave spectral band +INTEGER(KIND=JPIM), PARAMETER :: NG1 = 10 +INTEGER(KIND=JPIM), PARAMETER :: NG2 = 12 +INTEGER(KIND=JPIM), PARAMETER :: NG3 = 16 +INTEGER(KIND=JPIM), PARAMETER :: NG4 = 14 +INTEGER(KIND=JPIM), PARAMETER :: NG5 = 16 +INTEGER(KIND=JPIM), PARAMETER :: NG6 = 8 +INTEGER(KIND=JPIM), PARAMETER :: NG7 = 12 +INTEGER(KIND=JPIM), PARAMETER :: NG8 = 8 +INTEGER(KIND=JPIM), PARAMETER :: NG9 = 12 +INTEGER(KIND=JPIM), PARAMETER :: NG10 = 6 +INTEGER(KIND=JPIM), PARAMETER :: NG11 = 8 +INTEGER(KIND=JPIM), PARAMETER :: NG12 = 8 +INTEGER(KIND=JPIM), PARAMETER :: NG13 = 4 +INTEGER(KIND=JPIM), PARAMETER :: NG14 = 2 +INTEGER(KIND=JPIM), PARAMETER :: NG15 = 2 +INTEGER(KIND=JPIM), PARAMETER :: NG16 = 2 +!-- NGSnn: accumulated number of g-points at the beginning of spectral band nn+1 +INTEGER(KIND=JPIM), PARAMETER :: NGS1 = 10 +INTEGER(KIND=JPIM), PARAMETER :: NGS2 = 22 +INTEGER(KIND=JPIM), PARAMETER :: NGS3 = 38 +INTEGER(KIND=JPIM), PARAMETER :: NGS4 = 52 +INTEGER(KIND=JPIM), PARAMETER :: NGS5 = 68 +INTEGER(KIND=JPIM), PARAMETER :: NGS6 = 76 +INTEGER(KIND=JPIM), PARAMETER :: NGS7 = 88 +INTEGER(KIND=JPIM), PARAMETER :: NGS8 = 96 +INTEGER(KIND=JPIM), PARAMETER :: NGS9 = 108 +INTEGER(KIND=JPIM), PARAMETER :: NGS10 = 114 +INTEGER(KIND=JPIM), PARAMETER :: NGS11 = 122 +INTEGER(KIND=JPIM), PARAMETER :: NGS12 = 130 +INTEGER(KIND=JPIM), PARAMETER :: NGS13 = 134 +INTEGER(KIND=JPIM), PARAMETER :: NGS14 = 136 +INTEGER(KIND=JPIM), PARAMETER :: NGS15 = 138 + + +INTEGER(KIND=JPIM) :: NGN(JPGMAX), NGBLW(JPGMAX) + +! ------------------------------------------------------------------ +END MODULE YOERRTM + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto1.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto1.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto1.F90 (revision 6016) @@ -0,0 +1,43 @@ +MODULE YOERRTO1 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO1* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 1 +! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) +! ABozzo may 2013 update to rrtmg v4.85 +! band 1: 10-350 cm-1 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO1 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO1) , FRACREFBO(NO1) +REAL(KIND=JPRB) :: KAO(5,13,NO1) +REAL(KIND=JPRB) :: KBO(5,13:59,NO1) +REAL(KIND=JPRD) :: KAO_D(5,13,NO1) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO1) +REAL(KIND=JPRB) :: KAO_MN2(19,NO1) , KBO_MN2(19,NO1) +REAL(KIND=JPRB) :: SELFREFO(10,NO1), FORREFO(4,NO1) + + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +!FRACREFAO: REAL +!FRACREFBO: REAL +! FORREFO : REAL +! KAO : REAL +! KBO : REAL +! SELFREFO: REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO1 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto10.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto10.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto10.F90 (revision 6016) @@ -0,0 +1,41 @@ +MODULE YOERRTO10 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO14* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 10 +! BAND 10: 1390-1480 cm-1 (low - H2O; high - H2O) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO10 = 16 + +REAL(KIND=JPRB) , DIMENSION(NO10) :: FRACREFAO +REAL(KIND=JPRB) , DIMENSION(NO10) :: FRACREFBO + +REAL(KIND=JPRB) :: KAO(5,13,NO10) +REAL(KIND=JPRB) :: KBO(5,13:59,NO10) +REAL(KIND=JPRD) :: KAO_D(5,13,NO10) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO10) +REAL(KIND=JPRB) :: SELFREFO(10,NO10) +REAL(KIND=JPRB) :: FORREFO(4,NO10) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! FRACREFB: REAL +! KA : REAL +! KB : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO10 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto11.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto11.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto11.F90 (revision 6016) @@ -0,0 +1,44 @@ +MODULE YOERRTO11 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO11* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 11 +! BAND 11: 1480-1800 cm-1 (low - H2O; high - H2O) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO11 = 16 + +REAL(KIND=JPRB) , DIMENSION(NO11) :: FRACREFAO +REAL(KIND=JPRB) , DIMENSION(NO11) :: FRACREFBO + +REAL(KIND=JPRB) :: KAO(5,13,NO11) +REAL(KIND=JPRB) :: KBO(5,13:59,NO11) +REAL(KIND=JPRD) :: KAO_D(5,13,NO11) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO11) +REAL(KIND=JPRB) :: KAO_MO2(19,NO11) +REAL(KIND=JPRB) :: KBO_MO2(19,NO11) +REAL(KIND=JPRB) :: SELFREFO(10,NO11) +REAL(KIND=JPRB) :: FORREFO(4,NO11) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! FRACREFB: REAL +! KA : REAL +! KB : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO11 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto12.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto12.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto12.F90 (revision 6016) @@ -0,0 +1,36 @@ +MODULE YOERRTO12 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO12* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 12 +! BAND 12: 1800-2080 cm-1 (low - H2O,CO2; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO12 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO12,9) +REAL(KIND=JPRB) :: KAO(9,5,13,NO12) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO12) +REAL(KIND=JPRB) :: SELFREFO(10,NO12) +REAL(KIND=JPRB) :: FORREFO(4,NO12) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! KA : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO12 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto13.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto13.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto13.F90 (revision 6016) @@ -0,0 +1,41 @@ +MODULE YOERRTO13 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO13* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 13 +! BAND 13: 2080-2250 cm-1 (low - H2O,N2O; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO13 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO13,9) +REAL(KIND=JPRB) , DIMENSION(NO13) :: FRACREFBO + +REAL(KIND=JPRB) :: KAO(9,5,13,NO13) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO13) +REAL(KIND=JPRB) :: SELFREFO(10,NO13) +REAL(KIND=JPRB) :: KAO_MCO2(9,19,NO13) +REAL(KIND=JPRB) :: KAO_MCO(9,19,NO13) +REAL(KIND=JPRB) :: KBO_MO3(19,NO13) +REAL(KIND=JPRB) :: FORREFO(4,NO13) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! KA : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO13 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto14.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto14.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto14.F90 (revision 6016) @@ -0,0 +1,42 @@ +MODULE YOERRTO14 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO14* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 14 +! BAND 14: 2250-2380 cm-1 (low - CO2; high - CO2) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO14 = 16 + +REAL(KIND=JPRB) , DIMENSION(NO14) :: FRACREFAO +REAL(KIND=JPRB) , DIMENSION(NO14) :: FRACREFBO + +REAL(KIND=JPRB) :: KAO(5,13,NO14) +REAL(KIND=JPRB) :: KBO(5,13:59,NO14) +REAL(KIND=JPRD) :: KAO_D(5,13,NO14) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO14) +REAL(KIND=JPRB) :: SELFREFO(10,NO14) +REAL(KIND=JPRB) :: FORREFO(4,NO14) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/01/15 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! FRACREFB: REAL +! KA : REAL +! KB : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO14 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto15.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto15.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto15.F90 (revision 6016) @@ -0,0 +1,39 @@ +MODULE YOERRTO15 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO15* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 15 +! BAND 15: 2380-2600 cm-1 (low - N2O,CO2; high - nothing) +! ABozzo 2001306 updated to rrtmg v4.85 +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO15 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO15,9) + +REAL(KIND=JPRB) :: KAO(9,5,13,NO15) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO15) +REAL(KIND=JPRB) :: SELFREFO(10,NO15) +REAL(KIND=JPRB) :: FORREFO(4,NO15) +REAL(KIND=JPRB) :: KAO_MN2(9,19,NO15) +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! KA : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO15 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto16.F90 (revision 6016) @@ -0,0 +1,41 @@ +MODULE YOERRTO16 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO16* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 16 +! BAND 16: 2600-3000 cm-1 (low - H2O,CH4; high - nothing) +! ABozzo 201306 updated to rrtmg v4.85 +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO16 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO16,9) +REAL(KIND=JPRB) , DIMENSION(NO16) :: FRACREFBO + +REAL(KIND=JPRB) :: KAO(9,5,13,NO16) +REAL(KIND=JPRB) :: KBO(5,13:59,NO16) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO16) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO16) +REAL(KIND=JPRB) :: SELFREFO(10,NO16) +REAL(KIND=JPRB) :: FORREFO(4,NO16) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! KA : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO16 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto2.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto2.F90 (revision 6016) @@ -0,0 +1,45 @@ +MODULE YOERRTO2 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO2* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 2 +! BAND 2: 250-500 cm-1 (low - H2O; high - H2O) +! ABozzo May 2013 updated to rrtmg v4.85 +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO2 = 16 + +! The ith set of reference fractions are from the ith reference +! pressure level. +REAL(KIND=JPRB) :: FRACREFAO(NO2), FRACREFBO(NO2) +REAL(KIND=JPRB) :: KAO(5,13,NO2) +REAL(KIND=JPRB) :: KBO(5,13:59,NO2) +REAL(KIND=JPRD) :: KAO_D(5,13,NO2) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO2) +REAL(KIND=JPRB) :: SELFREFO(10,NO2) , FORREFO(4,NO2) + + + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +!FRACREFAO: REAL +!FRACREFBO: REAL +! KAO : REAL +! KBO : REAL +! SELFREFO: REAL +! FORREFO : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO2 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto3.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto3.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto3.F90 (revision 6016) @@ -0,0 +1,46 @@ +MODULE YOERRTO3 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO3* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 3 +! BAND 3: 500-630 cm-1 (low - H2O,CO2; high - H2O,CO2) +! ABozzo 200130517 updated to rrtmg_lw_v4.85: +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) +! (high key - h2o,co2; high minor - n2o) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO3 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO3,9) ,FRACREFBO(NO3,5) + +REAL(KIND=JPRB) :: KAO_MN2O(9,19,NO3), KBO_MN2O(5,19,NO3) +REAL(KIND=JPRB) :: KAO(9,5,13,NO3) +REAL(KIND=JPRB) :: KBO(5,5,13:59,NO3) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO3) +REAL(KIND=JPRD) :: KBO_D(5,5,13:59,NO3) +REAL(KIND=JPRB) :: SELFREFO(10,NO3),FORREFO(4,NO3) + + +! ------------------------------------------------------------------ +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSN2OAO: REAL +! ABSN2OBO: REAL +!FRACREFAO: REAL +!FRACREFBO: REAL +! KAO : REAL +! KBO : REAL +! SELFREFO: REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO3 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto4.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto4.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto4.F90 (revision 6016) @@ -0,0 +1,40 @@ +MODULE YOERRTO4 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO4* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 4 +! BAND 4: 630-700 cm-1 (low - H2O,CO2; high - O3,CO2) +! 201306 ABozzo updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO4 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO4,9) ,FRACREFBO(NO4,5) +REAL(KIND=JPRB) :: KAO(9,5,13,NO4) +REAL(KIND=JPRB) :: KBO(5,5,13:59,NO4) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO4) +REAL(KIND=JPRD) :: KBO_D(5,5,13:59,NO4) +REAL(KIND=JPRB) :: SELFREFO(10,NO4),FORREFO(4,NO4) + + +! ------------------------------------------------------------------ +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! FRACREFB: REAL +! KA : REAL +! KB : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO4 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto5.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto5.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto5.F90 (revision 6016) @@ -0,0 +1,45 @@ +MODULE YOERRTO5 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO5* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 5 +! BAND 5: 700-820 cm-1 (low - H2O,CO2; high - O3,CO2) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO5 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO5,9) ,FRACREFBO(NO5,5) + +REAL(KIND=JPRB) , DIMENSION(NO5) :: CCL4O + +REAL(KIND=JPRB) :: KAO_MO3(9,19,NO5) +REAL(KIND=JPRB) :: KAO(9,5,13,NO5) +REAL(KIND=JPRB) :: KBO(5,5,13:59,NO5) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO5) +REAL(KIND=JPRD) :: KBO_D(5,5,13:59,NO5) +REAL(KIND=JPRB) :: SELFREFO(10,NO5) +REAL(KIND=JPRB) :: FORREFO(4,NO5) + + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! FRACREFB: REAL +! KA : REAL +! KB : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO5 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto6.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto6.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto6.F90 (revision 6016) @@ -0,0 +1,44 @@ +MODULE YOERRTO6 + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO6* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 6 +! BAND 6: 820-980 cm-1 (low - H2O; high - nothing) +! ABozzo 201306 update to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO6 = 16 + +REAL(KIND=JPRB) , DIMENSION(NO6) :: FRACREFAO + +REAL(KIND=JPRB) , DIMENSION(NO6) :: CFC11ADJO +REAL(KIND=JPRB) , DIMENSION(NO6) :: CFC12O + + +REAL(KIND=JPRB) :: KAO(5,13,NO6) +REAL(KIND=JPRD) :: KAO_D(5,13,NO6) +REAL(KIND=JPRB) :: SELFREFO(10,NO6) +REAL(KIND=JPRB) :: KAO_MCO2(19,NO6) +REAL(KIND=JPRB) :: FORREFO(4,NO6) + + + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! KA : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO6 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto7.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto7.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto7.F90 (revision 6016) @@ -0,0 +1,46 @@ +MODULE YOERRTO7 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO7* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 7 +! BAND 7: 980-1080 cm-1 (low - H2O,O3; high - O3) +! ABozzo updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO7 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO7,9) + +REAL(KIND=JPRB) , DIMENSION(NO7) :: FRACREFBO +REAL(KIND=JPRB) :: KAO(9,5,13,NO7) +REAL(KIND=JPRB) :: KBO(5,13:59,NO7) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO7) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO7) +REAL(KIND=JPRB) :: SELFREFO(10,NO7) +REAL(KIND=JPRB) :: KAO_MCO2(9,19,NO7) +REAL(KIND=JPRB) :: KBO_MCO2(19,NO7) +REAL(KIND=JPRB) :: FORREFO(4,NO7) + + + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! FRACREFB: REAL +! KA : REAL +! KB : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO7 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto8.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto8.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto8.F90 (revision 6016) @@ -0,0 +1,57 @@ +MODULE YOERRTO8 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO8* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 8 +! BAND 8: 1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO8 = 16 + +REAL(KIND=JPRB) , DIMENSION(NO8) :: FRACREFAO +REAL(KIND=JPRB) , DIMENSION(NO8) :: FRACREFBO +REAL(KIND=JPRB) , DIMENSION(NO8) :: CFC12O +REAL(KIND=JPRB) , DIMENSION(NO8) :: CFC22ADJO + +REAL(KIND=JPRB) :: KAO(5,13,NO8) +REAL(KIND=JPRB) :: KBO(5,13:59,NO8) +REAL(KIND=JPRD) :: KAO_D(5,13,NO8) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO8) +REAL(KIND=JPRB) :: SELFREFO(10,NO8) +REAL(KIND=JPRB) :: KAO_MCO2(19,NO8) +REAL(KIND=JPRB) :: KAO_MN2O(19,NO8) +REAL(KIND=JPRB) :: KAO_MO3(19,NO8) +REAL(KIND=JPRB) :: KBO_MCO2(19,NO8) +REAL(KIND=JPRB) :: KBO_MN2O(19,NO8) +REAL(KIND=JPRB) :: FORREFO(4,NO8) + + + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSCO2A : REAL +! ABSCO2B : REAL +! ABSN2OA : REAL +! ABSN2OB : REAL +! CFC12 : REAL +! CFC22ADJ: REAL +! FRACREFA: REAL +! FRACREFB: REAL +! KA : REAL +! KB : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO8 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto9.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto9.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrto9.F90 (revision 6016) @@ -0,0 +1,51 @@ +MODULE YOERRTO9 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTO9* - RRTM ORIGINAL COEFFICIENTS FOR INTERVAL 9 +! BAND 9: 1180-1390 cm-1 (low - H2O,CH4; high - CH4) +! ABozzo 201306 updated to rrtmg v4.85 +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: NO9 = 16 + +REAL(KIND=JPRB) :: FRACREFAO(NO9,9) + +REAL(KIND=JPRB) , DIMENSION(NO9) :: FRACREFBO +! 48 = 3*NO9 + + +REAL(KIND=JPRB) :: KAO(9,5,13,NO9) +REAL(KIND=JPRB) :: KBO(5,13:59,NO9) +REAL(KIND=JPRD) :: KAO_D(9,5,13,NO9) +REAL(KIND=JPRD) :: KBO_D(5,13:59,NO9) +REAL(KIND=JPRB) :: KAO_MN2O(9,19,NO9) +REAL(KIND=JPRB) :: KBO_MN2O(19,NO9) +REAL(KIND=JPRB) :: SELFREFO(10,NO9) +REAL(KIND=JPRB) :: FORREFO(4,NO9) +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! ABSN2O : REAL +! CH4REF : REAL +! ETAREF : REAL +! FRACREFA: REAL +! FRACREFB: REAL +! H2OREF : REAL +! N2OREF : REAL +! KA : REAL +! KB : REAL +! SELFREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTO9 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtrf.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtrf.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtrf.F90 (revision 6016) @@ -0,0 +1,35 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTRF + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOERRTRF* - RRTM REFERENCE ATMOSPHERE +! ----------------------------------------------------------------- + +REAL(KIND=JPRB) , DIMENSION(59) :: PREF +REAL(KIND=JPRB) , DIMENSION(59) :: PREFLOG +REAL(KIND=JPRB) , DIMENSION(59) :: TREF +REAL(KIND=JPRB) :: CHI_MLS(7,59) + +!$ACC DECLARE CREATE(PREF, PREFLOG, TREF, CHI_MLS) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/01/15 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! PREF : REAL +! PREFLOG: REAL +! TREF : REAL +! ----------------------------------------------------------------- +END MODULE YOERRTRF Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtrwt.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtrwt.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtrwt.F90 (revision 6016) @@ -0,0 +1,36 @@ +MODULE YOERRTRWT + +USE PARKIND1, ONLY : JPRB +!USE PARRRTM, ONLY : JPGPT, JPG, JPBAND +USE PARRRTM, ONLY : JPG, JPBAND, JPGMAX + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------- + +! ------------------------------------------------------------------- + +REAL(KIND=JPRB) :: FREFA (JPGMAX,13) +REAL(KIND=JPRB) :: FREFB (JPGMAX,6) +REAL(KIND=JPRB) :: FREFADF(JPGMAX,13) +REAL(KIND=JPRB) :: FREFBDF(JPGMAX,6) +REAL(KIND=JPRB) :: RWGT (JPG*JPBAND) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FREFA : REAL : +! FREFB : REAL : +! FREFADF: REAL : +! FREFBDF: REAL : +! RWT : REAL : +! ------------------------------------------------------------------- +END MODULE YOERRTRWT Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtwn.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtwn.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoerrtwn.F90 (revision 6016) @@ -0,0 +1,40 @@ +! This file has been modified for the use in ICON + +MODULE YOERRTWN + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------- + +INTEGER(KIND=JPIM) , DIMENSION(16) :: NG +INTEGER(KIND=JPIM) , DIMENSION(16) :: NSPA +INTEGER(KIND=JPIM) , DIMENSION(16) :: NSPB + +REAL(KIND=JPRB) , DIMENSION(16) :: DELWAVE + +REAL(KIND=JPRB) , DIMENSION(181,16) :: TOTPLNK + +!$ACC DECLARE CREATE(NSPA, NSPB, DELWAVE, TOTPLNK) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM LW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 98/01/15 + +! NAME TYPE PURPOSE +! ---- : ---- : ------- +! NG : INTEGER : Number of k-coefficients in spectral intervals +! NSPA : INTEGER : +! NSPB : INTEGER : +! WAVENUM1: REAL : Lower wavenumber spectral limit +! WAVENUM2: REAL : Higher wavenumber spectral limit +! DELWAVE : REAL : Spectral interval width +! TOTPLNK : REAL : +! ----------------------------------------------------------------- +END MODULE YOERRTWN Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta16.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta16.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta16.F90 (revision 6016) @@ -0,0 +1,63 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA16 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA16* - SRTM COEFFICIENTS FOR INTERVAL 16 +! BAND 16: 2600-3250 cm-1 (low - H2O,CH4; high - CH4) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG=16, NG16 = 16, NGS15 = 0 + +REAL(KIND=JPRB) :: KA(9,5,13,JPG) +REAL(KIND=JPRB) :: KB(5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(9,5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG),FORREF(3,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG) +REAL(KIND=JPRB) :: RAYL ,STRRAT1 +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(9,5,13,NG16),ABSA(585,NG16) +REAL(KIND=JPRB) :: KBC(5,13:59,NG16),ABSB(235,NG16) +REAL(KIND=JPRB) :: SELFREFC(10,NG16),FORREFC(3,NG16) +REAL(KIND=JPRB) :: SFLUXREFC(NG16) + +!EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1,1),ABSA(1,1)), (KBC(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! STRRAT1 : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ----------------------------------------------------------------- +END MODULE YOESRTA16 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta17.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta17.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta17.F90 (revision 6016) @@ -0,0 +1,63 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA17 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA17* - SRTM COEFFICIENTS FOR INTERVAL 17 +! BAND 17: 3250-4000 cm-1 (low - H2O,CO2; high - H2O,CO2) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG17 = 16, NGS16=16 + +REAL(KIND=JPRB) :: KA(9,5,13,JPG) +REAL(KIND=JPRB) :: KB(5,5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(9,5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG) ,FORREF(4,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG,5) +REAL(KIND=JPRB) :: RAYL ,STRRAT +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(9,5,13,NG17),ABSA(585,NG17) +REAL(KIND=JPRB) :: KBC(5,5,13:59,NG17),ABSB(1175,NG17) +REAL(KIND=JPRB) :: SELFREFC(10,NG17),FORREFC(4,NG17) +REAL(KIND=JPRB) :: SFLUXREFC(NG17,5) + +!EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1,1),ABSA(1,1)), (KBC(1,1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! STRRAT : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ----------------------------------------------------------------- +END MODULE YOESRTA17 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta18.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta18.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta18.F90 (revision 6016) @@ -0,0 +1,64 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA18 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA18* - SRTM COEFFICIENTS FOR INTERVAL 16 +! BAND 18: 4000-4650 cm-1 (low - H2O,CH4; high - CH4) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG18 = 16, NGS17=32 + +REAL(KIND=JPRB) :: KA(9,5,13,JPG) +REAL(KIND=JPRB) :: KB(5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(9,5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG),FORREF(3,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG,9) +REAL(KIND=JPRB) :: RAYL ,STRRAT + +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(9,5,13,NG18) ,ABSA(585,NG18) +REAL(KIND=JPRB) :: KBC(5,13:59,NG18),ABSB(235,NG18) +REAL(KIND=JPRB) :: SELFREFC(10,NG18),FORREFC(3,NG18) +REAL(KIND=JPRB) :: SFLUXREFC(NG18,9) + +!EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1,1),ABSA(1,1)), (KBC(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! STRRAT : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ----------------------------------------------------------------- +END MODULE YOESRTA18 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta19.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta19.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta19.F90 (revision 6016) @@ -0,0 +1,63 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA19 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA19* - SRTM COEFFICIENTS FOR INTERVAL 19 +! BAND 19: 4650-5150 cm-1 (low - H2O,CO2; high - CO2) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG19 = 16 + +REAL(KIND=JPRB) :: KA(9,5,13,JPG) +REAL(KIND=JPRB) :: KB(5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(9,5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG),FORREF(3,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG,9) +REAL(KIND=JPRB) :: RAYL ,STRRAT +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(9,5,13,NG19) ,ABSA(585,NG19) +REAL(KIND=JPRB) :: KBC(5,13:59,NG19),ABSB(235,NG19) +REAL(KIND=JPRB) :: SELFREFC(10,NG19),FORREFC(3,NG19) +REAL(KIND=JPRB) :: SFLUXREFC(NG19,9) + +!EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1,1),ABSA(1,1)), (KBC(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! STRRAT : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ----------------------------------------------------------------- +END MODULE YOESRTA19 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta20.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta20.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta20.F90 (revision 6016) @@ -0,0 +1,63 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA20 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA20* - SRTM COEFFICIENTS FOR INTERVAL 20 +! BAND 20: 5150-6150 cm-1 (low - H2O; high - H2O) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG20 = 16 + +REAL(KIND=JPRB) :: KA(5,13,JPG) +REAL(KIND=JPRB) :: KB(5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG),FORREF(4,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG) ,ABSCH4(JPG) +REAL(KIND=JPRB) :: RAYL +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(5,13,NG20) ,ABSA(65,NG20) +REAL(KIND=JPRB) :: KBC(5,13:59,NG20),ABSB(235,NG20) +REAL(KIND=JPRB) :: SELFREFC(10,NG20),FORREFC(4,NG20) +REAL(KIND=JPRB) :: SFLUXREFC(NG20) ,ABSCH4C(NG20) + +!EQUIVALENCE (KA(1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1),ABSA(1,1)), (KBC(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC, ABSCH4C) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! ABSCH4 : REAL absorption coefficient for CH4 +! RAYL : REAL Rayleigh scattering parameter +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ABSCH4C : REAL Reduced g-point array for ABSCH4 +! ----------------------------------------------------------------- +END MODULE YOESRTA20 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta21.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta21.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta21.F90 (revision 6016) @@ -0,0 +1,63 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA21 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA21* - SRTM COEFFICIENTS FOR INTERVAL 21 +! BAND 21: 6150-7700 cm-1 (low - H2O,CO2; high - H2O,CO2) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG21 = 16 + +REAL(KIND=JPRB) :: KA(9,5,13,JPG) +REAL(KIND=JPRB) :: KB(5,5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(9,5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG) ,FORREF(4,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG,9) +REAL(KIND=JPRB) :: RAYL ,STRRAT +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(9,5,13,NG21) ,ABSA(585,NG21) +REAL(KIND=JPRB) :: KBC(5,5,13:59,NG21),ABSB(1175,NG21) +REAL(KIND=JPRB) :: SELFREFC(10,NG21) ,FORREFC(4,NG21) +REAL(KIND=JPRB) :: SFLUXREFC(NG21,9) + +!EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1,1),ABSA(1,1)), (KBC(1,1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! STRRAT : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ----------------------------------------------------------------- +END MODULE YOESRTA21 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta22.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta22.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta22.F90 (revision 6016) @@ -0,0 +1,63 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA22 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA22* - SRTM COEFFICIENTS FOR INTERVAL 22 +! BAND 22: 7700-8050 cm-1 (low - H2O,O2; high - O2) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG22 = 16 + +REAL(KIND=JPRB) :: KA(9,5,13,JPG) +REAL(KIND=JPRB) :: KB(5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(9,5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG),FORREF(3,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG,9) +REAL(KIND=JPRB) :: RAYL ,STRRAT +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(9,5,13,NG22) ,ABSA(585,NG22) +REAL(KIND=JPRB) :: KBC(5,13:59,NG22),ABSB(235,NG22) +REAL(KIND=JPRB) :: SELFREFC(10,NG22),FORREFC(3,NG22) +REAL(KIND=JPRB) :: SFLUXREFC(NG22,9) + +!EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1,1),ABSA(1,1)), (KBC(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! STRRAT : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ----------------------------------------------------------------- +END MODULE YOESRTA22 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta23.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta23.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta23.F90 (revision 6016) @@ -0,0 +1,60 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA23 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA23* - SRTM COEFFICIENTS FOR INTERVAL 23 +! BAND 23: 8050-12850 cm-1 (low - H2O; high - nothing) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG23 = 16 + +REAL(KIND=JPRB) :: KA(5,13,JPG) +REAL(KIND=JPRD) :: KA_D(5,13,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG),FORREF(3,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG) ,RAYL(JPG) +REAL(KIND=JPRB) :: GIVFAC +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(5,13,NG23) ,ABSA(65,NG23) +REAL(KIND=JPRB) :: SELFREFC(10,NG23),FORREFC(3,NG23) +REAL(KIND=JPRB) :: SFLUXREFC(NG23) ,RAYLC(NG23) + +!EQUIVALENCE (KA(1,1,1),ABSA(1,1)) +EQUIVALENCE (KAC(1,1,1),ABSA(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, SELFREFC, FORREFC, SFLUXREFC, RAYLC) + + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! LAYREFFR: INTEGER +! KA : REAL absorption coefficient of major absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! GIVFAC : REAL adjustment factor +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! RAYLC : REAL Reduced g-point array for RAYL +! ----------------------------------------------------------------- +END MODULE YOESRTA23 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta24.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta24.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta24.F90 (revision 6016) @@ -0,0 +1,73 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA24 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA24* - SRTM COEFFICIENTS FOR INTERVAL 24 +! BAND 24: 12850-16000 cm-1 (low - H2O,O2; high - O2) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG24 = 16 + +REAL(KIND=JPRB) :: KA(9,5,13,JPG) +REAL(KIND=JPRB) :: KB(5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(9,5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG),FORREF(3,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG,9) +REAL(KIND=JPRB) :: ABSO3A(JPG), ABSO3B(JPG), RAYLA(JPG,9), RAYLB(JPG) +REAL(KIND=JPRB) :: STRRAT +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(9,5,13,NG24) ,ABSA(585,NG24) +REAL(KIND=JPRB) :: KBC(5,13:59,NG24),ABSB(235,NG24) +REAL(KIND=JPRB) :: SELFREFC(10,NG24),FORREFC(3,NG24) +REAL(KIND=JPRB) :: SFLUXREFC(NG24,9) +REAL(KIND=JPRB) :: ABSO3AC(NG24), ABSO3BC(NG24), RAYLAC(NG24,9), RAYLBC(NG24) + +!EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1,1),ABSA(1,1)), (KBC(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC, & +!$ACC ABSO3AC, ABSO3BC, RAYLAC, RAYLBC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! ABSO3A : REAL O3 absorption coefficient in first part of band +! ABSO3B : REAL O3 absorption coefficient in second part of band +! RAYLA : REAL Rayleigh scattering parameter in first part of band +! RAYLB : REAL Rayleigh scattering parameter in second part of band +! STRRAT : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ABSO3AC : REAL Reduced g-point array for ABSO3A +! ABSO3BC : REAL Reduced g-point array for ABSO3B +! RAYLAC : REAL Reduced g-point array for RAYLA +! RAYLBC : REAL Reduced g-point array for RAYLB +! ----------------------------------------------------------------- +END MODULE YOESRTA24 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta25.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta25.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta25.F90 (revision 6016) @@ -0,0 +1,56 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA25 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA25* - SRTM COEFFICIENTS FOR INTERVAL 25 +! BAND 25: 16000-22650 cm-1 (low - H2O; high - nothing) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG25 = 16 + +REAL(KIND=JPRB) :: KA(5,13,JPG) +REAL(KIND=JPRD) :: KA_D(5,13,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG) +REAL(KIND=JPRB) :: RAYL(JPG), ABSO3A(JPG), ABSO3B(JPG) +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(5,13,NG25) ,ABSA(65,NG25) +REAL(KIND=JPRB) :: SFLUXREFC(NG25) +REAL(KIND=JPRB) :: RAYLC(NG25), ABSO3AC(NG25), ABSO3BC(NG25) + +!EQUIVALENCE (KA(1,1,1),ABSA(1,1)) +EQUIVALENCE (KAC(1,1,1),ABSA(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, SFLUXREFC, RAYLC, ABSO3AC, ABSO3BC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! ABSO3A : REAL O3 absorption coefficient in first part of band +! ABSO3B : REAL O3 absorption coefficient in second part of band +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! RAYLC : REAL Reduced g-point array for RAYL +! ABSO3AC : REAL Reduced g-point array for ABSO3A +! ABSO3BC : REAL Reduced g-point array for ABSO3B +! ----------------------------------------------------------------- +END MODULE YOESRTA25 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta26.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta26.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta26.F90 (revision 6016) @@ -0,0 +1,40 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA26 + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA26* - SRTM COEFFICIENTS FOR INTERVAL 26 +! BAND 26: 22650-29000 cm-1 (low - nothing; high - nothing) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG26 = 16 + +REAL(KIND=JPRB) :: SFLUXREF(JPG), RAYL(JPG) + +REAL(KIND=JPRB) :: SFLUXREFC(NG26), RAYLC(NG26) + +!$ACC DECLARE CREATE(SFLUXREFC, RAYLC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! RAYLC : REAL Reduced g-point array for RAYL +! ----------------------------------------------------------------- +END MODULE YOESRTA26 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta27.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta27.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta27.F90 (revision 6016) @@ -0,0 +1,58 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA27 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA27* - SRTM COEFFICIENTS FOR INTERVAL 27 +! BAND 27: 29000-38000 cm-1 (low - O3; high - O3) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG27 = 16 + +REAL(KIND=JPRB) :: KA(5,13,JPG) +REAL(KIND=JPRB) :: KB(5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,13:59,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG) ,RAYL(JPG) +REAL(KIND=JPRB) :: SCALEKUR +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(5,13,NG27) ,ABSA(65,NG27) +REAL(KIND=JPRB) :: KBC(5,13:59,NG27),ABSB(235,NG27) +REAL(KIND=JPRB) :: SFLUXREFC(NG27) ,RAYLC(NG27) + +!EQUIVALENCE (KA(1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1),ABSA(1,1)), (KBC(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SFLUXREFC, RAYLC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! FRACREFA: REAL +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! SCALEKUR: REAL weighting factor to account for Kurucz's correction to solar spectrum +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! RAYLC : REAL Reduced g-point array for RAYL +! ----------------------------------------------------------------- +END MODULE YOESRTA27 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta28.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta28.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta28.F90 (revision 6016) @@ -0,0 +1,57 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA28 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA28* - SRTM COEFFICIENTS FOR INTERVAL 28 +! BAND 28: 38000-50000 cm-1 (low - O3, O2; high - O3, O2) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG28 = 16 + +REAL(KIND=JPRB) :: KA(9,5,13,JPG) +REAL(KIND=JPRB) :: KB(5,5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(9,5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,5,13:59,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG,5) +REAL(KIND=JPRB) :: RAYL ,STRRAT +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(9,5,13,NG28) ,ABSA(585,NG28) +REAL(KIND=JPRB) :: KBC(5,5,13:59,NG28),ABSB(1175,NG28) +REAL(KIND=JPRB) :: SFLUXREFC(NG28,5) + +!EQUIVALENCE (KA(1,1,1,1),ABSA(1,1)), (KB(1,1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1,1),ABSA(1,1)), (KBC(1,1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SFLUXREFC) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! RAYL : REAL Rayleigh scattering parameter +! STRRAT : REAL weighting factor for the transition between tropospheric +! and stratospheric computations +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ----------------------------------------------------------------- +END MODULE YOESRTA28 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta29.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta29.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrta29.F90 (revision 6016) @@ -0,0 +1,66 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTA29 + +USE PARKIND1 ,ONLY : JPIM ,JPRB,JPRD + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ----------------------------------------------------------------- +!* ** *YOESRTA29* - SRTM COEFFICIENTS FOR INTERVAL 29 +! BAND 29: 820-2600 cm-1 (low - H2O; high - CO2) +! ----------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPG = 16, NG29 = 16 + +REAL(KIND=JPRB) :: KA(5,13,JPG) +REAL(KIND=JPRB) :: KB(5,13:59,JPG) +REAL(KIND=JPRD) :: KA_D(5,13,JPG) +REAL(KIND=JPRD) :: KB_D(5,13:59,JPG) +REAL(KIND=JPRB) :: SELFREF(10,JPG),FORREF(4,JPG) +REAL(KIND=JPRB) :: SFLUXREF(JPG) ,ABSH2O(JPG) , ABSCO2(JPG) +REAL(KIND=JPRB) :: RAYL +INTEGER(KIND=JPIM) :: LAYREFFR + +REAL(KIND=JPRB) :: KAC(5,13,NG29) ,ABSA(65,NG29) +REAL(KIND=JPRB) :: KBC(5,13:59,NG29),ABSB(235,NG29) +REAL(KIND=JPRB) :: SELFREFC(10,NG29),FORREFC(4,NG29) +REAL(KIND=JPRB) :: SFLUXREFC(NG29) ,ABSH2OC(NG29) , ABSCO2C(NG29) + +!EQUIVALENCE (KA(1,1,1),ABSA(1,1)), (KB(1,13,1),ABSB(1,1)) +EQUIVALENCE (KAC(1,1,1),ABSA(1,1)), (KBC(1,13,1),ABSB(1,1)) + +!$ACC DECLARE CREATE(KAC, ABSA, KBC, ABSB, SELFREFC, FORREFC, SFLUXREFC, & +!$ACC ABSH2OC, ABSCO2C) + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 02/10/29 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! KA : REAL absorption coefficient of major absorber +! KB : REAL absorption coefficient of secondary absorber +! SELFREF : REAL self brodening coefficient for water vapour +! FORREF : REAL foreign broadening coefficient for water vapour +! SFLUXREF: REAL Incident solar radiation in the spectral interval +! ABSH2O : REAL line absorption coefficient for H2O +! ABSCO2 : REAL line absorption coefficient for CO2 +! RAYL : REAL Rayleigh scattering parameter +! LAYREFFR: INTEGER reference level for the transition +! KAC : REAL Reduced g-point array for KA +! KBC : REAL Reduced g-point array for KB +! SELFREFC: REAL Reduced g-point array for SELFREF +! FORREFC : REAL Reduced g-point array for FORREF +!SFLUXREFC: REAL Reduced g-point array for SFLUXREF +! ABSH2OC : REAL Reduced g-point array for ABSH2O +! ABSCO2C : REAL Reduced g-point array for ABSCO2 +! ----------------------------------------------------------------- +END MODULE YOESRTA29 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtab.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtab.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtab.F90 (revision 6016) @@ -0,0 +1,28 @@ +MODULE YOESRTAB + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +SAVE + +! ------------------------------------------------------------------- + +REAL(KIND=JPRB) , DIMENSION(0:10000) :: TRANS +REAL(KIND=JPRB) :: BPADE, RODLOW, RTBLINT + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 20080724 +! adapted from M.J. IACONO, AER Inc, 200708 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! TRANS : REAL : TABULATED REFERENCE FOR SW TRANSMISSION +! BPADE : REAL : INVERSE OF PADE APPROXIMATION CONSTANT (= 1./0.278) +! RODLOW : REAL : VALUE OF TAU BELOW WHICH EXPANSION IS USED IN LIEU OF +! LOOK-UP TABLE +! RTBLINT: REAL : LOOK-UP TABLE CONVERSION FACTOR +! ----------------------------------------------------------------- +END MODULE YOESRTAB Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtaer.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtaer.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtaer.F90 (revision 6016) @@ -0,0 +1,35 @@ +MODULE YOESRTAER + +USE PARKIND1 ,ONLY : JPRB + +IMPLICIT NONE + +SAVE + +! ------------------------------------------------------------------ +!* ** *YOESRTAER* - AEROSOL OPTICAL PROPERTIES FOR SRTM +! ------------------------------------------------------------------ + +!-- AEROSOL OPTICAL PROPERTIES + +!-- coefficients and parameters related to SRTM_SW 16 sp.int. + +REAL(KIND=JPRB) :: RSRTAUA(14,6) +REAL(KIND=JPRB) :: RSRPIZA(14,6) +REAL(KIND=JPRB) :: RSRASYA(14,6) + +! ----------------------------------------------------------------- + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 03/03/07 + +! NAME TYPE PURPOSE +! ---- : ---- : ------- +!RSRTAUA : REAL S.W. NORMALIZED OPTICAL THICKNESS AT 0.55 MICRON +!RSRPIZA : REAL S.W. SINGLE SCATTERING ALBEDO +!RSRASYA : REAL S.W. ASSYMETRY FACTOR + +! ----------------------------------------------------------------- +END MODULE YOESRTAER + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtm.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtm.F90 (revision 6016) @@ -0,0 +1,63 @@ +MODULE YOESRTM + +USE PARKIND1 ,ONLY : JPIM +USE PARSRTM ,ONLY : JPGMAX + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------ +! Parameters relevant to AER's RRTM-SW radiation scheme: Part 2 + +! 20110610 JJMorcrette + +! Modified to allow possibilities of different g-point numbers. +! ------------------------------------------------------------------ + +!INTEGER(KIND=JPIM) :: JPGPT +!INTEGER(KIND=JPIM) :: JPGSW + +!INTEGER(KIND=JPIM) :: NG16 +!INTEGER(KIND=JPIM) :: NG17 +!INTEGER(KIND=JPIM) :: NG18 +!INTEGER(KIND=JPIM) :: NG19 +!INTEGER(KIND=JPIM) :: NG20 +!INTEGER(KIND=JPIM) :: NG21 +!INTEGER(KIND=JPIM) :: NG22 +!INTEGER(KIND=JPIM) :: NG23 +!INTEGER(KIND=JPIM) :: NG24 +!INTEGER(KIND=JPIM) :: NG25 +!INTEGER(KIND=JPIM) :: NG26 +!INTEGER(KIND=JPIM) :: NG27 +!INTEGER(KIND=JPIM) :: NG28 +!INTEGER(KIND=JPIM) :: NG29 + +!-- NGnn : number of g-points in bands nn=16 to 29 +!- as used for the (operational) 112 g-points version of RRTM_SW +INTEGER(KIND=JPIM), PARAMETER :: JPGPT = 112 +INTEGER(KIND=JPIM), PARAMETER :: JPGSW = 112 + +INTEGER(KIND=JPIM), PARAMETER :: NG16 = 6 +INTEGER(KIND=JPIM), PARAMETER :: NG17 = 12 +INTEGER(KIND=JPIM), PARAMETER :: NG18 = 8 +INTEGER(KIND=JPIM), PARAMETER :: NG19 = 8 +INTEGER(KIND=JPIM), PARAMETER :: NG20 = 10 +INTEGER(KIND=JPIM), PARAMETER :: NG21 = 10 +INTEGER(KIND=JPIM), PARAMETER :: NG22 = 2 +INTEGER(KIND=JPIM), PARAMETER :: NG23 = 10 +INTEGER(KIND=JPIM), PARAMETER :: NG24 = 8 +INTEGER(KIND=JPIM), PARAMETER :: NG25 = 6 +INTEGER(KIND=JPIM), PARAMETER :: NG26 = 6 +INTEGER(KIND=JPIM), PARAMETER :: NG27 = 8 +INTEGER(KIND=JPIM), PARAMETER :: NG28 = 6 +INTEGER(KIND=JPIM), PARAMETER :: NG29 = 12 + + +INTEGER(KIND=JPIM) :: NGN(JPGMAX), NGBSW(JPGMAX) + +! ------------------------------------------------------------------ +END MODULE YOESRTM + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtwn.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtwn.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesrtwn.F90 (revision 6016) @@ -0,0 +1,71 @@ +! This file has been modified for the use in ICON + +MODULE YOESRTWN + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +PUBLIC + +SAVE + +! ------------------------------------------------------------------- + +INTEGER(KIND=JPIM) , DIMENSION(16:29) :: NG +INTEGER(KIND=JPIM) , DIMENSION(16:29) :: NSPA +INTEGER(KIND=JPIM) , DIMENSION(16:29) :: NSPB +INTEGER(KIND=JPIM) , DIMENSION(14) :: NMPSRTM + +REAL(KIND=JPRB), DIMENSION(59) :: PREF +REAL(KIND=JPRB), DIMENSION(59) :: PREFLOG +REAL(KIND=JPRB), DIMENSION(59) :: TREF + +INTEGER(KIND=JPIM), DIMENSION(224) :: NGM +INTEGER(KIND=JPIM), DIMENSION(14) :: NGC, NGS + +REAL(KIND=JPRB), DIMENSION(16) :: WT, WTSM +REAL(KIND=JPRB), DIMENSION(224) :: RWGT + +!$ACC DECLARE CREATE(NSPA, NSPB, PREFLOG, TREF, NGC) + +! Use for 56 g-points +!INTEGER(KIND=JPIM), DIMENSION(56) :: NGBSW, NGN +! Use for 112 g-points +!INTEGER(KIND=JPIM), DIMENSION(112) :: NGBSW, NGN +! Use for 224 g-points +!INTEGER(KIND=JPIM), DIMENSION(224) :: NGBSW, NGN + +! ----------------------------------------------------------------- +! * E.C.M.W.F. PHYSICS PACKAGE ** RRTM SW RADIATION ** + +! J.-J. MORCRETTE E.C.M.W.F. 03-03-07 +! M. J. IACONO AER 12/09/03 + +! NAME TYPE PURPOSE +! ---- : ---- : ------- +! NG : INTEGER : Number of k-coefficients in spectral intervals +! NSPA : INTEGER : +! NSPB : INTEGER : +! NMPSRTM : INTEGER : MAPPING INDICES FOR 6-SPECTRAL INT. SURFACE ALBEDO +! WAVENUM1: REAL : Lower wavenumber spectral limit +! WAVENUM2: REAL : Higher wavenumber spectral limit +! DELWAVE : REAL : Spectral interval width +! PREF : REAL : Reference pressure +! PREFLOG : REAL : Log reference pressure +! TREF : REAL : Reference temperature +! NGC : INTEGER : The number of new g-points in each band +! NGS : INTEGER : The cumulative sum of new g-points for each band +! NGM : INTEGER : The index of each new g-point relative to the +! original 16 g-points for each band. +! +! WT : REAL : RRTM weights for 16 g-points. +! WTSUM : REAL : Sum of the weights +! RWGT : REAL : +! +! NGN : INTEGER : The number of original g-points that are combined +! to make each new g-point in each band. +! NGBSW : INTEGER : The band index for each new g-point. +! ----------------------------------------------------------------- +END MODULE YOESRTWN + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yoesw.F90 (revision 6016) @@ -0,0 +1,213 @@ +MODULE YOESW + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +! ------------------------------------------------------------------ +!* ** *YOESW* - COEFFICIENTS FOR SHORTWAVE RADIATION TRANSFER +! ------------------------------------------------------------------ + +REAL(KIND=JPRB) :: APAD(6,3,7) +REAL(KIND=JPRB) :: BPAD(6,3,7) +REAL(KIND=JPRB) :: RRAY(6,6) +REAL(KIND=JPRB), ALLOCATABLE :: RSUN(:) +REAL(KIND=JPRB) :: RPDH1 +REAL(KIND=JPRB) :: RPDU1 +REAL(KIND=JPRB) :: RPNH +REAL(KIND=JPRB) :: RPNU +REAL(KIND=JPRB) :: RSWCE(6) +REAL(KIND=JPRB) :: RSWCP(6) +REAL(KIND=JPRB) :: RTDH2O +REAL(KIND=JPRB) :: RTDUMG +REAL(KIND=JPRB) :: RTH2O +REAL(KIND=JPRB) :: RTUMG +REAL(KIND=JPRB) :: D(6,3) +REAL(KIND=JPRB) :: REXPO3(6,2,7) +INTEGER(KIND=JPIM) :: NEXPO3(6) + +REAL(KIND=JPRB) :: RYFWCA(6) +REAL(KIND=JPRB) :: RYFWCB(6) +REAL(KIND=JPRB) :: RYFWCC(6) +REAL(KIND=JPRB) :: RYFWCD(6) +REAL(KIND=JPRB) :: RYFWCE(6) +REAL(KIND=JPRB) :: RYFWCF(6) + +REAL(KIND=JPRB) :: REBCUA(6) +REAL(KIND=JPRB) :: REBCUB(6) +REAL(KIND=JPRB) :: REBCUC(6) +REAL(KIND=JPRB) :: REBCUD(6) +REAL(KIND=JPRB) :: REBCUE(6) +REAL(KIND=JPRB) :: REBCUF(6) +REAL(KIND=JPRB) :: REBCUG(16) +REAL(KIND=JPRB) :: REBCUH(16) +REAL(KIND=JPRB) :: REBCUI(6) +REAL(KIND=JPRB) :: REBCUJ(6) + +REAL(KIND=JPRB) :: RASWCA(6) +REAL(KIND=JPRB) :: RASWCB(6) +REAL(KIND=JPRB) :: RASWCC(6) +REAL(KIND=JPRB) :: RASWCD(6) +REAL(KIND=JPRB) :: RASWCE(6) +REAL(KIND=JPRB) :: RASWCF(6) + +REAL(KIND=JPRB) :: RFUETA(16,3),RFUETB(16,4), RFUETC(16,4) +REAL(KIND=JPRB) :: RFULIO(16,3) +REAL(KIND=JPRB) :: RHSAVI(16,3) +REAL(KIND=JPRB) :: RLILIA(16,5),RLILIB(16,4) + +REAL(KIND=JPRB) :: RFLAA0(6) +REAL(KIND=JPRB) :: RFLAA1(6) +REAL(KIND=JPRB) :: RFLBB0(6) +REAL(KIND=JPRB) :: RFLBB1(6) +REAL(KIND=JPRB) :: RFLBB2(6) +REAL(KIND=JPRB) :: RFLBB3(6) +REAL(KIND=JPRB) :: RFLCC0(6) +REAL(KIND=JPRB) :: RFLCC1(6) +REAL(KIND=JPRB) :: RFLCC2(6) +REAL(KIND=JPRB) :: RFLCC3(6) + +REAL(KIND=JPRB) :: RFUAA0(6) +REAL(KIND=JPRB) :: RFUAA1(6) +REAL(KIND=JPRB) :: RFUBB0(6) +REAL(KIND=JPRB) :: RFUBB1(6) +REAL(KIND=JPRB) :: RFUBB2(6) +REAL(KIND=JPRB) :: RFUBB3(6) +REAL(KIND=JPRB) :: RFUCC0(6) +REAL(KIND=JPRB) :: RFUCC1(6) +REAL(KIND=JPRB) :: RFUCC2(6) +REAL(KIND=JPRB) :: RFUCC3(6) +REAL(KIND=JPRB) :: RFLDD0(6) +REAL(KIND=JPRB) :: RFLDD1(6) +REAL(KIND=JPRB) :: RFLDD2(6) +REAL(KIND=JPRB) :: RFLDD3(6) + +REAL(KIND=JPRB) :: REFFIA + +REAL(KIND=JPRB) :: RTAUA(6,6) +REAL(KIND=JPRB) :: RPIZA(6,6) +REAL(KIND=JPRB) :: RCGA(6,6) +REAL(KIND=JPRB) :: RAER(6,6) + +INTEGER(KIND=JPIM) :: NMPSRTM(14), NTYPS + +REAL(KIND=JPRB) :: RADJUST + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +! APAD : REAL PADE APPROXIMANTS NUMERATOR +! BPAD : REAL PADE APPROXIMANTS DENOMINATOR +! D : REAL TRANSMISSION LIMIT FOR INFINITE ABSORBER AMOUNT +! RRAY : REAL RAYLEIGH SCATTERING COEFFICIENTS +! RSUN : REAL SOLAR FRACTION IN SPECTRAL INTERVALS +! RPDH1 : 1 + EXPONENT PRESSURE DEPENDENCE H2O +! RPDU1 : 1 + EXPONENT PRESSURE DEPENDENCE UNIFORMLY MIXED GASES +! RPNH : REFERENCE PRESSURE FACTOR FOR H2O +! RPNU : REFERENCE PRESSURE FACTOR FOR UNIFORMLY MIXED GASES +! RSWCE : E-TYPE, H2O CONTINUUM ABSORPTION COEFFICIENT +! RSWCP : P-TYPE, H2O CONTINUUM ABSORPTION COEFFICIENT +! RTDH2O: EXPONENT TEMPERATURE DEPENDENCE H2O +! RTDUMG: EXPONENT TEMPERATURE DEPENDENCE UNIFORMLY MIXED GASES +! RTH2O : REFERENCE TEMPERATURE H2O +! RTUMG : REFERENCE TEMPERATURE UNIFORMLY MIXED GASES +! ----------------------------------------------------------------- + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : --------------------------------------------------- +!* FOUQUART (1987) WATER CLOUD OPTICAL PROPERTIES + +! RYFWCA : REAL : C1 IN OPTICAL THICKNESS FORMULA +! RYFWCB : REAL : C2 IN OPTICAL THICKNESS FORMULA +! RYFWCC : REAL : SINGLE SCATTERING ALBEDO PARAMETER +! RYFWCD : REAL : SINGLE SCATTERING ALBEDO PARAMETER +! RYFWCE : REAL : SINGLE SCATTERING ALBEDO PARAMETER +! RYFWCF : REAL : ASSYMETRY FACTOR + +!* SLINGO (1989) WATER CLOUD OPTICAL PROPERTIES + +! RASWCA : REAL : C1 IN OPTICAL THICKNESS FORMULA +! RASWCB : REAL : C2 IN OPTICAL THICKNESS FORMULA +! RASWCC : REAL : SINGLE SCATTERING ALBEDO PARAMETER +! RASWCD : REAL : SINGLE SCATTERING ALBEDO PARAMETER +! RASWCE : REAL : SINGLE SCATTERING ALBEDO PARAMETER +! RASWCF : REAL : ASSYMETRY FACTOR + +!* LINDNER,LI (2000) WATER CLOUD OPTICAL PROPERTIES (RRTM) + +! RLILIA : REAL : MASS ABSORPTION COEFFICIENTS (POLYNOMIAL DEVELOPM) +! RLILIB : REAL : 1-SSA COEFFICIENTS (POLYNOMIAL DEVELOPM) + +!* ICE CLOUD OPTICAL PROPERTIES DERIVED FROM EBERT-CURRY (1992) + +! REBCUA : REAL : C1 IN OPTICAL THICKNESS FORMULA +! REBCUB : REAL : C2 IN OPTICAL THICKNESS FORMULA +! REBCUC : REAL : 1-C3 IN SINGLE SCATTERING ALBEDO FORMULA +! REBCUD : REAL : C4 IN SINGLE SCATTERING ALBEDO FORMULA +! REBCUE : REAL : C5 IN ASSYMETRY FACTOR FORMULA +! REBCUF : REAL : C6 IN ASSYMETRY FACTOR FORMULA +! REBCUG : REAL : C7 IN MASS ABSORPTION COEFFICIENT FORMULA +! REBCUH : REAL : C8 IN MASS ABSORPTION COEFFICIENT FORMULA +! REBCUI : REAL : C7 IN MASS ABSORPTION COEFFICIENT SPECTRAL FORMULA +! REBCUJ : REAL : C8 IN MASS ABSORPTION COEFFICIENT SPECTRAL FORMULA + +!* ICE CLOUD OPTICAL PROPERTIES DERIVED FROM SUN-SHINE (1995) + +! RSHSUE : REAL : E IN SINGLE SCATTERING ALBEDO FORMULA +! RSHSUF : REAL : F IN SINGLE SCATTERING ALBEDO FORMULA +! RSHSUH : REAL : H IN ASSYMETRY FACTOR FORMULA +! RSHSUK : REAL : K IN ASSYMETRY FACTOR FORMULA +! RSHSUA : REAL : ALPHA IN SSA CORRECTION FACTOR FORMULA +! RSHSUG : REAL : GAMMA IN ASSYMETRY CORRECTION FACTOR FORMULA +! RSHSUFA: REAL : COEFFICIENTS IN TEMPERATURE CORRECTION FACTOR + +! REFFIA : REAL : C9 IN EFFECTIVE RADIUS FORMULA + +!* ICE CLOUD OPTICAL PROPERTIES DERIVED FROM FU-LIOU (1993) + +! RFULIO : REAL : COEFFICIENTS IN EXPRESSION FOR LW EXTINCTION COEFF. +! RFLAA : REAL : COEFFICIENTS IN EXPRESSION FOR SW EXTINCTION COEFF. +! RFLBB : REAL : COEFFICIENTS IN EXPRESSION FOR SW SINGLE SCATT.ALB. +! RFLCC : REAL : COEFFICIENTS IN EXPRESSION FOR SW ASSYMETRY FACTOR +! RFLDD : REAL : COEFFICIENTS IN EXPRESSION FOR SW ASSYMETRY FACTOR + +!* ICE CLOUD OPTICAL PROPERTIES DERIVED FROM FU (1996) & FU ET AL. (1998) + +! RFUETA : REAL : COEFFICIENTS IN EXPRESSION FOR LW EXTINCTION COEFF. +! RFUAA : REAL : COEFFICIENTS IN EXPRESSION FOR SW EXTINCTION COEFF. +! RFUBB : REAL : COEFFICIENTS IN EXPRESSION FOR SW SINGLE SCATT.ALB. +! RFUCC : REAL : COEFFICIENTS IN EXPRESSION FOR SW ASSYMETRY FACTOR + +! ----------------------------------------------------------------- + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : ------- +! RTAUA : REAL S.W. NORMALIZED OPTICAL THICKNESS AT 0.55 MICRON +! RPIZA : REAL S.W. SINGLE SCATTERING ALBEDO +! RCGA : REAL S.W. ASSYMETRY FACTOR +! RAER : REAL L.W. ABSORPTION COEFFICIENTS +! ----------------------------------------------------------------- + +! * E.C.M.W.F. PHYSICS PACKAGE * + +! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 + +! NAME TYPE PURPOSE +! ---- : ---- : ------- +!RTWEIGHT: REAL S.W. INTEGRATED WEIGHT +! NMPSRTM: INTEGER : Indices for mapping SW[1:6] albedo into SRTM[1:14] +! ----------------------------------------------------------------- +END MODULE YOESW Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yom_ygfl.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yom_ygfl.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yom_ygfl.F90 (revision 6016) @@ -0,0 +1,431 @@ +MODULE YOM_YGFL + +USE PARKIND1 , ONLY : JPIM, JPRB + +IMPLICIT NONE +SAVE + +!------------------------------------------------------------------------- +! Contains the descriptors of GFL arrays +!------------------------------------------------------------------------- + +! JPGFL : Max number of GFL fields +! JPNAMED_GFL : Number of currently pre-defined components of GFL +! JPGHG : Number of greenhouse gas fields +! JPGRG : Number of reactive gas fields +! JPCHEM : Number of chemical species +! JPAERO : Number of active aerosol fields +! JPAEROUT: Number of output aerosol fields +! JPUVP : Number of output from UV processor +! JPTRAC : Number of tracers for diagnostics +! JPERA40 : Number of ERA40 diagnostic fields +! JPCH4S : Number of added fields related to methane +! JPNOGW : Number of diagnostic fields for NORO GWD SCHEME +! JPSLDIA : Number of SL dynamics diagnostic fields +! JPCHEM_ASSIM : Maximum number of assimilated of chemical species +!------------------------------------------------------------------------- + +INTEGER(KIND=JPIM), PARAMETER :: JPGFL=2163 +INTEGER(KIND=JPIM), PARAMETER :: JPNAMED_GFL=27 +INTEGER(KIND=JPIM), PARAMETER :: JPGHG=3 +INTEGER(KIND=JPIM), PARAMETER :: JPTRAC=10 +INTEGER(KIND=JPIM), PARAMETER :: JPCHEM=66 +INTEGER(KIND=JPIM), PARAMETER :: JPGRG=5 +INTEGER(KIND=JPIM), PARAMETER :: JPCHEM_ASSIM=5 +INTEGER(KIND=JPIM), PARAMETER :: JPAERO=16 +INTEGER(KIND=JPIM), PARAMETER :: JPFORC=1800 +INTEGER(KIND=JPIM), PARAMETER :: JPERA40=14 +INTEGER(KIND=JPIM), PARAMETER :: JPSLDIA=7 +INTEGER(KIND=JPIM), PARAMETER :: JPEZDIAG=50 +INTEGER(KIND=JPIM), PARAMETER :: JPCH4S=2 +INTEGER(KIND=JPIM), PARAMETER :: JPNOGW=2 +INTEGER(KIND=JPIM), PARAMETER :: JPAEROUT=17 +INTEGER(KIND=JPIM), PARAMETER :: JPUVP=2 +INTEGER(KIND=JPIM), PARAMETER :: JPPHYS=8 +INTEGER(KIND=JPIM), PARAMETER :: GRIB_CODE_GFL_PHYS=81 ! AJGDB hopefully harmless + +TYPE TYPE_GFL_COMP ! Individual field descriptor + +SEQUENCE ! daand: necessary to avoid memory corruption with gfortran 4.3.3 + +CHARACTER(LEN=16) :: CNAME = '' ! ARPEGE field name +INTEGER(KIND=JPIM) :: IGRBCODE = -999 ! GRIB code +LOGICAL :: LADV = .FALSE. ! Field advected or not +LOGICAL :: LADV5 = .FALSE. ! Field advected without wind increments +LOGICAL :: LTDIABLIN = .FALSE. ! Diabatic tendency is interpolated by lin. int. +LOGICAL :: LHORTURB = .FALSE. ! Horizontal part affected by 3D turbulence +INTEGER(KIND=JPIM) :: NREQIN = 0 ! 1 if field requiered in input, 0 if not, -1 if initialised + ! with a reference value REFVALI +LOGICAL :: LREQOUT = .FALSE. ! T if field requiered in output +LOGICAL :: LGPINGP = .TRUE. ! GP field input as GP +LOGICAL :: LGP = .FALSE. ! Field exists and of grid-point type +LOGICAL :: LSP = .FALSE. ! Field exists and of spectral type +LOGICAL :: LCDERS = .FALSE. ! Derivatives required (spectral only) +LOGICAL :: LACTIVE = .FALSE. ! Field in use +LOGICAL :: LTHERMACT = .FALSE. ! Field thermodynamically active +REAL(KIND=JPRB) :: R = 0.0_JPRB +REAL(KIND=JPRB) :: RCP = 0.0_JPRB +LOGICAL :: LT9 = .FALSE. ! Field in t-dt GFL +LOGICAL :: LT1 = .FALSE. ! Field in t+dt GFL +LOGICAL :: LT5 = .FALSE. ! Field in trajectory GFL +LOGICAL :: LPHY = .FALSE. ! Field in physics GFL +LOGICAL :: LPT = .FALSE. ! Field in PC phy. tend. GFL (GFLPT) +LOGICAL :: LTRAJIO = .FALSE. ! Field written to and from trajectory structure +LOGICAL :: LDIAG = .FALSE. ! Field is "diagnostic" at t; e.g. cloud fraction +LOGICAL :: LPC = .FALSE. ! Field in predictor/corrector time stepping (GFLPC) +REAL(KIND=JPRB) :: REFVALI = 0.0_JPRB ! Reference value for init, used in case NREQIN==-1 +! LAM specific attributes (Arome/Aladin) +LOGICAL :: LADJUST0 = .FALSE. ! True if field is thermodynamically adjusted at t + ! (immediatly after inverse spectral transforms) +LOGICAL :: LADJUST1 = .FALSE. ! True if field is thermodynamically adjusted at t+dt + ! (after SL interpolations and NL residuals) +INTEGER(KIND=JPIM) :: NCOUPLING = 0 ! 1 if field is coupled by Davies relaxation, 0 if not, + ! -1 if coupled with reference value for coupling REFVALC +REAL(KIND=JPRB) :: REFVALC = 0.0_JPRB ! Reference value for coupling, used in case NCOUPLING==-1 +LOGICAL :: LBIPER = .FALSE. ! True if field must be biperiodised inside the transforms +! End LAM specific attributes (Arome/Aladin) +CHARACTER(LEN=12) :: CSLINT = '' ! S.L interpolaion "type" +INTEGER(KIND=JPIM) :: MP = -99999999 ! Basic field "pointer" +INTEGER(KIND=JPIM) :: MPL = -99999999 ! zonal derivative "pointer" +INTEGER(KIND=JPIM) :: MPM = -99999999 ! Meridional derivative "pointer" +INTEGER(KIND=JPIM) :: MP9 = -99999999 ! Basic field "pointer" t-dt +INTEGER(KIND=JPIM) :: MP9_PH = -99999999 ! Basic field "pointer" for Physics +INTEGER(KIND=JPIM) :: MP1 = -99999999 ! Basic field "pointer" t+dt +INTEGER(KIND=JPIM) :: MP5 = -99999999 ! Basic field "pointer" trajectory +INTEGER(KIND=JPIM) :: MP5L = -99999999 ! zonal derivative "pointer" trajectory +INTEGER(KIND=JPIM) :: MP5M = -99999999 ! Meridional derivative "pointer" trajectory +INTEGER(KIND=JPIM) :: MPSLP = -99999999 ! Basic field "pointer" physics +INTEGER(KIND=JPIM) :: MPSP = -99999999 ! Basic field "pointer" spectral space +INTEGER(KIND=JPIM) :: MP_SPL = -99999999 ! Basic field "pointer" spline interpolation +INTEGER(KIND=JPIM) :: MP_SL1 = -99999999 ! Basic field "pointer" in SLBUF1 +INTEGER(KIND=JPIM) :: MP_SLX = -99999999 ! Basic field "pointer" in SLBUF1 for CPG_PT +INTEGER(KIND=JPIM) :: MPPT = -99999999 ! Physics tendency "pointer" +INTEGER(KIND=JPIM) :: MPPC = -99999999 ! Predictor/corrector auxiliary array "pointer" + +! daand: INTFLEX attributes +LOGICAL :: LWATER ! TRUE for water species +LOGICAL :: LPRECIP ! TRUE for precipitating water species +REAL(KIND=JPRB) :: RLZER ! Latent heat change at 0K + +! gems nl ext +INTEGER(KIND=JPIM) :: NCOUPLO4 ! Coupled to CTM by OASIS4 intefrace +LOGICAL :: LASSIM ! use as Control Variable (either monitored or assimilated) +INTEGER(KIND=JPIM) :: IGRIBDV ! GRIB code of deposition velocity +INTEGER(KIND=JPIM) :: IGRIBTC ! GRIB code of Total Column +INTEGER(KIND=JPIM) :: IGRIBSFC ! GRIB code of Surface Flux +LOGICAL :: LDIFF ! Diffusion on +LOGICAL :: LCONV ! Convection on +REAL(KIND=JPRB) :: RMOLMASS ! Molar Mass +REAL(KIND=JPRB) :: REFOLD ! Efolding decay time +REAL(KIND=JPRB) :: HENRYA ! Henry constant a +REAL(KIND=JPRB) :: HENRYB ! Henry constant b +LOGICAL :: LNEGFIX ! Cut off negative values in sugridug an +LOGICAL :: LMASSFIX ! Correct mass error of sl advection in gpmodel (if LTRCMFIX) +TYPE(TYPE_GFL_COMP),POINTER :: PREVIOUS ! Pointer to previously def. field + +END TYPE TYPE_GFL_COMP + +TYPE TYPE_GFL_NAML ! Individual field descriptor for namelist input + +SEQUENCE ! daand: necessary to avoid memory corruption with gfortran 4.3.3 + +CHARACTER(LEN=16) :: CNAME ! ARPEGE field name +INTEGER(KIND=JPIM) :: IGRBCODE ! GRIB code +INTEGER(KIND=JPIM) :: NREQIN ! 1 if field required in input, 0 if not, -1 if initialised + ! with a reference value REFVALI +REAL(KIND=JPRB) :: REFVALI ! Reference value for initialisation, used in case NREQIN==-1 +LOGICAL :: LREQOUT ! T if field requiered in output +LOGICAL :: LGPINGP ! GP field input as GP +LOGICAL :: LGP ! Field exists and of grid-point type +LOGICAL :: LSP ! Field exists and of spectral type +LOGICAL :: LCDERS ! Derivatives required (spectral only) +LOGICAL :: LT9 ! Field in t-dt GFL +LOGICAL :: LT1 ! Field in t+dt GFL +LOGICAL :: LT5 ! Field in trajectory GFL +LOGICAL :: LPHY ! Field with physics tendencies GFL +LOGICAL :: LPT ! Field in PC physics tendency GFLPT +LOGICAL :: LTRAJIO ! Field written to and from trajectory structure +LOGICAL :: LDIAG ! Field is "diagnostic" at t; e.g. cloud fraction +LOGICAL :: LPC ! Field in predictor/corrector time stepping GFLPC +LOGICAL :: LADV ! Field advected or not +LOGICAL :: LADV5 ! Field advected without wind increments +LOGICAL :: LINTLIN ! Linear interpolation for field +LOGICAL :: LTDIABLIN ! Diabatic tendency is interpolated by linear int. +LOGICAL :: LHORTURB ! Horizontal part affected by 3D turbulence +LOGICAL :: LQM ! quasi-monotonous interpolation for field +LOGICAL :: LQMH ! quasi-monotonous interpolation in horizontal for field +LOGICAL :: LQM3D ! quasi-monotone interpolation applied directly in 3 dimensions +LOGICAL :: LSLHD ! Semi-lagrangian horizontal diffusion used for field +LOGICAL :: LCOMAD ! COMAD weights used for SL interpolation of field +LOGICAL :: LHV ! Hermite vertical interpolation used for field (only ozone sofar) +LOGICAL :: LVSPLIP ! vertical spline interpolation used for field (only ozone sofar) +INTEGER(KIND=JPIM) :: NCOUPLING ! 1 if field is coupled by Davies relaxation, 0 if not, + ! -1 if coupled with reference value for coupling REFVALC +REAL(KIND=JPRB) :: REFVALC ! Reference value for coupling, used in case + ! NCOUPLING==-1 +! gems nl ext +INTEGER(KIND=JPIM) :: NCOUPLO4 ! Coupled to CTM by OASIS4 intefrace =1 input,=2 in&output,=-1 none +LOGICAL :: LASSIM ! use as Control Variable (either monitored or assimilated) +INTEGER(KIND=JPIM) :: IGRIBDV ! GRIB code of deposition velocity +INTEGER(KIND=JPIM) :: IGRIBTC ! GRIB code of Total Column +INTEGER(KIND=JPIM) :: IGRIBSFC ! GRIB code of Surface Flux +LOGICAL :: LDIFF ! Diffusion on +LOGICAL :: LCONV ! Convection on +LOGICAL :: LNEGFIX ! Cut off negative values in sugridug and callpar +LOGICAL :: LMASSFIX ! Correct mass error of sl advection in gpmodel (if LTRCMFIX) +REAL(KIND=JPRB) :: RMOLMASS ! Molar Mass +REAL(KIND=JPRB) :: REFOLD ! Efolding decay time +REAL(KIND=JPRB) :: HENRYA ! Henry constant a +REAL(KIND=JPRB) :: HENRYB ! Henry constant b + +END TYPE TYPE_GFL_NAML + +!------------------------------------------------------------------------- +! Derived types for describing the GFL structure. +!------------------------------------------------------------------------- +! Modifications: +! 03/07/09 C. Fischer - add Arome/Aladin attributes +! 03/10/01 C. Moussy - add Arome/Aladin attributes coupling +! 03/10/31 M. Tudor - add physics tendencies for predictor-corrector +! 05/10/10 J. Haseler - switch for I/O to trajectory structure +! 2004-Nov F. Vana - update of CSLINT attribute +! 20-Feb-2005 Vivoda - 3TL Eul PC scheme (GFLPC) +! 07/06/27 E. Holm - TL/AD advection without wind increments LADV5 +! 12/04/08 J. Flemming - GFL attribute extention for GEMS +! 22-Feb-11 F. Vana - LTDIABLIN and LHORTURB +! spring 2011 ECMWF - LINTLIN +! Nov. 2013 - LCOMAD +! 2013-11, D. Degrauwe - INTFLEX attributes + +TYPE TYPE_GFLD + +SEQUENCE ! daand: necessary to avoid memory corruption with gfortran 4.3.3 + +! Overall descriptor,dimensioning etc. +INTEGER(KIND=JPIM) :: NUMFLDS = 0 ! Number of GFL fields +INTEGER(KIND=JPIM) :: NDERS = 0 ! Number of horizontal derivatives fields +INTEGER(KIND=JPIM) :: NUMSPFLDS = 0 ! Number of spectrally represented GFL fields +INTEGER(KIND=JPIM) :: NUMGPFLDS = 0 ! Number of grid-point GFL fields +INTEGER(KIND=JPIM) :: NUMFLDS9 = 0 ! Number of GFL fields in (t-dt) part +INTEGER(KIND=JPIM) :: NUMFLDS1 = 0 ! Number of GFL fields in (t+dt) array +INTEGER(KIND=JPIM) :: NUMSPFLDS1 = 0 ! Number of spectrally represented GFL fields (t+dt) +INTEGER(KIND=JPIM) :: NUMFLDS5 = 0 ! Number of GFL fields (trajectory) +INTEGER(KIND=JPIM) :: NUMFLDSPHY = 0 ! Number of GFL fields (phys.) +INTEGER(KIND=JPIM) :: NUMFLDS_SPL = 0 ! Number of GFL fields (S.L. spline interpolation) +INTEGER(KIND=JPIM) :: NUMFLDS_SL1 = 0 ! Number of GFL fields in S.L. buffer 1 +INTEGER(KIND=JPIM) :: NUMFLDSPC = 0 ! Number of GFL fields (predictor/corrector) +INTEGER(KIND=JPIM) :: NDIM = 0 ! Dimension of main array holding GFL fields(GFL) +INTEGER(KIND=JPIM) :: NUMFLDSPT = 0 ! Number of GFL fields (phy. tend.) +INTEGER(KIND=JPIM) :: NDIM0 = 0 ! Dimension of t0 part of GFL +INTEGER(KIND=JPIM) :: NDIM9 = 0 ! Dimension of t-dt part of GFL +INTEGER(KIND=JPIM) :: NDIM1 = 0 ! Dimension of t+dt array (GFLT1) +INTEGER(KIND=JPIM) :: NDIM5 = 0 ! Dimension of traj. GFL array (GFL5) +INTEGER(KIND=JPIM) :: NDIMSLP = 0 ! Diminsion of S.L. phys. GFL array (GFLSLP) +INTEGER(KIND=JPIM) :: NDIM_SPL = 0 ! Dim. of arrays holding GFL fields (S.L.spline int.) +INTEGER(KIND=JPIM) :: NDIMPT = 0 ! Dimension of phy. tend. GFL array (GFLPT) +INTEGER(KIND=JPIM) :: NDIMPC = 0 ! Dimension of iterative scheme auxiliary array (GFLPC) + +INTEGER(KIND=JPIM) :: NGFL_EXT +INTEGER(KIND=JPIM) :: NGFL_FORC +INTEGER(KIND=JPIM) :: NGFL_EZDIAG +INTEGER(KIND=JPIM) :: NGHG +INTEGER(KIND=JPIM) :: NTRAC +INTEGER(KIND=JPIM) :: NGRG +INTEGER(KIND=JPIM) :: NGRG_CPLO4 +INTEGER(KIND=JPIM) :: NGRG_ASSIM +INTEGER(KIND=JPIM) :: NAERO +INTEGER(KIND=JPIM) :: NACTAERO +INTEGER(KIND=JPIM) :: NDDHAERO +INTEGER(KIND=JPIM) :: NERA40 +INTEGER(KIND=JPIM) :: NNOGW +INTEGER(KIND=JPIM) :: NAEROUT +INTEGER(KIND=JPIM) :: NUVP +INTEGER(KIND=JPIM) :: NSLDIA +INTEGER(KIND=JPIM) :: NSLDIAGP +INTEGER(KIND=JPIM) :: NGFL_PHYS +LOGICAL :: LCO2SFC +LOGICAL :: LCH4SFC +LOGICAL :: LAEROSFC +LOGICAL :: LFIRE +LOGICAL :: LAERODIU +LOGICAL :: LTRCMFIX ! Activates tracer mass fixer +LOGICAL :: LTRCMFIX_PS ! Adjust pressure to conserve dry mass in mass fixer calculations +LOGICAL :: LAEROUT +LOGICAL :: LUVPOUT +LOGICAL :: LCHEM + +INTEGER(KIND=JPIM) :: NGEMS ! The total number of "GEMS" fields. +INTEGER(KIND=JPIM) :: NCHEM +INTEGER(KIND=JPIM) :: NCHEM_ASSIM +INTEGER(KIND=JPIM) :: NCHEM_FLX +INTEGER(KIND=JPIM) :: NCHEM_DV +INTEGER(KIND=JPIM) :: NCHEM_TC +INTEGER(KIND=JPIM) :: NCHEM_SCV + +! ------------------------------------------------------------------ +! Mass fixers +! ------------------------------------------------------------------ +INTEGER(KIND=JPIM) :: NNEGAFIX ! Num of fields to apply -ve fixer +INTEGER(KIND=JPIM) :: NOPTNEGFIX ! 1: simple negative fixer (reset to 0) + ! 2: reset to local minimum + +LOGICAL :: LQM3DCONS ! Bermejo & Staniforth quasi-monotone limiter with improved + ! conservation option. When true, applied to all GFL s.t. LQM3D=true +LOGICAL :: LADVNEGFIX ! Activates negative fixer for advection +LOGICAL :: LTRCMFBC ! Activate Bermejo & Conde if true +LOGICAL :: LTRCMFPR ! Activate Priestley algorithm if true +LOGICAL :: LTRCMFMG ! Activate Mac Gregor's algorithm if true +LOGICAL :: LEXTRADF ! Extra diagnostics + + +INTEGER(KIND=JPIM) :: NFLDSFIX ! Number of fields to be fixed +INTEGER(KIND=JPIM) :: NOPTMFIX ! Bermejo & Conde fixer option for calculating its weight +INTEGER(KIND=JPIM) :: NOPTVFE ! Use Vertical FE in calculation of column mass total +INTEGER(KIND=JPIM) :: NPMFIX ! Parameter used in weight calculation +INTEGER(KIND=JPIM) :: NMFDIAGLEV ! Determines global diagnostic output level for fixer: + ! 0 - nothing, 1 - norms printed, 2 - norms + monotonicity +INTEGER(KIND=JPIM) :: NMFIXFLDS(JPNAMED_GFL+JPGHG+JPGRG+JPCHEM+JPAERO+JPTRAC) + ! Index of fields to be corrected by mass fixers +INTEGER(KIND=JPIM) :: NNEGFLDS(JPNAMED_GFL+JPGHG+JPGRG+JPCHEM+JPAERO+JPTRAC) + ! Index of fields to be corrected by SL -ve fixer +REAL(KIND=JPRB) :: ZMFIXEPS ! Threshold for mass fixing scheme + +TYPE(TYPE_GFL_COMP) :: YCOMP(JPGFL) ! General descriptor of all components + +TYPE(TYPE_GFL_COMP),POINTER :: YQ => NULL() ! Specific humidity +TYPE(TYPE_GFL_COMP),POINTER :: YI => NULL() ! Ice water +TYPE(TYPE_GFL_COMP),POINTER :: YL => NULL() ! Liquid water +TYPE(TYPE_GFL_COMP),POINTER :: YLCONV => NULL() ! Liquid water (CONV. PART) +TYPE(TYPE_GFL_COMP),POINTER :: YICONV => NULL() ! Ice water (CONV. PART) +TYPE(TYPE_GFL_COMP),POINTER :: YRCONV => NULL() ! Rain (CONV. PART) +TYPE(TYPE_GFL_COMP),POINTER :: YSCONV => NULL() ! Snow (CONV. PART) +TYPE(TYPE_GFL_COMP),POINTER :: YIRAD => NULL() ! Radiative cloud Ice water +TYPE(TYPE_GFL_COMP),POINTER :: YLRAD => NULL() ! Radiative cloud Liquid water +TYPE(TYPE_GFL_COMP),POINTER :: YS => NULL() ! Snow +TYPE(TYPE_GFL_COMP),POINTER :: YR => NULL() ! Rain +TYPE(TYPE_GFL_COMP),POINTER :: YG => NULL() ! Graupel +TYPE(TYPE_GFL_COMP),POINTER :: YH => NULL() ! Hail +TYPE(TYPE_GFL_COMP),POINTER :: YTKE => NULL() ! Turbulent Kinetic Energy +TYPE(TYPE_GFL_COMP),POINTER :: YTTE => NULL() ! Turbulent Total Energy +TYPE(TYPE_GFL_COMP),POINTER :: YEFB1 => NULL() ! First variable EFB scheme +TYPE(TYPE_GFL_COMP),POINTER :: YEFB2 => NULL() ! Second variable EFB scheme +TYPE(TYPE_GFL_COMP),POINTER :: YEFB3 => NULL() ! Third variable EFB scheme +TYPE(TYPE_GFL_COMP),POINTER :: YA => NULL() ! Cloud fraction +TYPE(TYPE_GFL_COMP),POINTER :: YO3 => NULL() ! Ozone +TYPE(TYPE_GFL_COMP),POINTER :: YSRC => NULL() ! Second-order flux for AROME s'rc'/2Sigma_s2 multiplied by Lambda_3 +TYPE(TYPE_GFL_COMP),POINTER :: YMXL => NULL() ! Prognostic mixing length +TYPE(TYPE_GFL_COMP),POINTER :: YSCC2 => NULL() ! Saturation deficit^2 for Tompkins +TYPE(TYPE_GFL_COMP),POINTER :: YGCCA => NULL() ! Skewness for Tompkins +TYPE(TYPE_GFL_COMP),POINTER :: YCPF => NULL() ! Convective precipitation flux +TYPE(TYPE_GFL_COMP),POINTER :: YSPF => NULL() ! Stratiform precipitation flux +TYPE(TYPE_GFL_COMP),POINTER :: YCVGQ => NULL() ! Moisture Convergence for french physics +TYPE(TYPE_GFL_COMP),POINTER :: YQVA => NULL() ! total humidity variation +TYPE(TYPE_GFL_COMP),POINTER :: YGHG(:) => NULL() ! Greenhouse Gases +TYPE(TYPE_GFL_COMP),POINTER :: YGRG(:) => NULL() ! Reactive Gases +TYPE(TYPE_GFL_COMP),POINTER :: YCHEM(:) => NULL() ! Chemistry +TYPE(TYPE_GFL_COMP),POINTER :: YGRGTEND(:) => NULL() ! Reactive Gases Tendecies +TYPE(TYPE_GFL_COMP),POINTER :: YAERO(:) => NULL() ! Aerosols +TYPE(TYPE_GFL_COMP),POINTER :: YTRAC(:) => NULL() ! tracers for diagnostics +TYPE(TYPE_GFL_COMP),POINTER :: YLRCH4 => NULL() ! CH4 loss rate (instantaneous field) +TYPE(TYPE_GFL_COMP),POINTER :: YCH4S => NULL() ! CH4 atmospheric sink (accumulated field) +TYPE(TYPE_GFL_COMP),POINTER :: YFORC(:) => NULL() ! large scale forcing +TYPE(TYPE_GFL_COMP),POINTER :: YEZDIAG(:) => NULL() ! easy diagnostics +TYPE(TYPE_GFL_COMP),POINTER :: YERA40(:) => NULL() ! ERA40 diagnostic fields +TYPE(TYPE_GFL_COMP),POINTER :: YNOGW(:) => NULL() ! NORO GWD SCHEME +TYPE(TYPE_GFL_COMP),POINTER :: YSLDIA(:) => NULL() ! SL dynamics diagnostics +TYPE(TYPE_GFL_COMP),POINTER :: YAEROUT(:) => NULL() ! Aerosol outputs +TYPE(TYPE_GFL_COMP),POINTER :: YUVP(:) => NULL() ! UV-processor output +TYPE(TYPE_GFL_COMP),POINTER :: YPHYS(:) => NULL() ! PHYS output + + +TYPE(TYPE_GFL_COMP),POINTER :: YSDSAT => NULL() ! Standard Deviation of the + ! SATuration Depression (Sigma_s) +TYPE(TYPE_GFL_COMP),POINTER :: YCVV => NULL() ! Convective Vertical Velocity +TYPE(TYPE_GFL_COMP),POINTER :: YRKTH => NULL() ! Rasch-Kristjansson H tendency +TYPE(TYPE_GFL_COMP),POINTER :: YRKTQV => NULL() ! Rasch-Kristjansson Qv tendency +TYPE(TYPE_GFL_COMP),POINTER :: YRKTQC => NULL() ! Rasch-Kristjansson Qc tendency + +! Prognostic convection variables: add 6 named components +TYPE(TYPE_GFL_COMP),POINTER :: YUOM => NULL() ! Updraught vert velocity +TYPE(TYPE_GFL_COMP),POINTER :: YUAL => NULL() ! Updraught mesh fraction +TYPE(TYPE_GFL_COMP),POINTER :: YDOM => NULL() ! Downdraught vert velocity +TYPE(TYPE_GFL_COMP),POINTER :: YDAL => NULL() ! Downdraught mesh fraction +TYPE(TYPE_GFL_COMP),POINTER :: YUEN => NULL() ! Updraught entrainment +TYPE(TYPE_GFL_COMP),POINTER :: YUNEBH => NULL() ! pseudo-historic convective + +! Extra fields + +TYPE(TYPE_GFL_COMP),POINTER :: YEXT(:) => NULL() ! Extra fields + +TYPE(TYPE_GFL_NAML) :: YQ_NL ! Specific humidity +TYPE(TYPE_GFL_NAML) :: YI_NL ! Ice water +TYPE(TYPE_GFL_NAML) :: YL_NL ! Liquid water +TYPE(TYPE_GFL_NAML) :: YLCONV_NL ! Liquid water (CONV. PART) +TYPE(TYPE_GFL_NAML) :: YICONV_NL ! Ice water (CONV. PART) +TYPE(TYPE_GFL_NAML) :: YRCONV_NL ! Rain (CONV. PART) +TYPE(TYPE_GFL_NAML) :: YSCONV_NL ! Snow (CONV. PART) +TYPE(TYPE_GFL_NAML) :: YIRAD_NL ! Radiative cloud Ice water +TYPE(TYPE_GFL_NAML) :: YLRAD_NL ! Radiative cloud Liquid water +TYPE(TYPE_GFL_NAML) :: YS_NL ! Snow +TYPE(TYPE_GFL_NAML) :: YR_NL ! Rain +TYPE(TYPE_GFL_NAML) :: YG_NL ! Graupels +TYPE(TYPE_GFL_NAML) :: YH_NL ! Hail +TYPE(TYPE_GFL_NAML) :: YTKE_NL ! Turbulent Kinetic Energy +TYPE(TYPE_GFL_NAML) :: YTTE_NL ! Turbulent Total Energy +TYPE(TYPE_GFL_NAML) :: YEFB1_NL ! First variable EFB scheme +TYPE(TYPE_GFL_NAML) :: YEFB2_NL ! Second variable EFB scheme +TYPE(TYPE_GFL_NAML) :: YEFB3_NL ! Third variable EFB scheme +TYPE(TYPE_GFL_NAML) :: YA_NL ! Cloud fraction +TYPE(TYPE_GFL_NAML) :: YO3_NL ! Ozone +TYPE(TYPE_GFL_NAML) :: YSRC_NL ! Second-order flux for AROME + ! s'rc'/2Sigma_s2 + ! multiplied by Lambda_3 +TYPE(TYPE_GFL_NAML) :: YMXL_NL ! Prognostic mixing length +TYPE(TYPE_GFL_NAML) :: YSCC2_NL ! Saturation deficit^2 for Tompkins +TYPE(TYPE_GFL_NAML) :: YGCCA_NL ! Skewness for Tompkins +TYPE(TYPE_GFL_NAML) :: YCPF_NL ! Convective precipitation flux +TYPE(TYPE_GFL_NAML) :: YSPF_NL ! Stratiform precipitation flux +TYPE(TYPE_GFL_NAML) :: YCVGQ_NL ! Moisture Convergence for french physics +TYPE(TYPE_GFL_NAML) :: YQVA_NL ! Total humidity variation + +TYPE(TYPE_GFL_NAML) :: YGHG_NL(JPGHG) ! Greenhouse Gases +TYPE(TYPE_GFL_NAML) :: YGRG_NL(JPGRG) ! Reactive Gases +TYPE(TYPE_GFL_NAML) :: YCHEM_NL(JPCHEM) ! Chemical species +TYPE(TYPE_GFL_NAML) :: YGRGTEND_NL(JPGRG) ! Reactive Gases Tendecies +TYPE(TYPE_GFL_NAML) :: YAERO_NL(JPAERO) ! Aerosol fields +TYPE(TYPE_GFL_NAML) :: YTRAC_NL(JPTRAC) ! Tracers for diagnostics +TYPE(TYPE_GFL_NAML) :: YERA40_NL(JPERA40) ! ERA40 diagnostic fields +TYPE(TYPE_GFL_NAML) :: YNOGW_NL(JPNOGW) ! NORO GWD SCHEME +TYPE(TYPE_GFL_NAML) :: YSLDIA_NL(JPSLDIA) ! SL dynamics diagnostics +TYPE(TYPE_GFL_NAML) :: YLRCH4_NL ! CH4 loss rate +TYPE(TYPE_GFL_NAML) :: YCH4S_NL ! CH4 atmospheric sink +TYPE(TYPE_GFL_NAML) :: YAEROUT_NL(JPAEROUT) ! Aerosol outputs +TYPE(TYPE_GFL_NAML) :: YUVP_NL(JPUVP) ! UV-processor outputs +TYPE(TYPE_GFL_NAML) :: YRKTH_NL ! Rasch-Kristjansson H tendency +TYPE(TYPE_GFL_NAML) :: YRKTQV_NL ! Rasch-Kristjansson Qv tendency +TYPE(TYPE_GFL_NAML) :: YRKTQC_NL ! Rasch-Kristjansson Qc tendency +TYPE(TYPE_GFL_NAML) :: YPHYS_NL(JPPHYS) ! PHYS outputs + +! Extra fields +TYPE(TYPE_GFL_NAML) :: YSDSAT_NL ! Standard Deviation of the + ! SATuration Depression (Sigma_s) +TYPE(TYPE_GFL_NAML) :: YCVV_NL ! Convective Vertical Velocity +TYPE(TYPE_GFL_NAML) :: YFORC_NL(JPFORC) ! Forcing precursor +TYPE(TYPE_GFL_NAML) :: YEZDIAG_NL(JPEZDIAG) ! Easy diagnostics +TYPE(TYPE_GFL_NAML) :: YEXT_NL(JPGFL-JPNAMED_GFL-JPGHG-JPGRG-JPFORC-JPEZDIAG-JPAERO-JPTRAC-JPERA40-& + & JPNOGW-JPSLDIA-JPCH4S-JPAEROUT-JPUVP-JPCHEM-JPPHYS) ! Extra fields + +! Prognostic convection variables: 6 more namelist components +TYPE(TYPE_GFL_NAML) :: YUOM_NL ! Updraught vert velocity +TYPE(TYPE_GFL_NAML) :: YUAL_NL ! Updraught mesh fraction +TYPE(TYPE_GFL_NAML) :: YDOM_NL ! Downdraught vert velocity +TYPE(TYPE_GFL_NAML) :: YDAL_NL ! Downdraught mesh fraction +TYPE(TYPE_GFL_NAML) :: YUEN_NL ! Updraught entrainment +TYPE(TYPE_GFL_NAML) :: YUNEBH_NL ! Pseudi Hist Conv cloud fraction + +END TYPE TYPE_GFLD + +! GFL general descriptor +TYPE(TYPE_GFLD), POINTER :: YGFL => NULL() + +END MODULE YOM_YGFL Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yomdimv.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yomdimv.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/ifsrrtm/yomdimv.F90 (revision 6016) @@ -0,0 +1,43 @@ +MODULE YOMDIMV + +USE PARKIND1 ,ONLY : JPIM + +IMPLICIT NONE + +SAVE + +! ------------------------------------------------------------------ + +TYPE :: TDIMV + +!* Dimensions of model working arrays + +! === VERTICAL RESOLUTION ===================================================== + +! NFLEVG : number of levels in grid point space +! NFLEVL : number of levels in Fourier and Legendre space +! NFLEVLMX : maximum NFLEVL among all PEs +! NFLSUR : over dimensioning of NFLEVL for technical reasons, always odd +! NFLSUL : number of additional levels for semi-lagrangian +! NFLSA = 1 -NFLSUL +! NFLEN = NFLEVG+NFLSUL +! NIOLEVG : number of levels in the whole atmosphere (used for I/Os and definitions) ; +! NFLEVG can be a truncation of NIOLEVG + +INTEGER(KIND=JPIM) :: NFLEVG +INTEGER(KIND=JPIM) :: NFLEVL +INTEGER(KIND=JPIM) :: NFLEVLMX +INTEGER(KIND=JPIM) :: NFLSUR +INTEGER(KIND=JPIM) :: NFLSUL +INTEGER(KIND=JPIM) :: NFLSA +INTEGER(KIND=JPIM) :: NFLEN +INTEGER(KIND=JPIM) :: NFLEVSF +INTEGER(KIND=JPIM) :: NIOLEVG + +END TYPE TDIMV + +TYPE(TDIMV), POINTER :: YRDIMV => NULL() + +! ------------------------------------------------------------------ + +END MODULE YOMDIMV Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/abor1.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/abor1.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/abor1.intfb.h (revision 6016) @@ -0,0 +1,5 @@ +INTERFACE +SUBROUTINE ABOR1(CDTEXT) +CHARACTER(LEN=*), INTENT(IN) :: CDTEXT +END SUBROUTINE ABOR1 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/cloud_overlap_decorr_len.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/cloud_overlap_decorr_len.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/cloud_overlap_decorr_len.intfb.h (revision 6016) @@ -0,0 +1,15 @@ +interface +SUBROUTINE CLOUD_OVERLAP_DECORR_LEN & + & (KIDIA, KFDIA, KLON, PGEMU, KDECOLAT, & + & PDECORR_LEN_EDGES_KM, PDECORR_LEN_WATER_KM, PDECORR_LEN_RATIO) +USE PARKIND1 , ONLY : JPIM, JPRB +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLON +INTEGER(KIND=JPIM),INTENT(IN) :: KDECOLAT +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PDECORR_LEN_EDGES_KM(KLON) +REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_WATER_KM(KLON) +REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_RATIO +END SUBROUTINE CLOUD_OVERLAP_DECORR_LEN +end interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/cos_sza.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/cos_sza.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/cos_sza.intfb.h (revision 6016) @@ -0,0 +1,12 @@ +interface +SUBROUTINE COS_SZA(KSTART,KEND,KCOL,PGEMU,PGELAM,LDRADIATIONTIMESTEP,PMU0) +USE PARKIND1 , ONLY : JPIM, JPRB +INTEGER(KIND=JPIM),INTENT(IN) :: KSTART +INTEGER(KIND=JPIM),INTENT(IN) :: KEND +INTEGER(KIND=JPIM),INTENT(IN) :: KCOL +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KCOL) +REAL(KIND=JPRB), INTENT(IN) :: PGELAM(KCOL) +LOGICAL, INTENT(IN) :: LDRADIATIONTIMESTEP +REAL(KIND=JPRB), INTENT(OUT) :: PMU0(KCOL) +END SUBROUTINE COS_SZA +end interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/ice_effective_radius.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/ice_effective_radius.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/ice_effective_radius.intfb.h (revision 6016) @@ -0,0 +1,21 @@ +interface +SUBROUTINE ICE_EFFECTIVE_RADIUS & + & (YDERAD,KIDIA, KFDIA, KLON, KLEV, & + & PPRESSURE, PTEMPERATURE, PCLOUD_FRAC, PQ_ICE, PQ_SNOW, PGEMU, & + & PRE_UM) +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOERAD , ONLY : TERAD +TYPE(TERAD) ,INTENT(IN):: YDERAD +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLON +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_ICE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_SNOW(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PRE_UM(KLON,KLEV) +END SUBROUTINE ICE_EFFECTIVE_RADIUS +end interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/liquid_effective_radius.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/liquid_effective_radius.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/liquid_effective_radius.intfb.h (revision 6016) @@ -0,0 +1,24 @@ +interface +SUBROUTINE LIQUID_EFFECTIVE_RADIUS & + & (YDERAD,KIDIA, KFDIA, KLON, KLEV, & + & PPRESSURE, PTEMPERATURE, PCLOUD_FRAC, PQ_LIQ, PQ_RAIN, & + & PLAND_FRAC, PCCN_LAND, PCCN_SEA, & + & PRE_UM) +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOERAD , ONLY : TERAD +TYPE(TERAD) ,INTENT(IN):: YDERAD +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLON +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_LIQ(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_RAIN(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PLAND_FRAC(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PCCN_LAND(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PCCN_SEA(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PRE_UM(KLON,KLEV) +END SUBROUTINE LIQUID_EFFECTIVE_RADIUS +end interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/modify_wv_continuum.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/modify_wv_continuum.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/modify_wv_continuum.intfb.h (revision 6016) @@ -0,0 +1,7 @@ +interface +SUBROUTINE MODIFY_WV_CONTINUUM(NWVCONTINUUM) +use parkind1 , only:& + & jpim +INTEGER(KIND=JPIM), INTENT(IN) :: NWVCONTINUUM +END SUBROUTINE MODIFY_WV_CONTINUUM +end interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/radiation_scheme.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/radiation_scheme.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/radiation_scheme.intfb.h (revision 6016) @@ -0,0 +1,83 @@ +interface +SUBROUTINE RADIATION_SCHEME & + & (YRADIATION,KIDIA, KFDIA, KLON, KLEV, KAEROSOL, & + & PSOLAR_IRRADIANCE, & + & PMU0, PTEMPERATURE_SKIN, PALBEDO_DIF, PALBEDO_DIR, & + & PSPECTRALEMISS, & + & PCCN_LAND, PCCN_SEA, & + & PGELAM, PGEMU, PLAND_SEA_MASK, & + & PPRESSURE, PTEMPERATURE, & + & PPRESSURE_H, PTEMPERATURE_H, & + & PQ, PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, PCCL4, PO3, & + & PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_RAIN, PQ_SNOW, & + & PAEROSOL_OLD, PAEROSOL, & + & PFLUX_SW, PFLUX_LW, PFLUX_SW_CLEAR, PFLUX_LW_CLEAR, & + & PFLUX_SW_DN, PFLUX_LW_DN, PFLUX_SW_DN_CLEAR, PFLUX_LW_DN_CLEAR, & + & PFLUX_DIR, PFLUX_DIR_CLEAR, PFLUX_DIR_INTO_SUN, & + & PFLUX_UV, PFLUX_PAR, PFLUX_PAR_CLEAR, & + & PFLUX_SW_DN_TOA, PEMIS_OUT, PLWDERIVATIVE, & + & PSWDIFFUSEBAND, PSWDIRECTBAND) +use parkind1 , only:& + & jpim,& + & jprb +use radiation_setup, only:& + & tradiation +TYPE(TRADIATION), INTENT(IN) :: YRADIATION +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLON +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL +REAL(KIND=JPRB), INTENT(IN) :: PSOLAR_IRRADIANCE +REAL(KIND=JPRB), INTENT(IN) :: PMU0(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE_SKIN(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIF(KLON,YRADIATION%YRERAD%NSW) +REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIR(KLON,YRADIATION%YRERAD%NSW) +REAL(KIND=JPRB), INTENT(IN) :: PSPECTRALEMISS(KLON,YRADIATION%YRERAD%NLWEMISS) +REAL(KIND=JPRB), INTENT(IN) :: PGELAM(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PLAND_SEA_MASK(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE_H(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(IN) :: PQ(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCO2(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCH4(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PN2O(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PNO2(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCFC11(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCFC12(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PHCFC22(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCCL4(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PO3(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_LIQUID(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_ICE(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_RAIN(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_SNOW(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL_OLD(KLON,6,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL) +REAL(KIND=JPRB), INTENT(IN) :: PCCN_LAND(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PCCN_SEA(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_DN(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN_CLEAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_DN_CLEAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_UV(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_PAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_PAR_CLEAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN_TOA(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PEMIS_OUT(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PLWDERIVATIVE(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PSWDIFFUSEBAND(KLON,YRADIATION%YRERAD%NSW) +REAL(KIND=JPRB), INTENT(OUT) :: PSWDIRECTBAND (KLON,YRADIATION%YRERAD%NSW) +END SUBROUTINE RADIATION_SCHEME +end interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb1.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb1.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb1.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB1 +END SUBROUTINE RRTM_CMBGB1 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb10.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb10.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb10.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB10 +END SUBROUTINE RRTM_CMBGB10 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb11.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb11.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb11.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB11 +END SUBROUTINE RRTM_CMBGB11 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb12.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb12.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb12.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB12 +END SUBROUTINE RRTM_CMBGB12 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb13.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb13.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb13.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB13 +END SUBROUTINE RRTM_CMBGB13 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb14.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb14.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb14.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB14 +END SUBROUTINE RRTM_CMBGB14 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb15.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb15.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb15.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB15 +END SUBROUTINE RRTM_CMBGB15 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb16.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb16.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb16.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB16 +END SUBROUTINE RRTM_CMBGB16 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb2.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb2.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb2.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB2 +END SUBROUTINE RRTM_CMBGB2 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb3.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb3.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb3.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB3 +END SUBROUTINE RRTM_CMBGB3 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb4.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb4.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb4.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB4 +END SUBROUTINE RRTM_CMBGB4 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb5.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb5.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb5.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB5 +END SUBROUTINE RRTM_CMBGB5 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb6.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb6.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb6.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB6 +END SUBROUTINE RRTM_CMBGB6 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb7.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb7.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb7.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB7 +END SUBROUTINE RRTM_CMBGB7 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb8.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb8.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb8.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB8 +END SUBROUTINE RRTM_CMBGB8 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb9.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb9.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_cmbgb9.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_CMBGB9 +END SUBROUTINE RRTM_CMBGB9 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_gas_optical_depth.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_gas_optical_depth.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_gas_optical_depth.intfb.h (revision 6016) @@ -0,0 +1,59 @@ +INTERFACE +SUBROUTINE RRTM_GAS_OPTICAL_DEPTH(KIDIA,KFDIA,KLEV,POD,PAVEL, PCOLDRY,PCOLBRD,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLO3,PCOLN2O,PCOLCH4,PCOLO2,P_CO2MULT,& + & KLAYTROP,KLAYSWTCH,KLAYLOW,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC,& + & KINDMINOR,PSCALEMINOR,PSCALEMINORN2,PMINORFRAC,& + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_H2OO3, PRAT_H2OO3_1,& + & PRAT_H2ON2O, PRAT_H2ON2O_1, PRAT_H2OCH4, PRAT_H2OCH4_1,& + & PRAT_N2OCO2, PRAT_N2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(OUT) :: POD(JPGPT,KLEV,KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PWX(KIDIA:KFDIA,JPXSEC,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_CO2MULT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYLOW(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINORN2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLBRD(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) , INTENT(IN) ::& + & PRAT_H2OCO2(KIDIA:KFDIA,KLEV),PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2OO3(KIDIA:KFDIA,KLEV),PRAT_H2OO3_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2ON2O(KIDIA:KFDIA,KLEV),PRAT_H2ON2O_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2OCH4(KIDIA:KFDIA,KLEV),PRAT_H2OCH4_1(KIDIA:KFDIA,KLEV),& + & PRAT_N2OCO2(KIDIA:KFDIA,KLEV),PRAT_N2OCO2_1(KIDIA:KFDIA,KLEV),& + & PRAT_O3CO2(KIDIA:KFDIA,KLEV),PRAT_O3CO2_1(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_GAS_OPTICAL_DEPTH +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_gasabs1a_140gp.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_gasabs1a_140gp.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_gasabs1a_140gp.intfb.h (revision 6016) @@ -0,0 +1,61 @@ +INTERFACE +SUBROUTINE RRTM_GASABS1A_140GP (KIDIA,KFDIA,KLEV,PATR1,POD,PTF1,PAVEL, PCOLDRY,PCOLBRD,PWX,& + & PTAUAERL,PFAC00,PFAC01,PFAC10,PFAC11,PFORFAC,PFORFRAC,KINDFOR,KJP,KJT,KJT1,PONEMINUS,& + & PCOLH2O,PCOLCO2,PCOLO3,PCOLN2O,PCOLCH4,PCOLO2,P_CO2MULT,& + & KLAYTROP,KLAYSWTCH,KLAYLOW,PSELFFAC,PSELFFRAC,KINDSELF,PFRAC,& + & KINDMINOR,PSCALEMINOR,PSCALEMINORN2,PMINORFRAC,& + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_H2OO3, PRAT_H2OO3_1,& + & PRAT_H2ON2O, PRAT_H2ON2O_1, PRAT_H2OCH4, PRAT_H2OCH4_1,& + & PRAT_N2OCO2, PRAT_N2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(OUT) :: PATR1(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: POD(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTF1(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PWX(KIDIA:KFDIA,JPXSEC,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PTAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_CO2MULT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYLOW(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINORN2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLBRD(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) , INTENT(IN) ::& + & PRAT_H2OCO2(KIDIA:KFDIA,KLEV),PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2OO3(KIDIA:KFDIA,KLEV),PRAT_H2OO3_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2ON2O(KIDIA:KFDIA,KLEV),PRAT_H2ON2O_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2OCH4(KIDIA:KFDIA,KLEV),PRAT_H2OCH4_1(KIDIA:KFDIA,KLEV),& + & PRAT_N2OCO2(KIDIA:KFDIA,KLEV),PRAT_N2OCO2_1(KIDIA:KFDIA,KLEV),& + & PRAT_O3CO2(KIDIA:KFDIA,KLEV),PRAT_O3CO2_1(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_GASABS1A_140GP +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_init_140gp.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_init_140gp.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_init_140gp.intfb.h (revision 6016) @@ -0,0 +1,5 @@ +INTERFACE +SUBROUTINE RRTM_INIT_140GP(DIRECTORY) +CHARACTER(LEN=*), INTENT(IN) :: DIRECTORY +END SUBROUTINE RRTM_INIT_140GP +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb1.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb1.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb1.intfb.h (revision 6016) @@ -0,0 +1,5 @@ +INTERFACE +SUBROUTINE RRTM_KGB1(DIRECTORY) +CHARACTER(LEN=*), INTENT(IN) :: DIRECTORY +END SUBROUTINE RRTM_KGB1 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb10.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb10.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb10.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB10 +END SUBROUTINE RRTM_KGB10 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb11.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb11.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb11.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB11 +END SUBROUTINE RRTM_KGB11 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb12.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb12.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb12.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB12 +END SUBROUTINE RRTM_KGB12 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb13.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb13.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb13.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB13 +END SUBROUTINE RRTM_KGB13 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb14.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb14.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb14.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB14 +END SUBROUTINE RRTM_KGB14 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb15.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb15.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb15.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB15 +END SUBROUTINE RRTM_KGB15 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb16.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb16.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb16.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB16 +END SUBROUTINE RRTM_KGB16 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb2.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb2.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb2.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB2 +END SUBROUTINE RRTM_KGB2 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb3.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb3.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb3.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB3 +END SUBROUTINE RRTM_KGB3 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb4.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb4.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb4.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB4 +END SUBROUTINE RRTM_KGB4 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb5.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb5.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb5.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB5 +END SUBROUTINE RRTM_KGB5 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb6.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb6.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb6.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB6 +END SUBROUTINE RRTM_KGB6 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb7.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb7.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb7.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB7 +END SUBROUTINE RRTM_KGB7 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb8.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb8.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb8.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB8 +END SUBROUTINE RRTM_KGB8 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb9.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb9.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_kgb9.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE RRTM_KGB9 +END SUBROUTINE RRTM_KGB9 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_prepare_gases.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_prepare_gases.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_prepare_gases.intfb.h (revision 6016) @@ -0,0 +1,38 @@ +INTERFACE +SUBROUTINE RRTM_PREPARE_GASES& + & ( KIDIA, KFDIA, KLON, KLEV,& + & PAPH , PAP ,& + & PTH , PT ,& + & PQ , PCO2 , PCH4, PN2O , PNO2, PC11, PC12, PC22, PCL4, POZN,& + & PCOLDRY, PWBRODL, PWKL, PWX ,& + & PAVEL , PTAVEL , PZ , PTZ , KREFLECT) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARRRTM , ONLY : JPBAND, JPXSEC, JPINPX +INTEGER(KIND=JPIM),INTENT(IN) :: KLON +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +REAL(KIND=JPRB) ,INTENT(IN) :: PAPH(KLON,KLEV+1) +REAL(KIND=JPRB) ,INTENT(IN) :: PAP(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PTH(KLON,KLEV+1) +REAL(KIND=JPRB) ,INTENT(IN) :: PT(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PQ(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCO2(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCH4(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PN2O(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PNO2(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PC11(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PC12(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PC22(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCL4(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: POZN(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWBRODL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWKL(KIDIA:KFDIA,JPINPX,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PWX(KIDIA:KFDIA,JPXSEC,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PZ(KIDIA:KFDIA,0:KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTZ(KIDIA:KFDIA,0:KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: KREFLECT(KIDIA:KFDIA) +END SUBROUTINE RRTM_PREPARE_GASES +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_setcoef_140gp.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_setcoef_140gp.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_setcoef_140gp.intfb.h (revision 6016) @@ -0,0 +1,56 @@ +INTERFACE +SUBROUTINE RRTM_SETCOEF_140GP (KIDIA,KFDIA,KLEV,P_COLDRY,P_WBROAD,P_WKL,& + & P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLH2O,P_COLCO2,P_COLO3,P_COLN2O,P_COLCH4, P_COLO2,P_CO2MULT, P_COLBRD,& + & K_LAYTROP,K_LAYSWTCH,K_LAYLOW,PAVEL,P_TAVEL,P_SELFFAC,P_SELFFRAC,K_INDSELF,& + & K_INDMINOR,P_SCALEMINOR,P_SCALEMINORN2,P_MINORFRAC,& + & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_H2OO3, PRAT_H2OO3_1,& + & PRAT_H2ON2O, PRAT_H2ON2O_1, PRAT_H2OCH4, PRAT_H2OCH4_1,& + & PRAT_N2OCO2, PRAT_N2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARRRTM , ONLY : JPINPX +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_WBROAD(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLBRD(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_WKL(KIDIA:KFDIA,JPINPX,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_CO2MULT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYLOW(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDSELF(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDFOR(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_SCALEMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_SCALEMINORN2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_MINORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) ::& + & PRAT_H2OCO2(KIDIA:KFDIA,KLEV),PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2OO3(KIDIA:KFDIA,KLEV) ,PRAT_H2OO3_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2ON2O(KIDIA:KFDIA,KLEV),PRAT_H2ON2O_1(KIDIA:KFDIA,KLEV),& + & PRAT_H2OCH4(KIDIA:KFDIA,KLEV),PRAT_H2OCH4_1(KIDIA:KFDIA,KLEV),& + & PRAT_N2OCO2(KIDIA:KFDIA,KLEV),PRAT_N2OCO2_1(KIDIA:KFDIA,KLEV),& + & PRAT_O3CO2(KIDIA:KFDIA,KLEV) ,PRAT_O3CO2_1(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_SETCOEF_140GP +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol1.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol1.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol1.intfb.h (revision 6016) @@ -0,0 +1,37 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL1 (KIDIA,KFDIA,KLEV,P_TAU,PAVEL,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,P_MINORFRAC,K_INDMINOR,PSCALEMINORN2,PCOLBRD) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG1 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_MINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINORN2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLBRD(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL1 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol10.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol10.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol10.intfb.h (revision 6016) @@ -0,0 +1,32 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL10 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG10 ,NGS9 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL10 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol11.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol11.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol11.intfb.h (revision 6016) @@ -0,0 +1,36 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL11 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLH2O,P_COLO2,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,P_MINORFRAC,KINDMINOR,PSCALEMINOR) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG11 ,NGS10 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_MINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINOR(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL11 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol12.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol12.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol12.intfb.h (revision 6016) @@ -0,0 +1,37 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL12 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLCO2,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & PRAT_H2OCO2, PRAT_H2OCO2_1) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG12 ,NGS11 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_H2OCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL12 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol13.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol13.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol13.intfb.h (revision 6016) @@ -0,0 +1,42 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL13 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLN2O,P_COLCO2,P_COLO3,P_COLDRY,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & PRAT_H2ON2O, PRAT_H2ON2O_1,PMINORFRAC,KINDMINOR) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG13 ,NGS12 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_H2ON2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_H2ON2O_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL13 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol14.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol14.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol14.intfb.h (revision 6016) @@ -0,0 +1,32 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL14 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLCO2,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NGS13 ,NG14 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL14 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol15.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol15.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol15.intfb.h (revision 6016) @@ -0,0 +1,42 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL15 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLCO2,P_COLN2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & PRAT_N2OCO2, PRAT_N2OCO2_1,PMINORFRAC,KINDMINOR,PSCALEMINOR,PCOLBRD) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NGS14 ,NG15 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLN2O(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_N2OCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_N2OCO2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLBRD(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL15 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol16.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol16.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol16.intfb.h (revision 6016) @@ -0,0 +1,37 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL16 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLCH4,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & P_RAT_H2OCH4,P_RAT_H2OCH4_1) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NGS15 ,NG16 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_H2OCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_H2OCH4_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL16 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol2.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol2.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol2.intfb.h (revision 6016) @@ -0,0 +1,34 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL2 (KIDIA,KFDIA,KLEV,P_TAU,PAVEL,P_COLDRY,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG2 ,NGS1 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +END SUBROUTINE RRTM_TAUMOL2 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol3.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol3.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol3.intfb.h (revision 6016) @@ -0,0 +1,41 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL3 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLCO2,P_COLN2O,P_COLDRY,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & PRAT_H2OCO2, PRAT_H2OCO2_1,PMINORFRAC,KINDMINOR) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG3 ,NGS2 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_H2OCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL3 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol4.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol4.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol4.intfb.h (revision 6016) @@ -0,0 +1,40 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL4 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLCO2,P_COLO3,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & P_RAT_H2OCO2, P_RAT_H2OCO2_1, P_RAT_O3CO2, P_RAT_O3CO2_1) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG4 ,NGS3 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_H2OCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_H2OCO2_1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_O3CO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_O3CO2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL4 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol5.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol5.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol5.intfb.h (revision 6016) @@ -0,0 +1,43 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL5 (KIDIA,KFDIA,KLEV,P_TAU,P_WX,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLCO2, P_COLO3,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & P_RAT_H2OCO2, P_RAT_H2OCO2_1, P_RAT_O3CO2, P_RAT_O3CO2_1,PMINORFRAC,KINDMINOR) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT ,NG5 ,NGS4 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_WX(KIDIA:KFDIA,JPXSEC,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_H2OCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_H2OCO2_1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_O3CO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_O3CO2_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL5 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol6.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol6.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol6.intfb.h (revision 6016) @@ -0,0 +1,37 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL6 (KIDIA,KFDIA,KLEV,P_TAU,P_WX,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLH2O,P_COLCO2,P_COLDRY,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,PMINORFRAC,KINDMINOR) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT ,NG6 ,NGS5 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_WX(KIDIA:KFDIA,JPXSEC,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL6 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol7.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol7.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol7.intfb.h (revision 6016) @@ -0,0 +1,41 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL7 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLO3,P_COLCO2,P_COLDRY,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & P_RAT_H2OO3, P_RAT_H2OO3_1,PMINORFRAC,KINDMINOR) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG7 ,NGS6 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_H2OO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_RAT_H2OO3_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL7 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol8.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol8.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol8.intfb.h (revision 6016) @@ -0,0 +1,40 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL8 (KIDIA,KFDIA,KLEV,P_TAU,P_WX,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& + & P_COLH2O,P_COLO3,P_COLN2O,P_COLCO2,P_COLDRY,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & PMINORFRAC,KINDMINOR) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND ,JPXSEC +USE YOERRTM , ONLY : JPGPT ,NG8 ,NGS7 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_WX(KIDIA:KFDIA,JPXSEC,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL8 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol9.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol9.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/rrtm_taumol9.intfb.h (revision 6016) @@ -0,0 +1,43 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE RRTM_TAUMOL9 (KIDIA,KFDIA,KLEV,P_TAU,& + & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,& + & P_COLH2O,P_COLN2O,P_COLCH4,P_COLDRY,K_LAYTROP,K_LAYSWTCH,K_LAYLOW,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,& + & PRAT_H2OCH4,PRAT_H2OCH4_1,PMINORFRAC,KINDMINOR) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARRRTM , ONLY : JPBAND +USE YOERRTM , ONLY : JPGPT ,NG9 ,NGS8 +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLN2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYSWTCH(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYLOW(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_H2OCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRAT_H2OCH4_1(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PMINORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDMINOR(KIDIA:KFDIA,KLEV) +END SUBROUTINE RRTM_TAUMOL9 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/satur.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/satur.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/satur.intfb.h (revision 6016) @@ -0,0 +1,16 @@ +interface +SUBROUTINE SATUR ( KIDIA , KFDIA , KLON , KTDIA , KLEV, LDPHYLIN, & + & PAPRSF, PT , PQSAT , KFLAG) +USE PARKIND1 ,ONLY : JPIM ,JPRB +INTEGER(KIND=JPIM),INTENT(IN) :: KLON +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KTDIA +LOGICAL ,INTENT(IN) :: LDPHYLIN +REAL(KIND=JPRB) ,INTENT(IN) :: PAPRSF(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PT(KLON,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: PQSAT(KLON,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KFLAG +END SUBROUTINE SATUR +end interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb16.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb16.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb16.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB16 +END SUBROUTINE SRTM_CMBGB16 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb17.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb17.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb17.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB17 +END SUBROUTINE SRTM_CMBGB17 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb18.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb18.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb18.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB18 +END SUBROUTINE SRTM_CMBGB18 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb19.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb19.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb19.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB19 +END SUBROUTINE SRTM_CMBGB19 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb20.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb20.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb20.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB20 +END SUBROUTINE SRTM_CMBGB20 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb21.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb21.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb21.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB21 +END SUBROUTINE SRTM_CMBGB21 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb22.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb22.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb22.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB22 +END SUBROUTINE SRTM_CMBGB22 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb23.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb23.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb23.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB23 +END SUBROUTINE SRTM_CMBGB23 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb24.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb24.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb24.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB24 +END SUBROUTINE SRTM_CMBGB24 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb25.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb25.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb25.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB25 +END SUBROUTINE SRTM_CMBGB25 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb26.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb26.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb26.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB26 +END SUBROUTINE SRTM_CMBGB26 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb27.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb27.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb27.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB27 +END SUBROUTINE SRTM_CMBGB27 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb28.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb28.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb28.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB28 +END SUBROUTINE SRTM_CMBGB28 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb29.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb29.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_cmbgb29.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_CMBGB29 +END SUBROUTINE SRTM_CMBGB29 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_gas_optical_depth.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_gas_optical_depth.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_gas_optical_depth.intfb.h (revision 6016) @@ -0,0 +1,41 @@ +INTERFACE +SUBROUTINE SRTM_GAS_OPTICAL_DEPTH& + & ( KIDIA , KFDIA , KLEV , PONEMINUS,& + & PRMU0,& + & KLAYTROP,& + & PCOLCH4 , PCOLCO2 , PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& + & PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 ,& + & POD, PSSA, PINCSOL) +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOESRTM , ONLY : JPGPT +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(OUT) :: POD(KIDIA:KFDIA,KLEV,JPGPT) +REAL(KIND=JPRB) ,INTENT(OUT) :: PSSA(KIDIA:KFDIA,KLEV,JPGPT) +REAL(KIND=JPRB) ,INTENT(OUT) :: PINCSOL(KIDIA:KFDIA,JPGPT) +END SUBROUTINE SRTM_GAS_OPTICAL_DEPTH +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_init.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_init.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_init.intfb.h (revision 6016) @@ -0,0 +1,7 @@ +INTERFACE +SUBROUTINE SRTM_INIT(DIRECTORY, NWVCONTINUUM) +USE PARKIND1, ONLY : JPIM +CHARACTER(LEN=*), INTENT(IN) :: DIRECTORY +INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NWVCONTINUUM +END SUBROUTINE SRTM_INIT +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb16.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb16.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb16.intfb.h (revision 6016) @@ -0,0 +1,5 @@ +INTERFACE +SUBROUTINE SRTM_KGB16(DIRECTORY) +CHARACTER(LEN=*), INTENT(IN) :: DIRECTORY +END SUBROUTINE SRTM_KGB16 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb17.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb17.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb17.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB17 +END SUBROUTINE SRTM_KGB17 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb18.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb18.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb18.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB18 +END SUBROUTINE SRTM_KGB18 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb19.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb19.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb19.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB19 +END SUBROUTINE SRTM_KGB19 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb20.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb20.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb20.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB20 +END SUBROUTINE SRTM_KGB20 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb21.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb21.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb21.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB21 +END SUBROUTINE SRTM_KGB21 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb22.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb22.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb22.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB22 +END SUBROUTINE SRTM_KGB22 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb23.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb23.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb23.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB23 +END SUBROUTINE SRTM_KGB23 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb24.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb24.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb24.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB24 +END SUBROUTINE SRTM_KGB24 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb25.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb25.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb25.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB25 +END SUBROUTINE SRTM_KGB25 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb26.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb26.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb26.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB26 +END SUBROUTINE SRTM_KGB26 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb27.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb27.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb27.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB27 +END SUBROUTINE SRTM_KGB27 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb28.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb28.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb28.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB28 +END SUBROUTINE SRTM_KGB28 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb29.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb29.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_kgb29.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SRTM_KGB29 +END SUBROUTINE SRTM_KGB29 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_setcoef.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_setcoef.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_setcoef.intfb.h (revision 6016) @@ -0,0 +1,43 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_SETCOEF& + & ( KIDIA , KFDIA , KLEV ,& + & PAVEL , PTAVEL ,& + & PCOLDRY , PWKL ,& + & KLAYTROP,& + & PCOLCH4 , PCOLCO2 , PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& + & PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,& + & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& + & KJP , KJT , KJT1 , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PTAVEL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PCOLDRY(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PWKL(KIDIA:KFDIA,35,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KLAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PCOLO3(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KINDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PSELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PSELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KINDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PFAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KJP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KJT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(INOUT) :: KJT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_SETCOEF +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol16.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol16.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol16.intfb.h (revision 6016) @@ -0,0 +1,39 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL16& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCH4 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC , P_SELFFRAC, K_INDSELF , P_FORFAC , P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL16 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol17.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol17.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol17.intfb.h (revision 6016) @@ -0,0 +1,39 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL17& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCO2 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL17 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol18.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol18.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol18.intfb.h (revision 6016) @@ -0,0 +1,39 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL18& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCH4 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL18 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol19.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol19.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol19.intfb.h (revision 6016) @@ -0,0 +1,39 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL19& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCO2 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL19 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol20.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol20.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol20.intfb.h (revision 6016) @@ -0,0 +1,38 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL20& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLH2O , P_COLCH4 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL20 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol21.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol21.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol21.intfb.h (revision 6016) @@ -0,0 +1,39 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL21& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLCO2 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL21 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol22.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol22.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol22.intfb.h (revision 6016) @@ -0,0 +1,39 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL22& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLMOL , P_COLO2,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO2(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL22 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol23.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol23.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol23.intfb.h (revision 6016) @@ -0,0 +1,37 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL23& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLH2O , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL23 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol24.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol24.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol24.intfb.h (revision 6016) @@ -0,0 +1,40 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL24& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLH2O , P_COLMOL , P_COLO2 , P_COLO3,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL24 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol25.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol25.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol25.intfb.h (revision 6016) @@ -0,0 +1,32 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL25& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLH2O , P_COLMOL , P_COLO3,& + & K_LAYTROP,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL25 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol26.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol26.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol26.intfb.h (revision 6016) @@ -0,0 +1,20 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL26& + & ( KIDIA , KFDIA , KLEV,& + & P_COLMOL ,K_LAYTROP,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL26 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol27.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol27.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol27.intfb.h (revision 6016) @@ -0,0 +1,31 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL27& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLMOL , P_COLO3,& + & K_LAYTROP,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL27 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol28.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol28.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol28.intfb.h (revision 6016) @@ -0,0 +1,33 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL28& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1 , P_ONEMINUS,& + & P_COLMOL , P_COLO2 , P_COLO3,& + & K_LAYTROP,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_ONEMINUS(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLO3(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL28 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol29.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol29.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/srtm_taumol29.intfb.h (revision 6016) @@ -0,0 +1,38 @@ +! This file has been modified for the use in ICON + +INTERFACE +SUBROUTINE SRTM_TAUMOL29& + & ( KIDIA , KFDIA , KLEV,& + & P_FAC00 , P_FAC01 , P_FAC10 , P_FAC11,& + & K_JP , K_JT , K_JT1,& + & P_COLH2O , P_COLCO2 , P_COLMOL,& + & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF , P_FORFAC, P_FORFRAC, K_INDFOR,& + & P_SFLUXZEN, P_TAUG , P_TAUR , PRMU0& + & ) +USE PARKIND1 , ONLY : JPIM, JPRB +USE PARSRTM , ONLY : JPG +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCO2(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_COLMOL(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) +INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_SFLUXZEN(KIDIA:KFDIA,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUG(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(INOUT) :: P_TAUR(KIDIA:KFDIA,KLEV,JPG) +REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) +END SUBROUTINE SRTM_TAUMOL29 +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surdi.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surdi.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surdi.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SURDI +END SUBROUTINE SURDI +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtab.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtab.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtab.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SURRTAB +END SUBROUTINE SURRTAB +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtftr.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtftr.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtftr.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SURRTFTR +END SUBROUTINE SURRTFTR +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtpk.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtpk.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtpk.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SURRTPK +END SUBROUTINE SURRTPK +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtrf.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtrf.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/surrtrf.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SURRTRF +END SUBROUTINE SURRTRF +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/include/susrtm.intfb.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/include/susrtm.intfb.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/include/susrtm.intfb.h (revision 6016) @@ -0,0 +1,4 @@ +INTERFACE +SUBROUTINE SUSRTM +END SUBROUTINE SUSRTM +END INTERFACE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/aeropt_5wv_ecrad.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/aeropt_5wv_ecrad.f90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/aeropt_5wv_ecrad.f90 (revision 6016) @@ -0,0 +1,100 @@ +!aeropt_5wv_ecrad.F90 2022-09-20 A. Idelkadi et O. Boucher +! + SUBROUTINE AEROPT_5WV_ECRAD(istartcol,iendcol,istartlev,iendlev, & + config,thermodynamics,aerosol) + + + USE DIMPHY + USE aero_mod + USE phys_local_var_mod, ONLY: od443aer,od550aer,od865aer +! dryod550aer, +! ec550aer,od550lt1aer,abs550aer +! USE phys_output_var_mod, ONLY: dryaod_diag +! USE YOMCST, ONLY: RD,RG + USE phys_local_var_mod, ONLY: rhcl + + use parkind1, only : jprb + use radiation_config, only : config_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_aerosol, only : aerosol_type + use radiation_constants, only : AccelDueToGravity + use radiation_aerosol_optics_data, only : aerosol_optics_type, & + & IAerosolClassUndefined, IAerosolClassIgnored, & + & IAerosolClassHydrophobic, IAerosolClassHydrophilic + + IMPLICIT NONE + + !---ATTENTION n_mono est a redéfinir proprement + + ! Range of levels over which aerosols are present + integer, intent(in) :: istartlev, iendlev, istartcol,iendcol + type(config_type), intent(in), target :: config + type(thermodynamics_type),intent(in) :: thermodynamics + type(aerosol_type), intent(in) :: aerosol + type(aerosol_optics_type), pointer :: ao + + ! Loop indices for column, level, g point, band and aerosol type, and relative humidity + integer :: jcol, jlev, jtype, irh + ! indice wavelength in aerosol_optics_lmdz.nc + INTEGER, PARAMETER :: la443 = 1 + INTEGER, PARAMETER :: la550 = 2 +! INTEGER, PARAMETER :: la670 = 3 +! INTEGER, PARAMETER :: la765 = 4 + INTEGER, PARAMETER :: la865 = 5 + real(jprb) :: factor + ! n_bands_sw + real(jprb), dimension(config%aerosol_optics%n_mono_wl) :: od_aerosol_mono, local_od_mono + + !--initialization + od443aer = 0.0_jprb + od550aer = 0.0_jprb + od865aer = 0.0_jprb + + ao => config%aerosol_optics + + ! Loop over level + do jlev = istartlev,iendlev + + ! Loop over column + do jcol = istartcol,iendcol + + ! Compute relative humidity with respect to liquid + ! saturation and the index to the relative-humidity index of + ! hydrophilic-aerosol data + irh = ao%calc_rh_index(rhcl(jcol,jlev)) + + factor = ( thermodynamics%pressure_hl(jcol,jlev+1) & + & -thermodynamics%pressure_hl(jcol,jlev ) ) & + & / AccelDueToGravity + + ! Reset temporary arrays + od_aerosol_mono = 0.0_jprb + + do jtype = 1,config%n_aerosol_types + ! Add the optical depth for this aerosol type to the total for all aerosols. + ! Note that the following expressions are array-wise + if (ao%iclass(jtype) == IAerosolClassHydrophobic) then + local_od_mono = factor * aerosol%mixing_ratio(jcol,jlev,jtype) & + & * ao%mass_ext_mono_phobic(:,ao%itype(jtype)) + od_aerosol_mono = od_aerosol_mono + local_od_mono + else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then + ! Hydrophilic aerosols require the look-up tables to + ! be indexed with irh + local_od_mono = factor * aerosol%mixing_ratio(jcol,jlev,jtype) & + & * ao%mass_ext_mono_philic(:,irh,ao%itype(jtype)) + od_aerosol_mono = od_aerosol_mono + local_od_mono + end if + + end do ! Loop over aerosol type + + !--ATTENTION A BIEN FAIRE CORRESPONDRE LES INDICES + od443aer(jcol) = od443aer(jcol) + od_aerosol_mono(la443) + od550aer(jcol) = od550aer(jcol) + od_aerosol_mono(la550) + od865aer(jcol) = od865aer(jcol) + od_aerosol_mono(la865) + + end do ! Loop over column + + end do ! Loop over level + + END SUBROUTINE AEROPT_5WV_ECRAD + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/calcul_cloud_overlap_decorr_len.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/calcul_cloud_overlap_decorr_len.f90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/calcul_cloud_overlap_decorr_len.f90 (revision 6016) @@ -0,0 +1,155 @@ +SUBROUTINE CALCUL_CLOUD_OVERLAP_DECORR_LEN & + & (KIDIA, KFDIA, KLON, KLEV, & + & driver_config, & + & pressure_hl, & + & PDECORR_LEN_EDGES_M, PDECORR_LEN_WATER_M, PDECORR_LEN_RATIO) + +! A Idelkadi ! ------------- +! 04 2024 +! Depart de la routine de l' IFS +! But : calcul de la Ld (longueur de decorrelation) +! Dans le cas overlap_scheme_name=="Exp-Ran" +! 3 cas en fonction de kdecolat (namelist_ecrad) : +! 0 => Ld=overlap_decorr_length (namelist_ecrad) +! 1 => Ld=f(latitude) Shonk et al. (2010) Eq. 13 formula +! 2 => Ld=f(latitude) Shonk et al. (2010) lissee a l equateur +! 3 => Ld=f(pres) : +! Ld=low_decorrelation_length si pres >= 680hPa +! Ld=mid_decorrelation_length si pres entre [440,680] +! Ld=high_decorrelation_length si pres < 440hPa +! +! TO DO +! Que faire de PDECORR_LEN_WATER_M ? +! ------------------------------------------------------------------- + +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +USE YOMCST , ONLY : RPI +USE geometry_mod, ONLY: latitude_deg +USE lmdz_cloud_optics_prop_ini , ONLY : prmhc, prlmc +USE setup_config_from_lmdz, ONLY : driver_config_type +USE write_field_phy +! ------------------------------------------------------------------- + +IMPLICIT NONE + +! INPUT ARGUMENTS + +! *** Array dimensions and ranges +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA ! Start column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA ! End column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KLON ! Number of columns +! AI 04 2024 +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV + +! *** Single-level variables +!AI 04 2024 +REAL(KIND=JPRB), intent(in) :: pressure_hl(KLON,KLEV+1) +type(driver_config_type),intent(in) :: driver_config + +! OUTPUT ARGUMENTS + +! *** Decorrelation lengths for cloud edges and cloud water content, in m +! A.I 04 2024 +REAL(KIND=JPRB), INTENT(OUT) :: PDECORR_LEN_EDGES_M(KLON,KLEV) +REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_WATER_M(KLON,KLEV) + +! Ratio of water-content to cloud-edge decorrelation lengths +REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_RATIO + +! LOCAL VARIABLES + +REAL(KIND=JPRB) :: ZRADIANS_TO_DEGREES, ZABS_LAT_DEG, ZCOS_LAT + +! AI 04 2024 +REAL(KIND=JPRB) :: PGEMU(KLON) ! Sine of latitude +REAL(KIND=JPRB) :: RDECORR_CF +REAL(KIND=JPRB) :: RDECORR_CW = 1.0_JPRB + +INTEGER(KIND=JPIM) :: JL, JK + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('CLOUD_OVERLAP_DECORR_LEN',0,ZHOOK_HANDLE) + +! ------------------------------------------------------------------- +print*,'driver_config%kdecolat = ', driver_config%kdecolat + +IF (driver_config%kdecolat == 0) THEN + + ! Decorrelation lengths are constant values + ! overlap_decorr_length lu dans namelist en m + RDECORR_CF = driver_config%overlap_decorr_length / 1000.0_JPRB + PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) = driver_config%overlap_decorr_length +! IF (PRESENT(PDECORR_LEN_WATER_M)) THEN +! PDECORR_LEN_WATER_M = RDECORR_CW * 1000.0_JPRB +! ENDIF +! IF (PRESENT(PDECORR_LEN_RATIO)) THEN +! PDECORR_LEN_RATIO = RDECORR_CW / RDECORR_CF +! ENDIF + +ELSE + + ZRADIANS_TO_DEGREES = 180.0_JPRB / RPI + PGEMU = SIN(latitude_deg) + + IF (driver_config%kdecolat == 1) THEN + ! Shonk et al. (2010) Eq. 13 formula + DO JL = KIDIA,KFDIA + ZABS_LAT_DEG = ABS(ASIN(PGEMU(JL)) * ZRADIANS_TO_DEGREES) + PDECORR_LEN_EDGES_M(JL,:) = (2.899_JPRB - 0.02759_JPRB * ZABS_LAT_DEG) * 1000.0_JPRB + ENDDO + ELSE ! KDECOLAT == 2 + DO JL = KIDIA,KFDIA + ! Shonk et al. (2010) but smoothed over the equator + ZCOS_LAT = COS(ASIN(PGEMU(JL))) + PDECORR_LEN_EDGES_M(JL,:) = (0.75_JPRB + 2.149_JPRB * ZCOS_LAT*ZCOS_LAT) * 1000.0_JPRB + ENDDO + ENDIF + + + ! Both KDECOLAT = 1 and 2 assume that the decorrelation length for + ! cloud water content is half that for cloud edges +! IF (PRESENT(PDECORR_LEN_WATER_M)) THEN +! PDECORR_LEN_WATER_M(KIDIA:KFDIA,:) = PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) * 0.5_JPRB +! ENDIF + +! IF (PRESENT(PDECORR_LEN_RATIO)) THEN +! PDECORR_LEN_RATIO = 0.5_JPRB +! ENDIF + +ENDIF + +!AI 04 2024 +IF (driver_config%kdecolat == 3) THEN + DO jk = 1, klev + DO JL = 1, klon + IF (pressure_hl(JL,jk)=prmhc .AND. pressure_hl(JL,jk)=prlmc) THEN + PDECORR_LEN_EDGES_M(JL,jk) = driver_config%low_decorrelation_length + ENDIF + ENDDO + ENDDO + + ! Both KDECOLAT = 1 and 2 assume that the decorrelation length for + ! cloud water content is half that for cloud edges +! IF (PRESENT(PDECORR_LEN_WATER_M)) THEN +! PDECORR_LEN_WATER_M(KIDIA:KFDIA,:) = PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) * 0.5_JPRB +! ENDIF +! IF (PRESENT(PDECORR_LEN_RATIO)) THEN +! PDECORR_LEN_RATIO = 0.5_JPRB +! ENDIF +ENDIF +!CALL writefield_phy('latitude',latitude_deg,1) +!CALL writefield_phy('pressure_hl',pressure_hl,klev+1) +!CALL writefield_phy('Ldecorel',PDECORR_LEN_EDGES_M,klev) +! ------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('CLOUD_OVERLAP_DECORR_LEN',1,ZHOOK_HANDLE) + +END SUBROUTINE CALCUL_CLOUD_OVERLAP_DECORR_LEN Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/radiation_scheme_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/radiation_scheme_mod.f90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/radiation_scheme_mod.f90 (revision 6016) @@ -0,0 +1,1382 @@ +! AI mars 2021 +! ====================== Interface between ECRAD and LMDZ ==================== +! Depart de la version IFS R.H +! radiation_scheme.F90 appelee dans radlwsw_m.F90 si iflag_rttm = 2 +! revoir toutes les parties avec "AI ATTENTION" +! Mars 2021 : +! - Revoir toutes les parties commentees AI ATTENTION +! 1. Traitement des aerosols +! 2. Verifier les parametres times issus de LMDZ (calcul issed) +! 3. Configuration a partir de namelist +! 4. frac_std = 0.75 +! Juillet 2023 : +! +! ============================================================================ +module interface_lmdz_ecrad + +IMPLICIT NONE + +contains + +SUBROUTINE RADIATION_SCHEME & +! Inputs + & (KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW, & + & namelist_file, ok_3Deffect, & + & debut, ok_volcan, flag_aerosol_strat, & + & IDAY, TIME, & + & PSOLAR_IRRADIANCE, & + & PMU0, PTEMPERATURE_SKIN, & + & PALBEDO_DIF, PALBEDO_DIR, & + & PEMIS, PEMIS_WINDOW, & + & PGELAM, PGEMU, & + & PPRESSURE_H, PTEMPERATURE_H, PQ, PQSAT, & + & PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, & + & PCCL4, PO3, PO2, & + & PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW, & + & ZRE_LIQUID_UM, ZRE_ICE_UM, & + & PAEROSOL_OLD, PAEROSOL, & +! Outputs + & PFLUX_SW, PFLUX_LW, PFLUX_SW_CLEAR, PFLUX_LW_CLEAR, & + & PFLUX_SW_DN, PFLUX_LW_DN, PFLUX_SW_DN_CLEAR, PFLUX_LW_DN_CLEAR, & + & PFLUX_SW_UP, PFLUX_LW_UP, PFLUX_SW_UP_CLEAR, PFLUX_LW_UP_CLEAR, & + & PFLUX_DIR, PFLUX_DIR_CLEAR, PFLUX_DIR_INTO_SUN, & + & PFLUX_UV, PFLUX_PAR, PFLUX_PAR_CLEAR, & + & PEMIS_OUT, PLWDERIVATIVE, & + & PSWDIFFUSEBAND, PSWDIRECTBAND, & + & ecrad_cloud_cover_sw) + +!----------------------------------------------------------------------- + +! Modules from ifs or ifsaux libraries +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE RADIATION_SETUP +USE YOMCST , ONLY : RSIGMA ! Stefan-Boltzmann constant + +! Modules from radiation library +USE radiation_single_level, ONLY : single_level_type +USE radiation_thermodynamics, ONLY : thermodynamics_type +USE radiation_gas +USE radiation_cloud, ONLY : cloud_type +USE radiation_aerosol, ONLY : aerosol_type +USE radiation_flux, ONLY : flux_type +USE radiation_interface, ONLY : radiation, set_gas_units +USE radiation_save, ONLY : save_inputs + +USE mod_phys_lmdz_para +use geometry_mod, only: longitude_deg, latitude_deg + +IMPLICIT NONE + +! INPUT ARGUMENTS +! *** Array dimensions and ranges +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA ! Start column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA ! End column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KLON ! Number of columns +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV ! Number of levels +INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL +INTEGER(KIND=JPIM),INTENT(IN) :: NSW ! Numbe of bands + +! AI ATTENTION +!INTEGER, PARAMETER :: KAEROSOL = 12 + +! *** Single-level fields +REAL(KIND=JPRB), INTENT(IN) :: PSOLAR_IRRADIANCE ! (W m-2) +REAL(KIND=JPRB), INTENT(IN) :: PMU0(KLON) ! Cosine of solar zenith ang +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE_SKIN(KLON) ! (K) +! Diffuse and direct components of surface shortwave albedo +!REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIF(KLON,YRERAD%NSW) +!REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIR(KLON,YRERAD%NSW) +REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIF(KLON,NSW) +REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIR(KLON,NSW) +! Longwave emissivity outside and inside the window region +REAL(KIND=JPRB), INTENT(IN) :: PEMIS(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PEMIS_WINDOW(KLON) +! Longitude (radians), sine of latitude +REAL(KIND=JPRB), INTENT(IN) :: PGELAM(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) +! Land-sea mask +!REAL(KIND=JPRB), INTENT(IN) :: PLAND_SEA_MASK(KLON) + +! *** Variables on half levels +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1) ! (Pa) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE_H(KLON,KLEV+1) ! (K) + +! *** Gas mass mixing ratios on full levels +REAL(KIND=JPRB), INTENT(IN) :: PQ(KLON,KLEV) +! AI +REAL(KIND=JPRB), INTENT(IN) :: PQSAT(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCO2 +REAL(KIND=JPRB), INTENT(IN) :: PCH4 +REAL(KIND=JPRB), INTENT(IN) :: PN2O +REAL(KIND=JPRB), INTENT(IN) :: PNO2 +REAL(KIND=JPRB), INTENT(IN) :: PCFC11 +REAL(KIND=JPRB), INTENT(IN) :: PCFC12 +REAL(KIND=JPRB), INTENT(IN) :: PHCFC22 +REAL(KIND=JPRB), INTENT(IN) :: PCCL4 +REAL(KIND=JPRB), INTENT(IN) :: PO3(KLON,KLEV) ! AI (kg/kg) ATTENTION (Pa*kg/kg) +REAL(KIND=JPRB), INTENT(IN) :: PO2 + +! *** Cloud fraction and hydrometeor mass mixing ratios +REAL(KIND=JPRB), INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_LIQUID(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_ICE(KLON,KLEV) +!REAL(KIND=JPRB), INTENT(IN) :: PQ_RAIN(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_SNOW(KLON,KLEV) + +! *** Aerosol mass mixing ratios +REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL_OLD(KLON,6,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL) + +!REAL(KIND=JPRB), INTENT(IN) :: PCCN_LAND(KLON) +!REAL(KIND=JPRB), INTENT(IN) :: PCCN_SEA(KLON) + +!AI mars 2021 +INTEGER(KIND=JPIM), INTENT(IN) :: IDAY +REAL(KIND=JPRB), INTENT(IN) :: TIME + +! Name of file names specified on command line +character(len=512), INTENT(IN) :: namelist_file +logical, INTENT(IN) :: ok_3Deffect, debut, ok_volcan +INTEGER(KIND=JPIM), INTENT(IN) :: flag_aerosol_strat + + +! OUTPUT ARGUMENTS + +! *** Net fluxes on half-levels (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_CLEAR(KLON,KLEV+1) + +!*** DN and UP flux on half-levels (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_DN(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_DN_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_UP(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_UP(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_UP_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_UP_CLEAR(KLON,KLEV+1) + +! Direct component of surface flux into horizontal plane +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON,KLEV+1) +! As PFLUX_DIR but into a plane perpendicular to the sun +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON) + +! *** Ultraviolet and photosynthetically active radiation (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_UV(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_PAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_PAR_CLEAR(KLON) + +! Diagnosed longwave surface emissivity across the whole spectrum +REAL(KIND=JPRB), INTENT(OUT) :: PEMIS_OUT(KLON) + +! Partial derivative of total-sky longwave upward flux at each level +! with respect to upward flux at surface, used to correct heating +! rates at gridpoints/timesteps between calls to the full radiation +! scheme. Note that this version uses the convention of level index +! increasing downwards, unlike the local variable ZLwDerivative that +! is returned from the LW radiation scheme. +REAL(KIND=JPRB), INTENT(OUT) :: PLWDERIVATIVE(KLON,KLEV+1) + +! Surface diffuse and direct downwelling shortwave flux in each +! shortwave albedo band, used in RADINTG to update the surface fluxes +! accounting for high-resolution albedo information +REAL(KIND=JPRB), INTENT(OUT) :: PSWDIFFUSEBAND(KLON,NSW) +REAL(KIND=JPRB), INTENT(OUT) :: PSWDIRECTBAND (KLON,NSW) + +!AI Nov 2023 +REAL(KIND=JPRB), INTENT(OUT) :: ecrad_cloud_cover_sw(KLON) + +! LOCAL VARIABLES +! AI ATTENTION +type(config_type),save :: rad_config +!!$OMP THREADPRIVATE(rad_config) +type(driver_config_type),save :: driver_config +!!$OMP THREADPRIVATE(driver_config) +TYPE(single_level_type) :: single_level +TYPE(thermodynamics_type) :: thermodynamics +TYPE(gas_type) :: gas +TYPE(cloud_type) :: cloud +TYPE(aerosol_type) :: aerosol +TYPE(flux_type) :: flux + +! Mass mixing ratio of ozone (kg/kg) +REAL(KIND=JPRB) :: ZO3(KLON,KLEV) + +! Cloud effective radii in microns +REAL(KIND=JPRB) :: ZRE_LIQUID_UM(KLON,KLEV) +REAL(KIND=JPRB) :: ZRE_ICE_UM(KLON,KLEV) + +! Cloud overlap decorrelation length for cloud boundaries in km +REAL(KIND=JPRB) :: ZDECORR_LEN_M +REAL(KIND=JPRB) :: ZDECORR_LEN_M_1D(KLON) +REAL(KIND=JPRB) :: ZDECORR_LEN_M_2D(KLON,KLEV) + +! Ratio of cloud overlap decorrelation length for cloud water +! inhomogeneities to that for cloud boundaries (typically 0.5) +!REAL(KIND=JPRB) :: ZDECORR_LEN_RATIO = 0.5_jprb + +! The surface net longwave flux if the surface was a black body, used +! to compute the effective broadband surface emissivity +REAL(KIND=JPRB) :: ZBLACK_BODY_NET_LW(KIDIA:KFDIA) + +! Layer mass in kg m-2 +REAL(KIND=JPRB) :: ZLAYER_MASS(KIDIA:KFDIA,KLEV) + +! Time integers +INTEGER :: ITIM + +! Loop indices +INTEGER :: JLON, JLEV, JBAND, JB_ALBEDO, JAER + +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +! AI ATTENTION traitement aerosols +INTEGER, PARAMETER :: NAERMACC = 1 + +logical :: loutput=.true. +logical :: lprint_input=.false. +logical :: lprint_config=.false. +logical, save :: debut_ecrad=.true. +!$OMP THREADPRIVATE(debut_ecrad) +integer, save :: itap_ecrad=0 +!$OMP THREADPRIVATE(itap_ecrad) + +REAL(KIND=JPRB) :: inv_cloud_effective_size(KLON,KLEV) +REAL(KIND=JPRB) :: inv_inhom_effective_size(KLON,KLEV) + +integer :: irang + + +IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',0,ZHOOK_HANDLE) + + print*,'Entree radiation_scheme, ok_3Deffect, namelist_file = ', & + ok_3Deffect, namelist_file +! A.I juillet 2023 : +! Initialisation dans radiation_setup au 1er passage dans Ecrad +!$OMP MASTER + if (debut_ecrad) then + call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config) + endif +!$OMP END MASTER +!$OMP BARRIER +! Fin partie initialisation et configuration + +!AI print fichiers namelist utilise +!if (is_omp_root) then +! itap_ecrad=itap_ecrad+1 +! print*,'Dans radiation_scheme itap_ecrad, mpi_rank, omp_rank, namelist_file : ', & +! itap_ecrad, mpi_rank, omp_rank, namelist_file +!else +! print*,'mpi_rank omp_rank, namelist_file :', mpi_rank, omp_rank, namelist_file +!endif + +! AI 11 23 Allocates depplaces au debut +print*,'*********** ALLOCATES *******************************' +! AI ATTENTION +! Allocate memory in radiation objects +! emissivite avec une seule bande +CALL single_level%allocate(KLON, NSW, 1, & + & use_sw_albedo_direct=.TRUE.) +CALL thermodynamics%allocate(KLON, KLEV, use_h2o_sat=.true.) +CALL cloud%allocate(KLON, KLEV) +CALL aerosol%allocate(KLON, 1, KLEV, KAEROSOL) +CALL gas%allocate(KLON, KLEV) +CALL flux%allocate(rad_config, 1, KLON, KLEV) + +print*,'************* THERMO (input) ************************************' +! AI +! pressure_hl > paprs +! temperature_hl calculee dans radlsw de la meme facon que pour RRTM +thermodynamics%pressure_hl (KIDIA:KFDIA,:) = PPRESSURE_H (KIDIA:KFDIA,:) +thermodynamics%temperature_hl(KIDIA:KFDIA,:) = PTEMPERATURE_H(KIDIA:KFDIA,:) +!print*,'Compute saturation specific humidity' +! Compute saturation specific humidity, used to hydrate aerosols. The +! "2" for the last argument indicates that the routine is not being +! called from within the convection scheme. +!CALL SATUR(KIDIA, KFDIA, KLON, 1, KLEV, & +! & PPRESSURE, PTEMPERATURE, thermodynamics%h2o_sat_liq, 2) +! Alternative approximate version using temperature and pressure from +! the thermodynamics structure +!CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA) +!AI ATTENTION +thermodynamics%h2o_sat_liq = PQSAT + +print*,'********** SINGLE LEVEL VARS **********************************' +!AI ATTENTION +! Set single-level fileds +single_level%solar_irradiance = PSOLAR_IRRADIANCE +single_level%cos_sza(KIDIA:KFDIA) = PMU0(KIDIA:KFDIA) +single_level%skin_temperature(KIDIA:KFDIA) = PTEMPERATURE_SKIN(KIDIA:KFDIA) +single_level%sw_albedo(KIDIA:KFDIA,:) = PALBEDO_DIF(KIDIA:KFDIA,:) +single_level%sw_albedo_direct(KIDIA:KFDIA,:)=PALBEDO_DIR(KIDIA:KFDIA,:) +single_level%lw_emissivity(KIDIA:KFDIA,1) = PEMIS(KIDIA:KFDIA) +!single_level%lw_emissivity(KIDIA:KFDIA,2) = PEMIS_WINDOW(KIDIA:KFDIA) + +! Create the relevant seed from date and time get the starting day +! and number of minutes since start +!IDAY = NDD(NINDAT) +!cur_day +!ITIM = NINT(NSTEP * YRRIP%TSTEP / 60.0_JPRB) +!ITIM = NINT(TIME / 60.0_JPRB) +!current_time +!allocate(single_level%iseed(KIDIA:KFDIA)) +!DO JLON = KIDIA, KFDIA + ! This method gives a unique value for roughly every 1-km square + ! on the globe and every minute. ASIN(PGEMU)*60 gives rough + ! latitude in degrees, which we multiply by 100 to give a unique + ! value for roughly every km. PGELAM*60*100 gives a unique number + ! for roughly every km of longitude around the equator, which we + ! multiply by 180*100 so there is no overlap with the latitude + ! values. The result can be contained in a 32-byte integer (but + ! since random numbers are generated with the help of integer + ! overflow, it should not matter if the number did overflow). +! single_level%iseed(JLON) = ITIM + IDAY & +! & + NINT(PGELAM(JLON)*108000000.0_JPRB & +! & + ASIN(PGEMU(JLON))*6000.0_JPRB) +!ENDDO +!AI Nov 23 +! Simple initialization of the seeds for the Monte Carlo scheme +call single_level%init_seed_simple(kidia, kfdia) + +print*,'********** CLOUDS (allocate + input) *******************************************' +!print*,'Appel Allocate clouds' +! Set cloud fields +cloud%q_liq(KIDIA:KFDIA,:) = PQ_LIQUID(KIDIA:KFDIA,:) +cloud%q_ice(KIDIA:KFDIA,:) = PQ_ICE(KIDIA:KFDIA,:) + PQ_SNOW(KIDIA:KFDIA,:) +cloud%fraction(KIDIA:KFDIA,:) = PCLOUD_FRAC(KIDIA:KFDIA,:) +!!! ok AI ATTENTION a voir avec JL +! Compute effective radi and convert to metres +! AI. : on passe directement les champs de LMDZ +cloud%re_liq(KIDIA:KFDIA,:) = ZRE_LIQUID_UM(KIDIA:KFDIA,:) +cloud%re_ice(KIDIA:KFDIA,:) = ZRE_ICE_UM(KIDIA:KFDIA,:) +! Get the cloud overlap decorrelation length (for cloud boundaries), +! in km, according to the parameterization specified by NDECOLAT, +! and insert into the "cloud" object. Also get the ratio of +! decorrelation lengths for cloud water content inhomogeneities and +! cloud boundaries, and set it in the "rad_config" object. +! IFS : +!CALL CLOUD_OVERLAP_DECORR_LEN(KIDIA, KFDIA, KLON, PGEMU, YRERAD%NDECOLAT, & +! & ZDECORR_LEN_KM, PDECORR_LEN_RATIO=ZDECORR_LEN_RATIO) +CALL CALCUL_CLOUD_OVERLAP_DECORR_LEN & + & (KIDIA, KFDIA, KLON, KLEV, & + & driver_config, & + & thermodynamics%pressure_hl, & + & ZDECORR_LEN_M_2D) + + if (driver_config%kdecolat.eq.0) then + ZDECORR_LEN_M = ZDECORR_LEN_M_2D(1,1) + DO JLON = KIDIA,KFDIA + CALL cloud%set_overlap_param(thermodynamics, & + & ZDECORR_LEN_M, & + & istartcol=JLON, iendcol=JLON) + ENDDO + else if (driver_config%kdecolat.eq.1.or.driver_config%kdecolat.eq.2) then + ZDECORR_LEN_M_1D = ZDECORR_LEN_M_2D(:,1) + DO JLON = KIDIA,KFDIA + CALL cloud%set_overlap_param(thermodynamics, & + & ZDECORR_LEN_M_1D, & + & istartcol=JLON, iendcol=JLON) + ENDDO + else if (driver_config%kdecolat.eq.3) then + DO JLON = KIDIA,KFDIA + CALL cloud%set_overlap_param_var2D(thermodynamics, & + & ZDECORR_LEN_M_2D, KLEV, & + & istartcol=JLON, iendcol=JLON) + ENDDO + endif + + + +! IFS : +! Cloud water content fractional standard deviation is configurable +! from namelist NAERAD but must be globally constant. Before it was +! hard coded at 1.0. +!CALL cloud%create_fractional_std(KLON, KLEV, YRERAD%RCLOUD_FRAC_STD) +! AI ATTENTION frac_std=0.75 meme valeur que dans la version offline +CALL cloud%create_fractional_std(KLON, KLEV, driver_config%frac_std) + +!if (ok_3Deffect) then +! if (driver_config%ok_effective_size) then +! call cloud%create_inv_cloud_effective_size_eta(klon, klev, & +! & thermodynamics%pressure_hl, & +! & driver_config%low_inv_effective_size, & +! & driver_config%middle_inv_effective_size, & +! & driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, & +! & KIDIA, KFDIA) +! else if (driver_config%ok_separation) then +! call cloud%param_cloud_effective_separation_eta(klon, klev, & +! & thermodynamics%pressure_hl, & +! & driver_config%cloud_separation_scale_surface, & +! & driver_config%cloud_separation_scale_toa, & +! & driver_config%cloud_separation_scale_power, & +! & driver_config%cloud_inhom_separation_factor, & +! & KIDIA, KFDIA) +! endif +! else + if (rad_config%i_solver_sw == ISolverSPARTACUS & + & .or. rad_config%i_solver_lw == ISolverSPARTACUS) then + ! AI ! Read cloud properties needed by SPARTACUS + if (driver_config%ok_effective_size) then + call cloud%create_inv_cloud_effective_size_eta(klon, klev, & + & thermodynamics%pressure_hl, & + & driver_config%low_inv_effective_size, & + & driver_config%middle_inv_effective_size, & + & driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, & + & KIDIA, KFDIA) + else if (driver_config%ok_separation_eta) then + call cloud%param_cloud_effective_separation_eta(klon, klev, & + & thermodynamics%pressure_hl, & + & driver_config%cloud_separation_scale_surface, & + & driver_config%cloud_separation_scale_toa, & + & driver_config%cloud_separation_scale_power, & + & driver_config%cloud_inhom_separation_factor, & + & KIDIA, KFDIA) + else if (driver_config%ok_separation_tanh) then + call cloud%param_cloud_effective_separation_tanh(klon, klev, & + & thermodynamics%pressure_hl, & + & driver_config%cloud_separation_scale_surface, & + & driver_config%cloud_separation_scale_toa, & + & driver_config%cloud_separation_scale_power, & + & driver_config%cloud_inhom_separation_factor, & + & KIDIA, KFDIA) + endif + endif +!endif + +print*,'******** AEROSOLS (input) **************************************' +!IF (NAERMACC > 0) THEN +!ELSE +! CALL aerosol%allocate(KLON, 1, KLEV, 6) ! Tegen climatology +!ENDIF +! Compute the dry mass of each layer neglecting humidity effects, in +! kg m-2, needed to scale some of the aerosol inputs +! AI commente ATTENTION +!CALL thermodynamics%get_layer_mass(ZLAYER_MASS) + +! Copy over aerosol mass mixing ratio +!IF (NAERMACC > 0) THEN + + ! MACC aerosol climatology - this is already in mass mixing ratio + ! units with the required array orientation so we can copy it over + ! directly + aerosol%mixing_ratio(KIDIA:KFDIA,:,:) = PAEROSOL(KIDIA:KFDIA,:,:) + + ! Add the tropospheric and stratospheric backgrounds contained in the + ! old Tegen arrays - this is very ugly! +! AI ATTENTION +! IF (TROP_BG_AER_MASS_EXT > 0.0_JPRB) THEN +! aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) & +! & = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) & +! & + PAEROSOL_OLD(KIDIA:KFDIA,1,:) & +! & / (ZLAYER_MASS * TROP_BG_AER_MASS_EXT) +! ENDIF +! IF (STRAT_BG_AER_MASS_EXT > 0.0_JPRB) THEN +! aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) & +! & = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) & +! & + PAEROSOL_OLD(KIDIA:KFDIA,6,:) & +! & / (ZLAYER_MASS * STRAT_BG_AER_MASS_EXT) +! ENDIF + +!ELSE + + ! Tegen aerosol climatology - the array PAEROSOL_OLD contains the + ! 550-nm optical depth in each layer. The optics data file + ! aerosol_ifs_rrtm_tegen.nc does not contain mass extinction + ! coefficient, but a scaling factor that the 550-nm optical depth + ! should be multiplied by to obtain the optical depth in each + ! spectral band. Therefore, in order for the units to work out, we + ! need to divide by the layer mass (in kg m-2) to obtain the 550-nm + ! cross-section per unit mass of dry air (so in m2 kg-1). We also + ! need to permute the array. +! DO JLEV = 1,KLEV +! DO JAER = 1,6 +! aerosol%mixing_ratio(KIDIA:KFDIA,JLEV,JAER) & +! & = PAEROSOL_OLD(KIDIA:KFDIA,JAER,JLEV) & +! & / ZLAYER_MASS(KIDIA:KFDIA,JLEV) +! ENDDO +! ENDDO +!ENDIF + +print*,'********** GAS (input) ************************************************' +!print*,'Appel Allocate gas' +! Convert ozone Pa*kg/kg to kg/kg +! AI ATTENTION +!DO JLEV = 1,KLEV +! DO JLON = KIDIA,KFDIA +! ZO3(JLON,JLEV) = PO3_DP(JLON,JLEV) & +! & / (PPRESSURE_H(JLON,JLEV+1)-PPRESSURE_H(JLON,JLEV)) +! ENDDO +!ENDDO +! Insert gas mixing ratios +!print*,'Insert gas mixing ratios' +CALL gas%put(IH2O, IMassMixingRatio, PQ) +CALL gas%put(IO3, IMassMixingRatio, PO3) +CALL gas%put_well_mixed(ICO2, IMAssMixingRatio, PCO2) +CALL gas%put_well_mixed(ICH4, IMassMixingRatio, PCH4) +CALL gas%put_well_mixed(IN2O, IMassMixingRatio, PN2O) +CALL gas%put_well_mixed(ICFC11, IMassMixingRatio, PCFC11) +CALL gas%put_well_mixed(ICFC12, IMassMixingRatio, PCFC12) +CALL gas%put_well_mixed(IHCFC22, IMassMixingRatio, PHCFC22) +CALL gas%put_well_mixed(ICCL4, IMassMixingRatio, PCCL4) +CALL gas%put_well_mixed(IO2, IMassMixingRatio, PO2) +! Ensure the units of the gas mixing ratios are what is required by +! the gas absorption model +call set_gas_units(rad_config, gas) + +! Call radiation scheme +!print*,'*** Appel radiation *** namelist **** omp_rank ****', & +! omp_rank, namelist_file +! if (rad_config%i_solver_sw == ISolverSPARTACUS) then +! if (driver_config%ok_separation) then +! print*,'Avant radiation, mpi_rank, omp_rank, size, chape inv_cloud = ',& +! mpi_rank, omp_rank, & +! shape(cloud%inv_cloud_effective_size), & +! size(cloud%inv_cloud_effective_size) +! do jlon=KIDIA, KFDIA +! do jlev=1,klev +! print*,' Avant radiation mpi_rank, omp_rank, jlon, jlev, & +! & cloud%inv_cloud_effective_size =', mpi_rank, & +! & omp_rank, jlon, jlev, & +! & cloud%inv_cloud_effective_size(jlon,jlev) +! enddo +! enddo +! cloud%inv_cloud_effective_size=inv_cloud_effective_size +! cloud%inv_inhom_effective_size=inv_inhom_effective_size +! endif +! endif +if (debut_ecrad .and. driver_config%do_save_inputs) & + call save_inputs('inputs.nc', rad_config, single_level, thermodynamics, & + gas, cloud, aerosol, lat = latitude_deg, lon = longitude_deg) + +CALL radiation(KLON, KLEV, KIDIA, KFDIA, rad_config, & + & single_level, thermodynamics, gas, cloud, aerosol, flux) + + if (rad_config%use_aerosols) then + if (rad_config%i_gas_model_sw == IGasModelIFSRRTMG .or. & + & rad_config%i_gas_model_lw == IGasModelIFSRRTMG) then + CALL aeropt_5wv_ecrad(kidia, kfdia, 1, klev, & + & rad_config,thermodynamics, aerosol) + endif + + if (flag_aerosol_strat.eq.2) then + CALL readaerosolstrato_ecrad(rad_config, debut, ok_volcan) + endif + endif + +print*,'*********** Sortie flux ****************' +! Cloud cover +ecrad_cloud_cover_sw = flux%cloud_cover_sw +! Compute required output fluxes +! DN and UP flux +PFLUX_SW_DN(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:) +PFLUX_SW_UP(KIDIA:KFDIA,:) = flux%sw_up(KIDIA:KFDIA,:) +PFLUX_LW_DN(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:) +PFLUX_LW_UP(KIDIA:KFDIA,:) = flux%lw_up(KIDIA:KFDIA,:) +PFLUX_SW_DN_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_clear(KIDIA:KFDIA,:) +PFLUX_SW_UP_CLEAR(KIDIA:KFDIA,:) = flux%sw_up_clear(KIDIA:KFDIA,:) +PFLUX_LW_DN_CLEAR(KIDIA:KFDIA,:) = flux%lw_dn_clear(KIDIA:KFDIA,:) +PFLUX_LW_UP_CLEAR(KIDIA:KFDIA,:) = flux%lw_up_clear(KIDIA:KFDIA,:) +! First the net fluxes +PFLUX_SW(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:) - flux%sw_up(KIDIA:KFDIA,:) +PFLUX_LW(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:) - flux%lw_up(KIDIA:KFDIA,:) +PFLUX_SW_CLEAR(KIDIA:KFDIA,:) & + & = flux%sw_dn_clear(KIDIA:KFDIA,:) - flux%sw_up_clear(KIDIA:KFDIA,:) +PFLUX_LW_CLEAR(KIDIA:KFDIA,:) & + & = flux%lw_dn_clear(KIDIA:KFDIA,:) - flux%lw_up_clear(KIDIA:KFDIA,:) +! Now the surface fluxes +!PFLUX_SW_DN_SURF(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,KLEV+1) +!PFLUX_LW_DN_SURF(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,KLEV+1) +!PFLUX_SW_UP_SURF(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,KLEV+1) +!PFLUX_LW_UP_SURF(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,KLEV+1) +!PFLUX_SW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_dn_clear(KIDIA:KFDIA,KLEV+1) +!PFLUX_LW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_dn_clear(KIDIA:KFDIA,KLEV+1) +!PFLUX_SW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_up_clear(KIDIA:KFDIA,KLEV+1) +!PFLUX_LW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_up_clear(KIDIA:KFDIA,KLEV+1) +! Direct component of flux into horizontal plane +PFLUX_DIR(KIDIA:KFDIA,:) = flux%sw_dn_direct(KIDIA:KFDIA,:) +PFLUX_DIR_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_direct_clear(KIDIA:KFDIA,:) +PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB +WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB)) +! Direct Surface component of flux into a plane perpendicular to the sun + PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA,KLEV+1) / PMU0(KIDIA:KFDIA) +END WHERE +! Top-of-atmosphere downwelling flux +!PFLUX_SW_DN_TOA(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,1) +!PFLUX_SW_UP_TOA(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,1) +!PFLUX_LW_DN_TOA(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,1) +!PFLUX_LW_UP_TOA(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,1) +!AI ATTENTION +if (0.eq.1) then +PFLUX_UV (KIDIA:KFDIA) = 0.0_JPRB +DO JBAND = 1,NWEIGHT_UV + PFLUX_UV(KIDIA:KFDIA) = PFLUX_UV(KIDIA:KFDIA) + WEIGHT_UV(JBAND) & + & * flux%sw_dn_surf_band(IBAND_UV(JBAND),KIDIA:KFDIA) +ENDDO +! Compute photosynthetically active radiation similarly +PFLUX_PAR (KIDIA:KFDIA) = 0.0_JPRB +PFLUX_PAR_CLEAR(KIDIA:KFDIA) = 0.0_JPRB +DO JBAND = 1,NWEIGHT_PAR + PFLUX_PAR(KIDIA:KFDIA) = PFLUX_PAR(KIDIA:KFDIA) + WEIGHT_PAR(JBAND) & + & * flux%sw_dn_surf_band(IBAND_PAR(JBAND),KIDIA:KFDIA) + PFLUX_PAR_CLEAR(KIDIA:KFDIA) = PFLUX_PAR_CLEAR(KIDIA:KFDIA) & + & + WEIGHT_PAR(JBAND) & + & * flux%sw_dn_surf_clear_band(IBAND_PAR(JBAND),KIDIA:KFDIA) +ENDDO +endif +! Compute effective broadband emissivity +ZBLACK_BODY_NET_LW = flux%lw_dn(KIDIA:KFDIA,KLEV+1) & + & - RSIGMA*PTEMPERATURE_SKIN(KIDIA:KFDIA)**4 +PEMIS_OUT(KIDIA:KFDIA) = PEMIS(KIDIA:KFDIA) +WHERE (ABS(ZBLACK_BODY_NET_LW) > 1.0E-5) + PEMIS_OUT(KIDIA:KFDIA) = PFLUX_LW(KIDIA:KFDIA,KLEV+1) / ZBLACK_BODY_NET_LW +END WHERE +! Copy longwave derivatives +! AI ATTENTION +!IF (YRERAD%LAPPROXLWUPDATE) THEN +IF (rad_config%do_lw_derivatives) THEN + PLWDERIVATIVE(KIDIA:KFDIA,:) = flux%lw_derivatives(KIDIA:KFDIA,:) +END IF +! Store the shortwave downwelling fluxes in each albedo band +!AI ATTENTION +!IF (YRERAD%LAPPROXSWUPDATE) THEN +if (0.eq.1) then +IF (rad_config%do_surface_sw_spectral_flux) THEN + PSWDIFFUSEBAND(KIDIA:KFDIA,:) = 0.0_JPRB + PSWDIRECTBAND (KIDIA:KFDIA,:) = 0.0_JPRB + DO JBAND = 1,rad_config%n_bands_sw + JB_ALBEDO = rad_config%i_albedo_from_band_sw(JBAND) + DO JLON = KIDIA,KFDIA + PSWDIFFUSEBAND(JLON,JB_ALBEDO) = PSWDIFFUSEBAND(JLON,JB_ALBEDO) & + & + flux%sw_dn_surf_band(JBAND,JLON) & + & - flux%sw_dn_direct_surf_band(JBAND,JLON) + PSWDIRECTBAND(JLON,JB_ALBEDO) = PSWDIRECTBAND(JLON,JB_ALBEDO) & + & + flux%sw_dn_direct_surf_band(JBAND,JLON) + ENDDO + ENDDO +ENDIF +endif + +print*,'********** DEALLOCATIONS ************************' +CALL single_level%deallocate +CALL thermodynamics%deallocate +CALL gas%deallocate +CALL cloud%deallocate +CALL aerosol%deallocate +CALL flux%deallocate + +IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',1,ZHOOK_HANDLE) +debut_ecrad=.false. + +END SUBROUTINE RADIATION_SCHEME + +SUBROUTINE RADIATION_SCHEME_S2 & +! Inputs + & (KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW, & + & namelist_file, ok_3Deffect, & + & debut, ok_volcan, flag_aerosol_strat, & + & IDAY, TIME, & + & PSOLAR_IRRADIANCE, & + & PMU0, PTEMPERATURE_SKIN, & + & PALBEDO_DIF, PALBEDO_DIR, & + & PEMIS, PEMIS_WINDOW, & + & PGELAM, PGEMU, & + & PPRESSURE_H, PTEMPERATURE_H, PQ, PQSAT, & + & PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, & + & PCCL4, PO3, PO2, & + & PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW, & + & ZRE_LIQUID_UM, ZRE_ICE_UM, & + & PAEROSOL_OLD, PAEROSOL, & +! Outputs + & PFLUX_SW, PFLUX_LW, PFLUX_SW_CLEAR, PFLUX_LW_CLEAR, & + & PFLUX_SW_DN, PFLUX_LW_DN, PFLUX_SW_DN_CLEAR, PFLUX_LW_DN_CLEAR, & + & PFLUX_SW_UP, PFLUX_LW_UP, PFLUX_SW_UP_CLEAR, PFLUX_LW_UP_CLEAR, & + & PFLUX_DIR, PFLUX_DIR_CLEAR, PFLUX_DIR_INTO_SUN, & + & PFLUX_UV, PFLUX_PAR, PFLUX_PAR_CLEAR, & + & PEMIS_OUT, PLWDERIVATIVE, & + & PSWDIFFUSEBAND, PSWDIRECTBAND, & + & ecrad_cloud_cover_sw) + +! RADIATION_SCHEME - Interface to modular radiation scheme +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! PURPOSE +! ------- +! The modular radiation scheme is contained in a separate +! library. This routine puts the the IFS arrays into appropriate +! objects, computing the additional data that is required, and sends +! it to the radiation scheme. It returns net fluxes and surface +! flux components needed by the rest of the model. +! +! Lower case is used for variables and types taken from the +! radiation library +! +! INTERFACE +! --------- +! RADIATION_SCHEME is called from RADLSWR. The +! SETUP_RADIATION_SCHEME routine (in the RADIATION_SETUP module) +! should have been run first. +! +! AUTHOR +! ------ +! Robin Hogan, ECMWF +! Original: 2015-09-16 +! +! MODIFICATIONS +! ------------- +! +! TO DO +! ----- +! +!----------------------------------------------------------------------- + +! Modules from ifs or ifsaux libraries +USE PARKIND1 , ONLY : JPIM, JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK +USE RADIATION_SETUP +USE YOMCST , ONLY : RSIGMA ! Stefan-Boltzmann constant +!USE RADIATION_SETUP, ONLY : SETUP_RADIATION_SCHEME, & +! & config_type, driver_config_type, & +! & NWEIGHT_UV, IBAND_UV, WEIGHT_UV, & +! & NWEIGHT_PAR, IBAND_PAR, WEIGHT_PAR, & +! & ITYPE_TROP_BG_AER, TROP_BG_AER_MASS_EXT, & +! & ITYPE_STRAT_BG_AER, STRAT_BG_AER_MASS_EXT, & +! & ISolverSpartacus + +! Modules from radiation library +USE radiation_single_level, ONLY : single_level_type +USE radiation_thermodynamics, ONLY : thermodynamics_type +USE radiation_gas +USE radiation_cloud, ONLY : cloud_type +USE radiation_aerosol, ONLY : aerosol_type +USE radiation_flux, ONLY : flux_type +USE radiation_interface, ONLY : radiation, set_gas_units +USE radiation_save, ONLY : save_inputs + +USE mod_phys_lmdz_para + +IMPLICIT NONE + +! INPUT ARGUMENTS +! *** Array dimensions and ranges +INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA ! Start column to process +INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA ! End column to process +!INTEGER, INTENT(IN) :: KIDIA, KFDIA +INTEGER(KIND=JPIM),INTENT(IN) :: KLON ! Number of columns +INTEGER(KIND=JPIM),INTENT(IN) :: KLEV ! Number of levels +!INTEGER, INTENT(IN) :: KLON, KLEV +!INTEGER(KIND=JPIM),INTENT(IN) :: KAEROLMDZ ! Number of aerosol types +INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL +INTEGER(KIND=JPIM),INTENT(IN) :: NSW ! Numbe of bands + +! AI ATTENTION +!INTEGER, PARAMETER :: KAEROSOL = 12 + +! *** Single-level fields +REAL(KIND=JPRB), INTENT(IN) :: PSOLAR_IRRADIANCE ! (W m-2) +REAL(KIND=JPRB), INTENT(IN) :: PMU0(KLON) ! Cosine of solar zenith ang +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE_SKIN(KLON) ! (K) +! Diffuse and direct components of surface shortwave albedo +!REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIF(KLON,YRERAD%NSW) +!REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIR(KLON,YRERAD%NSW) +REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIF(KLON,NSW) +REAL(KIND=JPRB), INTENT(IN) :: PALBEDO_DIR(KLON,NSW) +! Longwave emissivity outside and inside the window region +REAL(KIND=JPRB), INTENT(IN) :: PEMIS(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PEMIS_WINDOW(KLON) +! Longitude (radians), sine of latitude +REAL(KIND=JPRB), INTENT(IN) :: PGELAM(KLON) +REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) +! Land-sea mask +!REAL(KIND=JPRB), INTENT(IN) :: PLAND_SEA_MASK(KLON) + +! *** Variables on half levels +REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1) ! (Pa) +REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE_H(KLON,KLEV+1) ! (K) + +! *** Gas mass mixing ratios on full levels +REAL(KIND=JPRB), INTENT(IN) :: PQ(KLON,KLEV) +! AI +REAL(KIND=JPRB), INTENT(IN) :: PQSAT(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PCO2 +REAL(KIND=JPRB), INTENT(IN) :: PCH4 +REAL(KIND=JPRB), INTENT(IN) :: PN2O +REAL(KIND=JPRB), INTENT(IN) :: PNO2 +REAL(KIND=JPRB), INTENT(IN) :: PCFC11 +REAL(KIND=JPRB), INTENT(IN) :: PCFC12 +REAL(KIND=JPRB), INTENT(IN) :: PHCFC22 +REAL(KIND=JPRB), INTENT(IN) :: PCCL4 +REAL(KIND=JPRB), INTENT(IN) :: PO3(KLON,KLEV) ! AI (kg/kg) ATTENTION (Pa*kg/kg) +REAL(KIND=JPRB), INTENT(IN) :: PO2 + +! *** Cloud fraction and hydrometeor mass mixing ratios +REAL(KIND=JPRB), INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_LIQUID(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_ICE(KLON,KLEV) +!REAL(KIND=JPRB), INTENT(IN) :: PQ_RAIN(KLON,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PQ_SNOW(KLON,KLEV) + +! *** Aerosol mass mixing ratios +REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL_OLD(KLON,6,KLEV) +REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL) + +!REAL(KIND=JPRB), INTENT(IN) :: PCCN_LAND(KLON) +!REAL(KIND=JPRB), INTENT(IN) :: PCCN_SEA(KLON) + +!AI mars 2021 +INTEGER(KIND=JPIM), INTENT(IN) :: IDAY +REAL(KIND=JPRB), INTENT(IN) :: TIME + +! Name of file names specified on command line +character(len=512), INTENT(IN) :: namelist_file +logical, INTENT(IN) :: ok_3Deffect, debut, ok_volcan +INTEGER(KIND=JPIM), INTENT(IN) :: flag_aerosol_strat + + +! OUTPUT ARGUMENTS + +! *** Net fluxes on half-levels (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_CLEAR(KLON,KLEV+1) + +!*** DN and UP flux on half-levels (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_DN(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_DN_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_DN_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_UP(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_UP(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_SW_UP_CLEAR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_LW_UP_CLEAR(KLON,KLEV+1) + +! Direct component of surface flux into horizontal plane +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON,KLEV+1) +! As PFLUX_DIR but into a plane perpendicular to the sun +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON) + +! *** Ultraviolet and photosynthetically active radiation (W m-2) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_UV(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_PAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_PAR_CLEAR(KLON) + +! Diagnosed longwave surface emissivity across the whole spectrum +REAL(KIND=JPRB), INTENT(OUT) :: PEMIS_OUT(KLON) + +! Partial derivative of total-sky longwave upward flux at each level +! with respect to upward flux at surface, used to correct heating +! rates at gridpoints/timesteps between calls to the full radiation +! scheme. Note that this version uses the convention of level index +! increasing downwards, unlike the local variable ZLwDerivative that +! is returned from the LW radiation scheme. +REAL(KIND=JPRB), INTENT(OUT) :: PLWDERIVATIVE(KLON,KLEV+1) + +! Surface diffuse and direct downwelling shortwave flux in each +! shortwave albedo band, used in RADINTG to update the surface fluxes +! accounting for high-resolution albedo information +REAL(KIND=JPRB), INTENT(OUT) :: PSWDIFFUSEBAND(KLON,NSW) +REAL(KIND=JPRB), INTENT(OUT) :: PSWDIRECTBAND (KLON,NSW) + +!AI Nov 2023 +REAL(KIND=JPRB), INTENT(OUT) :: ecrad_cloud_cover_sw(KLON) + +! LOCAL VARIABLES +! AI ATTENTION +type(config_type),save :: rad_config +!!$OMP THREADPRIVATE(rad_config) +type(driver_config_type),save :: driver_config +!!$OMP THREADPRIVATE(driver_config) +!type(config_type) :: rad_config +!type(driver_config_type) :: driver_config +TYPE(single_level_type) :: single_level +TYPE(thermodynamics_type) :: thermodynamics +TYPE(gas_type) :: gas +TYPE(cloud_type) :: cloud +TYPE(aerosol_type) :: aerosol +TYPE(flux_type) :: flux + +! Mass mixing ratio of ozone (kg/kg) +REAL(KIND=JPRB) :: ZO3(KLON,KLEV) + +! Cloud effective radii in microns +REAL(KIND=JPRB) :: ZRE_LIQUID_UM(KLON,KLEV) +REAL(KIND=JPRB) :: ZRE_ICE_UM(KLON,KLEV) + +! Cloud overlap decorrelation length for cloud boundaries in km +REAL(KIND=JPRB) :: ZDECORR_LEN_M +REAL(KIND=JPRB) :: ZDECORR_LEN_M_1D(KLON) +REAL(KIND=JPRB) :: ZDECORR_LEN_M_2D(KLON,KLEV) + +! Ratio of cloud overlap decorrelation length for cloud water +! inhomogeneities to that for cloud boundaries (typically 0.5) +!REAL(KIND=JPRB) :: ZDECORR_LEN_RATIO = 0.5_jprb + +! The surface net longwave flux if the surface was a black body, used +! to compute the effective broadband surface emissivity +REAL(KIND=JPRB) :: ZBLACK_BODY_NET_LW(KIDIA:KFDIA) + +! Layer mass in kg m-2 +REAL(KIND=JPRB) :: ZLAYER_MASS(KIDIA:KFDIA,KLEV) + +! Time integers +INTEGER :: ITIM + +! Loop indices +INTEGER :: JLON, JLEV, JBAND, JB_ALBEDO, JAER + +REAL(KIND=JPRB) :: ZHOOK_HANDLE + +! AI ATTENTION traitement aerosols +INTEGER, PARAMETER :: NAERMACC = 1 + +logical :: loutput=.true. +logical :: lprint_input=.false. +logical :: lprint_config=.false. +logical, save :: debut_ecrad=.true. +!$OMP THREADPRIVATE(debut_ecrad) +integer, save :: itap_ecrad=0 +!$OMP THREADPRIVATE(itap_ecrad) + +REAL(KIND=JPRB) :: inv_cloud_effective_size(KLON,KLEV) +REAL(KIND=JPRB) :: inv_inhom_effective_size(KLON,KLEV) + +integer :: irang + + +IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',0,ZHOOK_HANDLE) + + print*,'Entree radiation_scheme_s2, ok_3Deffect, namelist_file = ', & + ok_3Deffect, namelist_file +! A.I juillet 2023 : +! Initialisation dans radiation_setup au 1er passage dans Ecrad +!$OMP MASTER +!if (.not.ok_3Deffect) then + if (debut_ecrad) then + call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config) + debut_ecrad=.false. + endif +!else +! call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config) +!endif +!$OMP END MASTER +!$OMP BARRIER +! Fin partie initialisation et configuration + +!AI print fichiers namelist utilise +!if (is_omp_root) then +! itap_ecrad=itap_ecrad+1 +! print*,'Dans radiation_scheme itap_ecrad, mpi_rank, omp_rank, namelist_file : ', & +! itap_ecrad, mpi_rank, omp_rank, namelist_file +!else +! print*,'mpi_rank omp_rank, namelist_file :', mpi_rank, omp_rank, namelist_file +!endif + +! AI 11 23 Allocates depplaces au debut +print*,'*********** ALLOCATES *******************************' +! AI ATTENTION +! Allocate memory in radiation objects +! emissivite avec une seule bande +CALL single_level%allocate(KLON, NSW, 1, & + & use_sw_albedo_direct=.TRUE.) +CALL thermodynamics%allocate(KLON, KLEV, use_h2o_sat=.true.) +CALL cloud%allocate(KLON, KLEV) +CALL aerosol%allocate(KLON, 1, KLEV, KAEROSOL) +CALL gas%allocate(KLON, KLEV) +CALL flux%allocate(rad_config, 1, KLON, KLEV) + +print*,'************* THERMO (input) ************************************' +! Set thermodynamic profiles: simply copy over the half-level +! pressure and temperature +! AI +! pressure_hl > paprs +! temperature_hl calculee dans radlsw de la meme facon que pour RRTM +thermodynamics%pressure_hl (KIDIA:KFDIA,:) = PPRESSURE_H (KIDIA:KFDIA,:) +thermodynamics%temperature_hl(KIDIA:KFDIA,:) = PTEMPERATURE_H(KIDIA:KFDIA,:) +!print*,'Compute saturation specific humidity' +! Compute saturation specific humidity, used to hydrate aerosols. The +! "2" for the last argument indicates that the routine is not being +! called from within the convection scheme. +!CALL SATUR(KIDIA, KFDIA, KLON, 1, KLEV, & +! & PPRESSURE, PTEMPERATURE, thermodynamics%h2o_sat_liq, 2) +! Alternative approximate version using temperature and pressure from +! the thermodynamics structure +!CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA) +!AI ATTENTION +thermodynamics%h2o_sat_liq = PQSAT + +print*,'********** SINGLE LEVEL VARS **********************************' +!AI ATTENTION +! Set single-level fileds +single_level%solar_irradiance = PSOLAR_IRRADIANCE +single_level%cos_sza(KIDIA:KFDIA) = PMU0(KIDIA:KFDIA) +single_level%skin_temperature(KIDIA:KFDIA) = PTEMPERATURE_SKIN(KIDIA:KFDIA) +single_level%sw_albedo(KIDIA:KFDIA,:) = PALBEDO_DIF(KIDIA:KFDIA,:) +single_level%sw_albedo_direct(KIDIA:KFDIA,:)=PALBEDO_DIR(KIDIA:KFDIA,:) +single_level%lw_emissivity(KIDIA:KFDIA,1) = PEMIS(KIDIA:KFDIA) +!single_level%lw_emissivity(KIDIA:KFDIA,2) = PEMIS_WINDOW(KIDIA:KFDIA) + +! Create the relevant seed from date and time get the starting day +! and number of minutes since start +!IDAY = NDD(NINDAT) +!cur_day +!ITIM = NINT(NSTEP * YRRIP%TSTEP / 60.0_JPRB) +!ITIM = NINT(TIME / 60.0_JPRB) +!current_time +!allocate(single_level%iseed(KIDIA:KFDIA)) +!DO JLON = KIDIA, KFDIA + ! This method gives a unique value for roughly every 1-km square + ! on the globe and every minute. ASIN(PGEMU)*60 gives rough + ! latitude in degrees, which we multiply by 100 to give a unique + ! value for roughly every km. PGELAM*60*100 gives a unique number + ! for roughly every km of longitude around the equator, which we + ! multiply by 180*100 so there is no overlap with the latitude + ! values. The result can be contained in a 32-byte integer (but + ! since random numbers are generated with the help of integer + ! overflow, it should not matter if the number did overflow). +! single_level%iseed(JLON) = ITIM + IDAY & +! & + NINT(PGELAM(JLON)*108000000.0_JPRB & +! & + ASIN(PGEMU(JLON))*6000.0_JPRB) +!ENDDO +!AI Nov 23 +! Simple initialization of the seeds for the Monte Carlo scheme +call single_level%init_seed_simple(kidia, kfdia) + +print*,'********** CLOUDS (allocate + input) *******************************************' +!print*,'Appel Allocate clouds' +! Set cloud fields +cloud%q_liq(KIDIA:KFDIA,:) = PQ_LIQUID(KIDIA:KFDIA,:) +cloud%q_ice(KIDIA:KFDIA,:) = PQ_ICE(KIDIA:KFDIA,:) + PQ_SNOW(KIDIA:KFDIA,:) +cloud%fraction(KIDIA:KFDIA,:) = PCLOUD_FRAC(KIDIA:KFDIA,:) +!!! ok AI ATTENTION a voir avec JL +! Compute effective radi and convert to metres +! AI. : on passe directement les champs de LMDZ +cloud%re_liq(KIDIA:KFDIA,:) = ZRE_LIQUID_UM(KIDIA:KFDIA,:) +cloud%re_ice(KIDIA:KFDIA,:) = ZRE_ICE_UM(KIDIA:KFDIA,:) +! Get the cloud overlap decorrelation length (for cloud boundaries), +! in km, according to the parameterization specified by NDECOLAT, +! and insert into the "cloud" object. Also get the ratio of +! decorrelation lengths for cloud water content inhomogeneities and +! cloud boundaries, and set it in the "rad_config" object. +! IFS : +!CALL CLOUD_OVERLAP_DECORR_LEN(KIDIA, KFDIA, KLON, PGEMU, YRERAD%NDECOLAT, & +! & ZDECORR_LEN_KM, PDECORR_LEN_RATIO=ZDECORR_LEN_RATIO) +! AI valeur dans namelist +! rad_config%cloud_inhom_decorr_scaling = ZDECORR_LEN_RATIO +!AI ATTENTION meme valeur que dans offline +! A mettre dans namelist + CALL CALCUL_CLOUD_OVERLAP_DECORR_LEN & + & (KIDIA, KFDIA, KLON, KLEV, & + & driver_config, & + & thermodynamics%pressure_hl , & + & ZDECORR_LEN_M_2D) + + if (driver_config%kdecolat.eq.0) then + ZDECORR_LEN_M = ZDECORR_LEN_M_2D(1,1) + DO JLON = KIDIA,KFDIA + CALL cloud%set_overlap_param(thermodynamics, & + & ZDECORR_LEN_M, & + & istartcol=JLON, iendcol=JLON) + ENDDO + else if (driver_config%kdecolat.eq.1.or.driver_config%kdecolat.eq.2) then + ZDECORR_LEN_M_1D = ZDECORR_LEN_M_2D(:,1) + DO JLON = KIDIA,KFDIA + CALL cloud%set_overlap_param(thermodynamics, & + & ZDECORR_LEN_M_1D, & + & istartcol=JLON, iendcol=JLON) + ENDDO + else if (driver_config%kdecolat.eq.3) then + DO JLON = KIDIA,KFDIA + CALL cloud%set_overlap_param_var2D(thermodynamics, & + & ZDECORR_LEN_M_2D, KLEV, & + & istartcol=JLON, iendcol=JLON) + ENDDO + endif + +! IFS : +! Cloud water content fractional standard deviation is configurable +! from namelist NAERAD but must be globally constant. Before it was +! hard coded at 1.0. +!CALL cloud%create_fractional_std(KLON, KLEV, YRERAD%RCLOUD_FRAC_STD) +! AI ATTENTION frac_std=0.75 meme valeur que dans la version offline +CALL cloud%create_fractional_std(KLON, KLEV, driver_config%frac_std) + +!if (ok_3Deffect) then +! if (driver_config%ok_effective_size) then +! call cloud%create_inv_cloud_effective_size_eta(klon, klev, & +! & thermodynamics%pressure_hl, & +! & driver_config%low_inv_effective_size, & +! & driver_config%middle_inv_effective_size, & +! & driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, & +! & KIDIA, KFDIA) +! else if (driver_config%ok_separation) then +! call cloud%param_cloud_effective_separation_eta(klon, klev, & +! & thermodynamics%pressure_hl, & +! & driver_config%cloud_separation_scale_surface, & +! & driver_config%cloud_separation_scale_toa, & +! & driver_config%cloud_separation_scale_power, & +! & driver_config%cloud_inhom_separation_factor, & +! & KIDIA, KFDIA) +! endif +! else + if (rad_config%i_solver_sw == ISolverSPARTACUS & + & .or. rad_config%i_solver_lw == ISolverSPARTACUS) then + ! AI ! Read cloud properties needed by SPARTACUS + if (driver_config%ok_effective_size) then + call cloud%create_inv_cloud_effective_size_eta(klon, klev, & + & thermodynamics%pressure_hl, & + & driver_config%low_inv_effective_size, & + & driver_config%middle_inv_effective_size, & + & driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, & + & KIDIA, KFDIA) + else if (driver_config%ok_separation_eta) then + call cloud%param_cloud_effective_separation_eta(klon, klev, & + & thermodynamics%pressure_hl, & + & driver_config%cloud_separation_scale_surface, & + & driver_config%cloud_separation_scale_toa, & + & driver_config%cloud_separation_scale_power, & + & driver_config%cloud_inhom_separation_factor, & + & KIDIA, KFDIA) + else if (driver_config%ok_separation_tanh) then + call cloud%param_cloud_effective_separation_tanh(klon, klev, & + & thermodynamics%pressure_hl, & + & driver_config%cloud_separation_scale_surface, & + & driver_config%cloud_separation_scale_toa, & + & driver_config%cloud_separation_scale_power, & + & driver_config%cloud_inhom_separation_factor, & + & KIDIA, KFDIA) + endif + endif +!endif + +print*,'******** AEROSOLS (input) **************************************' +!IF (NAERMACC > 0) THEN +!ELSE +! CALL aerosol%allocate(KLON, 1, KLEV, 6) ! Tegen climatology +!ENDIF +! Compute the dry mass of each layer neglecting humidity effects, in +! kg m-2, needed to scale some of the aerosol inputs +! AI commente ATTENTION +!CALL thermodynamics%get_layer_mass(ZLAYER_MASS) + +! Copy over aerosol mass mixing ratio +!IF (NAERMACC > 0) THEN + + ! MACC aerosol climatology - this is already in mass mixing ratio + ! units with the required array orientation so we can copy it over + ! directly + aerosol%mixing_ratio(KIDIA:KFDIA,:,:) = PAEROSOL(KIDIA:KFDIA,:,:) + + ! Add the tropospheric and stratospheric backgrounds contained in the + ! old Tegen arrays - this is very ugly! +! AI ATTENTION +! IF (TROP_BG_AER_MASS_EXT > 0.0_JPRB) THEN +! aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) & +! & = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) & +! & + PAEROSOL_OLD(KIDIA:KFDIA,1,:) & +! & / (ZLAYER_MASS * TROP_BG_AER_MASS_EXT) +! ENDIF +! IF (STRAT_BG_AER_MASS_EXT > 0.0_JPRB) THEN +! aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) & +! & = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) & +! & + PAEROSOL_OLD(KIDIA:KFDIA,6,:) & +! & / (ZLAYER_MASS * STRAT_BG_AER_MASS_EXT) +! ENDIF + +!ELSE + + ! Tegen aerosol climatology - the array PAEROSOL_OLD contains the + ! 550-nm optical depth in each layer. The optics data file + ! aerosol_ifs_rrtm_tegen.nc does not contain mass extinction + ! coefficient, but a scaling factor that the 550-nm optical depth + ! should be multiplied by to obtain the optical depth in each + ! spectral band. Therefore, in order for the units to work out, we + ! need to divide by the layer mass (in kg m-2) to obtain the 550-nm + ! cross-section per unit mass of dry air (so in m2 kg-1). We also + ! need to permute the array. +! DO JLEV = 1,KLEV +! DO JAER = 1,6 +! aerosol%mixing_ratio(KIDIA:KFDIA,JLEV,JAER) & +! & = PAEROSOL_OLD(KIDIA:KFDIA,JAER,JLEV) & +! & / ZLAYER_MASS(KIDIA:KFDIA,JLEV) +! ENDDO +! ENDDO +!ENDIF + +print*,'********** GAS (input) ************************************************' +!print*,'Appel Allocate gas' +! Convert ozone Pa*kg/kg to kg/kg +! AI ATTENTION +!DO JLEV = 1,KLEV +! DO JLON = KIDIA,KFDIA +! ZO3(JLON,JLEV) = PO3_DP(JLON,JLEV) & +! & / (PPRESSURE_H(JLON,JLEV+1)-PPRESSURE_H(JLON,JLEV)) +! ENDDO +!ENDDO +! Insert gas mixing ratios +!print*,'Insert gas mixing ratios' +CALL gas%put(IH2O, IMassMixingRatio, PQ) +CALL gas%put(IO3, IMassMixingRatio, PO3) +CALL gas%put_well_mixed(ICO2, IMAssMixingRatio, PCO2) +CALL gas%put_well_mixed(ICH4, IMassMixingRatio, PCH4) +CALL gas%put_well_mixed(IN2O, IMassMixingRatio, PN2O) +CALL gas%put_well_mixed(ICFC11, IMassMixingRatio, PCFC11) +CALL gas%put_well_mixed(ICFC12, IMassMixingRatio, PCFC12) +CALL gas%put_well_mixed(IHCFC22, IMassMixingRatio, PHCFC22) +CALL gas%put_well_mixed(ICCL4, IMassMixingRatio, PCCL4) +CALL gas%put_well_mixed(IO2, IMassMixingRatio, PO2) +! Ensure the units of the gas mixing ratios are what is required by +! the gas absorption model +call set_gas_units(rad_config, gas) + +! Call radiation scheme +!print*,'*** Appel radiation *** namelist **** omp_rank ****', & +! omp_rank, namelist_file +! if (rad_config%i_solver_sw == ISolverSPARTACUS) then +! if (driver_config%ok_separation) then +! print*,'Avant radiation, mpi_rank, omp_rank, size, chape inv_cloud = ',& +! mpi_rank, omp_rank, & +! shape(cloud%inv_cloud_effective_size), & +! size(cloud%inv_cloud_effective_size) +! do jlon=KIDIA, KFDIA +! do jlev=1,klev +! print*,' Avant radiation mpi_rank, omp_rank, jlon, jlev, & +! & cloud%inv_cloud_effective_size =', mpi_rank, & +! & omp_rank, jlon, jlev, & +! & cloud%inv_cloud_effective_size(jlon,jlev) +! enddo +! enddo +! cloud%inv_cloud_effective_size=inv_cloud_effective_size +! cloud%inv_inhom_effective_size=inv_inhom_effective_size +! endif +! endif +CALL radiation(KLON, KLEV, KIDIA, KFDIA, rad_config, & + & single_level, thermodynamics, gas, cloud, aerosol, flux) + + if (rad_config%use_aerosols) then + if (rad_config%i_gas_model_sw == IGasModelIFSRRTMG .or. & + & rad_config%i_gas_model_lw == IGasModelIFSRRTMG) then + CALL aeropt_5wv_ecrad(kidia, kfdia, 1, klev, & + rad_config,thermodynamics,aerosol) + endif + if (flag_aerosol_strat.eq.2) then + CALL readaerosolstrato_ecrad(rad_config, debut, ok_volcan) + endif + endif + +print*,'*********** Sortie flux ****************' +! Cloud cover +ecrad_cloud_cover_sw = flux%cloud_cover_sw +! Compute required output fluxes +! DN and UP flux +PFLUX_SW_DN(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:) +PFLUX_SW_UP(KIDIA:KFDIA,:) = flux%sw_up(KIDIA:KFDIA,:) +PFLUX_LW_DN(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:) +PFLUX_LW_UP(KIDIA:KFDIA,:) = flux%lw_up(KIDIA:KFDIA,:) +PFLUX_SW_DN_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_clear(KIDIA:KFDIA,:) +PFLUX_SW_UP_CLEAR(KIDIA:KFDIA,:) = flux%sw_up_clear(KIDIA:KFDIA,:) +PFLUX_LW_DN_CLEAR(KIDIA:KFDIA,:) = flux%lw_dn_clear(KIDIA:KFDIA,:) +PFLUX_LW_UP_CLEAR(KIDIA:KFDIA,:) = flux%lw_up_clear(KIDIA:KFDIA,:) +! First the net fluxes +PFLUX_SW(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:) - flux%sw_up(KIDIA:KFDIA,:) +PFLUX_LW(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:) - flux%lw_up(KIDIA:KFDIA,:) +PFLUX_SW_CLEAR(KIDIA:KFDIA,:) & + & = flux%sw_dn_clear(KIDIA:KFDIA,:) - flux%sw_up_clear(KIDIA:KFDIA,:) +PFLUX_LW_CLEAR(KIDIA:KFDIA,:) & + & = flux%lw_dn_clear(KIDIA:KFDIA,:) - flux%lw_up_clear(KIDIA:KFDIA,:) +! Now the surface fluxes +!PFLUX_SW_DN_SURF(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,KLEV+1) +!PFLUX_LW_DN_SURF(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,KLEV+1) +!PFLUX_SW_UP_SURF(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,KLEV+1) +!PFLUX_LW_UP_SURF(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,KLEV+1) +!PFLUX_SW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_dn_clear(KIDIA:KFDIA,KLEV+1) +!PFLUX_LW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_dn_clear(KIDIA:KFDIA,KLEV+1) +!PFLUX_SW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_up_clear(KIDIA:KFDIA,KLEV+1) +!PFLUX_LW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_up_clear(KIDIA:KFDIA,KLEV+1) +PFLUX_DIR(KIDIA:KFDIA,:) = flux%sw_dn_direct(KIDIA:KFDIA,:) +PFLUX_DIR_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_direct_clear(KIDIA:KFDIA,:) +PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB +WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB)) + PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA,KLEV+1) / PMU0(KIDIA:KFDIA) +END WHERE +! Top-of-atmosphere downwelling flux +!PFLUX_SW_DN_TOA(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,1) +!PFLUX_SW_UP_TOA(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,1) +!PFLUX_LW_DN_TOA(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,1) +!PFLUX_LW_UP_TOA(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,1) +!AI ATTENTION +if (0.eq.1) then +PFLUX_UV (KIDIA:KFDIA) = 0.0_JPRB +DO JBAND = 1,NWEIGHT_UV + PFLUX_UV(KIDIA:KFDIA) = PFLUX_UV(KIDIA:KFDIA) + WEIGHT_UV(JBAND) & + & * flux%sw_dn_surf_band(IBAND_UV(JBAND),KIDIA:KFDIA) +ENDDO +! Compute photosynthetically active radiation similarly +PFLUX_PAR (KIDIA:KFDIA) = 0.0_JPRB +PFLUX_PAR_CLEAR(KIDIA:KFDIA) = 0.0_JPRB +DO JBAND = 1,NWEIGHT_PAR + PFLUX_PAR(KIDIA:KFDIA) = PFLUX_PAR(KIDIA:KFDIA) + WEIGHT_PAR(JBAND) & + & * flux%sw_dn_surf_band(IBAND_PAR(JBAND),KIDIA:KFDIA) + PFLUX_PAR_CLEAR(KIDIA:KFDIA) = PFLUX_PAR_CLEAR(KIDIA:KFDIA) & + & + WEIGHT_PAR(JBAND) & + & * flux%sw_dn_surf_clear_band(IBAND_PAR(JBAND),KIDIA:KFDIA) +ENDDO +endif +! Compute effective broadband emissivity +ZBLACK_BODY_NET_LW = flux%lw_dn(KIDIA:KFDIA,KLEV+1) & + & - RSIGMA*PTEMPERATURE_SKIN(KIDIA:KFDIA)**4 +PEMIS_OUT(KIDIA:KFDIA) = PEMIS(KIDIA:KFDIA) +WHERE (ABS(ZBLACK_BODY_NET_LW) > 1.0E-5) + PEMIS_OUT(KIDIA:KFDIA) = PFLUX_LW(KIDIA:KFDIA,KLEV+1) / ZBLACK_BODY_NET_LW +END WHERE +! Copy longwave derivatives +! AI ATTENTION +!IF (YRERAD%LAPPROXLWUPDATE) THEN +IF (rad_config%do_lw_derivatives) THEN + PLWDERIVATIVE(KIDIA:KFDIA,:) = flux%lw_derivatives(KIDIA:KFDIA,:) +END IF +! Store the shortwave downwelling fluxes in each albedo band +!AI ATTENTION +!IF (YRERAD%LAPPROXSWUPDATE) THEN +if (0.eq.1) then +IF (rad_config%do_surface_sw_spectral_flux) THEN + PSWDIFFUSEBAND(KIDIA:KFDIA,:) = 0.0_JPRB + PSWDIRECTBAND (KIDIA:KFDIA,:) = 0.0_JPRB + DO JBAND = 1,rad_config%n_bands_sw + JB_ALBEDO = rad_config%i_albedo_from_band_sw(JBAND) + DO JLON = KIDIA,KFDIA + PSWDIFFUSEBAND(JLON,JB_ALBEDO) = PSWDIFFUSEBAND(JLON,JB_ALBEDO) & + & + flux%sw_dn_surf_band(JBAND,JLON) & + & - flux%sw_dn_direct_surf_band(JBAND,JLON) + PSWDIRECTBAND(JLON,JB_ALBEDO) = PSWDIRECTBAND(JLON,JB_ALBEDO) & + & + flux%sw_dn_direct_surf_band(JBAND,JLON) + ENDDO + ENDDO +ENDIF +endif + +print*,'********** DEALLOCATIONS ************************' +CALL single_level%deallocate +CALL thermodynamics%deallocate +CALL gas%deallocate +CALL cloud%deallocate +CALL aerosol%deallocate +CALL flux%deallocate + +IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',1,ZHOOK_HANDLE) + +END SUBROUTINE RADIATION_SCHEME_S2 + +end module interface_lmdz_ecrad Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/radiation_setup.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/radiation_setup.f90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/radiation_setup.f90 (revision 6016) @@ -0,0 +1,149 @@ +MODULE RADIATION_SETUP + + ! RADIATION_SETUP - Setting up modular radiation scheme + ! + ! AUTHOR + ! ------ + ! Robin Hogan, ECMWF + ! Original: 2015-09-16 + ! + ! MODIFICATIONS + ! ------------- + ! Abderrahmane Idelkadi LMD, juillet 2023 + ! + !----------------------------------------------------------------------- + + USE PARKIND1, ONLY : JPRB + USE radiation_config, ONLY : config_type, & + & ISolverMcICA, ISolverSpartacus, & + & ILiquidModelSlingo, ILiquidModelSOCRATES, & + & IIceModelFu, IIceModelBaran, IGasModelECCKD, & + & IGasModelIFSRRTMG, IOverlapExponentialRandom + + USE radiation_interface, ONLY : setup_radiation + USE setup_config_from_lmdz, ONLY : driver_config_type + + IMPLICIT NONE + + + ! Ultraviolet weightings + INTEGER :: NWEIGHT_UV + INTEGER :: IBAND_UV(100) + REAL(KIND=JPRB) :: WEIGHT_UV(100) + ! Photosynthetically active radiation weightings + INTEGER :: NWEIGHT_PAR + INTEGER :: IBAND_PAR(100) + REAL(KIND=JPRB) :: WEIGHT_PAR(100) + + ! Background aerosol is specified in an ugly way: using the old + ! Tegen fields that are in terms of optical depth, and converted to + ! mass mixing ratio via the relevant mass-extinction coefficient + INTEGER, PARAMETER :: ITYPE_TROP_BG_AER = 8 ! hydrophobic organic + INTEGER, PARAMETER :: ITYPE_STRAT_BG_AER=12 ! non-absorbing sulphate + REAL(KIND=JPRB) :: TROP_BG_AER_MASS_EXT + REAL(KIND=JPRB) :: STRAT_BG_AER_MASS_EXT + +CONTAINS + + ! This routine copies information between the LMDZ radiation + ! configuration (stored in global variables) and the radiation + ! configuration of the modular radiation scheme (stored in + ! rad_config). The optional input logical LOUTPUT controls whether + ! to print lots of information during the setup stage (default is + ! no). + ! AI At the end of the routine, the parameters are read in namelist + ! + SUBROUTINE SETUP_RADIATION_SCHEME(LOUTPUT,file_name,rad_config,driver_config) + + ! USE radiation_config, ONLY : config_type, & + ! & ISolverMcICA, ISolverSpartacus, & + ! & ILiquidModelSlingo, ILiquidModelSOCRATES, & + ! & IIceModelFu, IIceModelBaran, & + ! & IOverlapExponentialRandom + USE mod_phys_lmdz_para + + USE YOMHOOK, ONLY : LHOOK, DR_HOOK + USE YOMLUN, ONLY : NULOUT, NULERR + USE YOESRTWN, ONLY : NMPSRTM + + ! USE radiation_interface, ONLY : setup_radiation + ! USE setup_config_from_lmdz, ONLY : driver_config_type + + ! Whether or not to provide information on the radiation scheme + ! configuration + LOGICAL, INTENT(IN), OPTIONAL :: LOUTPUT + + REAL(KIND=JPRB) :: ZHOOK_HANDLE + + character(len=512) :: file_name + + logical :: lprint_setp=.TRUE. + + ! Store configuration information for the radiation scheme in a + ! global variable + type(config_type) :: rad_config + type(driver_config_type) :: driver_config + + IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',0,ZHOOK_HANDLE) + + ! *** GENERAL SETUP *** + + ! Configure verbosity of setup of radiation scheme + + print*,'********** Dans radiation_setup *****************' + + rad_config%i_aerosol_type_map(1:13) = (/ & + & -1, & + & -2, & + & -3, & + & -4, & + & -5, & + & -6, & + & -7, & + & 1, & + & 2, & + & 3, & + & -8, & + & -9, & + & 4 /) + + ! Populate the mapping between the 14 RRTM shortwave bands and the + ! 6 albedo inputs. The mapping according to the stated wavelength + ! ranges of the 6-band model does not match the hard-wired mapping + ! in NMPSRTM, but only the hard-wired values produce sensible + ! results... + ! Note that NMPSRTM(:)=(/ 6, 6, 5, 5, 5, 5, 5, 4, 4, 3, 2, 2, 1, 6 /) + ! AI (6 albedo SW bands) + call rad_config%define_sw_albedo_intervals(6, & + & [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, & + & 1.19e-6_jprb, 2.38e-6_jprb], [1,2,3,4,5,6]) + ! Likewise between the 16 RRTM longwave bands and the 2 emissivity + ! inputs (info taken from rrtm_ecrt_140gp_mcica.F90) representing + ! outside and inside the window region of the spectrum + ! rad_config%i_emiss_from_band_lw = (/ 1,1,1,1,1,2,2,2,1,1,1,1,1,1,1,1 /) + ! AI ATTENTION ????? + !! call rad_config%define_lw_emiss_intervals(3, & + !! & (/ 8.0e-6_jprb,13.0e-6_jprb /), (/ 1,2,1 /)) + + ! AI ATTENTION (parameters read in namelist file) + ! file_name="namelist_ecrad" + call rad_config%read(file_name=file_name) + call driver_config%read(file_name) + call rad_config%print(iverbose = 2) + + ! Use configuration data to set-up radiation scheme, including + ! reading scattering datafiles + CALL setup_radiation(rad_config) + + ! ! Get spectral weightings for UV and PAR + call rad_config%get_sw_weights(0.2e-6_jprb, 0.4415e-6_jprb, & + & NWEIGHT_UV, IBAND_UV, WEIGHT_UV, 'ultraviolet') + call rad_config%get_sw_weights(0.4e-6_jprb, 0.7e-6_jprb, & + & NWEIGHT_PAR, IBAND_PAR, WEIGHT_PAR, & + & 'photosynthetically active radiation, PAR') + + IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',1,ZHOOK_HANDLE) + + END SUBROUTINE SETUP_RADIATION_SCHEME + +END MODULE RADIATION_SETUP Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/readaerosol_optic_ecrad.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/readaerosol_optic_ecrad.f90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/readaerosol_optic_ecrad.f90 (revision 6016) @@ -0,0 +1,314 @@ +! $Id: readaerosol_optic_ecrad.F90 +! +SUBROUTINE readaerosol_optic_ecrad(debut, aerosol_couple, ok_alw, ok_volcan, & + flag_aerosol, flag_bc_internal_mixture, itap, rjourvrai, & + pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & + tr_seri, mass_solu_aero, mass_solu_aero_pi, m_allaer) +! tau_aero, piz_aero, cg_aero, & +! tausum_aero, drytausum_aero, tau3d_aero ) + + ! This routine will : + ! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol + ! 2) calculate the optical properties for the aerosols + ! + + USE clesphys_mod_h + USE dimphy + USE aero_mod + USE phys_local_var_mod, only: sconcso4,sconcno3,sconcoa,sconcbc,sconcss,sconcdust, & + concso4,concno3,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, & + loadno3,load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7, & + load_tmp8,load_tmp9,load_tmp10 + + USE infotrac_phy, ONLY: tracers, nqtot, nbtr + USE YOMCST + + IMPLICIT NONE + + + ! Input arguments + !**************************************************************************************** + LOGICAL, INTENT(IN) :: debut + LOGICAL, INTENT(IN) :: aerosol_couple + LOGICAL, INTENT(IN) :: ok_alw + LOGICAL, INTENT(IN) :: ok_volcan + INTEGER, INTENT(IN) :: flag_aerosol + LOGICAL, INTENT(IN) :: flag_bc_internal_mixture + INTEGER, INTENT(IN) :: itap + REAL, INTENT(IN) :: rjourvrai + REAL, INTENT(IN) :: pdtphys + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri + REAL, DIMENSION(klon,klev), INTENT(IN) :: rhcl ! humidite relative ciel clair + REAL, DIMENSION(klev), INTENT(IN) :: presnivs + REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri ! concentration tracer + + ! Output arguments + !**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: mass_solu_aero ! Total mass for all soluble aerosols + REAL, DIMENSION(klon,klev), INTENT(OUT) :: mass_solu_aero_pi ! -"- preindustrial values + REAL, DIMENSION(klon,klev,naero_tot), INTENT(OUT) :: m_allaer + ! AI a passer par la suite en argument si besoin pour ecrad + !REAL, DIMENSION(klon,klev,naero_tot), INTENT(OUT) :: m_allaer_pi !RAF + +! REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: tau_aero ! Aerosol optical thickness +! REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: piz_aero ! Single scattering albedo aerosol +! REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: cg_aero ! asymmetry parameter aerosol +! REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT) :: tausum_aero +! REAL, DIMENSION(klon,naero_tot), INTENT(OUT) :: drytausum_aero +! REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT) :: tau3d_aero + + ! Local variables + !**************************************************************************************** + REAL, DIMENSION(klon) :: aerindex ! POLDER aerosol index + REAL, DIMENSION(klon,klev) :: sulfacc ! SO4 accumulation concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sulfcoarse ! SO4 coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: bcsol ! BC soluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: bcins ! BC insoluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: pomsol ! POM soluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: pomins ! POM insoluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: cidust ! DUST aerosol concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sscoarse ! SS Coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sssupco ! SS Super Coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: ssacu ! SS Acumulation concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: nitracc ! nitrate accumulation concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: nitrcoarse ! nitrate coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: nitrinscoarse ! nitrate insoluble coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sulfacc_pi + REAL, DIMENSION(klon,klev) :: sulfcoarse_pi + REAL, DIMENSION(klon,klev) :: bcsol_pi + REAL, DIMENSION(klon,klev) :: bcins_pi + REAL, DIMENSION(klon,klev) :: pomsol_pi + REAL, DIMENSION(klon,klev) :: pomins_pi + REAL, DIMENSION(klon,klev) :: cidust_pi + REAL, DIMENSION(klon,klev) :: sscoarse_pi + REAL, DIMENSION(klon,klev) :: sssupco_pi + REAL, DIMENSION(klon,klev) :: ssacu_pi + REAL, DIMENSION(klon,klev) :: nitracc_pi + REAL, DIMENSION(klon,klev) :: nitrcoarse_pi + REAL, DIMENSION(klon,klev) :: nitrinscoarse_pi + REAL, DIMENSION(klon,klev) :: pdel, zrho + REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer_pi + + integer :: id_ASBCM, id_ASPOMM, id_ASSO4M, id_ASMSAM, id_CSSO4M, id_CSMSAM, id_SSSSM + integer :: id_CSSSM, id_ASSSM, id_CIDUSTM, id_AIBCM, id_AIPOMM, id_ASNO3M, id_CSNO3M, id_CINO3M + INTEGER :: k, i, iq, itr + + !--air density + zrho(:,:)=pplay(:,:)/t_seri(:,:)/RD !--kg/m3 + + !**************************************************************************************** + ! 1) Get aerosol mass + ! + !**************************************************************************************** + ! + ! + IF (aerosol_couple) THEN !--we get aerosols from tr_seri array from INCA + ! + !--copy fields from INCA tr_seri + !--convert to ug m-3 unit for consistency with offline fields + ! + itr = 0 + DO iq = 1,nqtot + IF(.NOT. tracers(iq)%isInPhysics) CYCLE + itr = itr+1 + SELECT CASE(trim(tracers(iq)%name)) + CASE ("ASBCM"); id_ASBCM = itr + CASE ("ASPOMM"); id_ASPOMM = itr + CASE ("ASSO4M"); id_ASSO4M = itr + CASE ("ASMSAM"); id_ASMSAM = itr + CASE ("CSSO4M"); id_CSSO4M = itr + CASE ("CSMSAM"); id_CSMSAM = itr + CASE ("SSSSM"); id_SSSSM = itr + CASE ("CSSSM"); id_CSSSM = itr + CASE ("ASSSM"); id_ASSSM = itr + CASE ("CIDUSTM");id_CIDUSTM= itr + CASE ("AIBCM"); id_AIBCM = itr + CASE ("AIPOMM"); id_AIPOMM = itr + CASE ("ASNO3M"); id_ASNO3M = itr + CASE ("CSNO3M"); id_CSNO3M = itr + CASE ("CINO3M"); id_CINO3M = itr + END SELECT + END DO + + bcsol(:,:) = tr_seri(:,:,id_ASBCM) *zrho(:,:)*1.e9 ! ASBCM + pomsol(:,:) = tr_seri(:,:,id_ASPOMM) *zrho(:,:)*1.e9 ! ASPOMM + sulfacc(:,:) = (tr_seri(:,:,id_ASSO4M)+tr_seri(:,:,id_ASMSAM))*zrho(:,:)*1.e9 ! ASSO4M (=SO4) + ASMSAM (=MSA) + sulfcoarse(:,:) = (tr_seri(:,:,id_CSSO4M)+tr_seri(:,:,id_CSMSAM))*zrho(:,:)*1.e9 ! CSSO4M (=SO4) + CSMSAM (=MSA) + sssupco(:,:) = tr_seri(:,:,id_SSSSM) *zrho(:,:)*1.e9 ! SSSSM + sscoarse(:,:) = tr_seri(:,:,id_CSSSM) *zrho(:,:)*1.e9 ! CSSSM + ssacu(:,:) = tr_seri(:,:,id_ASSSM) *zrho(:,:)*1.e9 ! ASSSM + cidust(:,:) = tr_seri(:,:,id_CIDUSTM) *zrho(:,:)*1.e9 ! CIDUSTM + bcins(:,:) = tr_seri(:,:,id_AIBCM) *zrho(:,:)*1.e9 ! AIBCM + pomins(:,:) = tr_seri(:,:,id_AIPOMM) *zrho(:,:)*1.e9 ! AIPOMM + nitracc(:,:) = tr_seri(:,:,id_ASNO3M) *zrho(:,:)*1.e9 ! ASNO3M + nitrcoarse(:,:) = tr_seri(:,:,id_CSNO3M) *zrho(:,:)*1.e9 ! CSNO3M + nitrinscoarse(:,:)= tr_seri(:,:,id_CINO3M) *zrho(:,:)*1.e9 ! CINO3M + ! + bcsol_pi(:,:) = 0.0 ! ASBCM pre-ind + pomsol_pi(:,:) = 0.0 ! ASPOMM pre-ind + sulfacc_pi(:,:) = 0.0 ! ASSO4M (=SO4) + ASMSAM (=MSA) pre-ind + sulfcoarse_pi(:,:) = 0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) pre-ind + sssupco_pi(:,:) = 0.0 ! SSSSM pre-ind + sscoarse_pi(:,:) = 0.0 ! CSSSM pre-ind + ssacu_pi(:,:) = 0.0 ! ASSSM pre-ind + cidust_pi(:,:) = 0.0 ! CIDUSTM pre-ind + bcins_pi(:,:) = 0.0 ! AIBCM pre-ind + pomins_pi(:,:) = 0.0 ! AIPOMM pre-ind + nitracc_pi(:,:) = 0.0 ! ASNO3M pre-ind + nitrcoarse_pi(:,:) = 0.0 ! CSNO3M pre-ind + nitrinscoarse_pi(:,:)= 0.0 ! CINO3M + ! + ELSE !--not aerosol_couple + ! + ! Read and interpolate sulfate + IF ( flag_aerosol .EQ. 1 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_ASSO4M_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfacc, sulfacc_pi,loadso4) + ELSE + sulfacc(:,:) = 0. ; sulfacc_pi(:,:) = 0. + loadso4=0. + ENDIF + + ! Read and interpolate bcsol and bcins + IF ( flag_aerosol .EQ. 2 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + ! Get bc aerosol distribution + CALL readaerosol_interp(id_ASBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi, load_tmp1 ) + CALL readaerosol_interp(id_AIBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi, load_tmp2 ) + loadbc(:)=load_tmp1(:)+load_tmp2(:) + ELSE + bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0. + bcins(:,:) = 0. ; bcins_pi(:,:) = 0. + loadbc=0. + ENDIF + + ! Read and interpolate pomsol and pomins + IF ( flag_aerosol .EQ. 3 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_ASPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi, load_tmp3) + CALL readaerosol_interp(id_AIPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi, load_tmp4) + loadoa(:)=load_tmp3(:)+load_tmp4(:) + ELSE + pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0. + pomins(:,:) = 0. ; pomins_pi(:,:) = 0. + loadoa=0. + ENDIF + + ! Read and interpolate csssm, ssssm, assssm + IF (flag_aerosol .EQ. 4 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_SSSSM_phy ,itap, pdtphys,rjourvrai, & + debut, pplay, paprs, t_seri, sssupco, sssupco_pi, load_tmp5) + CALL readaerosol_interp(id_CSSSM_phy ,itap, pdtphys,rjourvrai, & + debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi, load_tmp6) + CALL readaerosol_interp(id_ASSSM_phy ,itap, pdtphys,rjourvrai, & + debut, pplay, paprs, t_seri, ssacu, ssacu_pi, load_tmp7) + loadss(:)=load_tmp5(:)+load_tmp6(:)+load_tmp7(:) + ELSE + sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. + ssacu(:,:) = 0. ; ssacu_pi(:,:) = 0. + sssupco(:,:) = 0. ; sssupco_pi = 0. + loadss=0. + ENDIF + + ! Read and interpolate cidustm + IF (flag_aerosol .EQ. 5 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_CIDUSTM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi, loaddust) + + ELSE + cidust(:,:) = 0. ; cidust_pi(:,:) = 0. + loaddust=0. + ENDIF + ! + ! Read and interpolate asno3m, csno3m, cino3m + IF (flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_ASNO3M_phy, itap, pdtphys, rjourvrai, & + debut, pplay, paprs, t_seri, nitracc, nitracc_pi, load_tmp8) + CALL readaerosol_interp(id_CSNO3M_phy, itap, pdtphys, rjourvrai, & + debut, pplay, paprs, t_seri, nitrcoarse, nitrcoarse_pi, load_tmp9) + CALL readaerosol_interp(id_CINO3M_phy, itap, pdtphys, rjourvrai, & + debut, pplay, paprs, t_seri, nitrinscoarse, nitrinscoarse_pi, load_tmp10) + loadno3(:)=load_tmp8(:)+load_tmp9(:)+load_tmp10(:) + + ELSE + nitracc(:,:) = 0.0 ; nitracc_pi(:,:) = 0.0 + nitrcoarse(:,:) = 0.0 ; nitrcoarse_pi(:,:) = 0.0 + nitrinscoarse(:,:) = 0.0 ; nitrinscoarse_pi(:,:)= 0.0 + loadno3(:)=0.0 + ENDIF + ! + ! CSSO4M is set to 0 as not reliable + sulfcoarse(:,:) = 0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) + sulfcoarse_pi(:,:) = 0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) pre-ind + + ENDIF !--not aerosol_couple + + ! + ! Store all aerosols mixing ratios in one variable for radiation scheme (unit kg/kg for ECRAD) + ! present-day values + m_allaer(:,:,id_ASBCM_phy) = bcsol(:,:) /1.e9/zrho(:,:) ! ASBCM + m_allaer(:,:,id_ASPOMM_phy) = pomsol(:,:) /1.e9/zrho(:,:) ! ASPOMM + m_allaer(:,:,id_ASSO4M_phy) = sulfacc(:,:) /1.e9/zrho(:,:) ! ASSO4M (= SO4) + m_allaer(:,:,id_CSSO4M_phy) = sulfcoarse(:,:) /1.e9/zrho(:,:) ! CSSO4M + m_allaer(:,:,id_SSSSM_phy) = sssupco(:,:) /1.e9/zrho(:,:) ! SSSSM + m_allaer(:,:,id_CSSSM_phy) = sscoarse(:,:) /1.e9/zrho(:,:) ! CSSSM + m_allaer(:,:,id_ASSSM_phy) = ssacu(:,:) /1.e9/zrho(:,:) ! ASSSM + m_allaer(:,:,id_CIDUSTM_phy)= cidust(:,:) /1.e9/zrho(:,:) ! CIDUSTM + m_allaer(:,:,id_AIBCM_phy) = bcins(:,:) /1.e9/zrho(:,:) ! AIBCM + m_allaer(:,:,id_ASNO3M_phy) = nitracc(:,:) /1.e9/zrho(:,:) ! ASNO3M + m_allaer(:,:,id_CSNO3M_phy) = nitrcoarse(:,:) /1.e9/zrho(:,:) ! CSNO3M + m_allaer(:,:,id_CINO3M_phy) = nitrinscoarse(:,:)/1.e9/zrho(:,:) ! CINO3M + m_allaer(:,:,id_AIPOMM_phy) = pomins(:,:) /1.e9/zrho(:,:) ! AIPOMM + m_allaer(:,:,id_STRAT_phy) = 0.0 + + ! pre-industrial (pi) values + m_allaer_pi(:,:,id_ASBCM_phy) = bcsol_pi(:,:) /1.e9/zrho(:,:) ! ASBCM pre-ind + m_allaer_pi(:,:,id_ASPOMM_phy) = pomsol_pi(:,:) /1.e9/zrho(:,:) ! ASPOMM pre-ind + m_allaer_pi(:,:,id_ASSO4M_phy) = sulfacc_pi(:,:) /1.e9/zrho(:,:) ! ASSO4M (= SO4) pre-ind + m_allaer_pi(:,:,id_CSSO4M_phy) = sulfcoarse_pi(:,:) /1.e9/zrho(:,:) ! CSSO4M pre-ind + m_allaer_pi(:,:,id_SSSSM_phy) = sssupco_pi(:,:) /1.e9/zrho(:,:) ! SSSSM pre-ind + m_allaer_pi(:,:,id_CSSSM_phy) = sscoarse_pi(:,:) /1.e9/zrho(:,:) ! CSSSM pre-ind + m_allaer_pi(:,:,id_ASSSM_phy) = ssacu_pi(:,:) /1.e9/zrho(:,:) ! ASSSM pre-ind + m_allaer_pi(:,:,id_CIDUSTM_phy)= cidust_pi(:,:) /1.e9/zrho(:,:) ! CIDUSTM pre-ind + m_allaer_pi(:,:,id_AIBCM_phy) = bcins_pi(:,:) /1.e9/zrho(:,:) ! AIBCM pre-ind + m_allaer_pi(:,:,id_ASNO3M_phy) = nitracc_pi(:,:) /1.e9/zrho(:,:) ! ASNO3M pre-ind + m_allaer_pi(:,:,id_CSNO3M_phy) = nitrcoarse_pi(:,:) /1.e9/zrho(:,:) ! CSNO3M pre-ind + m_allaer_pi(:,:,id_CINO3M_phy) = nitrinscoarse_pi(:,:)/1.e9/zrho(:,:) ! CINO3M pre-ind + m_allaer_pi(:,:,id_AIPOMM_phy) = pomins_pi(:,:) /1.e9/zrho(:,:) ! AIPOMM pre-ind + m_allaer_pi(:,:,id_STRAT_phy) = 0.0 + + ! + ! Calculate the total mass of all soluble aersosols (in unit ug /m3) + ! to be revisited for AR6 + mass_solu_aero(:,:) = sulfacc(:,:) + bcsol(:,:) + pomsol(:,:) + nitracc(:,:) + ssacu(:,:) + mass_solu_aero_pi(:,:) = sulfacc_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) + nitracc_pi(:,:) + ssacu_pi(:,:) + + !**************************************************************************************** + ! 2) Calculate optical properties for the aerosols + ! + !**************************************************************************************** + DO k = 1, klev + DO i = 1, klon + pdel(i,k) = paprs(i,k) - paprs (i,k+1) + ENDDO + ENDDO + + ! Diagnostics calculation for CMIP5 protocol unit (in unit kg/m3) + sconcso4(:) =m_allaer(:,1,id_ASSO4M_phy)*1.e-9 + sconcno3(:) =(m_allaer(:,1,id_ASNO3M_phy)+m_allaer(:,1,id_CSNO3M_phy)+m_allaer(:,1,id_CINO3M_phy))*1.e-9 + sconcoa(:) =(m_allaer(:,1,id_ASPOMM_phy)+m_allaer(:,1,id_AIPOMM_phy))*1.e-9 + sconcbc(:) =(m_allaer(:,1,id_ASBCM_phy)+m_allaer(:,1,id_AIBCM_phy))*1.e-9 + sconcss(:) =(m_allaer(:,1,id_ASSSM_phy)+m_allaer(:,1,id_CSSSM_phy)+m_allaer(:,1,id_SSSSM_phy))*1.e-9 + sconcdust(:) =m_allaer(:,1,id_CIDUSTM_phy)*1.e-9 + concso4(:,:) =m_allaer(:,:,id_ASSO4M_phy)*1.e-9 + concno3(:,:) =(m_allaer(:,:,id_ASNO3M_phy)+m_allaer(:,:,id_CSNO3M_phy)+m_allaer(:,:,id_CINO3M_phy))*1.e-9 + concoa(:,:) =(m_allaer(:,:,id_ASPOMM_phy)+m_allaer(:,:,id_AIPOMM_phy))*1.e-9 + concbc(:,:) =(m_allaer(:,:,id_ASBCM_phy)+m_allaer(:,:,id_AIBCM_phy))*1.e-9 + concss(:,:) =(m_allaer(:,:,id_ASSSM_phy)+m_allaer(:,:,id_CSSSM_phy)+m_allaer(:,:,id_SSSSM_phy))*1.e-9 + concdust(:,:)=m_allaer(:,:,id_CIDUSTM_phy)*1.e-9 + +END SUBROUTINE readaerosol_optic_ecrad Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/readaerosolstrato_ecrad.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/readaerosolstrato_ecrad.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/readaerosolstrato_ecrad.F90 (revision 6016) @@ -0,0 +1,564 @@ +! +! $Id: readaerosolstrato_ecrad.F90 tlurton $ +! +SUBROUTINE readaerosolstrato_ecrad(config, debut, ok_volcan) + + USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & + nf95_inq_varid, nf95_open + USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite + + USE phys_cal_mod, ONLY : mth_cur + USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo, grid_type, unstructured + USE mod_phys_lmdz_mpi_data + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_para + USE phys_state_var_mod + USE phys_local_var_mod +! USE physiq_mod, ONLY : ok_volcan + USE aero_mod + USE dimphy +! USE YOERAD + USE radiation_config, ONLY : config_type + USE YOMCST +#ifdef CPP_XIOS + USE xios +#endif + + USE clesphys_mod_h + IMPLICIT NONE + + + CHARACTER (len = 80) :: abort_message + CHARACTER (LEN=20) :: modname = 'readaerosolstrato_ecrad' + +! Variable input + LOGICAL, INTENT(IN) :: debut + LOGICAL, INTENT(IN) :: ok_volcan !activate volcanic diags + +! Variables locales + INTEGER n_lat ! number of latitudes in the input data + INTEGER n_lon ! number of longitudes + INTEGER n_lev ! number of levels in the input data + INTEGER n_month ! number of months in the input data + INTEGER n_wav ! number of wavelengths in the input data + REAL, ALLOCATABLE:: latitude(:) + REAL, ALLOCATABLE:: time(:) + REAL, ALLOCATABLE:: lev(:) + REAL, ALLOCATABLE:: wav(:) + INTEGER i,k,wave,band + INTEGER, SAVE :: mth_pre=1 +!$OMP THREADPRIVATE(mth_pre) + + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: tau_aer_strat + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: piz_aer_strat + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cg_aer_strat + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: taulw_aer_strat +! add ThL + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: pizlw_aer_strat + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cglw_aer_strat +! end add ThL +! mod ThL +!$OMP THREADPRIVATE(tau_aer_strat,piz_aer_strat,cg_aer_strat,taulw_aer_strat,pizlw_aer_strat,cglw_aer_strat) +! end mod ThL + +! Champs reconstitues + REAL, ALLOCATABLE:: tauaerstrat(:, :, :, :) + REAL, ALLOCATABLE:: pizaerstrat(:, :, :, :) + REAL, ALLOCATABLE:: cgaerstrat(:, :, :, :) + REAL, ALLOCATABLE:: taulwaerstrat(:, :, :, :) +! add ThL + REAL, ALLOCATABLE:: pizlwaerstrat(:, :, :, :) + REAL, ALLOCATABLE:: cglwaerstrat(:, :, :, :) +! end add ThL + + REAL, ALLOCATABLE:: tauaerstrat_mois(:, :, :, :) + REAL, ALLOCATABLE:: pizaerstrat_mois(:, :, :, :) + REAL, ALLOCATABLE:: cgaerstrat_mois(:, :, :, :) + REAL, ALLOCATABLE:: taulwaerstrat_mois(:, :, :, :) +! add ThL + REAL, ALLOCATABLE:: pizlwaerstrat_mois(:, :, :, :) + REAL, ALLOCATABLE:: cglwaerstrat_mois(:, :, :, :) +! end add ThL + + REAL, ALLOCATABLE:: tauaerstrat_mois_glo(:, :, :) + REAL, ALLOCATABLE:: pizaerstrat_mois_glo(:, :, :) + REAL, ALLOCATABLE:: cgaerstrat_mois_glo(:, :, :) + REAL, ALLOCATABLE:: taulwaerstrat_mois_glo(:, :, :) +! add ThL + REAL, ALLOCATABLE:: pizlwaerstrat_mois_glo(:, :, :) + REAL, ALLOCATABLE:: cglwaerstrat_mois_glo(:, :, :) +! end add ThL + REAL, ALLOCATABLE:: tauaerstrat_mpi(:, :, :) + REAL, ALLOCATABLE:: pizaerstrat_mpi(:, :, :) + REAL, ALLOCATABLE:: cgaerstrat_mpi(:, :, :) + REAL, ALLOCATABLE:: taulwaerstrat_mpi(:, :, :) +! add ThL + REAL, ALLOCATABLE:: pizlwaerstrat_mpi(:, :, :) + REAL, ALLOCATABLE:: cglwaerstrat_mpi(:, :, :) +! end add ThL + +! For NetCDF: + INTEGER ncid_in ! IDs for input files + INTEGER varid, ncerr + + TYPE(config_type), INTENT(IN) :: config + +!-------------------------------------------------------- + + IF (.not.ALLOCATED(tau_aer_strat)) ALLOCATE(tau_aer_strat(klon,klev,config%n_bands_sw)) + IF (.not.ALLOCATED(piz_aer_strat)) ALLOCATE(piz_aer_strat(klon,klev,config%n_bands_sw)) + IF (.not.ALLOCATED(cg_aer_strat)) ALLOCATE(cg_aer_strat(klon,klev,config%n_bands_sw)) + + IF (.not.ALLOCATED(taulw_aer_strat)) ALLOCATE(taulw_aer_strat(klon,klev,config%n_bands_lw)) +! add ThL + IF (.not.ALLOCATED(pizlw_aer_strat)) ALLOCATE(pizlw_aer_strat(klon,klev,config%n_bands_lw)) + IF (.not.ALLOCATED(cglw_aer_strat)) ALLOCATE(cglw_aer_strat(klon,klev,config%n_bands_lw)) +! end add ThL + +!--we only read monthly strat aerosol data + IF (debut.OR.mth_cur.NE.mth_pre) THEN + +!--only root reads the data + IF (is_mpi_root.AND.is_omp_root) THEN + +!--check mth_cur + IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN + print *,'probleme avec le mois dans readaerosolstrat =', mth_cur + ENDIF + +!--initialize n_lon as input data is 2D (lat-alt) only + n_lon = nbp_lon + +!--Starts with SW optical properties + + CALL nf95_open("tauswstrat.2D.nc", nf90_nowrite, ncid_in) + + CALL nf95_inq_varid(ncid_in, "LEV", varid) + CALL nf95_gw_var(ncid_in, varid, lev) + n_lev = size(lev) + IF (n_lev.NE.klev) THEN + abort_message='Le nombre de niveaux n est pas egal a klev' + CALL abort_physic(modname,abort_message,1) + ENDIF + + CALL nf95_inq_varid(ncid_in, "LAT", varid) + CALL nf95_gw_var(ncid_in, varid, latitude) + n_lat = size(latitude) + + IF (grid_type/=unstructured) THEN + IF (n_lat.NE.nbp_lat) THEN + print *, 'latitude=', n_lat, nbp_lat + abort_message='Le nombre de lat n est pas egal a nbp_lat' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + + CALL nf95_inq_varid(ncid_in, "TIME", varid) + CALL nf95_gw_var(ncid_in, varid, time) + n_month = size(time) + IF (n_month.NE.12) THEN + abort_message='Le nombre de month n est pas egal a 12' + CALL abort_physic(modname,abort_message,1) + ENDIF + + CALL nf95_inq_varid(ncid_in, "WAV", varid) + CALL nf95_gw_var(ncid_in, varid, wav) + n_wav = size(wav) + print *, 'WAV aerosol strato=', n_wav, wav +! IF (n_wav.NE.config%n_bands_sw) THEN +! abort_message='Le nombre de wav n est pas egal a config%n_bands_sw' +! CALL abort_physic(modname,abort_message,1) +! ENDIF + + ALLOCATE(tauaerstrat(n_lat, n_lev, n_wav, n_month)) + ALLOCATE(pizaerstrat(n_lat, n_lev, n_wav, n_month)) + ALLOCATE(cgaerstrat(n_lat, n_lev, n_wav, n_month)) + +!--reading stratospheric aerosol tau per layer + CALL nf95_inq_varid(ncid_in, "TAU_SUN", varid) + ncerr = nf90_get_var(ncid_in, varid, tauaerstrat) + print *,'code erreur readaerosolstrato=', ncerr, varid + +!--reading stratospheric aerosol omega per layer + CALL nf95_inq_varid(ncid_in, "OME_SUN", varid) + ncerr = nf90_get_var(ncid_in, varid, pizaerstrat) + print *,'code erreur readaerosolstrato=', ncerr, varid + +!--reading stratospheric aerosol g per layer + CALL nf95_inq_varid(ncid_in, "GGG_SUN", varid) + ncerr = nf90_get_var(ncid_in, varid, cgaerstrat) + print *,'code erreur readaerosolstrato sw=', ncerr, varid + + CALL nf95_close(ncid_in) + + + IF (grid_type/=unstructured) THEN + ALLOCATE(tauaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) + ALLOCATE(pizaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) + ALLOCATE(cgaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) + + ALLOCATE(tauaerstrat_mois_glo(klon_glo, n_lev, n_wav)) + ALLOCATE(pizaerstrat_mois_glo(klon_glo, n_lev, n_wav)) + ALLOCATE(cgaerstrat_mois_glo(klon_glo, n_lev, n_wav)) +!--select the correct month +!--and copy into 1st longitude + tauaerstrat_mois(1,:,:,:) = tauaerstrat(:,:,:,mth_cur) + pizaerstrat_mois(1,:,:,:) = pizaerstrat(:,:,:,mth_cur) + cgaerstrat_mois(1,:,:,:) = cgaerstrat(:,:,:,mth_cur) + +!--copy longitudes + DO i=2, n_lon + tauaerstrat_mois(i,:,:,:) = tauaerstrat_mois(1,:,:,:) + pizaerstrat_mois(i,:,:,:) = pizaerstrat_mois(1,:,:,:) + cgaerstrat_mois(i,:,:,:) = cgaerstrat_mois(1,:,:,:) + ENDDO + +!---reduce to a klon_glo grid + DO band=1, config%n_bands_sw + CALL grid2dTo1d_glo(tauaerstrat_mois(:,:,:,band),tauaerstrat_mois_glo(:,:,band)) + CALL grid2dTo1d_glo(pizaerstrat_mois(:,:,:,band),pizaerstrat_mois_glo(:,:,band)) + CALL grid2dTo1d_glo(cgaerstrat_mois(:,:,:,band),cgaerstrat_mois_glo(:,:,band)) + ENDDO + ENDIF +!--Now LW optical properties +! + + CALL nf95_open("taulwstrat.2D.nc", nf90_nowrite, ncid_in) + + CALL nf95_inq_varid(ncid_in, "LEV", varid) + CALL nf95_gw_var(ncid_in, varid, lev) + n_lev = size(lev) + IF (n_lev.NE.klev) THEN + abort_message='Le nombre de niveaux n est pas egal a klev' + CALL abort_physic(modname,abort_message,1) + ENDIF + + CALL nf95_inq_varid(ncid_in, "LAT", varid) + CALL nf95_gw_var(ncid_in, varid, latitude) + n_lat = size(latitude) + + IF (grid_type/=unstructured) THEN + IF (n_lat.NE.nbp_lat) THEN + abort_message='Le nombre de lat n est pas egal a nbp_lat' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + + CALL nf95_inq_varid(ncid_in, "TIME", varid) + CALL nf95_gw_var(ncid_in, varid, time) + n_month = size(time) + IF (n_month.NE.12) THEN + abort_message='Le nombre de month n est pas egal a 12' + CALL abort_physic(modname,abort_message,1) + ENDIF + + CALL nf95_inq_varid(ncid_in, "WAV", varid) + CALL nf95_gw_var(ncid_in, varid, wav) + n_wav = size(wav) + print *, 'WAV aerosol strato=', n_wav, wav +! IF (n_wav.NE.config%n_bands_lw) THEN +! abort_message='Le nombre de wav n est pas egal a config%n_bands_lw' +! CALL abort_physic(modname,abort_message,1) +! ENDIF + + ALLOCATE(taulwaerstrat(n_lat, n_lev, n_wav, n_month)) +! add ThL + ALLOCATE(pizlwaerstrat(n_lat, n_lev, n_wav, n_month)) + ALLOCATE(cglwaerstrat(n_lat, n_lev, n_wav, n_month)) +! end add ThL + +!--reading stratospheric aerosol lw tau per layer + CALL nf95_inq_varid(ncid_in, "TAU_EAR", varid) + ncerr = nf90_get_var(ncid_in, varid, taulwaerstrat) + print *,'code erreur readaerosolstrato lw=', ncerr, varid + +! add/mod ThL +!--with ECRAd, we also read omega and g: + !--reading stratospheric aerosol omega per layer + CALL nf95_inq_varid(ncid_in, "OME_EAR", varid) + ncerr = nf90_get_var(ncid_in, varid, pizlwaerstrat) + print *,'code erreur readaerosolstrato lw=', ncerr, varid + +!--reading stratospheric aerosol g per layer + CALL nf95_inq_varid(ncid_in, "GGG_EAR", varid) + ncerr = nf90_get_var(ncid_in, varid, cglwaerstrat) + print *,'code erreur readaerosolstrato lw=', ncerr, varid + + CALL nf95_close(ncid_in) + + IF (grid_type/=unstructured) THEN + + ALLOCATE(taulwaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) + ALLOCATE(pizlwaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) + ALLOCATE(cglwaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) + + ALLOCATE(taulwaerstrat_mois_glo(klon_glo, n_lev, n_wav)) + ALLOCATE(pizlwaerstrat_mois_glo(klon_glo, n_lev, n_wav)) + ALLOCATE(cglwaerstrat_mois_glo(klon_glo, n_lev, n_wav)) +!--select the correct month +!--and copy into 1st longitude + taulwaerstrat_mois(1,:,:,:) = taulwaerstrat(:,:,:,mth_cur) + pizlwaerstrat_mois(1,:,:,:) = pizlwaerstrat(:,:,:,mth_cur) + cglwaerstrat_mois(1,:,:,:) = cglwaerstrat(:,:,:,mth_cur) +!--copy longitudes + DO i=2, n_lon + taulwaerstrat_mois(i,:,:,:) = taulwaerstrat_mois(1,:,:,:) + pizlwaerstrat_mois(i,:,:,:) = pizlwaerstrat_mois(1,:,:,:) + cglwaerstrat_mois(i,:,:,:) = cglwaerstrat_mois(1,:,:,:) + ENDDO + +!---reduce to a klon_glo grid + DO band=1, config%n_bands_lw + CALL grid2dTo1d_glo(taulwaerstrat_mois(:,:,:,band),taulwaerstrat_mois_glo(:,:,band)) + CALL grid2dTo1d_glo(pizlwaerstrat_mois(:,:,:,band),pizlwaerstrat_mois_glo(:,:,band)) + CALL grid2dTo1d_glo(cglwaerstrat_mois(:,:,:,band),cglwaerstrat_mois_glo(:,:,band)) + ENDDO + ENDIF + + ELSE !--proc other than mpi_root and omp_root + !--dummy allocation needed for debug mode + + ALLOCATE(tauaerstrat_mois_glo(1,1,1)) + ALLOCATE(pizaerstrat_mois_glo(1,1,1)) + ALLOCATE(cgaerstrat_mois_glo(1,1,1)) + ALLOCATE(taulwaerstrat_mois_glo(1,1,1)) + ALLOCATE(pizlwaerstrat_mois_glo(1,1,1)) + ALLOCATE(cglwaerstrat_mois_glo(1,1,1)) + + ALLOCATE(tauaerstrat(0,0,0,12)) + ALLOCATE(pizaerstrat(0,0,0,12)) + ALLOCATE(cgaerstrat(0,0,0,12)) + ALLOCATE(taulwaerstrat(0,0,0,12)) + ALLOCATE(pizlwaerstrat(0,0,0,12)) + ALLOCATE(cglwaerstrat(0,0,0,12)) +! end add/mod ThL + + ENDIF !--is_mpi_root and is_omp_root + +!$OMP BARRIER + +!--keep memory of previous month + mth_pre=mth_cur + + IF (grid_type==unstructured) THEN + +#ifdef CPP_XIOS + + IF (is_omp_master) THEN + ALLOCATE(tauaerstrat_mpi(klon_mpi, klev, config%n_bands_sw)) + ALLOCATE(pizaerstrat_mpi(klon_mpi, klev, config%n_bands_sw)) + ALLOCATE(cgaerstrat_mpi(klon_mpi, klev, config%n_bands_sw)) + ALLOCATE(taulwaerstrat_mpi(klon_mpi, klev, config%n_bands_lw)) +! add ThL + ALLOCATE(pizlwaerstrat_mpi(klon_mpi, klev, config%n_bands_lw)) + ALLOCATE(cglwaerstrat_mpi(klon_mpi, klev, config%n_bands_lw)) +! end add ThL + + CALL xios_send_field("tauaerstrat_in",SPREAD(tauaerstrat(:,:,:,mth_cur),1,8)) + CALL xios_recv_field("tauaerstrat_out",tauaerstrat_mpi) + CALL xios_send_field("pizaerstrat_in",SPREAD(pizaerstrat(:,:,:,mth_cur),1,8)) + CALL xios_recv_field("pizaerstrat_out",pizaerstrat_mpi) + CALL xios_send_field("cgaerstrat_in",SPREAD(cgaerstrat(:,:,:,mth_cur),1,8)) + CALL xios_recv_field("cgaerstrat_out",cgaerstrat_mpi) + CALL xios_send_field("taulwaerstrat_in",SPREAD(taulwaerstrat(:,:,:,mth_cur),1,8)) + CALL xios_recv_field("taulwaerstrat_out",taulwaerstrat_mpi) +! add ThL + CALL xios_send_field("pizlwaerstrat_in",SPREAD(pizlwaerstrat(:,:,:,mth_cur),1,8)) + CALL xios_recv_field("pizlwaerstrat_out",pizlwaerstrat_mpi) + CALL xios_send_field("cglwaerstrat_in",SPREAD(cglwaerstrat(:,:,:,mth_cur),1,8)) + CALL xios_recv_field("cglwaerstrat_out",cglwaerstrat_mpi) +! end add ThL + ELSE + ALLOCATE(tauaerstrat_mpi(0, 0, 0)) + ALLOCATE(pizaerstrat_mpi(0, 0, 0)) + ALLOCATE(cgaerstrat_mpi(0, 0, 0)) + ALLOCATE(taulwaerstrat_mpi(0, 0, 0)) +! add ThL + ALLOCATE(pizlwaerstrat_mpi(0, 0, 0)) + ALLOCATE(cglwaerstrat_mpi(0, 0, 0)) +! end add ThL + ENDIF + + CALL scatter_omp(tauaerstrat_mpi,tau_aer_strat) + CALL scatter_omp(pizaerstrat_mpi,piz_aer_strat) + CALL scatter_omp(cgaerstrat_mpi,cg_aer_strat) + CALL scatter_omp(taulwaerstrat_mpi,taulw_aer_strat) +! add ThL + CALL scatter_omp(pizlwaerstrat_mpi,pizlw_aer_strat) + CALL scatter_omp(cglwaerstrat_mpi,cglw_aer_strat) +! end add ThL +#endif + ELSE + +!--scatter on all proc + CALL scatter(tauaerstrat_mois_glo,tau_aer_strat) + CALL scatter(pizaerstrat_mois_glo,piz_aer_strat) + CALL scatter(cgaerstrat_mois_glo,cg_aer_strat) + CALL scatter(taulwaerstrat_mois_glo,taulw_aer_strat) +! add ThL + CALL scatter(pizlwaerstrat_mois_glo,pizlw_aer_strat) + CALL scatter(cglwaerstrat_mois_glo,cglw_aer_strat) +! end add ThL + IF (is_mpi_root.AND.is_omp_root) DEALLOCATE(tauaerstrat_mois, pizaerstrat_mois, cgaerstrat_mois, taulwaerstrat_mois, pizlwaerstrat_mois, cglwaerstrat_mois) ! mod ThL + + ENDIF + + IF (is_mpi_root.AND.is_omp_root) THEN + DEALLOCATE(tauaerstrat, pizaerstrat, cgaerstrat, taulwaerstrat, pizlwaerstrat, cglwaerstrat) ! mod ThL + ENDIF + + +!$OMP BARRIER + + ENDIF !--debut ou nouveau mois + +!--total vertical aod at the SW wavelengths +!--for now use ECRAD band #10 AOD into all wavelengths +!--it is only a reasonable approximation for 550 nm +!--WAV(10)=0.53 µm +!-- This is considering that wavebands are in their original order, +!--and have NOT been re-ordered monotonously, i.e. with +!--WAV(1) = 3.46 µm +!--WAV(2) = 2.79 µm +!--(...) +!--WAV(last-1) = 0.23 µm +!--WAV(last)= 8.02 µm +!--If bands were to be re-ordered, i.e. last band be put in 1st position, +!--then we should consider band=11 to fetch WAV=0.53 µm. + band=10 + DO i=1, klon + DO k=1, klev + IF (stratomask(i,k).GT.0.999999) THEN + DO wave=1, config%n_bands_sw + tausum_aero(i,wave,id_STRAT_phy)=tausum_aero(i,wave,id_STRAT_phy)+tau_aer_strat(i,k,band) + ENDDO + ENDIF + ENDDO + ENDDO + + IF (.NOT. ok_volcan) THEN +! +!--this is the default case +!--stratospheric aerosols are added to both index 2 and 1 for double radiation calls +!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones + DO band=1, config%n_bands_sw + WHERE (stratomask.GT.0.999999) +!--strat aerosols are added to index 2: natural and anthropogenic aerosols for bands 1 to config%n_bands_sw + cg_aero_sw_rrtm(:,:,2,band) = ( cg_aero_sw_rrtm(:,:,2,band)*piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & + cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & + MAX( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & + piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band), 1.e-15 ) + piz_aero_sw_rrtm(:,:,2,band) = ( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & + piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & + MAX( tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band), 1.e-15 ) + tau_aero_sw_rrtm(:,:,2,band) = tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band) +!--strat aerosols are added to index 1: natural aerosols only for bands 1 to config%n_bands_sw + cg_aero_sw_rrtm(:,:,1,band) = ( cg_aero_sw_rrtm(:,:,1,band)*piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) + & + cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & + MAX( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) + & + piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band), 1.e-15 ) + piz_aero_sw_rrtm(:,:,1,band) = ( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) + & + piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & + MAX( tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band), 1.e-15 ) + tau_aero_sw_rrtm(:,:,1,band) = tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band) + ENDWHERE + ENDDO +! + ELSE +! +!--this is the VOLMIP case +!--stratospheric aerosols are only added to index 2 in this case +!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones + DO band=1, config%n_bands_sw + WHERE (stratomask.GT.0.999999) +!--strat aerosols are added to index 2 : natural and anthropogenic aerosols for bands 1 to config%n_bands_sw + cg_aero_sw_rrtm(:,:,2,band) = ( cg_aero_sw_rrtm(:,:,2,band)*piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & + cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & + MAX( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & + piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band), 1.e-15 ) + piz_aero_sw_rrtm(:,:,2,band) = ( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & + piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & + MAX( tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band), 1.e-15 ) + tau_aero_sw_rrtm(:,:,2,band) = tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band) + ENDWHERE + ENDDO + ENDIF + +!--total vertical aod at 10 um +!--this is approximated from band 7 of ECRAD (9.73 µm) + band=7 + DO i=1, klon + DO k=1, klev + IF (stratomask(i,k).GT.0.999999) THEN + DO wave=1, config%n_bands_lw + tausum_aero(i,config%n_bands_sw+wave,id_STRAT_phy)=tausum_aero(i,config%n_bands_sw+wave,id_STRAT_phy)+taulw_aer_strat(i,k,band) + ENDDO + ENDIF + ENDDO + ENDDO + + IF (.NOT. ok_volcan) THEN +!--this is the default case +!--stratospheric aerosols are added to both index 2 and 1 + DO band=1, config%n_bands_lw + WHERE (stratomask.GT.0.999999) +! add ThL + cg_aero_lw_rrtm(:,:,2,band) = ( cg_aero_lw_rrtm(:,:,2,band)*piz_aero_lw_rrtm(:,:,2,band)*tau_aero_lw_rrtm(:,:,2,band) + & + cglw_aer_strat(:,:,band)*pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band) ) / & + MAX( piz_aero_lw_rrtm(:,:,2,band)*tau_aero_lw_rrtm(:,:,2,band) + & + pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band), 1.e-15 ) + piz_aero_lw_rrtm(:,:,2,band) = ( piz_aero_lw_rrtm(:,:,2,band)*tau_aero_lw_rrtm(:,:,2,band) + & + pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band) ) / & + MAX( tau_aero_lw_rrtm(:,:,2,band) + taulw_aer_strat(:,:,band), 1.e-15 ) + cg_aero_lw_rrtm(:,:,1,band) = ( cg_aero_lw_rrtm(:,:,1,band)*piz_aero_lw_rrtm(:,:,1,band)*tau_aero_lw_rrtm(:,:,1,band) + & + cglw_aer_strat(:,:,band)*pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band) ) / & + MAX( piz_aero_lw_rrtm(:,:,1,band)*tau_aero_lw_rrtm(:,:,1,band) + & + pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band), 1.e-15 ) + piz_aero_lw_rrtm(:,:,1,band) = ( piz_aero_lw_rrtm(:,:,1,band)*tau_aero_lw_rrtm(:,:,1,band) + & + pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band) ) / & + MAX( tau_aero_lw_rrtm(:,:,1,band) + taulw_aer_strat(:,:,band), 1.e-15 ) +! end add ThL + tau_aero_lw_rrtm(:,:,2,band) = tau_aero_lw_rrtm(:,:,2,band) + taulw_aer_strat(:,:,band) + tau_aero_lw_rrtm(:,:,1,band) = tau_aero_lw_rrtm(:,:,1,band) + taulw_aer_strat(:,:,band) + ENDWHERE + ENDDO +! + ELSE +! +! mod ThL +!--this is the VOLMIP case + DO band=1, config%n_bands_lw + WHERE (stratomask.GT.0.999999) +!--stratospheric aerosols are not added to index 1 +!--and we copy index 2 in index 1 because we want the same dust aerosol LW properties as above + cg_aero_lw_rrtm(:,:,1,band) = cg_aero_lw_rrtm(:,:,2,band) + piz_aero_lw_rrtm(:,:,1,band) = piz_aero_lw_rrtm(:,:,2,band) + tau_aero_lw_rrtm(:,:,1,band) = tau_aero_lw_rrtm(:,:,2,band) + +!--stratospheric aerosols are only added to index 2 + cg_aero_lw_rrtm(:,:,2,band) = (cg_aero_lw_rrtm(:,:,2,band)*piz_aero_lw_rrtm(:,:,2,band)*tau_aero_lw_rrtm(:,:,2,band) + & + cglw_aer_strat(:,:,band)*pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band)) / & + MAX( piz_aero_lw_rrtm(:,:,2,band)*tau_aero_lw_rrtm(:,:,2,band) + & + pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band), 1.e-15 ) + piz_aero_lw_rrtm(:,:,2,band) = (piz_aero_lw_rrtm(:,:,2,band)*tau_aero_lw_rrtm(:,:,2,band) + & + pizlw_aer_strat(:,:,band)*taulw_aer_strat(:,:,band) ) / & + MAX( tau_aero_lw_rrtm(:,:,2,band) + taulw_aer_strat(:,:,band), 1.e-15 ) + tau_aero_lw_rrtm(:,:,2,band) = tau_aero_lw_rrtm(:,:,2,band) + taulw_aer_strat(:,:,band) + ENDWHERE + ENDDO + ENDIF +! end mod ThL + +!--default SSA value if there is no aerosol +!--to avoid 0 values that seems to cause some problem to RRTM + WHERE (tau_aero_sw_rrtm.LT.1.e-14) + piz_aero_sw_rrtm = 1.0 + ENDWHERE + +!--in principle this should not be necessary +!--as these variables have min values already but just in case +!--put 1e-15 min value to both SW and LW AOD + tau_aero_sw_rrtm = MAX(tau_aero_sw_rrtm,1.e-15) + tau_aero_lw_rrtm = MAX(tau_aero_lw_rrtm,1.e-15) + +END SUBROUTINE readaerosolstrato_ecrad Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/setup_aerosol_optics_lmdz_m.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/setup_aerosol_optics_lmdz_m.f90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/setup_aerosol_optics_lmdz_m.f90 (revision 6016) @@ -0,0 +1,124 @@ +module setup_aerosol_optics_lmdz_m + + implicit none + +contains + + subroutine setup_aerosol_optics_lmdz(ao, file_name) + + ! Read aerosol optical properties. Note differences with + ! "radiation_aerosol_optics_data::setup_aerosol_optics": + + ! -- The input NetCDF file is not flat, it contains NetCDF groups. + + ! -- We do not define ao%ssa_mono_phobic, ao%g_mono_phobic, + ! ao%lidar_ratio_mono_phobic, ao%ssa_mono_philic, + ! ao%g_mono_philic, ao%lidar_ratio_mono_philic. They are not in + ! the input NetCDF file and they are not used by ECRad. + + ! -- We do not define ao%description_phobic_str and + ! ao%description_philic_str. We just leave the initialization + ! value, which is a blank. + + ! -- We have to cshift the shortwave fields because the the + ! shortwave bands are in ascending order in the NetCDF file while + ! they are not in ECRad. + + use radiation_aerosol_optics_data, only: aerosol_optics_type, & + IAerosolClassUndefined + use netcdf95, only: nf95_open, nf95_inq_grp_full_ncid, nf95_close, & + nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, & + nf95_get_var, nf95_gw_var, nf95_nowrite + + type(aerosol_optics_type), intent(out):: ao + + character(len=*), intent(in):: file_name + ! NetCDF file containing the aerosol optics data + + ! Local: + integer ncid, grpid, dimid, varid + + !----------------------------------------------------------------------- + + ao%use_hydrophilic = .true. + ao%use_monochromatic = .true. + call nf95_open(file_name, nf95_nowrite, ncid) + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic", grpid) + call nf95_inq_dimid(grpid, "hur", dimid) + call nf95_inquire_dimension(grpid, dimid, nclen = ao%nrh) + allocate(ao%rh_lower(ao%nrh)) + call nf95_inq_varid(grpid, "hur_bounds", varid) + call nf95_get_var(grpid, varid, ao%rh_lower, count_nc = [1, ao%nrh]) + + ! Hydrophilic/LW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/LW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_lw_philic) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_lw_philic) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_lw_philic) + + ! Hydrophilic/SW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/SW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_sw_philic) + ao%g_sw_philic = cshift(ao%g_sw_philic, 1) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_sw_philic) + ao%ssa_sw_philic = cshift(ao%ssa_sw_philic, 1) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_sw_philic) + ao%mass_ext_sw_philic = cshift(ao%mass_ext_sw_philic, 1) + + ! Hydrophilic/Monochromatic: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/Monochromatic", grpid) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_mono_philic) + + ! Hydrophobic/LW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/LW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_lw_phobic) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_lw_phobic) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_lw_phobic) + + ! Hydrophobic/SW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/SW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_sw_phobic) + ao%g_sw_phobic = cshift(ao%g_sw_phobic, 1) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_sw_phobic) + ao%ssa_sw_phobic = cshift(ao%ssa_sw_phobic, 1) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_sw_phobic) + ao%mass_ext_sw_phobic = cshift(ao%mass_ext_sw_phobic, 1) + + ! Hydrophobic/Monochromatic: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/Monochromatic", grpid) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_mono_phobic) + + call nf95_close(ncid) + + ! Get array sizes + ao%n_bands_lw = size(ao%mass_ext_lw_phobic, 1) + ao%n_bands_sw = size(ao%mass_ext_sw_phobic, 1) + ao%n_mono_wl = size(ao%mass_ext_mono_phobic, 1) + ao%n_type_phobic = size(ao%mass_ext_lw_phobic, 2) + ao%n_type_philic = size(ao%mass_ext_lw_philic, 3) + + ! Allocate memory for mapping arrays + ao%ntype = ao%n_type_phobic + ao%n_type_philic + allocate(ao%iclass(ao%ntype)) + allocate(ao%itype(ao%ntype)) + + ao%iclass = IAerosolClassUndefined + ao%itype = 0 + + end subroutine setup_aerosol_optics_lmdz + +end module setup_aerosol_optics_lmdz_m Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/setup_config_from_lmdz.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/setup_config_from_lmdz.f90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/lmdz/setup_config_from_lmdz.f90 (revision 6016) @@ -0,0 +1,132 @@ +module setup_config_from_lmdz + + use parkind1, only : jprb + + implicit none + + public + + type driver_config_type + logical :: ok_effective_size = .true. + logical :: ok_separation_eta = .false. + logical :: ok_separation_tanh = .false. + real(jprb) :: high_inv_effective_size = -1.0_jprb ! m-1 + real(jprb) :: middle_inv_effective_size = -1.0_jprb ! m-1 + real(jprb) :: low_inv_effective_size = -1.0_jprb ! m-1 + real(jprb) :: cloud_inhom_separation_factor = -1.0_jprb + real(jprb) :: cloud_separation_scale_surface = -1.0_jprb + real(jprb) :: cloud_separation_scale_toa = -1.0_jprb + real(jprb) :: cloud_separation_scale_power = -1.0_jprb + real(jprb) :: frac_std = 0.75_jprb + real(jprb) :: overlap_decorr_length = 2000.0_jprb + ! KDECOLAT : 0 > cste, 1 > Shonk et al. (2010) 2 > 1 lisse a l'equateur + ! 3 : 1+variation sur la verticale + ! 4 : 2+variation sur la verticale + integer :: kdecolat = 0 + real(jprb) :: low_decorrelation_length = 2000.0_jprb + real(jprb) :: mid_decorrelation_length = 2000.0_jprb + real(jprb) :: high_decorrelation_length = 2000.0_jprb + + ! Save inputs in "inputs.nc" + logical :: do_save_inputs + contains + procedure :: read => read_config_from_namelist + + end type driver_config_type + +contains + + !--------------------------------------------------------------------- + subroutine read_config_from_namelist(this, file_name, is_success) + + use radiation_io, only : nulerr, radiation_abort + + class(driver_config_type), intent(inout) :: this + character(*), intent(in) :: file_name + logical, intent(out), optional :: is_success + logical :: ok_effective_size, ok_separation_eta, ok_separation_tanh + integer :: iosopen ! Status after calling open + real(jprb) :: high_inv_effective_size + real(jprb) :: middle_inv_effective_size + real(jprb) :: low_inv_effective_size + real(jprb) :: cloud_inhom_separation_factor + real(jprb) :: cloud_separation_scale_surface + real(jprb) :: cloud_separation_scale_toa + real(jprb) :: cloud_separation_scale_power + real(jprb) :: frac_std + real(jprb) :: overlap_decorr_length + integer :: kdecolat + real(jprb) :: low_decorrelation_length + real(jprb) :: mid_decorrelation_length + real(jprb) :: high_decorrelation_length + logical :: do_save_inputs + + namelist /radiation_driver/ ok_effective_size, ok_separation_eta, ok_separation_tanh, & + & frac_std, overlap_decorr_length, kdecolat, & + & low_decorrelation_length, mid_decorrelation_length, high_decorrelation_length, & + & high_inv_effective_size, middle_inv_effective_size, low_inv_effective_size, & + & cloud_inhom_separation_factor, cloud_separation_scale_surface, & + & cloud_separation_scale_toa, cloud_separation_scale_power, & + do_save_inputs + + ok_effective_size = .false. + ok_separation_eta = .false. + ok_separation_tanh = .false. + high_inv_effective_size = -1.0_jprb + middle_inv_effective_size = -1.0_jprb + low_inv_effective_size = -1.0_jprb + cloud_inhom_separation_factor = -1.0_jprb + cloud_separation_scale_surface = -1.0_jprb + cloud_separation_scale_toa = -1.0_jprb + cloud_separation_scale_power = -1.0_jprb + frac_std = 0.75_jprb + overlap_decorr_length = 2000.0_jprb + kdecolat = 0 + low_decorrelation_length = 2000.0_jprb + mid_decorrelation_length = 2000.0_jprb + high_decorrelation_length = 2000.0_jprb + do_save_inputs = .false. + + ! Open the namelist file and read the radiation_driver namelist + open(unit=10, iostat=iosopen, file=trim(file_name)) + if (iosopen /= 0) then + ! An error occurred + if (present(is_success)) then + is_success = .false. + ! We now continue the subroutine so that the default values + ! are placed in the config structure + else + write(nulerr,'(a,a,a)') '*** Error: namelist file "', & + & trim(file_name), '" not found' + call radiation_abort('Driver configuration error') + end if + else + ! Read the radiation_driver namelist, noting that it is not an + ! error if this namelist is not present, provided all the required + ! variables are present in the NetCDF data file instead + read(unit=10, nml=radiation_driver) + close(unit=10) + end if + + ! Copy namelist data into configuration object + this%ok_effective_size = ok_effective_size + this%ok_separation_eta = ok_separation_eta + this%ok_separation_tanh = ok_separation_tanh + this%frac_std = frac_std + this%overlap_decorr_length = overlap_decorr_length + this%kdecolat = kdecolat + this%low_decorrelation_length = low_decorrelation_length + this%mid_decorrelation_length = mid_decorrelation_length + this%high_decorrelation_length = high_decorrelation_length + this%cloud_inhom_separation_factor = cloud_inhom_separation_factor + this%cloud_separation_scale_surface = cloud_separation_scale_surface + this%cloud_separation_scale_toa = cloud_separation_scale_toa + this%cloud_separation_scale_power = cloud_separation_scale_power + this%high_inv_effective_size = high_inv_effective_size + this%middle_inv_effective_size = middle_inv_effective_size + this%low_inv_effective_size = low_inv_effective_size + this%do_save_inputs = do_save_inputs + + end subroutine read_config_from_namelist + +end module setup_config_from_lmdz Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_compiler_simple.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_compiler_simple.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_compiler_simple.m4 (revision 6016) @@ -0,0 +1,277 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_COMPILER_FC_VENDOR_SIMPLE() +# ----------------------------------------------------------------------------- +# Detects the vendor of the Fortran compiler. The result is "intel", "nag", +# "portland", "cray", "nec", "gnu", "amd", "flang" or "unknown". +# +# This is a simplified version ACX_COMPILER_FC_VENDOR, which tries to detect +# the vendor based on the version output of the compiler, instead of checking +# whether vendor-specific macros are defined. +# +# The result is cached in the acx_cv_fc_compiler_vendor variable. +# +AC_DEFUN([ACX_COMPILER_FC_VENDOR_SIMPLE], + [AC_LANG_ASSERT([Fortran])dnl + m4_provide([ACX_COMPILER_FC_VENDOR])dnl + m4_pushdef([acx_cache_var], + [acx_cv_[]_AC_LANG_ABBREV[]_compiler_vendor])dnl + AC_CACHE_CHECK([for _AC_LANG compiler vendor], [acx_cache_var], + [AS_IF( + [AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +grep '^\(ifort\|ifx\) (IFORT)' >/dev/null 2>&1], + [acx_cache_var=intel], + [AS_VAR_GET([_AC_CC]) -V 2>&1 | dnl +grep '^NAG Fortran Compiler Release' >/dev/null 2>&1], + [acx_cache_var=nag], + [AS_VAR_GET([_AC_CC]) -V 2>/dev/null| dnl +grep '^Copyright.*\(The Portland Group\|NVIDIA CORPORATION\)' >/dev/null 2>&1], + [acx_cache_var=portland], + [AS_VAR_GET([_AC_CC]) -V 2>&1 | grep '^Cray Fortran' >/dev/null 2>&1], + [acx_cache_var=cray], + [AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +grep '^Copyright.*NEC Corporation' >/dev/null 2>&1], + [acx_cache_var=nec], + [AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +grep '^GNU Fortran' >/dev/null 2>&1], + [acx_cache_var=gnu], + [AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +grep '^AMD clang version' >/dev/null 2>&1], + [acx_cache_var=amd], + [AS_VAR_GET([_AC_CC]) -V 2>&1 | grep '^f18 compiler' >/dev/null 2>&1], + [acx_cache_var=flang], + [AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +grep 'clang version' >/dev/null 2>&1], + [acx_cache_var=flang], + [acx_cache_var=unknown]) + rm -f a.out a.out.dSYM a.exe b.out]) + m4_popdef([acx_cache_var])]) + +# ACX_COMPILER_FC_VERSION_SIMPLE() +# ----------------------------------------------------------------------------- +# Detects the version of the C compiler. The result is either "unknown" +# or a string in the form "[epoch:]major[.minor[.patchversion]]", where +# "epoch:" is an optional prefix used in order to have an increasing version +# number in case of marketing change. +# +# This is a simplified version ACX_COMPILER_FC_VERSION, which tries to detect +# the version based on the version output of the compiler, instead of checking +# for the values of vendor-specific macros. +# +# The result is cached in the acx_cv_fc_compiler_version variable. +# +AC_DEFUN([ACX_COMPILER_FC_VERSION_SIMPLE], + [AC_LANG_ASSERT([Fortran])dnl + AC_REQUIRE([ACX_COMPILER_FC_VENDOR])dnl + m4_provide([ACX_COMPILER_FC_VERSION])dnl + m4_pushdef([acx_cache_var], + [acx_cv_[]_AC_LANG_ABBREV[]_compiler_version])dnl + AC_CACHE_CHECK([for _AC_LANG compiler version], [acx_cache_var], + [AS_CASE([AS_VAR_GET([acx_cv_[]_AC_LANG_ABBREV[]_compiler_vendor])], + [intel], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -n 's/^ifort (IFORT) \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="classic:${acx_cache_var}"], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -n 's/^ifx (IFORT) \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="oneapi:${acx_cache_var}"])])], + [nag], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>&1 | dnl +[sed -n 's/^NAG Fortran Compiler Release \([0-9][0-9]*\.[0-9][0-9]*\).*]dnl +[Build \([0-9][0-9]*\)/\1.\2/p']`], + [portland], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>/dev/null | dnl +[sed -n 's/\(pgfortran\|pgf90\) \([0-9][0-9]*\.[0-9][0-9]*\)-\([0-9][0-9]*\).*/\2.\3/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="pg:${acx_cache_var}"], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>/dev/null | dnl +[sed -n 's/nvfortran \([0-9][0-9]*\.[0-9][0-9]*\)-\([0-9][0-9]*\).*/\1.\2/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="nv:${acx_cache_var}"])])], + [cray], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>&1 | dnl +[sed -n 's/.*[vV]ersion \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']`], + [nec], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +[sed -n 's/^nfort (NFORT) \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']`], + [gnu], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -dumpfullversion 2>/dev/null | dnl +[sed -n '/^[0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*$/p']` + AS_IF([test -z "$acx_cache_var"], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -dumpversion 2>/dev/null | dnl +[sed -n '/^[0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*$/p']`])], + [amd], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -n 's/.*AOCC_\([0-9][0-9]*\)[._]\([0-9][0-9]*\)[._]\([0-9][0-9]*\).*/\1.\2.\3/p']`], + [flang], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>&1 | dnl +[sed -n 's/.*version \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\)/\1/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="f18:${acx_cache_var}"], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -n 's/.*version \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="classic:${acx_cache_var}"])])], + [acx_cache_var=unknown]) + rm -f a.out a.out.dSYM a.exe b.out + AS_IF([test -z "$acx_cache_var"], [acx_cache_var=unknown])]) + m4_popdef([acx_cache_var])]) + +# ACX_COMPILER_CC_VENDOR_SIMPLE() +# ----------------------------------------------------------------------------- +# Detects the vendor of the C compiler. The result is "intel", "nag", +# "portland", "cray", "nec", "gnu", "amd", "clang" or "unknown". +# +# This is a simplified version ACX_COMPILER_CC_VENDOR, which tries to detect +# the vendor based on the version output of the compiler, instead of checking +# whether vendor-specific macros are defined. +# +# The result is cached in the acx_cv_c_compiler_vendor variable. +# +AC_DEFUN([ACX_COMPILER_CC_VENDOR_SIMPLE], + [AC_LANG_ASSERT([C])dnl + m4_provide([ACX_COMPILER_CC_VENDOR])dnl + m4_pushdef([acx_cache_var], + [acx_cv_[]_AC_LANG_ABBREV[]_compiler_vendor])dnl + AC_CACHE_CHECK([for _AC_LANG compiler vendor], [acx_cache_var], + [AS_IF( + [AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +grep '^icc (ICC)' >/dev/null 2>&1], + [acx_cache_var=intel], + [AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +grep '^Intel.*oneAPI.*Compiler' >/dev/null 2>&1], + [acx_cache_var=intel], + [AS_VAR_GET([_AC_CC]) -V 2>&1 | dnl +grep '^NAG Fortran Compiler Release' >/dev/null 2>&1], + [acx_cache_var=nag], + [AS_VAR_GET([_AC_CC]) -V 2>/dev/null| dnl +grep '^Copyright.*\(The Portland Group\|NVIDIA CORPORATION\)' >/dev/null 2>&1], + [acx_cache_var=portland], + [AS_VAR_GET([_AC_CC]) -V 2>&1 | grep '^Cray C' >/dev/null 2>&1], + [acx_cache_var=cray], + [AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +grep '^Cray clang' >/dev/null 2>&1], + [acx_cache_var=cray], + [AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +grep '^Copyright.*NEC Corporation' >/dev/null 2>&1], + [acx_cache_var=nec], + [AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +grep '^gcc' >/dev/null 2>&1], + [acx_cache_var=gnu], + [AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +grep '^AMD clang version' >/dev/null 2>&1], + [acx_cache_var=amd], + [AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +grep '^Apple \(LLVM\|clang\) version' >/dev/null 2>&1], + [acx_cache_var=apple], + [AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +grep 'clang version' >/dev/null 2>&1], + [acx_cache_var=clang], + [acx_cache_var=unknown]) + rm -f a.out a.out.dSYM a.exe b.out]) + m4_popdef([acx_cache_var])]) + +# ACX_COMPILER_CC_VERSION_SIMPLE() +# ----------------------------------------------------------------------------- +# Detects the version of the C compiler. The result is either "unknown" +# or a string in the form "[epoch:]major[.minor[.patchversion]]", where +# "epoch:" is an optional prefix used in order to have an increasing version +# number in case of marketing change. +# +# This is a simplified version ACX_COMPILER_CC_VERSION, which tries to detect +# the version based on the version output of the compiler, instead of checking +# for the values of vendor-specific macros. +# +# The result is cached in the acx_cv_c_compiler_version variable. +# +AC_DEFUN([ACX_COMPILER_CC_VERSION_SIMPLE], + [AC_LANG_ASSERT([C])dnl + AC_REQUIRE([ACX_COMPILER_CC_VENDOR])dnl + m4_provide([ACX_COMPILER_CC_VERSION])dnl + m4_pushdef([acx_cache_var], + [acx_cv_[]_AC_LANG_ABBREV[]_compiler_version])dnl + AC_CACHE_CHECK([for _AC_LANG compiler version], [acx_cache_var], + [AS_CASE([AS_VAR_GET([acx_cv_[]_AC_LANG_ABBREV[]_compiler_vendor])], + [intel], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -n 's/^icc (ICC) \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="classic:${acx_cache_var}"], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -n 's/^Intel.*oneAPI.*Compiler \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="oneapi:${acx_cache_var}"])])], + [nag], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>&1 | dnl +[sed -n 's/^NAG Fortran Compiler Release \([0-9][0-9]*\.[0-9][0-9]*\).*]dnl +[Build \([0-9][0-9]*\)/\1.\2/p']`], + [portland], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>/dev/null | dnl +[sed -n 's/pgcc \((.*) \)\?\([0-9][0-9]*\.[0-9][0-9]*\)-\([0-9][0-9]*\).*/\2.\3/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="pg:${acx_cache_var}"], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>/dev/null | dnl +[sed -n 's/nvc \([0-9][0-9]*\.[0-9][0-9]*\)-\([0-9][0-9]*\).*/\1.\2/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="nv:${acx_cache_var}"])])], + [cray], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -V 2>&1 | dnl +[sed -n 's/.*ersion \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="classic:${acx_cache_var}"], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version | dnl +[sed -n 's/.*version \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']` + AS_IF([test -n "$acx_cache_var"], + [acx_cache_var="clang:${acx_cache_var}"])])], + [nec], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>&1 | dnl +[sed -n 's/^ncc (NCC) \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']`], + [gnu], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -dumpfullversion 2>/dev/null | dnl +[sed -n '/^[0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*$/p']` + AS_IF([test -z "$acx_cache_var"], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) -dumpversion 2>/dev/null | dnl +[sed -n '/^[0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*$/p']`])], + [amd], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -n 's/.*AOCC_\([0-9][0-9]*\)[._]\([0-9][0-9]*\)[._]\([0-9][0-9]*\).*/\1.\2.\3/p']`], + [apple], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -E -n 's/^Apple (LLVM|clang) version ([0-9]+\.[0-9]+\.[0-9]+).*/\2/p']`], + [clang], + [acx_cache_var=`AS_VAR_GET([_AC_CC]) --version 2>/dev/null | dnl +[sed -n 's/.*clang version \([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/p']`], + [acx_cache_var=unknown]) + rm -f a.out a.out.dSYM a.exe b.out + AS_IF([test -z "$acx_cache_var"], [acx_cache_var=unknown])]) + m4_popdef([acx_cache_var])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_endianness.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_endianness.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_endianness.m4 (revision 6016) @@ -0,0 +1,98 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_FC_ENDIANNESS_REAL([DOUBLE-PRECISION-KIND = KIND(1.d0)] +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Inspired by the AX_C_FLOAT_WORDS_BIGENDIAN macro in Autoconf Archive. +# ----------------------------------------------------------------------------- +# Checks the floating-point endianness of the target system with the Fortran +# compiler. Tries to compile a program that sets a double-precision +# floating-point variable of type real and kind DOUBLE-PRECISION-KIND (defaults +# to KIND(1.d0)) to a value that can be interpreted as an ASCII string. The +# resulting object file is then grepped for several possible values, each +# representing the respective type of endianness: +# - "mkhElper" - little-endian; +# - "replEhkm" - big-endian; +# - "lpermkhE" - half little-endian, half big-endian. +# The list above might be extended in the future to detect other types of +# mixed-endianness. If more than one string from the list matches the contents +# of the object, the result is "unknown". +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_endianness_real variable. +# +AC_DEFUN([ACX_FC_ENDIANNESS_REAL], + [AC_LANG_ASSERT([Fortran])dnl + AC_MSG_CHECKING([for endianness of the target system]) + AC_CACHE_VAL([acx_cv_fc_endianness_real], + [acx_cv_fc_endianness_real=unknown + free_fmt=' + real(dp) :: b(2) = (/11436526043186408342932917319490312838905855& + &2118841611962449784525241959417255606719874468829884522246508686& + &0799336906947500199989578974774280030598291952243399484779227378& + &5162269613202128034599963034475950452228997847642131801671155898& + &01738240.0_dp,0.0_dp/)' + fixed_fmt=' + real(dp) :: b(2) = (/11436526043186408342932917319490312838905855 + + 2118841611962449784525241959417255606719874468829884522246508686 + + 0799336906947500199989578974774280030598291952243399484779227378 + + 5162269613202128034599963034475950452228997847642131801671155898 + + 01738240.0_dp,0.0_dp/)' + for acx_tmp in "$free_fmt" "$fixed_fmt"; do + AC_COMPILE_IFELSE([AC_LANG_SOURCE([[ subroutine conftest(i, a) + implicit none + integer, parameter :: dp = ]m4_default([$1], [[KIND(1.d0)]])[ + integer :: i + real(dp) :: a +$acx_tmp + a = b(i) + end subroutine]])], + [for acx_tmp in mkhElper replEhkm lpermkhE; do + AS_IF([grep "$acx_tmp" conftest.$ac_objext >/dev/null], + [AS_VAR_IF([acx_cv_fc_endianness_real], [unknown], + [acx_cv_fc_endianness_real=$acx_tmp], + [acx_cv_fc_endianness_real=unknown + break])]) + done]) + test 0 -eq "$ac_retval" && break + done + ]) + acx_tmp=unknown + AS_CASE([$acx_cv_fc_endianness_real], + [mkhElper], [acx_tmp='little-endian'], + [replEhkm], [acx_tmp='big-endian'], + [lpermkhE], [acx_tmp='half little-endian, half big-endian']) + AC_MSG_RESULT([$acx_tmp]) + AS_VAR_IF([acx_tmp], [unknown], [m4_default([$3], [AC_MSG_FAILURE( + [unable to detect the endianness of the target system])])], [$2])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_include.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_include.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_include.m4 (revision 6016) @@ -0,0 +1,350 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_FC_INCLUDE_FLAG([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the compiler flag needed to specify search paths for the Fortran +# "INCLUDE" statement. The result is either "unknown" or the actual compiler +# flag, which may contain a significant trailing whitespace. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_ftn_include_flag variable. +# +AC_DEFUN([ACX_FC_INCLUDE_FLAG], + [_ACX_FC_INCLUDE_FLAG + AS_VAR_IF([acx_cv_fc_ftn_include_flag], [unknown], + [m4_default([$2], + [AC_MSG_FAILURE([unable to detect Fortran compiler flag needed to dnl +specify search paths for _ACX_FC_INCLUDE_DESC([ftn])])])], [$1])]) + +# ACX_FC_INCLUDE_FLAG_PP([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the compiler flag needed to specify search paths for the quoted form of +# the preprocessor "#include" directive. The result is either "unknown" or the +# actual compiler flag, which may contain a significant trailing whitespace. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_pp_include_flag variable. +# +AC_DEFUN([ACX_FC_INCLUDE_FLAG_PP], + [_ACX_FC_INCLUDE_FLAG_PP + AS_VAR_IF([acx_cv_fc_pp_include_flag], [unknown], + [m4_default([$2], + [AC_MSG_FAILURE([unable to detect Fortran compiler flag needed to dnl +specify search paths for _ACX_FC_INCLUDE_DESC([pp])])])], [$1])]) + +# ACX_FC_INCLUDE_FLAG_PP_SYS([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the compiler flag needed to specify search paths for the angle-bracket +# form of the preprocessor "#include" directive. The result is either "unknown" +# or the actual compiler flag, which may contain a significant trailing +# whitespace. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_pp_sys_include_flag variable. +# +AC_DEFUN([ACX_FC_INCLUDE_FLAG_PP_SYS], + [_ACX_FC_INCLUDE_FLAG_PP_SYS + AS_VAR_IF([acx_cv_fc_pp_sys_include_flag], [unknown], + [m4_default([$2], + [AC_MSG_FAILURE([unable to detect Fortran compiler flag needed to dnl +specify search paths for _ACX_FC_INCLUDE_DESC([pp_sys])])])], [$1])]) + +# ACX_FC_INCLUDE_ORDER([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the search path order for the Fortran "INCLUDE" statement. The result +# is either "unknown" (e.g. in the case of cross-compilation) or a +# comma-separated list of identifiers that denote directories, in which the +# compiler searches for an included file: +# "cwd": current working directory; +# "flg": directories specified with the search path flags; +# "src": directory containing the compiled source file; +# "inc": directory containing the file with the the include statement or +# directive. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_ftn_include_order variable. +# +AC_DEFUN([ACX_FC_INCLUDE_ORDER], + [AC_REQUIRE([_ACX_FC_INCLUDE_FLAG])_ACX_FC_INCLUDE_ORDER([ftn],$@)]) + +# ACX_FC_INCLUDE_ORDER_PP([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the search path order for the quoted form of the preprocessor +# "#include" directive. See ACX_FC_INCLUDE_ORDER for the description of the +# result. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_pp_include_order variable. +# +AC_DEFUN([ACX_FC_INCLUDE_ORDER_PP], + [AC_REQUIRE([_ACX_FC_INCLUDE_FLAG_PP])_ACX_FC_INCLUDE_ORDER([pp],$@)]) + +# ACX_FC_INCLUDE_ORDER_PP_SYS([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the search path order for the angle-bracket form of the preprocessor +# "#include" directive. See ACX_FC_INCLUDE_ORDER for the description of the +# result. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_pp_sys_include_order variable. +# +AC_DEFUN([ACX_FC_INCLUDE_ORDER_PP_SYS], + [AC_REQUIRE([_ACX_FC_INCLUDE_FLAG_PP_SYS])dnl +_ACX_FC_INCLUDE_ORDER([pp_sys],$@)]) + +# ACX_FC_INCLUDE_CHECK(HEADER-FILE, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Checks whether the header HEADER-FILE included with the Fortran "INCLUDE" +# statement is available. The result is either "yes" or "no". +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the +# acx_cv_fc_ftn_header_[]AS_TR_SH(HEADER-FILE) variable. +# +AC_DEFUN([ACX_FC_INCLUDE_CHECK], [_ACX_FC_INCLUDE_CHECK([ftn],$@)]) + +# _ACX_FC_INCLUDE_LINE(HEADER-TYPE, HEADER-FILE) +# ----------------------------------------------------------------------------- +# Expands into a line of code with the include statement or directive for the +# HEADER-FILE. The HEADER-TYPE defines, which actual statement or directive is +# used, and can be one of the following: +# "ftn" for the Fortran "INCLUDE" statement; +# "pp" for the quoted form of the preprocessor "#include" directive; +# "pp_sys" for the angle-bracket form of the preprocessor "#include" +# directive. +# +m4_define([_ACX_FC_INCLUDE_LINE], + [m4_case([$1], + [ftn], [m4_n([[ include "$2"]])], + [pp], [m4_n([[@%:@include "$2"]])], + [pp_sys], [m4_n([[@%:@include <$2>]])], + [m4_fatal([unexpected header type: '$1'])])]) + +# _ACX_FC_INCLUDE_DESC(HEADER-TYPE) +# ----------------------------------------------------------------------------- +# Expands into a shell string with the description of the HEADER-TYPE (see +# ACX_FC_INCLUDE_LINE). +# +m4_define([_ACX_FC_INCLUDE_DESC], + [m4_case([$1], + [ftn], [[the \"INCLUDE\" statement]], + [pp], [[the quoted form of the \"#include\" directive]], + [pp_sys], [[the angle-bracket form of the \"#include\" directive]], + [m4_fatal([unexpected header type: '$1'])])]) + +# _ACX_FC_INCLUDE_KNOWN_FLAGS(HEADER-TYPE) +# ----------------------------------------------------------------------------- +# Expands into a space-separated list of known flags needed to specify search +# paths for the HEADER-TYPE (see _ACX_FC_INCLUDE_LINE). +# +m4_define([_ACX_FC_INCLUDE_KNOWN_FLAGS], + [m4_bmatch([$1], + [ftn], [[-I '-I ']], + [[pp|pp_sys]], [[-I '-I ' '-WF,-I' '-Wp,-I']], + [m4_fatal([unexpected header type: '$1'])])]) + +# _ACX_FC_INCLUDE_FLAG() +# ----------------------------------------------------------------------------- +# A parameterless alias for __ACX_FC_INCLUDE_FLAG([ftn]) to be used as an +# argument for AC_REQUIRE. +# +AC_DEFUN([_ACX_FC_INCLUDE_FLAG], [__ACX_FC_INCLUDE_FLAG([ftn])]) + +# _ACX_FC_INCLUDE_FLAG_PP() +# ----------------------------------------------------------------------------- +# A parameterless alias for __ACX_FC_INCLUDE_FLAG([pp]) to be used as an +# argument for AC_REQUIRE. +# +AC_DEFUN([_ACX_FC_INCLUDE_FLAG_PP], [__ACX_FC_INCLUDE_FLAG([pp])]) + +# _ACX_FC_INCLUDE_FLAG_PP_SYS() +# ----------------------------------------------------------------------------- +# A parameterless alias for __ACX_FC_INCLUDE_FLAG([pp_sys]) to be used as an +# argument for AC_REQUIRE. +# +AC_DEFUN([_ACX_FC_INCLUDE_FLAG_PP_SYS], [__ACX_FC_INCLUDE_FLAG([pp_sys])]) + +# __ACX_FC_INCLUDE_FLAG(HEADER-TYPE) +# ----------------------------------------------------------------------------- +# Finds the compiler flag needed to specify search paths for the HEADER-TYPE +# (see _ACX_FC_INCLUDE_LINE). +# +# The result is cached in the acx_cv_fc_[]HEADER-TYPE[]_include_flag variable. +# +# See _ACX_LANG_KNOWN_INC_FLAGS for the known flags. +# +m4_define([__ACX_FC_INCLUDE_FLAG], + [AC_LANG_ASSERT([Fortran])dnl + m4_pushdef([acx_cache_var], [acx_cv_fc_[]$1[]_include_flag])dnl + AC_CACHE_CHECK([for Fortran compiler flag needed to specify search dnl +paths for _ACX_FC_INCLUDE_DESC([$1])], [acx_cache_var], + [acx_cache_var=unknown + AS_MKDIR_P([conftest.dir]) + AC_LANG_CONFTEST([AC_LANG_PROGRAM]) + mv conftest.$ac_ext conftest.dir/conftest.inc + AC_LANG_CONFTEST([AC_LANG_SOURCE( + [_ACX_FC_INCLUDE_LINE([$1], [conftest.inc])])]) + acx_save_FCFLAGS=$FCFLAGS + for acx_flag in _ACX_FC_INCLUDE_KNOWN_FLAGS([$1]); do + FCFLAGS="$acx_save_FCFLAGS ${acx_flag}conftest.dir" + AC_LINK_IFELSE([], [AS_VAR_COPY([acx_cache_var], [acx_flag])]) + test "x$acx_cache_var" != xunknown && break + done + FCFLAGS=$acx_save_FCFLAGS + rm -f conftest.$ac_ext + rm -rf conftest.dir]) + m4_popdef([acx_cache_var])]) + +# _ACX_FC_INCLUDE_ORDER(HEADER-TYPE, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the search path order for the for the HEADER-TYPE (see +# _ACX_FC_INCLUDE_LINE). See ACX_FC_INCLUDE_ORDER for the description of the +# result. +# +# It is implied that __ACX_FC_INCLUDE_FLAG(HEADER-TYPE) has already been +# called. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_[]HEADER-TYPE[]_include_order +# variable. +# +m4_define([_ACX_FC_INCLUDE_ORDER], + [AC_LANG_ASSERT([Fortran])dnl + m4_pushdef([acx_cache_var], [acx_cv_fc_[]$1[]_include_order])dnl + AC_CACHE_CHECK([for Fortran compiler search path order for dnl +_ACX_FC_INCLUDE_DESC([$1])], [acx_cache_var], + [acx_cache_var= + AS_VAR_IF([cross_compiling], [no], + [AS_MKDIR_P([conftest.dir/src/inc]) + AS_MKDIR_P([conftest.dir/build]) + AS_MKDIR_P([conftest.dir/src/inc2]) + AC_LANG_CONFTEST([AC_LANG_PROGRAM([], + [_ACX_FC_INCLUDE_LINE([$1], [conftest.inc])])]) +dnl Copy the file to the build dir to keep _AC_MSG_LOG_CONFTEST happy. +dnl This copy does not get compiled. + cp conftest.$ac_ext conftest.dir/build/conftest.$ac_ext +dnl This instance of the file will be compiled. + mv conftest.$ac_ext conftest.dir/src/conftest.$ac_ext + AC_LANG_CONFTEST([AC_LANG_SOURCE( + [_ACX_FC_INCLUDE_LINE([$1], [conftest.write])])]) + mv conftest.$ac_ext conftest.dir/src/inc2/conftest.inc + set "src" "/src/" "flg" "/src/inc/" "inc" "/src/inc2/" "cwd" "/build/" + while test $[]@%:@ != 0; do + AC_LANG_CONFTEST([AC_LANG_SOURCE([[ write(*,"(a)") "${1}"]])]) + shift; mv conftest.$ac_ext conftest.dir${1}conftest.write; shift + done + cd conftest.dir/build + acx_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS ${acx_cv_fc_[]$1[]_include_flag}../src/inc dnl +${acx_cv_fc_[]$1[]_include_flag}../src/inc2" + acx_save_ac_link=$ac_link + ac_link=`AS_ECHO(["$ac_link"]) | sed 's%conftest\.\$ac_ext%../src/&%'` + while :; do + AC_LINK_IFELSE([], + [acx_exec_result=`./conftest$ac_exeext` + AS_IF([test $? -eq 0], + [AS_CASE([$acx_exec_result], + [src], [rm -f ../src/conftest.write], + [inc], [rm -f ../src/inc2/conftest.write], + [cwd], [rm -f ./conftest.write], + [flg], [rm -f ../src/inc/conftest.write dnl +../src/inc2/conftest.write], + [break]) + AS_IF([test -z "$acx_cache_var"], + [acx_cache_var=$acx_exec_result], + [AS_VAR_APPEND([acx_cache_var], [",$acx_exec_result"])]) + rm -f conftest$ac_exeext], + [break])], + [break]) + done + ac_link=$acx_save_ac_link + FCFLAGS=$acx_save_FCFLAGS + cd ../.. + rm -rf conftest.dir]) + AS_IF([test -z "$acx_cache_var"], [acx_cache_var=unknown])]) + AS_VAR_IF([acx_cache_var], [unknown], [m4_default([$3], + [AC_MSG_FAILURE([unable to detect Fortran compiler search path dnl +order for _ACX_FC_INCLUDE_DESC([$1])])])], [$2]) + m4_popdef([acx_cache_var])]) + +# _ACX_FC_INCLUDE_CHECK(HEADER-TYPE, +# HEADER-FILE, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Checks the availability of the header file HEADER-FILE of the type +# HEADER-TYPE (see _ACX_FC_INCLUDE_LINE). +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the +# acx_cv_fc_[]HEADER-TYPE[]_header_[]AS_TR_SH(HEADER-FILE) +# variable. +# +m4_define([_ACX_FC_INCLUDE_CHECK], + [AC_LANG_ASSERT([Fortran])dnl + m4_pushdef([acx_cache_var], [acx_cv_fc_[]$1[]_header_[]AS_TR_SH([$2])])dnl + AC_CACHE_CHECK([for $2], [acx_cache_var], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([],[_ACX_FC_INCLUDE_LINE([$1], [$2])])], + [AS_VAR_SET([acx_cache_var], [yes])], + [AS_VAR_SET([acx_cache_var], [no])])]) + AS_VAR_IF([acx_cache_var], [yes], [$3], [m4_default([$4], + [AC_MSG_FAILURE([Fortran header file '$2' included with dnl +_ACX_FC_INCLUDE_DESC([$1]) is not available])])]) + m4_popdef([acx_cache_var])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_line_length.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_line_length.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_line_length.m4 (revision 6016) @@ -0,0 +1,90 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_FC_LINE_LENGTH([LENGTH = 132], +# [ACTION-IF-SUCCESS = APPEND-FCFLAGS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the Fortran compiler flag needed to accept lines of length LENGTH, +# where LENGTH may be 80, 132 (default), or 'unlimited' for longer lines. The +# result is either "unknown", or the actual compiler flag required to to accept +# lines of length LENGTH. +# +# If successful, runs ACTION-IF-SUCCESS (defaults to appending the result to +# FCFLAGS), otherwise runs ACTION-IF-FAILURE (defaults to failing with an error +# message). +# +# The flag is cached in the acx_cv_fc_line_length_[]LENGTH. +# +# The implementation patches the standard Autoconf macro AC_FC_LINE_LENGTH to +# reduce the number of LANG switches and to avoid false negative results with +# the GFortran '-fimplicit-none' flag. +# +AC_DEFUN([ACX_FC_LINE_LENGTH], + [AC_LANG_ASSERT([Fortran])dnl +dnl Fail instead of warning: + m4_bmatch(m4_default([$1], [132]), + [unlimited\|132\|80], [], + [m4_fatal([Invalid LENGTH argument for $0: '$1'])])dnl +dnl Monkey-patch AC_FC_LINE_LENGTH: + m4_pushdef([acx_cache_var], [acx_cv_fc_line_length_$1])dnl + m4_pushdef([ac_cv_fc_line_length], [acx_cache_var])dnl + m4_pushdef([acx_orig_macro], + m4_bpatsubsts(m4_dquote(m4_defn([AC_FC_LINE_LENGTH])), + [\$ac_fc_line_length_test$], [\& + implicit integer (a)], + [AC_LANG_P\(OP\|USH\)(\[?Fortran\]?)], [dn][l ]))dnl +dnl This macro does not have a special meaning for the value 'none' +dnl but AC_FC_LINE_LENGTH does. To account for the difference, we need to know +dnl whether 'none' came from the cache variable and set the cache variable to +dnl 'none' if it is set to an empty string: + acx_fc_line_length_none_in_cache=no + AS_VAR_SET_IF([acx_cache_var], + [AS_CASE([$acx_cache_var], + [none], [acx_fc_line_length_none_in_cache=yes], + [''], [acx_cache_var=none])]) +dnl AC_FC_LINE_LENGTH changes the FCFLAGS, which we do not want: + acx_save_FCFLAGS=$FCFLAGS + m4_quote(acx_orig_macro([$1], [], [:])) + FCFLAGS=$acx_save_FCFLAGS + m4_popdef([acx_orig_macro])dnl + m4_popdef([ac_cv_fc_line_length])dnl +dnl Set the cache variable to an empty string if the value 'none' was set by +dnl AC_FC_LINE_LENGTH but not if the variable had it before the expansion: + AS_IF([test "x$acx_cache_var$acx_fc_line_length_none_in_cache" = xnoneno], + [acx_cache_var=]) + AS_VAR_IF([acx_cache_var], [unknown], + [m4_default([$3], + [AC_MSG_FAILURE([unable to detect Fortran compiler flag needed to dnl +accept m4_default([$1], [132]) column source lines])])], + [m4_default([$2], + [AS_IF([test -n "$acx_cache_var"], + [AS_VAR_APPEND([FCFLAGS], [" $acx_cache_var"])])])]) + m4_popdef([acx_cache_var])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_module.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_module.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_module.m4 (revision 6016) @@ -0,0 +1,253 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_FC_MODULE_IN_FLAG([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the Fortran compiler flag needed to specify module search paths. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The flag is cached in the acx_cv_fc_module_in_flag variable, which may +# contain a significant trailing whitespace. +# +# The implementation patches the standard Autoconf macro AC_FC_MODULE_FLAG to +# reduce the number of LANG switches and to avoid false negative results with +# the GFortran '-fmodule-private' flag. +# +AC_DEFUN([ACX_FC_MODULE_IN_FLAG], + [AC_LANG_ASSERT([Fortran])dnl + m4_pushdef([ac_cv_fc_module_flag], [acx_cv_fc_module_in_flag])dnl + m4_pushdef([AC_CACHE_CHECK], + m4_bpatsubst(m4_dquote(m4_defn([AC_CACHE_CHECK])), + [\$][1], + [for Fortran compiler flag needed to specify search paths for module dnl +files]))dnl + m4_pushdef([AC_SUBST], [dn][l ])dnl + m4_pushdef([AC_CONFIG_COMMANDS_PRE], [dn][l ])dnl + m4_pushdef([acx_orig_macro], + m4_bpatsubsts(m4_dquote(m4_defn([AC_FC_MODULE_FLAG])), + [^ module conftest_module], [\& + implicit none + public], + [^ use conftest_module], [\&, only : conftest_routine + implicit none], + [AC_LANG_P\(OP\|USH\)(\[?Fortran\]?)], [dn][l ], + [FC_MODINC=.*], [dn][l ], + [^ *#], [dn][l ]))dnl + acx_orig_macro([:], [:])dnl + m4_popdef([acx_orig_macro])dnl + m4_popdef([AC_SUBST])dnl + m4_popdef([AC_CONFIG_COMMANDS_PRE])dnl + m4_popdef([AC_CACHE_CHECK])dnl + m4_popdef([ac_cv_fc_module_flag])dnl + AS_VAR_IF([acx_cv_fc_module_in_flag], [unknown], [m4_default([$2], + [AC_MSG_FAILURE([unable to detect Fortran compiler flag needed to dnl +specify search paths for module files])])], [$1])]) + +# ACX_FC_MODULE_OUT_FLAG([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the Fortran compiler flag needed to specify module output path. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The flag is cached in the acx_cv_fc_module_out_flag variable, which may +# contain a significant trailing whitespace. +# +# The implementation patches the standard Autoconf macro +# AC_FC_MODULE_OUTPUT_FLAG to reduce the number of LANG switches and to avoid +# false negative results with the GFortran '-fmodule-private' flag. +# +AC_DEFUN([ACX_FC_MODULE_OUT_FLAG], + [AC_LANG_ASSERT([Fortran])dnl + m4_pushdef([ac_cv_fc_module_output_flag], [acx_cv_fc_module_out_flag])dnl + m4_pushdef([AC_CACHE_CHECK], + m4_bpatsubst(m4_dquote(m4_defn([AC_CACHE_CHECK])), + [\$][1], + [for Fortran compiler flag needed to specify output path for module dnl +files]))dnl + m4_pushdef([AC_SUBST], [dn][l ])dnl + m4_pushdef([AC_CONFIG_COMMANDS_PRE], [dn][l ])dnl + m4_pushdef([acx_orig_macro], + m4_bpatsubsts(m4_dquote(m4_defn([AC_FC_MODULE_OUTPUT_FLAG])), + [^ module conftest_module], [\& + implicit none + public], + [^ use conftest_module], [\&, only : conftest_routine + implicit none], + [AC_LANG_P\(OP\|USH\)(\[?Fortran\]?)], [dn][l ], + [FC_MODOUT=.*], [dn][l ], + [^ *#], [dn][l ]))dnl + m4_version_prereq([2.70], [], + [m4_define([acx_orig_macro], + m4_bpatsubsts(m4_dquote(m4_defn([acx_orig_macro])), + ['-mod '], ['-mdir ' \&],))])dnl + acx_orig_macro([:], [:])dnl + m4_popdef([acx_orig_macro])dnl + m4_popdef([AC_SUBST])dnl + m4_popdef([AC_CONFIG_COMMANDS_PRE])dnl + m4_popdef([AC_CACHE_CHECK])dnl + m4_popdef([ac_cv_fc_module_output_flag])dnl + AS_VAR_IF([acx_cv_fc_module_out_flag], [unknown], [m4_default([$2], + [AC_MSG_FAILURE([unable to detect Fortran compiler flag needed to dnl +specify output path for module files])])], [$1])]) + +# ACX_FC_MODULE_NAMING([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the Fortran compiler module file naming template. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_module_naming_upper and +# acx_cv_fc_module_naming_ext variables. If output module files have uppercase +# names, acx_cv_fc_module_naming_upper is "yes", and "no" otherwise. The +# acx_cv_fc_module_naming_ext variable stores the file extension without the +# leading dot. Either of the variables can have value "unknown". The result is +# successful only if both variables are detected. +# +AC_DEFUN([ACX_FC_MODULE_NAMING], + [AC_LANG_ASSERT([Fortran])dnl + AC_MSG_CHECKING([for Fortran compiler module file naming template]) + AS_IF([AS_VAR_TEST_SET([acx_cv_fc_module_naming_upper]) && dnl +AS_VAR_TEST_SET([acx_cv_fc_module_naming_ext])], + [AS_ECHO_N(["(cached) "]) >&AS_MESSAGE_FD], + [AS_MKDIR_P([conftest.dir]) + cd conftest.dir + AC_COMPILE_IFELSE([AC_LANG_SOURCE( +[[ module conftest_module + implicit none + public + contains + subroutine conftest_routine + end subroutine + end module]])], + [AS_CASE(["$acx_cv_fc_module_naming_upper"], + [yes], + [acx_tmp='CONFTEST_MODULE.*' + acx_cv_fc_module_naming_ext=unknown], + [no], + [acx_tmp='conftest_module.*' + acx_cv_fc_module_naming_ext=unknown], + [AS_VAR_SET_IF([acx_cv_fc_module_naming_ext], + [acx_tmp="CONFTEST_MODULE.$acx_cv_fc_module_naming_ext dnl +conftest_module.$acx_cv_fc_module_naming_ext" + acx_cv_fc_module_naming_upper=unknown], + [acx_tmp='CONFTEST_MODULE.* conftest_module.*' + acx_cv_fc_module_naming_upper=unknown + acx_cv_fc_module_naming_ext=unknown])]) + acx_tmp=`ls $acx_tmp 2>/dev/null` + AS_IF([test 1 -eq `AS_ECHO(["$acx_tmp"]) | wc -l` 2>/dev/null], + [AS_CASE(["$acx_tmp"], + [CONFTEST_MODULE.*], + [acx_cv_fc_module_naming_upper=yes + acx_cv_fc_module_naming_ext=`echo $acx_tmp | dnl +sed -n 's,CONFTEST_MODULE\.,,p'`], + [conftest_module.*], + [acx_cv_fc_module_naming_upper=no + acx_cv_fc_module_naming_ext=`echo $acx_tmp | dnl +sed -n 's,conftest_module\.,,p'`])])]) + cd .. + rm -rf conftest.dir]) + AS_IF([test "x$acx_cv_fc_module_naming_upper" = xunknown || dnl +test "x$acx_cv_fc_module_naming_ext" = xunknown], + [AC_MSG_RESULT([unknown]) + m4_default([$2], [AC_MSG_FAILURE([unable to detect Fortran compiler dnl +module file naming template])])], + [AS_VAR_IF([acx_cv_fc_module_naming_upper], [yes], + [AC_MSG_RESULT([NAME.$acx_cv_fc_module_naming_ext])], + [AC_MSG_RESULT([name.$acx_cv_fc_module_naming_ext])]) + $1])]) + +# ACX_FC_MODULE_CHECK(MODULE-NAME, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Checks whether the Fortran module MODULE-NAME is available. The result is +# either "yes" or "no". +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the acx_cv_fc_module_[]AS_TR_CPP(MODULE-NAME) +# variable. +# +AC_DEFUN([ACX_FC_MODULE_CHECK], + [AC_LANG_ASSERT([Fortran])dnl + m4_pushdef([acx_cache_var], [acx_cv_fc_module_[]AS_TR_CPP([$1])])dnl + AC_CACHE_CHECK([for Fortran module AS_TR_CPP([$1])], [acx_cache_var], + [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[ use $1]])], + [AS_VAR_SET([acx_cache_var], [yes])], + [AS_VAR_SET([acx_cache_var], [no])])]) + AS_VAR_IF([acx_cache_var], [yes], [$2], [m4_default([$3], + [AC_MSG_FAILURE([Fortran module 'AS_TR_CPP([$1])' is not available])])]) + m4_popdef([acx_cache_var])]) + +# ACX_FC_MODULE_PROC_CHECK(MODULE-NAME, +# PROCEDURE-NAME, +# [CALL-CODE = " CALL PROCEDURE-NAME()"], +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Checks whether the Fortran module procedure PROCEDURE-NAME from the module +# MODULE-NAME is available. The check is performed by linking a program that +# uses the module MODULE-NAME as "USE MODULE-NAME, ONLY : PROCEDURE-NAME" +# followed by the "IMPLICIT NONE" statement and the CALL-CODE (defaults to +# calling the PROCEDURE-NAME without parameters, which means that if +# PROCEDURE-NAME is a function or a subroutine with parameters, the CALL-CODE +# must be provided). The result is either "yes" or "no". +# +# If successful, runs ACTION-IF-SUCCESS (defaults to nothing), otherwise runs +# ACTION-IF-FAILURE (defaults to failing with an error message). +# +# The result is cached in the +# acx_cv_fc_module_proc_[]AS_TR_CPP(MODULE-NAME)_[]AS_TR_CPP(PROCEDURE-NAME) +# variable. +# +AC_DEFUN([ACX_FC_MODULE_PROC_CHECK], + [AC_LANG_ASSERT([Fortran])dnl + m4_pushdef([acx_cache_var], + [acx_cv_fc_module_proc_[]AS_TR_CPP([$1])_[]AS_TR_CPP([$2])])dnl + AC_CACHE_CHECK([for Fortran procedure AS_TR_CPP([$2]) from module dnl +AS_TR_CPP([$1])], + [acx_cache_var], + [AC_LINK_IFELSE([AC_LANG_PROGRAM([],[[ use $1, only : $2 + implicit none] +m4_default([$3], [[ call $2 ()]])])], + [AS_VAR_SET([acx_cache_var], [yes])], + [AS_VAR_SET([acx_cache_var], [no])])]) + AS_VAR_IF([acx_cache_var], [yes], [$4], [m4_default([$5], + [AC_MSG_FAILURE([Fortran module procedure 'AS_TR_CPP([$2])' from dnl +module 'AS_TR_CPP([$1])' is not available])])]) + m4_popdef([acx_cache_var])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_pp.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_pp.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_fc_pp.m4 (revision 6016) @@ -0,0 +1,82 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_FC_PP_SRCEXT(EXTENSION, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the Fortran compiler flag needed to enable Fortran preprocessing for +# source files with extension EXTENSION. The result is either "unknown", +# or the actual compiler flag required to enable Fortran preprocessing, which +# may be an empty string. +# +# If successful, sets the output variable FCFLAGS_[]EXTENSION and the shell +# variable ac_fcflags_srcext to the result, sets the shell variables +# ac_fc_srcext and ac_ext to the EXTENSION, and runs ACTION-IF-SUCCESS; +# otherwise sets the output variable FCFLAGS_[]EXTENSION and the shell variable +# ac_fcflags_srcext to empty strings, keeps the shell variables ac_fc_srcext +# and ac_ext unchanged, and runs ACTION-IF-FAILURE (defaults to failing with an +# error message). +# +# The flag is cached in the acx_cv_fc_pp_srcext_[]EXTENSION, which may contain +# whitespaces. +# +# The implementation patches the standard Autoconf macro AC_FC_PP_SRCEXT to +# reduce the number of LANG switches and to support additional known compiler +# flags: +# Cray: -e T (must precede -e Z, which triggers generation of unwanted *.i +# flags and crashes old versions of the compiler at the linking +# stage) +# +AC_DEFUN([ACX_FC_PP_SRCEXT], + [AC_LANG_ASSERT([Fortran])dnl + acx_ext_save=$ac_ext + m4_pushdef([acx_cache_var], [acx_cv_fc_pp_srcext_$1])dnl + m4_pushdef([ac_cv_fc_pp_srcext_$1], [acx_cache_var])dnl + m4_pushdef([AC_CACHE_CHECK], + m4_bpatsubst(m4_dquote(m4_defn([AC_CACHE_CHECK])), + [\$][1], + [for Fortran compiler flag needed to compile preprocessed .$1 files]))dnl + m4_pushdef([AC_FC_PP_SRCEXT], + m4_bpatsubsts(m4_dquote(m4_defn([AC_FC_PP_SRCEXT])), + ["-e Z"], ["-e T" \&], + [AC_LANG_P\(OP\|USH\)(\[?Fortran\]?)], [dn][l ]))dnl + AC_FC_PP_SRCEXT([$1], [], [:]) + m4_popdef([AC_FC_PP_SRCEXT])dnl + m4_popdef([AC_CACHE_CHECK])dnl + m4_popdef([ac_cv_fc_pp_srcext_$1])dnl + AS_VAR_IF([acx_cache_var], [unknown], + [ac_ext=$acx_ext_save + m4_default([$3], + [AC_MSG_FAILURE([unable to detect Fortran compiler flag needed to dnl +compile preprocessed .$1 files])])], + [ac_ext=$ac_fc_srcext + $2]) + m4_popdef([acx_cache_var])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_lib.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_lib.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_lib.m4 (revision 6016) @@ -0,0 +1,181 @@ +# Copyright (c) 2010-2024, DKRZ, MPI-M +# +# Authors: +# Thomas Jahns +# Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_LANG_LIB_CHECK(FUNC-NAME, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE], +# [CHECK-PROGRAM = AC_LANG_CALL([],FUNC-NAME)]) +# ----------------------------------------------------------------------------- +# Checks whether the function FUNC-NAME is available for the current language. +# The check is performed by linking a program CHECK-PROGRAM (defaults to +# AC_LANG_CALL([], FUNC-NAME)). The result is either "yes" or "no". +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is cached in the +# acx_cv_[]_AC_LANG_ABBREV[]_func_[]AS_TR_SH(FUNC-NAME) variable if the current +# language is case-sensitive (e.g. C), or in the +# acx_cv_[]_AC_LANG_ABBREV[]_func_[]AS_TR_CPP(FUNC-NAME) variable if the +# current language is case-insensitive (e.g. Fortran). +# +AC_DEFUN([ACX_LANG_LIB_CHECK], + [m4_ifdef([$0(]_AC_LANG[)], + [m4_indir([$0(]_AC_LANG[)], $@)], + [m4_indir([$0()], $@)])]) + +# ACX_LANG_LIB_SEARCH(VARIABLE, +# FUNC-NAME, +# [CANDIDATES], +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE], +# [CHECK-PROGRAM = AC_LANG_CALL([],FUNC-NAME)]) +# ----------------------------------------------------------------------------- +# Searches for a set of linker flags enabling the function FUNC-NAME for the +# current language. If the shell variable VARIABLE is set, checks whether the +# linker flags it stores enable FUNC-NAME. If VARIABLE is not set, checks +# whether additional flags are needed at all to enable FUNC-NAME. If the latter +# is the case, iterates over the values of the blank-separated list CANDIDATES +# and stops when the first value corresponding to the valid set of flags +# enabling FUNC-NAME is found. The checks are performed by trying to compile +# and link the program CHECK-PROGRAM (defaults to AC_LANG_CALL for FUNC-NAME). +# The result of the macro is either an empty string (i.e. no additional flags +# are needed), or the first successful element of the list CANDIDATES. The +# value of VARIABLE is never set or changed. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# A positive result of this test is cached in the +# acx_cv_[]_AC_LANG_ABBREV[]_lib_func_[]AS_TR_SH(FUNC-NAME) variable if the +# current language is case-sensitive (e.g. C), or in the +# acx_cv_[]_AC_LANG_ABBREV[]_lib_func_[]AS_TR_CPP(FUNC-NAME) variable if the +# current language is case-insensitive (e.g. Fortran). +# +AC_DEFUN([ACX_LANG_LIB_SEARCH], + [m4_ifdef([$0(]_AC_LANG[)], + [m4_indir([$0(]_AC_LANG[)], $@)], + [m4_indir([$0()], $@)])]) + +# ACX_LANG_LIB_CHECK()(FUNC-NAME, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE], +# [CHECK-PROGRAM = AC_LANG_CALL([],FUNC-NAME)]) +# ----------------------------------------------------------------------------- +# Default implementation of ACX_LANG_LIB_CHECK for case-sensitive languages. +# +# The result is cached in the +# acx_cv_[]_AC_LANG_ABBREV[]_func_[]AS_TR_SH(FUNC-NAME) variable. +# +m4_define([ACX_LANG_LIB_CHECK()], + [m4_pushdef([acx_cache_var], + [acx_cv_[]_AC_LANG_ABBREV[]_func_[]AS_TR_SH([$1])])dnl + AC_CACHE_CHECK([for _AC_LANG function $1], + [acx_cache_var], + [AC_LINK_IFELSE([m4_default([$4], [AC_LANG_CALL([], [$1])])], + [AS_VAR_SET([acx_cache_var], [yes])], + [AS_VAR_SET([acx_cache_var], [no])])]) + AS_IF([test x"AS_VAR_GET(acx_cache_var)" = xyes], [$2], + [m4_default([$3], + [AC_MSG_FAILURE([_AC_LANG function $1 is not available])])]) + m4_popdef([acx_cache_var])]) + +# ACX_LANG_LIB_CHECK(Fortran)(FUNC-NAME, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE], +# [CHECK-PROGRAM = AC_LANG_CALL([],FUNC-NAME)]) +# ----------------------------------------------------------------------------- +# Implementation of ACX_LANG_LIB_CHECK for Fortran language. Accounts for the +# case-insensitivity of the language. +# +# The result is cached in the +# acx_cv_[]_AC_LANG_ABBREV[]_func_[]AS_TR_CPP(FUNC-NAME) variable. +# +m4_define([ACX_LANG_LIB_CHECK(Fortran)], + [AS_VAR_SET([acx_tmp], [AS_TR_CPP([$1])]) + m4_indir([ACX_LANG_LIB_CHECK()], [$acx_tmp], m4_shift($@))]) + +# ACX_LANG_LIB_SEARCH()(VARIABLE, +# FUNC-NAME, +# [CANDIDATES], +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE], +# [CHECK-PROGRAM = AC_LANG_CALL([],FUNC-NAME)]) +# ----------------------------------------------------------------------------- +# Default implementation of ACX_LANG_LIB_SEARCH for case-sensitive languages. +# +# The result is cached in the +# acx_cv_[]_AC_LANG_ABBREV[]_lib_func_[]AS_TR_SH(FUNC-NAME) variable. +# +m4_define([ACX_LANG_LIB_SEARCH()], + [m4_pushdef([acx_cache_var], + [acx_cv_[]_AC_LANG_ABBREV[]_lib_func_[]AS_TR_SH([$2])])dnl + AC_MSG_CHECKING([for linker flags enabling _AC_LANG function $2]) + AC_CACHE_VAL([acx_cache_var], + [AC_LANG_CONFTEST([m4_default([$6], [AC_LANG_CALL([], [$2])])]) + acx_save_LIBS=$LIBS + AS_VAR_SET_IF([$1], [set dummy "AS_VAR_GET([$1])"], [set dummy '' $3]) + shift + for acx_libs in "$[@]"; do + LIBS="$acx_libs $acx_save_LIBS" + AC_LINK_IFELSE([], [AS_VAR_COPY([acx_cache_var], [acx_libs])]) + AS_VAR_SET_IF([acx_cache_var], [break]) + done + rm -f conftest.$ac_ext + LIBS=$acx_save_LIBS]) + AS_VAR_SET_IF([acx_cache_var], + [AS_IF([test -n "AS_VAR_GET(acx_cache_var)"], + [AC_MSG_RESULT([AS_VAR_GET(acx_cache_var)])], + [AC_MSG_RESULT([none needed])]) + $4], + [AC_MSG_RESULT([unknown]) + m4_default([$5], [AC_MSG_FAILURE( + [unable to find linker flags enabling _AC_LANG function $2])])]) + m4_popdef([acx_cache_var])]) + +# ACX_LANG_LIB_SEARCH(Fortran)(VARIABLE, +# FUNC-NAME, +# [CANDIDATES], +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE], +# [CHECK-PROGRAM = AC_LANG_CALL([],FUNC-NAME)]) +# ----------------------------------------------------------------------------- +# Implementation of ACX_LANG_LIB_SEARCH for Fortran language. Accounts for the +# case-insensitivity of the language. +# +# The result is cached in the +# acx_cv_[]_AC_LANG_ABBREV[]_lib_func_[]AS_TR_CPP(FUNC-NAME) variable. +# +m4_define([ACX_LANG_LIB_SEARCH(Fortran)], + [AS_VAR_SET([acx_fc_lib_search], [AS_TR_CPP([$2])]) + m4_indir([ACX_LANG_LIB_SEARCH()], + [$1], [$acx_fc_lib_search], m4_shift2($@))]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_macro.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_macro.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_macro.m4 (revision 6016) @@ -0,0 +1,250 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_LANG_MACRO_FLAG([ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Finds the compiler flag needed to specify a preprocessor macro definition. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The flag is cached in the acx_cv_[]_AC_LANG_ABBREV[]_macro_flag variable. +# +# See _ACX_LANG_KNOWN_MACRO_FLAGS for the known flags. +# +AC_DEFUN([ACX_LANG_MACRO_FLAG], + [m4_pushdef([acx_cache_var], [acx_cv_[]_AC_LANG_ABBREV[]_macro_flag])dnl + AC_CACHE_CHECK([for _AC_LANG compiler flag needed to define a dnl +preprocessor macro], + [acx_cache_var], + [acx_cache_var=unknown + AC_LANG_CONFTEST( + [AC_LANG_PROGRAM([], +[[#ifndef CONFTEST_ONE + choke me +#endif +#if CONFTEST_TWO != 42 + choke me +#endif]])]) + acx_save_[]_AC_LANG_PREFIX[]FLAGS=$[]_AC_LANG_PREFIX[]FLAGS + for acx_lang_macro_flag in _ACX_LANG_KNOWN_MACRO_FLAGS; do + _AC_LANG_PREFIX[]FLAGS="${acx_save_[]_AC_LANG_PREFIX[]FLAGS} dnl +${acx_lang_macro_flag}CONFTEST_ONE ${acx_lang_macro_flag}CONFTEST_TWO=42" + AC_COMPILE_IFELSE([], [acx_cache_var=$acx_lang_macro_flag]) + test "x$acx_cache_var" != xunknown && break + done + rm -f conftest.$ac_ext + _AC_LANG_PREFIX[]FLAGS=$acx_save_[]_AC_LANG_PREFIX[]FLAGS]) + AS_VAR_IF([acx_cache_var], [unknown], [m4_default([$2], + [AC_MSG_FAILURE([unable to detect _AC_LANG compiler flag needed to dnl +define a preprocessor macro])])], [$1]) + m4_popdef([acx_cache_var])]) + +# ACX_LANG_MACRO_CHECK_DEFINED(MACRO-NAME, +# [INCLUDES]) +# ----------------------------------------------------------------------------- +# Checks whether the preprocessor macro MACRO-NAME is defined with optional +# INCLUDE directives. The result is either "yes", "no" or "unsupported" (if the +# current language does not support preprocessor directives or the INCLUDE +# directives lead to a compilation error). +# +# The result is stored in the acx_macro_defined variable and cached in the +# acx_cv_[]_AC_LANG_ABBREV[]_macro_[]AS_TR_SH(MACRO-NAME)_defined variable. +# +AC_DEFUN([ACX_LANG_MACRO_CHECK_DEFINED], + [m4_pushdef([acx_cache_var], + [acx_cv_[]_AC_LANG_ABBREV[]_macro_[]AS_TR_SH([$1])_defined])dnl + AC_CACHE_CHECK([whether the _AC_LANG preprocessor macro $1 is defined], + [acx_cache_var], + [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([$2], [[#ifdef $1 +#else + choke me +#endif]])], + [AS_VAR_SET([acx_cache_var], [yes])], + [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([$2], [[#ifndef $1 +#else + choke me +#endif]])], + [AS_VAR_SET([acx_cache_var], [no])], + [AS_VAR_SET([acx_cache_var], [unsupported])])])]) + AS_VAR_COPY([acx_macro_defined], [acx_cache_var]) + m4_popdef([acx_cache_var])]) + +# ACX_LANG_MACRO_CHECK_VALUE(MACRO-NAME, +# [KNOWN-INTEGER-VALUES], +# [INCLUDES]) +# ----------------------------------------------------------------------------- +# Detects the value of the preprocessor macro MACRO-NAME with the optional +# INCLUDE directives. First, tries to link and to run a program that prints the +# value of MACRO-NAME. If that is successful, returns the output of the +# program. Otherwise (e.g. in the case of cross-compilation), goes through the +# optionally provided space-separated list of integers KNOWN-INTEGER-VALUES and +# checks whether MACRO-NAME expands to one of them. The result is either +# "unknown" or the actual value of the macro. +# +# The result is stored in the acx_macro_value variable and cached in the +# acx_cv_[]_AC_LANG_ABBREV[]_macro_[]AS_TR_SH(MACRO-NAME)_value variable. +# +AC_DEFUN([ACX_LANG_MACRO_CHECK_VALUE], + [m4_pushdef([acx_cache_var], + [acx_cv_[]_AC_LANG_ABBREV[]_macro_[]AS_TR_SH([$1])_value])dnl + AC_CACHE_CHECK([for the value of the _AC_LANG preprocessor macro $1], + [acx_cache_var], + [AS_VAR_SET([acx_cache_var], [unknown]) + AS_VAR_IF([cross_compiling], [no], + [AC_LINK_IFELSE([_ACX_LANG_MACRO_PRINT_PROGRAM([$1], [$3])], + [acx_exec_result=`./conftest$ac_exeext 2>&AS_MESSAGE_LOG_FD` + AS_IF([test $? -eq 0], + [AS_VAR_COPY([acx_cache_var], [acx_exec_result])])])]) + m4_ifnblank([$2], + [AS_VAR_IF([acx_cache_var], [unknown], + [set dummy $2; shift + while test $[]@%:@ != 0; do + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([$3], +[[#if $1 == _CONFTEST_UNDEFINED_OR_EMPTY || $1 != $][1 + choke me +#endif]])], + [AS_VAR_COPY([acx_cache_var], [1]) + set dummy; shift], + [shift]) + done])])]) + AS_VAR_COPY([acx_macro_value], [acx_cache_var]) + m4_popdef([acx_cache_var])]) + +# _ACX_LANG_KNOWN_MACRO_FLAGS() +# ----------------------------------------------------------------------------- +# Expands into a language-specific space-separated list of known flags needed +# to specify a preprocessor macro definition. By default, expands to m4_fatal +# with the message saying that _AC_LANG is not supported. +# +m4_define([_ACX_LANG_KNOWN_MACRO_FLAGS], + [m4_ifdef([$0(]_AC_LANG[)], + [m4_indir([$0(]_AC_LANG[)], $@)], + [m4_fatal([the list of known ]_AC_LANG[ compiler flags needed to ]dnl +[specify a preprocessor macro definition is undefined])])]) + +# _ACX_LANG_KNOWN_MACRO_FLAGS(C)() +# ----------------------------------------------------------------------------- +# Implementation of _ACX_LANG_KNOWN_MACRO_FLAGS for C language. +# +m4_define([_ACX_LANG_KNOWN_MACRO_FLAGS(C)], [-D]) + +# _ACX_LANG_KNOWN_MACRO_FLAGS(Fortran)(HEADER-TYPE) +# ----------------------------------------------------------------------------- +# Implementation of _ACX_LANG_KNOWN_MACRO_FLAGS for Fortran language. +# +m4_define([_ACX_LANG_KNOWN_MACRO_FLAGS(Fortran)], [-D]) + +# _ACX_LANG_MACRO_PRINT_PROGRAM(MACRO-NAME, +# [INCLUDES]) +# ----------------------------------------------------------------------------- +# Expands into the source code of a program in the current language that prints +# the value of the preprocessor macro MACRO-NAME with the optional INCLUDE +# directives. The program fails if MACRO-NAME is not defined. By default, +# expands to m4_fatal with the message saying that _AC_LANG is not supported. +# +m4_define([_ACX_LANG_MACRO_PRINT_PROGRAM], + [m4_ifdef([$0(]_AC_LANG[)], + [m4_indir([$0(]_AC_LANG[)], $@)], + [m4_fatal([the macro print program is not defined for ]dnl +_AC_LANG[ language])])]) + +# _ACX_LANG_MACRO_PRINT_PROGRAM(C)(MACRO-NAME, +# [INCLUDES]) +# ----------------------------------------------------------------------------- +# Implementation of _ACX_LANG_MACRO_PRINT_PROGRAM for C language. +# +m4_define([_ACX_LANG_MACRO_PRINT_PROGRAM(C)], + [AC_LANG_PROGRAM([[#include +$2]], +[[#ifndef $1 +choke me +#else +#define STRINGIFY2(X) #X +#define STRINGIFY(X) STRINGIFY2(X) +printf("%s\n", STRINGIFY($1)); +#endif]])]) + +# _ACX_LANG_MACRO_PRINT_PROGRAM(C)(MACRO-NAME) +# ----------------------------------------------------------------------------- +# Implementation of _ACX_LANG_MACRO_PRINT_PROGRAM for C++ language. +# +m4_copy([_ACX_LANG_MACRO_PRINT_PROGRAM(C)], + [_ACX_LANG_MACRO_PRINT_PROGRAM(C++)]) + +# _ACX_LANG_MACRO_PRINT_PROGRAM(Fortran)(MACRO-NAME, +# [INCLUDES]) +# ----------------------------------------------------------------------------- +# Implementation of _ACX_LANG_MACRO_PRINT_PROGRAM for Fortran language. The +# program compilation succeeds only if MACRO-NAME expands either to an integer, +# to an empty string or to a quoted string. If MACRO-NAME expands to a quoted +# string, the output of the program is always quoted with the double quotation +# marks (""), even if the actual value of MACRO-NAME is a string quoted with +# the single quotation marks (''). +# +m4_define([_ACX_LANG_MACRO_PRINT_PROGRAM(Fortran)], + [m4_ifval([$2], [m4_warn([syntax], [$0: ignoring INCLUDES: $2])])dnl +AC_LANG_SOURCE([[#ifndef $1 + choke me +#else + subroutine p_str(s) + implicit none + character(len=*) :: s + write(*, "(a)") """"//s//"""" + end subroutine + + subroutine p_int(i) + implicit none + integer :: i + write(*, "(i0)") i + end subroutine + + subroutine p_none() + write(*, "(a)") "" + end subroutine + + program main + implicit none + interface p_val + subroutine p_str(s) + implicit none + character(len=*) :: s + end subroutine + subroutine p_int(i) + implicit none + integer :: i + end subroutine + subroutine p_none() + end subroutine + end interface + call p_val($1) + end +#endif]])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_package.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_package.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_lang_package.m4 (revision 6016) @@ -0,0 +1,113 @@ +# Copyright (c) 2010-2024, DKRZ, MPI-M +# +# Authors: +# Thomas Jahns +# Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_LANG_PACKAGE_INIT(PACKAGE-NAME, +# [INC-SEARCH-FLAGS], +# [LIB-SEARCH-FLAGS], +# [INC-SEARCH-SUFFIX = /include], +# [LIB-SEARCH-SUFFIX = /lib]) +# ----------------------------------------------------------------------------- +# Sets command-line arguments of the configure script that allows for setting +# search paths for the PACKAGE-NAME. By default, sets only the +# "--with-package-name-root" argument. +# +# If the argument INC-SEARCH-FLAGS is not blank, adds a command-line argument +# "--with-package-name-include", declares a precious variable +# AS_TR_CPP(PACKAGE-NAME)_AC_LANG_PREFIX[]FLAGS (e.g. PACKAGE_NAME_FCFLAGS), +# and sets a shell variable +# acx_[]_AC_LANG_ABBREV[]_[]AS_TR_SH(PACKAGE-NAME)_inc_search_args +# (e.g. acx_fc_Package_Name_inc_search_args). The latter variable is set to +# a string containing each flag from the space-separated list INC-SEARCH-FLAGS +# appended either with the value of the command-line argument +# "--with-package-name-include" (if given) or with the concatenation of the +# value of the command-line argument "--with-package-name-root" (if given) and +# INC-SEARCH-SUFFIX (defaults to /include). If neither of the two mentioned +# command-line arguments is given the variable +# acx_[]_AC_LANG_ABBREV[]_[]AS_TR_SH(PACKAGE-NAME)_inc_search_args is empty. +# +# If the argument LIB-SEARCH-FLAGS is given, adds a command-line argument +# "--with-package-name-lib", declares a precious variable +# AS_TR_CPP(PACKAGE-NAME)_AC_LANG_PREFIX[]LIBS (e.g. PACKAGE_NAME_FCLIBS), and +# sets a shell variable +# acx_[]_AC_LANG_ABBREV[]_[]AS_TR_SH(PACKAGE-NAME)_lib_search_args (e.g. +# acx_fc_Package_Name_lib_search_args). The value for the latter variable is +# set according to the same rules as for the variable related to the include +# search path (LIB-SEARCH-SUFFIX defaults to /lib). +# +AC_DEFUN([ACX_LANG_PACKAGE_INIT], + [m4_pushdef([acx_package_ROOT], [AS_TR_CPP([$1]_ROOT)])dnl + m4_pushdef([acx_package_with_root], + [with_[]AS_TR_SH([ASX_TR_ARG([$1])])_root])dnl + AC_ARG_WITH(ASX_TR_ARG([$1])[-root], + [AS_HELP_STRING([--with-ASX_TR_ARG([$1])-root=[]acx_package_ROOT], + [root search path for $1 headers and libraries])]) + m4_ifnblank([$2], + [m4_pushdef([acx_package_with_include], + [with_[]AS_TR_SH([ASX_TR_ARG([$1])])_include])dnl + AC_ARG_WITH(ASX_TR_ARG([$1])[-include], + [AS_HELP_STRING([--with-ASX_TR_ARG([$1])-include=DIR], + [search path for $1 headers @<:@]acx_package_ROOT[]dnl +m4_default([$4], [/include])[@:>@])], [], + [AS_VAR_SET_IF([acx_package_with_root], + [acx_package_with_include="${acx_package_with_root}dnl +m4_default([$4], [/include])"])]) + AC_ARG_VAR(AS_TR_CPP([$1])_[]_AC_LANG_PREFIX[FLAGS], + [exact ]_AC_LANG[ compiler flags enabling $1]) + AS_VAR_SET_IF([acx_package_with_include], + [for acx_flag in $2; do + ASX_VAR_APPEND_UNIQ( + [acx_[]_AC_LANG_ABBREV[]_[]AS_TR_SH([$1])_inc_search_args], + ["${acx_flag}${acx_package_with_include}"], [" "]) + done]) + m4_popdef([acx_package_with_include])]) + m4_ifnblank([$3], + [m4_pushdef([acx_package_with_lib], + [with_[]AS_TR_SH([ASX_TR_ARG([$1])])_lib])dnl + AC_ARG_WITH(ASX_TR_ARG([$1])[-lib], + [AS_HELP_STRING([--with-ASX_TR_ARG([$1])-lib=DIR], + [search path for $1 libraries @<:@]acx_package_ROOT[]dnl +m4_default([$5], [/lib])[@:>@])], + [], + [AS_VAR_SET_IF([acx_package_with_root], + [acx_package_with_lib="${acx_package_with_root}dnl +m4_default([$5], [/lib])"])]) + AC_ARG_VAR(AS_TR_CPP([$1])_[]_AC_LANG_PREFIX[LIBS], + [exact linker flags enabling $1 when linking with ]_AC_LANG[ compiler]) + AS_VAR_SET_IF([acx_package_with_lib], + [for acx_flag in $3; do + ASX_VAR_APPEND_UNIQ( + [acx_[]_AC_LANG_ABBREV[]_[]AS_TR_SH([$1])_lib_search_args], + ["${acx_flag}${acx_package_with_lib}"], [" "]) + done]) + m4_popdef([acx_package_with_lib])]) + m4_popdef([acx_package_ROOT])dnl + m4_popdef([acx_package_with_root])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_prog_search.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_prog_search.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/acx_prog_search.m4 (revision 6016) @@ -0,0 +1,136 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ACX_PROG_SEARCH(VARIABLE, +# [CANDIDATES], +# [CHECK-SCRIPT = 'eval $acx_candidate'], +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ----------------------------------------------------------------------------- +# Searches for the program (command) that results into a zero exit status of +# the CHECK-SCRIPT (defaults to running the candidate command). CHECK-SCRIPT +# can get the tested command from the shell variable $acx_candidate. If the +# shell variable VARIABLE is set, checks whether the value it stores passes the +# test. If VARIABLE is not set, iterates over the values of the blank-separated +# list CANDIDATES and stops when the first valid command is found. The value of +# VARIABLE is never set or changed. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# A positive result of this test is cached in the +# acx_cv_prog_[]AS_TR_SH(VARIABLE) variable. +# +AC_DEFUN([ACX_PROG_SEARCH], + [AS_VAR_PUSHDEF([acx_cache_var], [acx_cv_prog_$1])dnl + AS_LITERAL_IF([$1], + [AC_MSG_CHECKING([for m4_tolower([$1])])], + [acx_tmp=`AS_ECHO(["$1"]) | tr 'm4_cr_LETTERS' 'm4_cr_letters'` + AC_MSG_CHECKING([for $acx_tmp])]) + AC_CACHE_VAL([acx_cache_var], + [AS_VAR_SET_IF([$1], [set dummy "AS_VAR_GET([$1])"], [set dummy $2]) + shift + for acx_candidate in "$[@]"; do + m4_default([$3], + [AC_TRY_COMMAND([$acx_candidate >&AS_MESSAGE_LOG_FD])]) + AS_IF([test $? -eq 0], + [AS_VAR_SET([acx_cache_var], [$acx_candidate]) + break]) + done]) + AS_VAR_SET_IF([acx_cache_var], + [AC_MSG_RESULT([AS_VAR_GET(acx_cache_var)]) + $4], + [AC_MSG_RESULT([unknown]) + m4_default([$5], + [AS_LITERAL_IF([$1], + [AC_MSG_FAILURE([unable to find m4_tolower([$1])])], + [acx_tmp=`AS_ECHO(["$1"]) | tr 'm4_cr_LETTERS' 'm4_cr_letters'` + AC_MSG_FAILURE([unable to find $acx_tmp])])])]) + AS_VAR_POPDEF([acx_cache_var])]) + +# ACX_PROG_SEARCH_ABSPATH(PROG-TO-CHECK-FOR, +# [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE], +# [PATH = $PATH]) +# ----------------------------------------------------------------------------- +# Searches for the absolute path to the PROG-TO-CHECK-FOR executable. If +# PROG-TO-CHECK-FOR contains slashes (i.e. specified as either absolute or +# relative path), the macro checks whether it is an executable and returns an +# absolute path to it (not necessarily in the canonical form). If the specified +# path is not a path to executable, the result is "unknown". If +# PROG-TO-CHECK-FOR does not contain slashes, the macro tries to find the +# executable in the list of directories stored in the PATH (defaults to the +# value of the $PATH shell variable). The value of the variable is interpreted +# as a list separated with the value of the $PATH_SEPARATOR shell variable, +# which is set by the configure script during the initialization (the usual +# value is ':'). If the path that contains PROG-TO-CHECK-FOR is a relative one, +# it will be converted to the absolute one. If PROG-TO-CHECK-FOR contains +# arguments, they will be preserved in the result. +# +# If successful, runs ACTION-IF-SUCCESS, otherwise runs ACTION-IF-FAILURE +# (defaults to failing with an error message). +# +# The result is stored in the acx_prog_search_abspath shell variable. +# +AC_DEFUN([ACX_PROG_SEARCH_ABSPATH], + [acx_prog_search_abspath=unknown + set dummy $1; shift; acx_prog_exec=$[1]; shift; acx_prog_args="$[@]" + AC_MSG_CHECKING([for the absolute path to $acx_prog_exec]) + AS_CASE([$acx_prog_exec], + [*[[\\/]]*], + [AS_IF([AS_EXECUTABLE_P([$acx_prog_exec])], + [acx_prog_search_abspath=$acx_prog_exec])], + [_AS_PATH_WALK([$4], + [AS_IF([AS_EXECUTABLE_P(["$as_dir/$acx_prog_exec"])], + [acx_prog_search_abspath="$as_dir/$acx_prog_exec"; break])])]) +dnl If acx_prog_search_abspath is not "unknown", it is a path to an executable +dnl (without arguments). + AS_CASE([$acx_prog_search_abspath], + [unknown], [], + [[[\\/]]* | ?:[[\\/]]*], [], + [asx_dir=`echo "$acx_prog_search_abspath" | dnl +sed 's%/@<:@^/@:>@*$%%' 2>/dev/null` + asx_file=`echo "$acx_prog_search_abspath" | sed 's%.*/%%' 2>/dev/null` + asx_dir=`cd "$asx_dir" >/dev/null 2>&1 && pwd 2>/dev/null` +dnl Set the result to unknown until we make sure that we can provide a correct +dnl one. + acx_prog_search_abspath=unknown + AS_CASE([$asx_dir], + [[[\\/]]* | ?:[[\\/]]*], + [AS_IF([AS_EXECUTABLE_P(["$asx_dir/$asx_file"])], + [acx_prog_search_abspath="$asx_dir/$asx_file"])])]) + AC_MSG_RESULT([$acx_prog_search_abspath]) + AS_VAR_IF([acx_prog_search_abspath], [unknown], + [m4_default([$3], + [AC_MSG_FAILURE( + [unable to find the absolute path to $acx_prog_exec])])], + [AS_IF([test -n "$acx_prog_args"], + [AS_VAR_APPEND([acx_prog_search_abspath], [" $acx_prog_args"])]) + $2])]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/asx_common.m4 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/asx_common.m4 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/m4/asx_common.m4 (revision 6016) @@ -0,0 +1,137 @@ +# Copyright (c) 2018-2024, MPI-M +# +# Author: Sergey Kosukhin +# +# SPDX-License-Identifier: BSD-3-Clause +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +# ASX_TR_ARG(EXPRESSION) +# ----------------------------------------------------------------------------- +# Transforms EXPRESSION into shell code that generates a name for a command +# line argument. The result is literal when possible at M4 time, but must be +# used with eval if EXPRESSION causes shell indirections. +# +AC_DEFUN([ASX_TR_ARG], + [AS_LITERAL_IF([$1], + [m4_translit(AS_TR_SH([$1]), [_A-Z], [-a-z])], + [m4_bpatsubst(AS_TR_SH([$1]), [`$], + [ | tr '_[]m4_cr_LETTERS[]' '-[]m4_cr_letters[]'`])])]) + +# ASX_VAR_APPEND_UNIQ(VARIABLE, +# [TEXT], +# [SEPARATOR]) +# ----------------------------------------------------------------------------- +# Emits shell code to append the shell expansion of TEXT to the end of the +# current contents of the polymorphic shell variable VARIABLE without +# duplicating substrings. The TEXT can optionally be prepended with the shell +# expansion of SEPARATOR. The SEPARATOR is not appended if VARIABLE is empty or +# unset. Both TEXT and SEPARATOR need to be quoted properly to avoid field +# splitting and file name expansion. +# +AC_DEFUN([ASX_VAR_APPEND_UNIQ], + [AS_CASE([$3[]AS_VAR_GET([$1])$3], + [*m4_ifnblank([$3], [$3$2$3], [$2])*], [], + [m4_ifnblank([$3],[$3$3],[''])], [AS_VAR_APPEND([$1], [$2])], + [AS_VAR_APPEND([$1], [$3]); AS_VAR_APPEND([$1], [$2])])]) + +# ASX_PREPEND_LDFLAGS([LDFLAGS], +# [LIBS], +# ...) +# ----------------------------------------------------------------------------- +# Prepends the first argument LDFLAGS to each of the rest of the arguments +# LIBS and expands into a space separated list of the resulting strings. Each +# element of the resulting list is shell-quoted with double quotation marks. +# +AC_DEFUN([ASX_PREPEND_LDFLAGS], [m4_foreach([arg], m4_cdr($@), [ "$1 arg"])]) + +# ASX_EXTRACT_ARGS(VARIABLE, +# ARGUMENTS, +# FLAG-PATTERN) +# ----------------------------------------------------------------------------- +# Emits shell code to extract values of arguments that match sed-like pattern +# FLAG-PATTERN from the string ARGUMENTS and set the result to the shell +# variable VARIABLE. Both ARGUMENTS and FLAG-PATTERN must be shell-quoted. +# +# For example, the following extract library paths from the linking command: +# ASX_EXTRACT_ARGS([FC_LIB_PATHS], +# ["$FCFLAGS $LDFLAGS $LIBS"], +# ['-L@<:@ @:>@*']) +# +AC_DEFUN([ASX_EXTRACT_ARGS], + [AS_VAR_SET([$1]) + asx_extract_args_args=$2 + asx_extract_args_args=`AS_ECHO(["$asx_extract_args_args"]) | dnl +sed 's%'$3'%_ASX_EXTRACT_ARGS_MARKER_%g'` + for asx_extract_args_arg in $asx_extract_args_args; do + AS_CASE([$asx_extract_args_arg], + [_ASX_EXTRACT_ARGS_MARKER_*], + [asx_extract_args_value=`AS_ECHO(["$asx_extract_args_arg"]) | dnl +sed 's%^_ASX_EXTRACT_ARGS_MARKER_%%'` + AS_VAR_APPEND([$1], [" $asx_extract_args_value"])]) + done]) + +# ASX_ESCAPE_SINGLE_QUOTE(VARIABLE) +# ----------------------------------------------------------------------------- +# Emits shell code that replaces any occurrence of the single-quote (') in the +# shell variable VARIABLE with the following string: '\'', which is required +# when contents of the VARIABLE must be passed literally to a subprocess, e.g. +# eval \$SHELL -c "'$VARIABLE'". +# +AC_DEFUN([ASX_ESCAPE_SINGLE_QUOTE], + [AS_CASE([AS_VAR_GET([$1])], [*\'*], + [AS_VAR_SET([$1], [`AS_ECHO(["AS_VAR_GET([$1])"]) | dnl +sed "s/'/'\\\\\\\\''/g"`])])]) + +# ASX_SRCDIRS(BUILD-DIR-NAME) +# ----------------------------------------------------------------------------- +# Receives a normalized (i.e. does not contain '/./', '..', etc.) path +# BUILD-DIR-NAME to a directory relative to the top build directory and emits +# shell code that sets the following variables: +# 1) ac_builddir - path to BUILD-DIR-NAME relative to BUILD-DIR-NAME +# (i.e. always equals to '.'); +# 2) ac_abs_builddir - absolute path to BUILD-DIR-NAME; +# 3) ac_top_builddir_sub - path to the top build directory relative to +# BUILD-DIR-NAME (i.e. equals to '.' if +# BUILD-DIR-NAME is the top build directory); +# 4) ac_top_build_prefix - empty if ac_top_builddir_sub equals to '.' and +# path to the top build directory relative to +# BUILD-DIR-NAME with a trailing slash, otherwise; +# 5) ac_abs_top_builddir - absolute path to the top build directory; +# 6) ac_srcdir - path to /BUILD-DIR-NAME relative to +# BUILD-DIR-NAME where is the top source +# directory (i.e. equals to the path from BUILD-DIR-NAME to +# its respective source directory); +# 7) ac_abs_srcdir - absolute path to /BUILD-DIR-NAME where +# is the top source directory (i.e. equals +# to the absolute path to the source directory that +# corresponds to BUILD-DIR-NAME); +# 8) ac_top_srcdir - path to the top source directory relative to +# BUILD-DIR-NAME; +# 9) ac_abs_top_srcdir - absolute path to the top source directory. +# +AC_DEFUN([ASX_SRCDIRS], + [AC_REQUIRE_SHELL_FN([acx_subdir_srcdirs_fn], [], [_AC_SRCDIRS(["$[]1"])])dnl + acx_subdir_srcdirs_fn $1]) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/_argparse.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/_argparse.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/_argparse.py (revision 6016) @@ -0,0 +1,2392 @@ +# Author: Steven J. Bethard . +# Maintainer: Thomas Waldmann + +"""Command-line parsing library + +This module is an optparse-inspired command-line parsing library that: + + - handles both optional and positional arguments + - produces highly informative usage messages + - supports parsers that dispatch to sub-parsers + +The following is a simple usage example that sums integers from the +command-line and writes the result to a file:: + + parser = argparse.ArgumentParser( + description='sum the integers at the command line') + parser.add_argument( + 'integers', metavar='int', nargs='+', type=int, + help='an integer to be summed') + parser.add_argument( + '--log', default=sys.stdout, type=argparse.FileType('w'), + help='the file where the sum should be written') + args = parser.parse_args() + args.log.write('%s' % sum(args.integers)) + args.log.close() + +The module contains the following public classes: + + - ArgumentParser -- The main entry point for command-line parsing. As the + example above shows, the add_argument() method is used to populate + the parser with actions for optional and positional arguments. Then + the parse_args() method is invoked to convert the args at the + command-line into an object with attributes. + + - ArgumentError -- The exception raised by ArgumentParser objects when + there are errors with the parser's actions. Errors raised while + parsing the command-line are caught by ArgumentParser and emitted + as command-line messages. + + - FileType -- A factory for defining types of files to be created. As the + example above shows, instances of FileType are typically passed as + the type= argument of add_argument() calls. + + - Action -- The base class for parser actions. Typically actions are + selected by passing strings like 'store_true' or 'append_const' to + the action= argument of add_argument(). However, for greater + customization of ArgumentParser actions, subclasses of Action may + be defined and passed as the action= argument. + + - HelpFormatter, RawDescriptionHelpFormatter, RawTextHelpFormatter, + ArgumentDefaultsHelpFormatter -- Formatter classes which + may be passed as the formatter_class= argument to the + ArgumentParser constructor. HelpFormatter is the default, + RawDescriptionHelpFormatter and RawTextHelpFormatter tell the parser + not to change the formatting for help text, and + ArgumentDefaultsHelpFormatter adds information about argument defaults + to the help. + +All other classes in this module are considered implementation details. +(Also note that HelpFormatter and RawDescriptionHelpFormatter are only +considered public as object names -- the API of the formatter objects is +still considered an implementation detail.) +""" + +__version__ = '1.4.0' # we use our own version number independant of the + # one in stdlib and we release this on pypi. + +__external_lib__ = True # to make sure the tests really test THIS lib, + # not the builtin one in Python stdlib + +__all__ = [ + 'ArgumentParser', + 'ArgumentError', + 'ArgumentTypeError', + 'FileType', + 'HelpFormatter', + 'ArgumentDefaultsHelpFormatter', + 'RawDescriptionHelpFormatter', + 'RawTextHelpFormatter', + 'Namespace', + 'Action', + 'ONE_OR_MORE', + 'OPTIONAL', + 'PARSER', + 'REMAINDER', + 'SUPPRESS', + 'ZERO_OR_MORE', +] + + +import copy as _copy +import os as _os +import re as _re +import sys as _sys +import textwrap as _textwrap + +from gettext import gettext as _ + +try: + set +except NameError: + # for python < 2.4 compatibility (sets module is there since 2.3): + from sets import Set as set + +try: + basestring +except NameError: + basestring = str + +try: + sorted +except NameError: + # for python < 2.4 compatibility: + def sorted(iterable, reverse=False): + result = list(iterable) + result.sort() + if reverse: + result.reverse() + return result + + +def _callable(obj): + return hasattr(obj, '__call__') or hasattr(obj, '__bases__') + + +SUPPRESS = '==SUPPRESS==' + +OPTIONAL = '?' +ZERO_OR_MORE = '*' +ONE_OR_MORE = '+' +PARSER = 'A...' +REMAINDER = '...' +_UNRECOGNIZED_ARGS_ATTR = '_unrecognized_args' + +# ============================= +# Utility functions and classes +# ============================= + +class _AttributeHolder(object): + """Abstract base class that provides __repr__. + + The __repr__ method returns a string in the format:: + ClassName(attr=name, attr=name, ...) + The attributes are determined either by a class-level attribute, + '_kwarg_names', or by inspecting the instance __dict__. + """ + + def __repr__(self): + type_name = type(self).__name__ + arg_strings = [] + for arg in self._get_args(): + arg_strings.append(repr(arg)) + for name, value in self._get_kwargs(): + arg_strings.append('%s=%r' % (name, value)) + return '%s(%s)' % (type_name, ', '.join(arg_strings)) + + def _get_kwargs(self): + return sorted(self.__dict__.items()) + + def _get_args(self): + return [] + + +def _ensure_value(namespace, name, value): + if getattr(namespace, name, None) is None: + setattr(namespace, name, value) + return getattr(namespace, name) + + +# =============== +# Formatting Help +# =============== + +class HelpFormatter(object): + """Formatter for generating usage messages and argument help strings. + + Only the name of this class is considered a public API. All the methods + provided by the class are considered an implementation detail. + """ + + def __init__(self, + prog, + indent_increment=2, + max_help_position=24, + width=None): + + # default setting for width + if width is None: + try: + width = int(_os.environ['COLUMNS']) + except (KeyError, ValueError): + width = 80 + width -= 2 + + self._prog = prog + self._indent_increment = indent_increment + self._max_help_position = max_help_position + self._width = width + + self._current_indent = 0 + self._level = 0 + self._action_max_length = 0 + + self._root_section = self._Section(self, None) + self._current_section = self._root_section + + self._whitespace_matcher = _re.compile(r'\s+') + self._long_break_matcher = _re.compile(r'\n\n\n+') + + # =============================== + # Section and indentation methods + # =============================== + def _indent(self): + self._current_indent += self._indent_increment + self._level += 1 + + def _dedent(self): + self._current_indent -= self._indent_increment + assert self._current_indent >= 0, 'Indent decreased below 0.' + self._level -= 1 + + class _Section(object): + + def __init__(self, formatter, parent, heading=None): + self.formatter = formatter + self.parent = parent + self.heading = heading + self.items = [] + + def format_help(self): + # format the indented section + if self.parent is not None: + self.formatter._indent() + join = self.formatter._join_parts + for func, args in self.items: + func(*args) + item_help = join([func(*args) for func, args in self.items]) + if self.parent is not None: + self.formatter._dedent() + + # return nothing if the section was empty + if not item_help: + return '' + + # add the heading if the section was non-empty + if self.heading is not SUPPRESS and self.heading is not None: + current_indent = self.formatter._current_indent + heading = '%*s%s:\n' % (current_indent, '', self.heading) + else: + heading = '' + + # join the section-initial newline, the heading and the help + return join(['\n', heading, item_help, '\n']) + + def _add_item(self, func, args): + self._current_section.items.append((func, args)) + + # ======================== + # Message building methods + # ======================== + def start_section(self, heading): + self._indent() + section = self._Section(self, self._current_section, heading) + self._add_item(section.format_help, []) + self._current_section = section + + def end_section(self): + self._current_section = self._current_section.parent + self._dedent() + + def add_text(self, text): + if text is not SUPPRESS and text is not None: + self._add_item(self._format_text, [text]) + + def add_usage(self, usage, actions, groups, prefix=None): + if usage is not SUPPRESS: + args = usage, actions, groups, prefix + self._add_item(self._format_usage, args) + + def add_argument(self, action): + if action.help is not SUPPRESS: + + # find all invocations + get_invocation = self._format_action_invocation + invocations = [get_invocation(action)] + for subaction in self._iter_indented_subactions(action): + invocations.append(get_invocation(subaction)) + + # update the maximum item length + invocation_length = max([len(s) for s in invocations]) + action_length = invocation_length + self._current_indent + self._action_max_length = max(self._action_max_length, + action_length) + + # add the item to the list + self._add_item(self._format_action, [action]) + + def add_arguments(self, actions): + for action in actions: + self.add_argument(action) + + # ======================= + # Help-formatting methods + # ======================= + def format_help(self): + help = self._root_section.format_help() + if help: + help = self._long_break_matcher.sub('\n\n', help) + help = help.strip('\n') + '\n' + return help + + def _join_parts(self, part_strings): + return ''.join([part + for part in part_strings + if part and part is not SUPPRESS]) + + def _format_usage(self, usage, actions, groups, prefix): + if prefix is None: + prefix = _('usage: ') + + # if usage is specified, use that + if usage is not None: + usage = usage % dict(prog=self._prog) + + # if no optionals or positionals are available, usage is just prog + elif usage is None and not actions: + usage = '%(prog)s' % dict(prog=self._prog) + + # if optionals and positionals are available, calculate usage + elif usage is None: + prog = '%(prog)s' % dict(prog=self._prog) + + # split optionals from positionals + optionals = [] + positionals = [] + for action in actions: + if action.option_strings: + optionals.append(action) + else: + positionals.append(action) + + # build full usage string + format = self._format_actions_usage + action_usage = format(optionals + positionals, groups) + usage = ' '.join([s for s in [prog, action_usage] if s]) + + # wrap the usage parts if it's too long + text_width = self._width - self._current_indent + if len(prefix) + len(usage) > text_width: + + # break usage into wrappable parts + part_regexp = r'\(.*?\)+|\[.*?\]+|\S+' + opt_usage = format(optionals, groups) + pos_usage = format(positionals, groups) + opt_parts = _re.findall(part_regexp, opt_usage) + pos_parts = _re.findall(part_regexp, pos_usage) + assert ' '.join(opt_parts) == opt_usage + assert ' '.join(pos_parts) == pos_usage + + # helper for wrapping lines + def get_lines(parts, indent, prefix=None): + lines = [] + line = [] + if prefix is not None: + line_len = len(prefix) - 1 + else: + line_len = len(indent) - 1 + for part in parts: + if line_len + 1 + len(part) > text_width: + lines.append(indent + ' '.join(line)) + line = [] + line_len = len(indent) - 1 + line.append(part) + line_len += len(part) + 1 + if line: + lines.append(indent + ' '.join(line)) + if prefix is not None: + lines[0] = lines[0][len(indent):] + return lines + + # if prog is short, follow it with optionals or positionals + if len(prefix) + len(prog) <= 0.75 * text_width: + indent = ' ' * (len(prefix) + len(prog) + 1) + if opt_parts: + lines = get_lines([prog] + opt_parts, indent, prefix) + lines.extend(get_lines(pos_parts, indent)) + elif pos_parts: + lines = get_lines([prog] + pos_parts, indent, prefix) + else: + lines = [prog] + + # if prog is long, put it on its own line + else: + indent = ' ' * len(prefix) + parts = opt_parts + pos_parts + lines = get_lines(parts, indent) + if len(lines) > 1: + lines = [] + lines.extend(get_lines(opt_parts, indent)) + lines.extend(get_lines(pos_parts, indent)) + lines = [prog] + lines + + # join lines into usage + usage = '\n'.join(lines) + + # prefix with 'usage:' + return '%s%s\n\n' % (prefix, usage) + + def _format_actions_usage(self, actions, groups): + # find group indices and identify actions in groups + group_actions = set() + inserts = {} + for group in groups: + try: + start = actions.index(group._group_actions[0]) + except ValueError: + continue + else: + end = start + len(group._group_actions) + if actions[start:end] == group._group_actions: + for action in group._group_actions: + group_actions.add(action) + if not group.required: + if start in inserts: + inserts[start] += ' [' + else: + inserts[start] = '[' + inserts[end] = ']' + else: + if start in inserts: + inserts[start] += ' (' + else: + inserts[start] = '(' + inserts[end] = ')' + for i in range(start + 1, end): + inserts[i] = '|' + + # collect all actions format strings + parts = [] + for i, action in enumerate(actions): + + # suppressed arguments are marked with None + # remove | separators for suppressed arguments + if action.help is SUPPRESS: + parts.append(None) + if inserts.get(i) == '|': + inserts.pop(i) + elif inserts.get(i + 1) == '|': + inserts.pop(i + 1) + + # produce all arg strings + elif not action.option_strings: + part = self._format_args(action, action.dest) + + # if it's in a group, strip the outer [] + if action in group_actions: + if part[0] == '[' and part[-1] == ']': + part = part[1:-1] + + # add the action string to the list + parts.append(part) + + # produce the first way to invoke the option in brackets + else: + option_string = action.option_strings[0] + + # if the Optional doesn't take a value, format is: + # -s or --long + if action.nargs == 0: + part = '%s' % option_string + + # if the Optional takes a value, format is: + # -s ARGS or --long ARGS + else: + default = action.dest.upper() + args_string = self._format_args(action, default) + part = '%s %s' % (option_string, args_string) + + # make it look optional if it's not required or in a group + if not action.required and action not in group_actions: + part = '[%s]' % part + + # add the action string to the list + parts.append(part) + + # insert things at the necessary indices + for i in sorted(inserts, reverse=True): + parts[i:i] = [inserts[i]] + + # join all the action items with spaces + text = ' '.join([item for item in parts if item is not None]) + + # clean up separators for mutually exclusive groups + open = r'[\[(]' + close = r'[\])]' + text = _re.sub(r'(%s) ' % open, r'\1', text) + text = _re.sub(r' (%s)' % close, r'\1', text) + text = _re.sub(r'%s *%s' % (open, close), r'', text) + text = _re.sub(r'\(([^|]*)\)', r'\1', text) + text = text.strip() + + # return the text + return text + + def _format_text(self, text): + if '%(prog)' in text: + text = text % dict(prog=self._prog) + text_width = self._width - self._current_indent + indent = ' ' * self._current_indent + return self._fill_text(text, text_width, indent) + '\n\n' + + def _format_action(self, action): + # determine the required width and the entry label + help_position = min(self._action_max_length + 2, + self._max_help_position) + help_width = self._width - help_position + action_width = help_position - self._current_indent - 2 + action_header = self._format_action_invocation(action) + + # ho nelp; start on same line and add a final newline + if not action.help: + tup = self._current_indent, '', action_header + action_header = '%*s%s\n' % tup + + # short action name; start on the same line and pad two spaces + elif len(action_header) <= action_width: + tup = self._current_indent, '', action_width, action_header + action_header = '%*s%-*s ' % tup + indent_first = 0 + + # long action name; start on the next line + else: + tup = self._current_indent, '', action_header + action_header = '%*s%s\n' % tup + indent_first = help_position + + # collect the pieces of the action help + parts = [action_header] + + # if there was help for the action, add lines of help text + if action.help: + help_text = self._expand_help(action) + help_lines = self._split_lines(help_text, help_width) + parts.append('%*s%s\n' % (indent_first, '', help_lines[0])) + for line in help_lines[1:]: + parts.append('%*s%s\n' % (help_position, '', line)) + + # or add a newline if the description doesn't end with one + elif not action_header.endswith('\n'): + parts.append('\n') + + # if there are any sub-actions, add their help as well + for subaction in self._iter_indented_subactions(action): + parts.append(self._format_action(subaction)) + + # return a single string + return self._join_parts(parts) + + def _format_action_invocation(self, action): + if not action.option_strings: + metavar, = self._metavar_formatter(action, action.dest)(1) + return metavar + + else: + parts = [] + + # if the Optional doesn't take a value, format is: + # -s, --long + if action.nargs == 0: + parts.extend(action.option_strings) + + # if the Optional takes a value, format is: + # -s ARGS, --long ARGS + else: + default = action.dest.upper() + args_string = self._format_args(action, default) + for option_string in action.option_strings: + parts.append('%s %s' % (option_string, args_string)) + + return ', '.join(parts) + + def _metavar_formatter(self, action, default_metavar): + if action.metavar is not None: + result = action.metavar + elif action.choices is not None: + choice_strs = [str(choice) for choice in action.choices] + result = '{%s}' % ','.join(choice_strs) + else: + result = default_metavar + + def format(tuple_size): + if isinstance(result, tuple): + return result + else: + return (result, ) * tuple_size + return format + + def _format_args(self, action, default_metavar): + get_metavar = self._metavar_formatter(action, default_metavar) + if action.nargs is None: + result = '%s' % get_metavar(1) + elif action.nargs == OPTIONAL: + result = '[%s]' % get_metavar(1) + elif action.nargs == ZERO_OR_MORE: + result = '[%s [%s ...]]' % get_metavar(2) + elif action.nargs == ONE_OR_MORE: + result = '%s [%s ...]' % get_metavar(2) + elif action.nargs == REMAINDER: + result = '...' + elif action.nargs == PARSER: + result = '%s ...' % get_metavar(1) + else: + formats = ['%s' for _ in range(action.nargs)] + result = ' '.join(formats) % get_metavar(action.nargs) + return result + + def _expand_help(self, action): + params = dict(vars(action), prog=self._prog) + for name in list(params): + if params[name] is SUPPRESS: + del params[name] + for name in list(params): + if hasattr(params[name], '__name__'): + params[name] = params[name].__name__ + if params.get('choices') is not None: + choices_str = ', '.join([str(c) for c in params['choices']]) + params['choices'] = choices_str + return self._get_help_string(action) % params + + def _iter_indented_subactions(self, action): + try: + get_subactions = action._get_subactions + except AttributeError: + pass + else: + self._indent() + for subaction in get_subactions(): + yield subaction + self._dedent() + + def _split_lines(self, text, width): + text = self._whitespace_matcher.sub(' ', text).strip() + return _textwrap.wrap(text, width) + + def _fill_text(self, text, width, indent): + text = self._whitespace_matcher.sub(' ', text).strip() + return _textwrap.fill(text, width, initial_indent=indent, + subsequent_indent=indent) + + def _get_help_string(self, action): + return action.help + + +class RawDescriptionHelpFormatter(HelpFormatter): + """Help message formatter which retains any formatting in descriptions. + + Only the name of this class is considered a public API. All the methods + provided by the class are considered an implementation detail. + """ + + def _fill_text(self, text, width, indent): + return ''.join([indent + line for line in text.splitlines(True)]) + + +class RawTextHelpFormatter(RawDescriptionHelpFormatter): + """Help message formatter which retains formatting of all help text. + + Only the name of this class is considered a public API. All the methods + provided by the class are considered an implementation detail. + """ + + def _split_lines(self, text, width): + return text.splitlines() + + +class ArgumentDefaultsHelpFormatter(HelpFormatter): + """Help message formatter which adds default values to argument help. + + Only the name of this class is considered a public API. All the methods + provided by the class are considered an implementation detail. + """ + + def _get_help_string(self, action): + help = action.help + if '%(default)' not in action.help: + if action.default is not SUPPRESS: + defaulting_nargs = [OPTIONAL, ZERO_OR_MORE] + if action.option_strings or action.nargs in defaulting_nargs: + help += ' (default: %(default)s)' + return help + + +# ===================== +# Options and Arguments +# ===================== + +def _get_action_name(argument): + if argument is None: + return None + elif argument.option_strings: + return '/'.join(argument.option_strings) + elif argument.metavar not in (None, SUPPRESS): + return argument.metavar + elif argument.dest not in (None, SUPPRESS): + return argument.dest + else: + return None + + +class ArgumentError(Exception): + """An error from creating or using an argument (optional or positional). + + The string value of this exception is the message, augmented with + information about the argument that caused it. + """ + + def __init__(self, argument, message): + self.argument_name = _get_action_name(argument) + self.message = message + + def __str__(self): + if self.argument_name is None: + format = '%(message)s' + else: + format = 'argument %(argument_name)s: %(message)s' + return format % dict(message=self.message, + argument_name=self.argument_name) + + +class ArgumentTypeError(Exception): + """An error from trying to convert a command line string to a type.""" + pass + + +# ============== +# Action classes +# ============== + +class Action(_AttributeHolder): + """Information about how to convert command line strings to Python objects. + + Action objects are used by an ArgumentParser to represent the information + needed to parse a single argument from one or more strings from the + command line. The keyword arguments to the Action constructor are also + all attributes of Action instances. + + Keyword Arguments: + + - option_strings -- A list of command-line option strings which + should be associated with this action. + + - dest -- The name of the attribute to hold the created object(s) + + - nargs -- The number of command-line arguments that should be + consumed. By default, one argument will be consumed and a single + value will be produced. Other values include: + - N (an integer) consumes N arguments (and produces a list) + - '?' consumes zero or one arguments + - '*' consumes zero or more arguments (and produces a list) + - '+' consumes one or more arguments (and produces a list) + Note that the difference between the default and nargs=1 is that + with the default, a single value will be produced, while with + nargs=1, a list containing a single value will be produced. + + - const -- The value to be produced if the option is specified and the + option uses an action that takes no values. + + - default -- The value to be produced if the option is not specified. + + - type -- The type which the command-line arguments should be converted + to, should be one of 'string', 'int', 'float', 'complex' or a + callable object that accepts a single string argument. If None, + 'string' is assumed. + + - choices -- A container of values that should be allowed. If not None, + after a command-line argument has been converted to the appropriate + type, an exception will be raised if it is not a member of this + collection. + + - required -- True if the action must always be specified at the + command line. This is only meaningful for optional command-line + arguments. + + - help -- The help string describing the argument. + + - metavar -- The name to be used for the option's argument with the + help string. If None, the 'dest' value will be used as the name. + """ + + def __init__(self, + option_strings, + dest, + nargs=None, + const=None, + default=None, + type=None, + choices=None, + required=False, + help=None, + metavar=None): + self.option_strings = option_strings + self.dest = dest + self.nargs = nargs + self.const = const + self.default = default + self.type = type + self.choices = choices + self.required = required + self.help = help + self.metavar = metavar + + def _get_kwargs(self): + names = [ + 'option_strings', + 'dest', + 'nargs', + 'const', + 'default', + 'type', + 'choices', + 'help', + 'metavar', + ] + return [(name, getattr(self, name)) for name in names] + + def __call__(self, parser, namespace, values, option_string=None): + raise NotImplementedError(_('.__call__() not defined')) + + +class _StoreAction(Action): + + def __init__(self, + option_strings, + dest, + nargs=None, + const=None, + default=None, + type=None, + choices=None, + required=False, + help=None, + metavar=None): + if nargs == 0: + raise ValueError('nargs for store actions must be > 0; if you ' + 'have nothing to store, actions such as store ' + 'true or store const may be more appropriate') + if const is not None and nargs != OPTIONAL: + raise ValueError('nargs must be %r to supply const' % OPTIONAL) + super(_StoreAction, self).__init__( + option_strings=option_strings, + dest=dest, + nargs=nargs, + const=const, + default=default, + type=type, + choices=choices, + required=required, + help=help, + metavar=metavar) + + def __call__(self, parser, namespace, values, option_string=None): + setattr(namespace, self.dest, values) + + +class _StoreConstAction(Action): + + def __init__(self, + option_strings, + dest, + const, + default=None, + required=False, + help=None, + metavar=None): + super(_StoreConstAction, self).__init__( + option_strings=option_strings, + dest=dest, + nargs=0, + const=const, + default=default, + required=required, + help=help) + + def __call__(self, parser, namespace, values, option_string=None): + setattr(namespace, self.dest, self.const) + + +class _StoreTrueAction(_StoreConstAction): + + def __init__(self, + option_strings, + dest, + default=False, + required=False, + help=None): + super(_StoreTrueAction, self).__init__( + option_strings=option_strings, + dest=dest, + const=True, + default=default, + required=required, + help=help) + + +class _StoreFalseAction(_StoreConstAction): + + def __init__(self, + option_strings, + dest, + default=True, + required=False, + help=None): + super(_StoreFalseAction, self).__init__( + option_strings=option_strings, + dest=dest, + const=False, + default=default, + required=required, + help=help) + + +class _AppendAction(Action): + + def __init__(self, + option_strings, + dest, + nargs=None, + const=None, + default=None, + type=None, + choices=None, + required=False, + help=None, + metavar=None): + if nargs == 0: + raise ValueError('nargs for append actions must be > 0; if arg ' + 'strings are not supplying the value to append, ' + 'the append const action may be more appropriate') + if const is not None and nargs != OPTIONAL: + raise ValueError('nargs must be %r to supply const' % OPTIONAL) + super(_AppendAction, self).__init__( + option_strings=option_strings, + dest=dest, + nargs=nargs, + const=const, + default=default, + type=type, + choices=choices, + required=required, + help=help, + metavar=metavar) + + def __call__(self, parser, namespace, values, option_string=None): + items = _copy.copy(_ensure_value(namespace, self.dest, [])) + items.append(values) + setattr(namespace, self.dest, items) + + +class _AppendConstAction(Action): + + def __init__(self, + option_strings, + dest, + const, + default=None, + required=False, + help=None, + metavar=None): + super(_AppendConstAction, self).__init__( + option_strings=option_strings, + dest=dest, + nargs=0, + const=const, + default=default, + required=required, + help=help, + metavar=metavar) + + def __call__(self, parser, namespace, values, option_string=None): + items = _copy.copy(_ensure_value(namespace, self.dest, [])) + items.append(self.const) + setattr(namespace, self.dest, items) + + +class _CountAction(Action): + + def __init__(self, + option_strings, + dest, + default=None, + required=False, + help=None): + super(_CountAction, self).__init__( + option_strings=option_strings, + dest=dest, + nargs=0, + default=default, + required=required, + help=help) + + def __call__(self, parser, namespace, values, option_string=None): + new_count = _ensure_value(namespace, self.dest, 0) + 1 + setattr(namespace, self.dest, new_count) + + +class _HelpAction(Action): + + def __init__(self, + option_strings, + dest=SUPPRESS, + default=SUPPRESS, + help=None): + super(_HelpAction, self).__init__( + option_strings=option_strings, + dest=dest, + default=default, + nargs=0, + help=help) + + def __call__(self, parser, namespace, values, option_string=None): + parser.print_help() + parser.exit() + + +class _VersionAction(Action): + + def __init__(self, + option_strings, + version=None, + dest=SUPPRESS, + default=SUPPRESS, + help="show program's version number and exit"): + super(_VersionAction, self).__init__( + option_strings=option_strings, + dest=dest, + default=default, + nargs=0, + help=help) + self.version = version + + def __call__(self, parser, namespace, values, option_string=None): + version = self.version + if version is None: + version = parser.version + formatter = parser._get_formatter() + formatter.add_text(version) + parser.exit(message=formatter.format_help()) + + +class _SubParsersAction(Action): + + class _ChoicesPseudoAction(Action): + + def __init__(self, name, aliases, help): + metavar = dest = name + if aliases: + metavar += ' (%s)' % ', '.join(aliases) + sup = super(_SubParsersAction._ChoicesPseudoAction, self) + sup.__init__(option_strings=[], dest=dest, help=help, + metavar=metavar) + + def __init__(self, + option_strings, + prog, + parser_class, + dest=SUPPRESS, + help=None, + metavar=None): + + self._prog_prefix = prog + self._parser_class = parser_class + self._name_parser_map = {} + self._choices_actions = [] + + super(_SubParsersAction, self).__init__( + option_strings=option_strings, + dest=dest, + nargs=PARSER, + choices=self._name_parser_map, + help=help, + metavar=metavar) + + def add_parser(self, name, **kwargs): + # set prog from the existing prefix + if kwargs.get('prog') is None: + kwargs['prog'] = '%s %s' % (self._prog_prefix, name) + + aliases = kwargs.pop('aliases', ()) + + # create a pseudo-action to hold the choice help + if 'help' in kwargs: + help = kwargs.pop('help') + choice_action = self._ChoicesPseudoAction(name, aliases, help) + self._choices_actions.append(choice_action) + + # create the parser and add it to the map + parser = self._parser_class(**kwargs) + self._name_parser_map[name] = parser + + # make parser available under aliases also + for alias in aliases: + self._name_parser_map[alias] = parser + + return parser + + def _get_subactions(self): + return self._choices_actions + + def __call__(self, parser, namespace, values, option_string=None): + parser_name = values[0] + arg_strings = values[1:] + + # set the parser name if requested + if self.dest is not SUPPRESS: + setattr(namespace, self.dest, parser_name) + + # select the parser + try: + parser = self._name_parser_map[parser_name] + except KeyError: + tup = parser_name, ', '.join(self._name_parser_map) + msg = _('unknown parser %r (choices: %s)' % tup) + raise ArgumentError(self, msg) + + # parse all the remaining options into the namespace + # store any unrecognized options on the object, so that the top + # level parser can decide what to do with them + namespace, arg_strings = parser.parse_known_args(arg_strings, namespace) + if arg_strings: + vars(namespace).setdefault(_UNRECOGNIZED_ARGS_ATTR, []) + getattr(namespace, _UNRECOGNIZED_ARGS_ATTR).extend(arg_strings) + + +# ============== +# Type classes +# ============== + +class FileType(object): + """Factory for creating file object types + + Instances of FileType are typically passed as type= arguments to the + ArgumentParser add_argument() method. + + Keyword Arguments: + - mode -- A string indicating how the file is to be opened. Accepts the + same values as the builtin open() function. + - bufsize -- The file's desired buffer size. Accepts the same values as + the builtin open() function. + """ + + def __init__(self, mode='r', bufsize=None): + self._mode = mode + self._bufsize = bufsize + + def __call__(self, string): + # the special argument "-" means sys.std{in,out} + if string == '-': + if 'r' in self._mode: + return _sys.stdin + elif 'w' in self._mode: + return _sys.stdout + else: + msg = _('argument "-" with mode %r' % self._mode) + raise ValueError(msg) + + try: + # all other arguments are used as file names + if self._bufsize: + return open(string, self._mode, self._bufsize) + else: + return open(string, self._mode) + except IOError: + err = _sys.exc_info()[1] + message = _("can't open '%s': %s") + raise ArgumentTypeError(message % (string, err)) + + def __repr__(self): + args = [self._mode, self._bufsize] + args_str = ', '.join([repr(arg) for arg in args if arg is not None]) + return '%s(%s)' % (type(self).__name__, args_str) + +# =========================== +# Optional and Positional Parsing +# =========================== + +class Namespace(_AttributeHolder): + """Simple object for storing attributes. + + Implements equality by attribute names and values, and provides a simple + string representation. + """ + + def __init__(self, **kwargs): + for name in kwargs: + setattr(self, name, kwargs[name]) + + __hash__ = None + + def __eq__(self, other): + return vars(self) == vars(other) + + def __ne__(self, other): + return not (self == other) + + def __contains__(self, key): + return key in self.__dict__ + + +class _ActionsContainer(object): + + def __init__(self, + description, + prefix_chars, + argument_default, + conflict_handler): + super(_ActionsContainer, self).__init__() + + self.description = description + self.argument_default = argument_default + self.prefix_chars = prefix_chars + self.conflict_handler = conflict_handler + + # set up registries + self._registries = {} + + # register actions + self.register('action', None, _StoreAction) + self.register('action', 'store', _StoreAction) + self.register('action', 'store_const', _StoreConstAction) + self.register('action', 'store_true', _StoreTrueAction) + self.register('action', 'store_false', _StoreFalseAction) + self.register('action', 'append', _AppendAction) + self.register('action', 'append_const', _AppendConstAction) + self.register('action', 'count', _CountAction) + self.register('action', 'help', _HelpAction) + self.register('action', 'version', _VersionAction) + self.register('action', 'parsers', _SubParsersAction) + + # raise an exception if the conflict handler is invalid + self._get_handler() + + # action storage + self._actions = [] + self._option_string_actions = {} + + # groups + self._action_groups = [] + self._mutually_exclusive_groups = [] + + # defaults storage + self._defaults = {} + + # determines whether an "option" looks like a negative number + self._negative_number_matcher = _re.compile(r'^-\d+$|^-\d*\.\d+$') + + # whether or not there are any optionals that look like negative + # numbers -- uses a list so it can be shared and edited + self._has_negative_number_optionals = [] + + # ==================== + # Registration methods + # ==================== + def register(self, registry_name, value, object): + registry = self._registries.setdefault(registry_name, {}) + registry[value] = object + + def _registry_get(self, registry_name, value, default=None): + return self._registries[registry_name].get(value, default) + + # ================================== + # Namespace default accessor methods + # ================================== + def set_defaults(self, **kwargs): + self._defaults.update(kwargs) + + # if these defaults match any existing arguments, replace + # the previous default on the object with the new one + for action in self._actions: + if action.dest in kwargs: + action.default = kwargs[action.dest] + + def get_default(self, dest): + for action in self._actions: + if action.dest == dest and action.default is not None: + return action.default + return self._defaults.get(dest, None) + + + # ======================= + # Adding argument actions + # ======================= + def add_argument(self, *args, **kwargs): + """ + add_argument(dest, ..., name=value, ...) + add_argument(option_string, option_string, ..., name=value, ...) + """ + + # if no positional args are supplied or only one is supplied and + # it doesn't look like an option string, parse a positional + # argument + chars = self.prefix_chars + if not args or len(args) == 1 and args[0][0] not in chars: + if args and 'dest' in kwargs: + raise ValueError('dest supplied twice for positional argument') + kwargs = self._get_positional_kwargs(*args, **kwargs) + + # otherwise, we're adding an optional argument + else: + kwargs = self._get_optional_kwargs(*args, **kwargs) + + # if no default was supplied, use the parser-level default + if 'default' not in kwargs: + dest = kwargs['dest'] + if dest in self._defaults: + kwargs['default'] = self._defaults[dest] + elif self.argument_default is not None: + kwargs['default'] = self.argument_default + + # create the action object, and add it to the parser + action_class = self._pop_action_class(kwargs) + if not _callable(action_class): + raise ValueError('unknown action "%s"' % action_class) + action = action_class(**kwargs) + + # raise an error if the action type is not callable + type_func = self._registry_get('type', action.type, action.type) + if not _callable(type_func): + raise ValueError('%r is not callable' % type_func) + + return self._add_action(action) + + def add_argument_group(self, *args, **kwargs): + group = _ArgumentGroup(self, *args, **kwargs) + self._action_groups.append(group) + return group + + def add_mutually_exclusive_group(self, **kwargs): + group = _MutuallyExclusiveGroup(self, **kwargs) + self._mutually_exclusive_groups.append(group) + return group + + def _add_action(self, action): + # resolve any conflicts + self._check_conflict(action) + + # add to actions list + self._actions.append(action) + action.container = self + + # index the action by any option strings it has + for option_string in action.option_strings: + self._option_string_actions[option_string] = action + + # set the flag if any option strings look like negative numbers + for option_string in action.option_strings: + if self._negative_number_matcher.match(option_string): + if not self._has_negative_number_optionals: + self._has_negative_number_optionals.append(True) + + # return the created action + return action + + def _remove_action(self, action): + self._actions.remove(action) + + def _add_container_actions(self, container): + # collect groups by titles + title_group_map = {} + for group in self._action_groups: + if group.title in title_group_map: + msg = _('cannot merge actions - two groups are named %r') + raise ValueError(msg % (group.title)) + title_group_map[group.title] = group + + # map each action to its group + group_map = {} + for group in container._action_groups: + + # if a group with the title exists, use that, otherwise + # create a new group matching the container's group + if group.title not in title_group_map: + title_group_map[group.title] = self.add_argument_group( + title=group.title, + description=group.description, + conflict_handler=group.conflict_handler) + + # map the actions to their new group + for action in group._group_actions: + group_map[action] = title_group_map[group.title] + + # add container's mutually exclusive groups + # NOTE: if add_mutually_exclusive_group ever gains title= and + # description= then this code will need to be expanded as above + for group in container._mutually_exclusive_groups: + mutex_group = self.add_mutually_exclusive_group( + required=group.required) + + # map the actions to their new mutex group + for action in group._group_actions: + group_map[action] = mutex_group + + # add all actions to this container or their group + for action in container._actions: + group_map.get(action, self)._add_action(action) + + def _get_positional_kwargs(self, dest, **kwargs): + # make sure required is not specified + if 'required' in kwargs: + msg = _("'required' is an invalid argument for positionals") + raise TypeError(msg) + + # mark positional arguments as required if at least one is + # always required + if kwargs.get('nargs') not in [OPTIONAL, ZERO_OR_MORE]: + kwargs['required'] = True + if kwargs.get('nargs') == ZERO_OR_MORE and 'default' not in kwargs: + kwargs['required'] = True + + # return the keyword arguments with no option strings + return dict(kwargs, dest=dest, option_strings=[]) + + def _get_optional_kwargs(self, *args, **kwargs): + # determine short and long option strings + option_strings = [] + long_option_strings = [] + for option_string in args: + # error on strings that don't start with an appropriate prefix + if not option_string[0] in self.prefix_chars: + msg = _('invalid option string %r: ' + 'must start with a character %r') + tup = option_string, self.prefix_chars + raise ValueError(msg % tup) + + # strings starting with two prefix characters are long options + option_strings.append(option_string) + if option_string[0] in self.prefix_chars: + if len(option_string) > 1: + if option_string[1] in self.prefix_chars: + long_option_strings.append(option_string) + + # infer destination, '--foo-bar' -> 'foo_bar' and '-x' -> 'x' + dest = kwargs.pop('dest', None) + if dest is None: + if long_option_strings: + dest_option_string = long_option_strings[0] + else: + dest_option_string = option_strings[0] + dest = dest_option_string.lstrip(self.prefix_chars) + if not dest: + msg = _('dest= is required for options like %r') + raise ValueError(msg % option_string) + dest = dest.replace('-', '_') + + # return the updated keyword arguments + return dict(kwargs, dest=dest, option_strings=option_strings) + + def _pop_action_class(self, kwargs, default=None): + action = kwargs.pop('action', default) + return self._registry_get('action', action, action) + + def _get_handler(self): + # determine function from conflict handler string + handler_func_name = '_handle_conflict_%s' % self.conflict_handler + try: + return getattr(self, handler_func_name) + except AttributeError: + msg = _('invalid conflict_resolution value: %r') + raise ValueError(msg % self.conflict_handler) + + def _check_conflict(self, action): + + # find all options that conflict with this option + confl_optionals = [] + for option_string in action.option_strings: + if option_string in self._option_string_actions: + confl_optional = self._option_string_actions[option_string] + confl_optionals.append((option_string, confl_optional)) + + # resolve any conflicts + if confl_optionals: + conflict_handler = self._get_handler() + conflict_handler(action, confl_optionals) + + def _handle_conflict_error(self, action, conflicting_actions): + message = _('conflicting option string(s): %s') + conflict_string = ', '.join([option_string + for option_string, action + in conflicting_actions]) + raise ArgumentError(action, message % conflict_string) + + def _handle_conflict_resolve(self, action, conflicting_actions): + + # remove all conflicting options + for option_string, action in conflicting_actions: + + # remove the conflicting option + action.option_strings.remove(option_string) + self._option_string_actions.pop(option_string, None) + + # if the option now has no option string, remove it from the + # container holding it + if not action.option_strings: + action.container._remove_action(action) + + +class _ArgumentGroup(_ActionsContainer): + + def __init__(self, container, title=None, description=None, **kwargs): + # add any missing keyword arguments by checking the container + update = kwargs.setdefault + update('conflict_handler', container.conflict_handler) + update('prefix_chars', container.prefix_chars) + update('argument_default', container.argument_default) + super_init = super(_ArgumentGroup, self).__init__ + super_init(description=description, **kwargs) + + # group attributes + self.title = title + self._group_actions = [] + + # share most attributes with the container + self._registries = container._registries + self._actions = container._actions + self._option_string_actions = container._option_string_actions + self._defaults = container._defaults + self._has_negative_number_optionals = \ + container._has_negative_number_optionals + + def _add_action(self, action): + action = super(_ArgumentGroup, self)._add_action(action) + self._group_actions.append(action) + return action + + def _remove_action(self, action): + super(_ArgumentGroup, self)._remove_action(action) + self._group_actions.remove(action) + + +class _MutuallyExclusiveGroup(_ArgumentGroup): + + def __init__(self, container, required=False): + super(_MutuallyExclusiveGroup, self).__init__(container) + self.required = required + self._container = container + + def _add_action(self, action): + if action.required: + msg = _('mutually exclusive arguments must be optional') + raise ValueError(msg) + action = self._container._add_action(action) + self._group_actions.append(action) + return action + + def _remove_action(self, action): + self._container._remove_action(action) + self._group_actions.remove(action) + + +class ArgumentParser(_AttributeHolder, _ActionsContainer): + """Object for parsing command line strings into Python objects. + + Keyword Arguments: + - prog -- The name of the program (default: sys.argv[0]) + - usage -- A usage message (default: auto-generated from arguments) + - description -- A description of what the program does + - epilog -- Text following the argument descriptions + - parents -- Parsers whose arguments should be copied into this one + - formatter_class -- HelpFormatter class for printing help messages + - prefix_chars -- Characters that prefix optional arguments + - fromfile_prefix_chars -- Characters that prefix files containing + additional arguments + - argument_default -- The default value for all arguments + - conflict_handler -- String indicating how to handle conflicts + - add_help -- Add a -h/-help option + """ + + def __init__(self, + prog=None, + usage=None, + description=None, + epilog=None, + version=None, + parents=[], + formatter_class=HelpFormatter, + prefix_chars='-', + fromfile_prefix_chars=None, + argument_default=None, + conflict_handler='error', + add_help=True): + + if version is not None: + import warnings + warnings.warn( + """The "version" argument to ArgumentParser is deprecated. """ + """Please use """ + """"add_argument(..., action='version', version="N", ...)" """ + """instead""", DeprecationWarning) + + superinit = super(ArgumentParser, self).__init__ + superinit(description=description, + prefix_chars=prefix_chars, + argument_default=argument_default, + conflict_handler=conflict_handler) + + # default setting for prog + if prog is None: + prog = _os.path.basename(_sys.argv[0]) + + self.prog = prog + self.usage = usage + self.epilog = epilog + self.version = version + self.formatter_class = formatter_class + self.fromfile_prefix_chars = fromfile_prefix_chars + self.add_help = add_help + + add_group = self.add_argument_group + self._positionals = add_group(_('positional arguments')) + self._optionals = add_group(_('optional arguments')) + self._subparsers = None + + # register types + def identity(string): + return string + self.register('type', None, identity) + + # add help and version arguments if necessary + # (using explicit default to override global argument_default) + if '-' in prefix_chars: + default_prefix = '-' + else: + default_prefix = prefix_chars[0] + if self.add_help: + self.add_argument( + default_prefix+'h', default_prefix*2+'help', + action='help', default=SUPPRESS, + help=_('show this help message and exit')) + if self.version: + self.add_argument( + default_prefix+'v', default_prefix*2+'version', + action='version', default=SUPPRESS, + version=self.version, + help=_("show program's version number and exit")) + + # add parent arguments and defaults + for parent in parents: + self._add_container_actions(parent) + try: + defaults = parent._defaults + except AttributeError: + pass + else: + self._defaults.update(defaults) + + # ======================= + # Pretty __repr__ methods + # ======================= + def _get_kwargs(self): + names = [ + 'prog', + 'usage', + 'description', + 'version', + 'formatter_class', + 'conflict_handler', + 'add_help', + ] + return [(name, getattr(self, name)) for name in names] + + # ================================== + # Optional/Positional adding methods + # ================================== + def add_subparsers(self, **kwargs): + if self._subparsers is not None: + self.error(_('cannot have multiple subparser arguments')) + + # add the parser class to the arguments if it's not present + kwargs.setdefault('parser_class', type(self)) + + if 'title' in kwargs or 'description' in kwargs: + title = _(kwargs.pop('title', 'subcommands')) + description = _(kwargs.pop('description', None)) + self._subparsers = self.add_argument_group(title, description) + else: + self._subparsers = self._positionals + + # prog defaults to the usage message of this parser, skipping + # optional arguments and with no "usage:" prefix + if kwargs.get('prog') is None: + formatter = self._get_formatter() + positionals = self._get_positional_actions() + groups = self._mutually_exclusive_groups + formatter.add_usage(self.usage, positionals, groups, '') + kwargs['prog'] = formatter.format_help().strip() + + # create the parsers action and add it to the positionals list + parsers_class = self._pop_action_class(kwargs, 'parsers') + action = parsers_class(option_strings=[], **kwargs) + self._subparsers._add_action(action) + + # return the created parsers action + return action + + def _add_action(self, action): + if action.option_strings: + self._optionals._add_action(action) + else: + self._positionals._add_action(action) + return action + + def _get_optional_actions(self): + return [action + for action in self._actions + if action.option_strings] + + def _get_positional_actions(self): + return [action + for action in self._actions + if not action.option_strings] + + # ===================================== + # Command line argument parsing methods + # ===================================== + def parse_args(self, args=None, namespace=None): + args, argv = self.parse_known_args(args, namespace) + if argv: + msg = _('unrecognized arguments: %s') + self.error(msg % ' '.join(argv)) + return args + + def parse_known_args(self, args=None, namespace=None): + # args default to the system args + if args is None: + args = _sys.argv[1:] + + # default Namespace built from parser defaults + if namespace is None: + namespace = Namespace() + + # add any action defaults that aren't present + for action in self._actions: + if action.dest is not SUPPRESS: + if not hasattr(namespace, action.dest): + if action.default is not SUPPRESS: + setattr(namespace, action.dest, action.default) + + # add any parser defaults that aren't present + for dest in self._defaults: + if not hasattr(namespace, dest): + setattr(namespace, dest, self._defaults[dest]) + + # parse the arguments and exit if there are any errors + try: + namespace, args = self._parse_known_args(args, namespace) + if hasattr(namespace, _UNRECOGNIZED_ARGS_ATTR): + args.extend(getattr(namespace, _UNRECOGNIZED_ARGS_ATTR)) + delattr(namespace, _UNRECOGNIZED_ARGS_ATTR) + return namespace, args + except ArgumentError: + err = _sys.exc_info()[1] + self.error(str(err)) + + def _parse_known_args(self, arg_strings, namespace): + # replace arg strings that are file references + if self.fromfile_prefix_chars is not None: + arg_strings = self._read_args_from_files(arg_strings) + + # map all mutually exclusive arguments to the other arguments + # they can't occur with + action_conflicts = {} + for mutex_group in self._mutually_exclusive_groups: + group_actions = mutex_group._group_actions + for i, mutex_action in enumerate(mutex_group._group_actions): + conflicts = action_conflicts.setdefault(mutex_action, []) + conflicts.extend(group_actions[:i]) + conflicts.extend(group_actions[i + 1:]) + + # find all option indices, and determine the arg_string_pattern + # which has an 'O' if there is an option at an index, + # an 'A' if there is an argument, or a '-' if there is a '--' + option_string_indices = {} + arg_string_pattern_parts = [] + arg_strings_iter = iter(arg_strings) + for i, arg_string in enumerate(arg_strings_iter): + + # all args after -- are non-options + if arg_string == '--': + arg_string_pattern_parts.append('-') + for arg_string in arg_strings_iter: + arg_string_pattern_parts.append('A') + + # otherwise, add the arg to the arg strings + # and note the index if it was an option + else: + option_tuple = self._parse_optional(arg_string) + if option_tuple is None: + pattern = 'A' + else: + option_string_indices[i] = option_tuple + pattern = 'O' + arg_string_pattern_parts.append(pattern) + + # join the pieces together to form the pattern + arg_strings_pattern = ''.join(arg_string_pattern_parts) + + # converts arg strings to the appropriate and then takes the action + seen_actions = set() + seen_non_default_actions = set() + + def take_action(action, argument_strings, option_string=None): + seen_actions.add(action) + argument_values = self._get_values(action, argument_strings) + + # error if this argument is not allowed with other previously + # seen arguments, assuming that actions that use the default + # value don't really count as "present" + if argument_values is not action.default: + seen_non_default_actions.add(action) + for conflict_action in action_conflicts.get(action, []): + if conflict_action in seen_non_default_actions: + msg = _('not allowed with argument %s') + action_name = _get_action_name(conflict_action) + raise ArgumentError(action, msg % action_name) + + # take the action if we didn't receive a SUPPRESS value + # (e.g. from a default) + if argument_values is not SUPPRESS: + action(self, namespace, argument_values, option_string) + + # function to convert arg_strings into an optional action + def consume_optional(start_index): + + # get the optional identified at this index + option_tuple = option_string_indices[start_index] + action, option_string, explicit_arg = option_tuple + + # identify additional optionals in the same arg string + # (e.g. -xyz is the same as -x -y -z if no args are required) + match_argument = self._match_argument + action_tuples = [] + while True: + + # if we found no optional action, skip it + if action is None: + extras.append(arg_strings[start_index]) + return start_index + 1 + + # if there is an explicit argument, try to match the + # optional's string arguments to only this + if explicit_arg is not None: + arg_count = match_argument(action, 'A') + + # if the action is a single-dash option and takes no + # arguments, try to parse more single-dash options out + # of the tail of the option string + chars = self.prefix_chars + if arg_count == 0 and option_string[1] not in chars: + action_tuples.append((action, [], option_string)) + char = option_string[0] + option_string = char + explicit_arg[0] + new_explicit_arg = explicit_arg[1:] or None + optionals_map = self._option_string_actions + if option_string in optionals_map: + action = optionals_map[option_string] + explicit_arg = new_explicit_arg + else: + msg = _('ignored explicit argument %r') + raise ArgumentError(action, msg % explicit_arg) + + # if the action expect exactly one argument, we've + # successfully matched the option; exit the loop + elif arg_count == 1: + stop = start_index + 1 + args = [explicit_arg] + action_tuples.append((action, args, option_string)) + break + + # error if a double-dash option did not use the + # explicit argument + else: + msg = _('ignored explicit argument %r') + raise ArgumentError(action, msg % explicit_arg) + + # if there is no explicit argument, try to match the + # optional's string arguments with the following strings + # if successful, exit the loop + else: + start = start_index + 1 + selected_patterns = arg_strings_pattern[start:] + arg_count = match_argument(action, selected_patterns) + stop = start + arg_count + args = arg_strings[start:stop] + action_tuples.append((action, args, option_string)) + break + + # add the Optional to the list and return the index at which + # the Optional's string args stopped + assert action_tuples + for action, args, option_string in action_tuples: + take_action(action, args, option_string) + return stop + + # the list of Positionals left to be parsed; this is modified + # by consume_positionals() + positionals = self._get_positional_actions() + + # function to convert arg_strings into positional actions + def consume_positionals(start_index): + # match as many Positionals as possible + match_partial = self._match_arguments_partial + selected_pattern = arg_strings_pattern[start_index:] + arg_counts = match_partial(positionals, selected_pattern) + + # slice off the appropriate arg strings for each Positional + # and add the Positional and its args to the list + for action, arg_count in zip(positionals, arg_counts): + args = arg_strings[start_index: start_index + arg_count] + start_index += arg_count + take_action(action, args) + + # slice off the Positionals that we just parsed and return the + # index at which the Positionals' string args stopped + positionals[:] = positionals[len(arg_counts):] + return start_index + + # consume Positionals and Optionals alternately, until we have + # passed the last option string + extras = [] + start_index = 0 + if option_string_indices: + max_option_string_index = max(option_string_indices) + else: + max_option_string_index = -1 + while start_index <= max_option_string_index: + + # consume any Positionals preceding the next option + next_option_string_index = min([ + index + for index in option_string_indices + if index >= start_index]) + if start_index != next_option_string_index: + positionals_end_index = consume_positionals(start_index) + + # only try to parse the next optional if we didn't consume + # the option string during the positionals parsing + if positionals_end_index > start_index: + start_index = positionals_end_index + continue + else: + start_index = positionals_end_index + + # if we consumed all the positionals we could and we're not + # at the index of an option string, there were extra arguments + if start_index not in option_string_indices: + strings = arg_strings[start_index:next_option_string_index] + extras.extend(strings) + start_index = next_option_string_index + + # consume the next optional and any arguments for it + start_index = consume_optional(start_index) + + # consume any positionals following the last Optional + stop_index = consume_positionals(start_index) + + # if we didn't consume all the argument strings, there were extras + extras.extend(arg_strings[stop_index:]) + + # if we didn't use all the Positional objects, there were too few + # arg strings supplied. + if positionals: + self.error(_('too few arguments')) + + # make sure all required actions were present, and convert defaults. + for action in self._actions: + if action not in seen_actions: + if action.required: + name = _get_action_name(action) + self.error(_('argument %s is required') % name) + else: + # Convert action default now instead of doing it before + # parsing arguments to avoid calling convert functions + # twice (which may fail) if the argument was given, but + # only if it was defined already in the namespace + if (action.default is not None and + isinstance(action.default, basestring) and + hasattr(namespace, action.dest) and + action.default is getattr(namespace, action.dest)): + setattr(namespace, action.dest, + self._get_value(action, action.default)) + + # make sure all required groups had one option present + for group in self._mutually_exclusive_groups: + if group.required: + for action in group._group_actions: + if action in seen_non_default_actions: + break + + # if no actions were used, report the error + else: + names = [_get_action_name(action) + for action in group._group_actions + if action.help is not SUPPRESS] + msg = _('one of the arguments %s is required') + self.error(msg % ' '.join(names)) + + # return the updated namespace and the extra arguments + return namespace, extras + + def _read_args_from_files(self, arg_strings): + # expand arguments referencing files + new_arg_strings = [] + for arg_string in arg_strings: + + # for regular arguments, just add them back into the list + if arg_string[0] not in self.fromfile_prefix_chars: + new_arg_strings.append(arg_string) + + # replace arguments referencing files with the file content + else: + try: + args_file = open(arg_string[1:]) + try: + arg_strings = [] + for arg_line in args_file.read().splitlines(): + for arg in self.convert_arg_line_to_args(arg_line): + arg_strings.append(arg) + arg_strings = self._read_args_from_files(arg_strings) + new_arg_strings.extend(arg_strings) + finally: + args_file.close() + except IOError: + err = _sys.exc_info()[1] + self.error(str(err)) + + # return the modified argument list + return new_arg_strings + + def convert_arg_line_to_args(self, arg_line): + return [arg_line] + + def _match_argument(self, action, arg_strings_pattern): + # match the pattern for this action to the arg strings + nargs_pattern = self._get_nargs_pattern(action) + match = _re.match(nargs_pattern, arg_strings_pattern) + + # raise an exception if we weren't able to find a match + if match is None: + nargs_errors = { + None: _('expected one argument'), + OPTIONAL: _('expected at most one argument'), + ONE_OR_MORE: _('expected at least one argument'), + } + default = _('expected %s argument(s)') % action.nargs + msg = nargs_errors.get(action.nargs, default) + raise ArgumentError(action, msg) + + # return the number of arguments matched + return len(match.group(1)) + + def _match_arguments_partial(self, actions, arg_strings_pattern): + # progressively shorten the actions list by slicing off the + # final actions until we find a match + result = [] + for i in range(len(actions), 0, -1): + actions_slice = actions[:i] + pattern = ''.join([self._get_nargs_pattern(action) + for action in actions_slice]) + match = _re.match(pattern, arg_strings_pattern) + if match is not None: + result.extend([len(string) for string in match.groups()]) + break + + # return the list of arg string counts + return result + + def _parse_optional(self, arg_string): + # if it's an empty string, it was meant to be a positional + if not arg_string: + return None + + # if it doesn't start with a prefix, it was meant to be positional + if not arg_string[0] in self.prefix_chars: + return None + + # if the option string is present in the parser, return the action + if arg_string in self._option_string_actions: + action = self._option_string_actions[arg_string] + return action, arg_string, None + + # if it's just a single character, it was meant to be positional + if len(arg_string) == 1: + return None + + # if the option string before the "=" is present, return the action + if '=' in arg_string: + option_string, explicit_arg = arg_string.split('=', 1) + if option_string in self._option_string_actions: + action = self._option_string_actions[option_string] + return action, option_string, explicit_arg + + # search through all possible prefixes of the option string + # and all actions in the parser for possible interpretations + option_tuples = self._get_option_tuples(arg_string) + + # if multiple actions match, the option string was ambiguous + if len(option_tuples) > 1: + options = ', '.join([option_string + for action, option_string, explicit_arg in option_tuples]) + tup = arg_string, options + self.error(_('ambiguous option: %s could match %s') % tup) + + # if exactly one action matched, this segmentation is good, + # so return the parsed action + elif len(option_tuples) == 1: + option_tuple, = option_tuples + return option_tuple + + # if it was not found as an option, but it looks like a negative + # number, it was meant to be positional + # unless there are negative-number-like options + if self._negative_number_matcher.match(arg_string): + if not self._has_negative_number_optionals: + return None + + # if it contains a space, it was meant to be a positional + if ' ' in arg_string: + return None + + # it was meant to be an optional but there is no such option + # in this parser (though it might be a valid option in a subparser) + return None, arg_string, None + + def _get_option_tuples(self, option_string): + result = [] + + # option strings starting with two prefix characters are only + # split at the '=' + chars = self.prefix_chars + if option_string[0] in chars and option_string[1] in chars: + if '=' in option_string: + option_prefix, explicit_arg = option_string.split('=', 1) + else: + option_prefix = option_string + explicit_arg = None + for option_string in self._option_string_actions: + if option_string.startswith(option_prefix): + action = self._option_string_actions[option_string] + tup = action, option_string, explicit_arg + result.append(tup) + + # single character options can be concatenated with their arguments + # but multiple character options always have to have their argument + # separate + elif option_string[0] in chars and option_string[1] not in chars: + option_prefix = option_string + explicit_arg = None + short_option_prefix = option_string[:2] + short_explicit_arg = option_string[2:] + + for option_string in self._option_string_actions: + if option_string == short_option_prefix: + action = self._option_string_actions[option_string] + tup = action, option_string, short_explicit_arg + result.append(tup) + elif option_string.startswith(option_prefix): + action = self._option_string_actions[option_string] + tup = action, option_string, explicit_arg + result.append(tup) + + # shouldn't ever get here + else: + self.error(_('unexpected option string: %s') % option_string) + + # return the collected option tuples + return result + + def _get_nargs_pattern(self, action): + # in all examples below, we have to allow for '--' args + # which are represented as '-' in the pattern + nargs = action.nargs + + # the default (None) is assumed to be a single argument + if nargs is None: + nargs_pattern = '(-*A-*)' + + # allow zero or one arguments + elif nargs == OPTIONAL: + nargs_pattern = '(-*A?-*)' + + # allow zero or more arguments + elif nargs == ZERO_OR_MORE: + nargs_pattern = '(-*[A-]*)' + + # allow one or more arguments + elif nargs == ONE_OR_MORE: + nargs_pattern = '(-*A[A-]*)' + + # allow any number of options or arguments + elif nargs == REMAINDER: + nargs_pattern = '([-AO]*)' + + # allow one argument followed by any number of options or arguments + elif nargs == PARSER: + nargs_pattern = '(-*A[-AO]*)' + + # all others should be integers + else: + nargs_pattern = '(-*%s-*)' % '-*'.join('A' * nargs) + + # if this is an optional action, -- is not allowed + if action.option_strings: + nargs_pattern = nargs_pattern.replace('-*', '') + nargs_pattern = nargs_pattern.replace('-', '') + + # return the pattern + return nargs_pattern + + # ======================== + # Value conversion methods + # ======================== + def _get_values(self, action, arg_strings): + # for everything but PARSER args, strip out '--' + if action.nargs not in [PARSER, REMAINDER]: + arg_strings = [s for s in arg_strings if s != '--'] + + # optional argument produces a default when not present + if not arg_strings and action.nargs == OPTIONAL: + if action.option_strings: + value = action.const + else: + value = action.default + if isinstance(value, basestring): + value = self._get_value(action, value) + self._check_value(action, value) + + # when nargs='*' on a positional, if there were no command-line + # args, use the default if it is anything other than None + elif (not arg_strings and action.nargs == ZERO_OR_MORE and + not action.option_strings): + if action.default is not None: + value = action.default + else: + value = arg_strings + self._check_value(action, value) + + # single argument or optional argument produces a single value + elif len(arg_strings) == 1 and action.nargs in [None, OPTIONAL]: + arg_string, = arg_strings + value = self._get_value(action, arg_string) + self._check_value(action, value) + + # REMAINDER arguments convert all values, checking none + elif action.nargs == REMAINDER: + value = [self._get_value(action, v) for v in arg_strings] + + # PARSER arguments convert all values, but check only the first + elif action.nargs == PARSER: + value = [self._get_value(action, v) for v in arg_strings] + self._check_value(action, value[0]) + + # all other types of nargs produce a list + else: + value = [self._get_value(action, v) for v in arg_strings] + for v in value: + self._check_value(action, v) + + # return the converted value + return value + + def _get_value(self, action, arg_string): + type_func = self._registry_get('type', action.type, action.type) + if not _callable(type_func): + msg = _('%r is not callable') + raise ArgumentError(action, msg % type_func) + + # convert the value to the appropriate type + try: + result = type_func(arg_string) + + # ArgumentTypeErrors indicate errors + except ArgumentTypeError: + name = getattr(action.type, '__name__', repr(action.type)) + msg = str(_sys.exc_info()[1]) + raise ArgumentError(action, msg) + + # TypeErrors or ValueErrors also indicate errors + except (TypeError, ValueError): + name = getattr(action.type, '__name__', repr(action.type)) + msg = _('invalid %s value: %r') + raise ArgumentError(action, msg % (name, arg_string)) + + # return the converted value + return result + + def _check_value(self, action, value): + # converted value must be one of the choices (if specified) + if action.choices is not None and value not in action.choices: + tup = value, ', '.join(map(repr, action.choices)) + msg = _('invalid choice: %r (choose from %s)') % tup + raise ArgumentError(action, msg) + + # ======================= + # Help-formatting methods + # ======================= + def format_usage(self): + formatter = self._get_formatter() + formatter.add_usage(self.usage, self._actions, + self._mutually_exclusive_groups) + return formatter.format_help() + + def format_help(self): + formatter = self._get_formatter() + + # usage + formatter.add_usage(self.usage, self._actions, + self._mutually_exclusive_groups) + + # description + formatter.add_text(self.description) + + # positionals, optionals and user-defined groups + for action_group in self._action_groups: + formatter.start_section(action_group.title) + formatter.add_text(action_group.description) + formatter.add_arguments(action_group._group_actions) + formatter.end_section() + + # epilog + formatter.add_text(self.epilog) + + # determine help from format above + return formatter.format_help() + + def format_version(self): + import warnings + warnings.warn( + 'The format_version method is deprecated -- the "version" ' + 'argument to ArgumentParser is no longer supported.', + DeprecationWarning) + formatter = self._get_formatter() + formatter.add_text(self.version) + return formatter.format_help() + + def _get_formatter(self): + return self.formatter_class(prog=self.prog) + + # ===================== + # Help-printing methods + # ===================== + def print_usage(self, file=None): + if file is None: + file = _sys.stdout + self._print_message(self.format_usage(), file) + + def print_help(self, file=None): + if file is None: + file = _sys.stdout + self._print_message(self.format_help(), file) + + def print_version(self, file=None): + import warnings + warnings.warn( + 'The print_version method is deprecated -- the "version" ' + 'argument to ArgumentParser is no longer supported.', + DeprecationWarning) + self._print_message(self.format_version(), file) + + def _print_message(self, message, file=None): + if message: + if file is None: + file = _sys.stderr + file.write(message) + + # =============== + # Exiting methods + # =============== + def exit(self, status=0, message=None): + if message: + self._print_message(message, _sys.stderr) + _sys.exit(status) + + def error(self, message): + """error(message: string) + + Prints a usage message incorporating the message to stderr and + exits. + + If you override this in a subclass, it should not return -- it + should either exit or raise an exception. + """ + self.print_usage(_sys.stderr) + self.exit(2, _('%s: error: %s\n') % (self.prog, message)) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen.py (revision 6016) @@ -0,0 +1,513 @@ +#!/usr/bin/env python +import os +import sys + +from depgen import open23, map23, StdStreamWrapper, DummyParser + +try: + import argparse +except ImportError: + import _argparse as argparse + + +def parse_args(): + class ArgumentParser(argparse.ArgumentParser): + def convert_arg_line_to_args(self, arg_line): + try: + # Drop everything after the first occurrence of #: + arg_line = arg_line[:arg_line.index('#')] + except ValueError: + pass + + result = [] + # Do not regard consecutive whitespaces as a single separator: + for arg in arg_line.split(' '): + if arg: + result.append(arg) + elif result: + # The previous argument has a significant whitespace: + result[-1] += ' ' + return result + + parser = ArgumentParser( + fromfile_prefix_chars='@', + description='Generates OUTPUT makefile containing dependency rules ' + 'for the INPUT source file. Recognizes preprocessor ' + '`#include`, `#if` and associated directives as well as ' + 'Fortran `INCLUDE`, `USE` and `MODULE` statements.') + + def comma_splitter(s): + return list(filter(None, s.lower().split(','))) + + def path_splitter(s): + return list(filter(None, s.split(':'))) + + def default_obj_name(src_name): + if src_name: + src_no_ext_basename = os.path.splitext( + os.path.basename(src_name))[0] + if src_no_ext_basename: + return src_no_ext_basename + '.o' + return '' + + parser.add_argument( + '--input', '-i', metavar='INPUT', nargs='+', + help='input source file; if not specified, the program reads from the ' + 'standard input stream') + parser.add_argument( + '--output', '-o', metavar='OUTPUT', nargs='+', + help='output makefile with generated dependency rules; if not ' + 'specified, the program writes to the standard output stream') + parser.add_argument( + '--debug', '-d', action='store_true', + help='dump debug information to OUTPUT (commented with `#`)') + parser.add_argument( + '--src-name', metavar='SRC_NAME', nargs='+', + help='name of the source file, the prerequisite of the corresponding ' + 'compilation rule as it will appear in the OUTPUT; normally (and ' + 'by default) equals to the INPUT or to an empty string when the ' + 'latter is set to the standard input stream') + parser.add_argument( + '--obj-name', metavar='OBJ_NAME', nargs='+', + help='name of the object file, the target of the corresponding ' + 'compilation rule as it will appear in the OUTPUT; normally ' + 'equals to the path to the object file that is supposed to be ' + 'generated as a result of compilation (default: SRC_NAME ' + 'without the directory-part and the file extension replaced ' + 'with `.o`)') + parser.add_argument( + '--dep-name', metavar='DEP_NAME', nargs='+', + help='name of the generated makefile, the additional target of the ' + 'corresponding compilation rule (for automatic dependency ' + 'generation) as it will appear in the OUTPUT; normally (and by ' + 'default) equals to the OUTPUT or to an empty string when the ' + 'latter is set to the standard output stream)') + parser.add_argument( + '--src-roots', metavar='SRC_ROOTS', + type=path_splitter, + help='colon-separated list of paths to directories; if specified and ' + 'not empty, dependencies on files that do not reside in one of ' + 'the specified directories will be ignored; applies only to ' + 'files included using the preprocessor `#include` directive or ' + 'the Fortran `INCLUDE` statement') + parser.add_argument( + '--lc-enable', action='store_true', + help='enable recognition of the preprocessor line control directives ' + 'and generation of additional dependencies based on the detected ' + 'filenames') + parser.add_argument( + 'flags', metavar='-- [$CPPFLAGS | $FCFLAGS]', nargs='?', + default=argparse.SUPPRESS, + help='actual flags to be used in compilation, i.e. $(CPPFLAGS) or ' + '$(FCFLAGS), must be given at the end of the command line ' + 'following the double dash separator (--); the program searches ' + 'these flags for (possibly multiple instances of) PP_INC_FLAG, ' + 'PP_MACRO_FLAG, FC_INC_FLAG and FC_MOD_DIR_FLAG; any values ' + 'found are used in the dependency generation (in the case of ' + 'FC_MOD_DIR_FLAG, only the last value found is used)') + + pp_arg_group = parser.add_argument_group('preprocessor arguments') + pp_arg_group.add_argument( + '--pp-enable', action='store_true', + help='enable the preprocessing stage; if disabled (default), all ' + 'arguments of this argument group are ignored') + pp_arg_group.add_argument( + '--pp-eval-expr', action='store_true', + help='enable evaluation of expressions that appear in preprocessor ' + 'directives `#if` and `#elif` (does not apply to `#ifdef` and ' + '`#ifndef`, which are always evaluated); if disabled (default) ' + 'or evaluation fails, both branches of the directives are ' + 'included by the preprocessing stage') + pp_arg_group.add_argument( + '--pp-inc-sys', action='store_true', + help='enable recognition of dependencies specified with the ' + 'angle-bracket form of the preprocessor `#include` directive ' + '(i.e. `#include `); the constraint set by SRC_ROOTS ' + 'applies') + pp_arg_group.add_argument( + '--pp-inc-order', default='inc,flg', metavar='ORDER_LIST', + type=comma_splitter, + help='directory search order of files included using the quoted form ' + 'of the preprocessor `#include` directive (i.e. `#include ' + '"filename"`) ; ORDER_LIST is an ordered comma-separated list of ' + 'keywords, the corresponding search paths of which are to be ' + 'searched in the given order. The recognized keywords are: `cwd` ' + '(for the current working directory), `flg` (for the directories ' + 'specified with PP_INC_FLAG compiler flag), `src` (for the ' + 'directory containing the INPUT source file), and `inc` (for the ' + 'directory containing the file with the `#include` directive). ' + 'Default: `%(default)s`.') + pp_arg_group.add_argument( + '--pp-inc-sys-order', default='flg', metavar='ORDER_LIST', + type=comma_splitter, + help='equivalent to the `--pp-inc-order` argument, only for the ' + 'angle-bracket form of the preprocessor `#include` directive ' + '(i.e. `#include `, default: `%(default)s`)') + + pp_arg_group.add_argument( + '--pp-macro-flag', metavar='PP_MACRO_FLAG', default='-D', + help='preprocessor flag used for macro definition; only flags ' + 'that start with a single dash (-) and have no more than one ' + 'trailing whitespace are supported (default: `%(default)s`)') + pp_arg_group.add_argument( + '--pp-inc-flag', metavar='PP_INC_FLAG', default='-I', + help='preprocessor flag used for setting search paths for the ' + '`#include` directive; only flags that start with a single dash ' + '(-) and have no more than one trailing whitespace are supported ' + '(default: `%(default)s`)') + + fc_arg_group = parser.add_argument_group('Fortran arguments') + fc_arg_group.add_argument( + '--fc-enable', action='store_true', + help='enable recognition of Fortran dependencies specified with ' + '`INCLUDE`, `USE` and `MODULE` statements; if disabled (default),' + 'all arguments of this argument group are ignored') + fc_arg_group.add_argument( + '--fc-mod-ext', default='mod', + help='filename extension (without leading dot) of compiler-generated ' + 'Fortran module files (default: `%(default)s`)') + fc_arg_group.add_argument( + '--fc-mod-upper', choices=['yes', 'no'], default='no', + help='whether Fortran compiler-generated module files have uppercase ' + 'names (default: `%(default)s`)') + fc_arg_group.add_argument( + '--fc-inc-order', default='src,flg', metavar='ORDER_LIST', + type=comma_splitter, + help='equivalent to the `--pp-inc-order` argument, only for the ' + 'Fortran `INCLUDE` statement and FC_INC_FLAG (default: ' + '`%(default)s`)') + fc_intrisic_mods_default = ('iso_c_binding,iso_fortran_env,ieee_exceptions,' + 'ieee_arithmetic,ieee_features,omp_lib,' + 'omp_lib_kinds,openacc') + fc_arg_group.add_argument( + '--fc-intrinsic-mods', metavar='INTRINSIC_MODS_LIST', + type=comma_splitter, + action='append', + help='comma-separated list of Fortran intrinsic modules. Fortran ' + 'modules that are explicitly specified as intrinsic in the ' + 'source file (i.e. `USE, INTRINSIC :: MODULENAME`) are ignored ' + 'regardless of whether they are mentioned on the ' + 'INTRINSIC_MODS_LIST. Fortran modules that are mentioned on the ' + 'INTRINSIC_MODS_LIST are ignored only when their nature is not ' + 'specified in the source file at all (i.e. `USE :: MODULENAME`). ' + 'Fortran modules that need to be ignored unconditionally must ' + 'be put on the EXTERNAL_MODS_LIST (see `--fc-external-mods`). ' + 'Default: `{0}`.'.format(fc_intrisic_mods_default)) + fc_arg_group.add_argument( + '--fc-external-mods', metavar='EXTERNAL_MODS_LIST', + type=comma_splitter, + action='append', + help='comma-separated list of external (to the project) Fortran ' + 'modules that need to be unconditionally ignored when generating ' + 'dependency rules (see also `--fc-intrinsic-mods`)') + fc_arg_group.add_argument( + '--fc-mod-dir-flag', metavar='FC_MOD_DIR_FLAG', default='-J', + help='Fortran compiler flag used to specify the directory where ' + 'module files are saved; only flags that start with a single ' + 'dash (-) and have no more than one trailing whitespace are ' + 'supported (default: `%(default)s`)') + fc_arg_group.add_argument( + '--fc-inc-flag', metavar='FC_INC_FLAG', default='-I', + help='preprocessor flag used for setting search paths for the ' + 'Fortran `INCLUDE` statement; only flags that start with a ' + 'single dash (-) and have no more than one trailing whitespace ' + 'are supported (default: `%(default)s`)') + + unknown = [] + try: + sep_idx = sys.argv.index('--') + args = parser.parse_args(sys.argv[1:sep_idx]) + unknown = sys.argv[sep_idx + 1:] + except ValueError: + args = parser.parse_args() + + if not args.input: + args.input = [None] + + if not args.src_name: + args.src_name = args.input + elif len(args.src_name) != len(args.input): + parser.error('number of SRC_NAME values is not equal to the number of ' + 'INPUT values') + + if not args.obj_name: + args.obj_name = map23(default_obj_name, args.src_name) + elif len(args.obj_name) != len(args.input): + parser.error('number of OBJ_NAME values is not equal to the number of ' + 'INPUT values') + + if not args.output: + args.output = [None] * len(args.input) + elif len(args.output) != len(args.input): + parser.error('number of OUTPUT values is not equal to the number of ' + 'INPUT values') + + if not args.dep_name: + args.dep_name = args.output + elif len(args.dep_name) != len(args.input): + parser.error('number of DEP_NAME values is not equal to the number of ' + 'INPUT values') + + compiler_arg_dests = dict() + + if args.pp_enable: + compiler_arg_dests.update(pp_inc_dirs=args.pp_inc_flag, + pp_macros=args.pp_macro_flag) + + if args.fc_enable: + compiler_arg_dests.update(fc_inc_dirs=args.fc_inc_flag, + fc_mod_dir=args.fc_mod_dir_flag) + + if compiler_arg_dests: + compiler_args = dict() + for dest, flag in compiler_arg_dests.items(): + if not flag.startswith('-') or flag.endswith(' '): + parser.error('unsupported compiler/preprocessor flag ' + flag) + # Several dests might share the same flag and we want them to share + # the same list of values in this the case: + val_list = compiler_args.get(flag, None) + if val_list is None: + val_list = [] + compiler_args[flag] = val_list + setattr(args, dest, val_list) + + appended_val_lists = [] + for arg in unknown: + if arg.startswith('-'): + appended_val_lists *= 0 + arg_ws = arg + ' ' + for flag, val_list in compiler_args.items(): + if flag == arg or flag == arg_ws: + # If the current argument equals to a flag, which might + # have a significant trailing whitespace, the next + # argument on the command line is the flag's value: + appended_val_lists.append(val_list) + elif arg.startswith(flag): + # If the current argument starts with a flag that does + # not have a trailing whitespace, the suffix of the + # argument is the flag's value: + val_list.append(arg[len(flag):]) + elif appended_val_lists: + for val_list in appended_val_lists: + val_list.append(arg) + appended_val_lists *= 0 + + if args.pp_enable and args.pp_macros: + import re + predefined_macros = dict() + for m in args.pp_macros: + match = re.match(r'^=*([a-zA-Z_]\w*)(\(.*\))?(?:=(.+))?$', m) + if match: + name = match.group(1) + if name != 'defined': + body = match.group(3) if match.group(3) else '1' + predefined_macros[name] = (match.group(2), body) + args.pp_macros = predefined_macros + + if args.fc_enable: + args.fc_mod_upper = (args.fc_mod_upper == 'yes') + args.fc_mod_dir = args.fc_mod_dir[-1] if args.fc_mod_dir else None + + if args.fc_intrinsic_mods: + args.fc_intrinsic_mods = [m for sublist in args.fc_intrinsic_mods + for m in sublist] + else: + args.fc_intrinsic_mods = comma_splitter(fc_intrisic_mods_default) + + if args.fc_external_mods: + args.fc_external_mods = [m for sublist in args.fc_external_mods + for m in sublist] + + return args + + +def main(): + args = parse_args() + + lc_files = set() + + def lc_callback(filename): + lc_files.add(filename) + + included_files = set() + + def include_callback(filename): + included_files.add(filename) + + provided_modules = set() + + def module_callback(module): + provided_modules.add(module) + + required_modules = set() + + def use_module_callback(module): + required_modules.add(module) + + lc_debug_info = None + pp_debug_info = None + ftn_debug_info = None + + parser = None + if args.fc_enable: + from depgen.fortran_parser import FortranParser + ftn = FortranParser(include_order=args.fc_inc_order, + include_dirs=args.fc_inc_dirs, + include_roots=args.src_roots, + intrinsic_mods=args.fc_intrinsic_mods, + external_mods=args.fc_external_mods) + + ftn.include_callback = include_callback + ftn.module_callback = module_callback + ftn.use_module_callback = use_module_callback + + def debug_callback(line, msg): + ftn_debug_info.append('# `%s`:\t%s\n' % (line[:-1], msg)) + + if args.debug: + ftn_debug_info = ['#\n# Fortran parser:\n'] + ftn.debug_callback = debug_callback + + parser = ftn + + elif args.pp_enable or args.lc_enable: + parser = DummyParser() + + for inp, out, src_name, obj_name, dep_name in zip(args.input, + args.output, + args.src_name, + args.obj_name, + args.dep_name): + in_stream = StdStreamWrapper(sys.stdin, '') \ + if inp is None else open23(inp) + + if args.lc_enable: + from depgen.line_control import LCProcessor + lc = LCProcessor(in_stream, + include_roots=args.src_roots) + lc.lc_callback = lc_callback + + def debug_callback(line, msg): + lc_debug_info.append('# `%s`:\t%s\n' % (line[:-1], msg)) + + if args.debug: + lc_debug_info = ['#\n# Line control processor:\n'] + lc.debug_callback = debug_callback + + in_stream = lc + + if args.pp_enable: + from depgen.preprocessor import Preprocessor + pp = Preprocessor(in_stream, + include_order=args.pp_inc_order, + include_sys_order=args.pp_inc_sys_order, + include_dirs=args.pp_inc_dirs, + include_roots=args.src_roots, + try_eval_expr=args.pp_eval_expr, + inc_sys=args.pp_inc_sys, + predefined_macros=args.pp_macros) + + pp.include_callback = include_callback + + def debug_callback(line, msg): + pp_debug_info.append('# `%s`:\t%s\n' % (line[:-1], msg)) + + if args.debug: + pp_debug_info = ['#\n# Preprocessor:\n'] + pp.debug_callback = debug_callback + + in_stream = pp + + if parser: + parser.parse(in_stream) + in_stream.close() + + out_lines = gen_lc_deps(src_name, lc_files) + lc_files.clear() + + out_lines.extend(gen_include_deps(src_name, obj_name, dep_name, + included_files)) + included_files.clear() + + if provided_modules or required_modules: + out_lines.extend(gen_module_deps(obj_name, provided_modules, + required_modules, + args.fc_mod_dir, + args.fc_mod_upper, + args.fc_mod_ext)) + provided_modules.clear() + required_modules.clear() + + if args.debug: + out_lines.extend([ + '\n# Python version: ', sys.version.replace('\n', ' '), + '\n#\n', + '# Command:\n', + '# ', ' '.join(sys.argv), '\n#\n', + '# Parsed arguments:\n# ', + '\n# '.join( + [k + '=' + str(v) for k, v in vars(args).items()]), '\n']) + if lc_debug_info is not None: + out_lines.extend(lc_debug_info) + if pp_debug_info is not None: + out_lines.extend(pp_debug_info) + if ftn_debug_info is not None: + out_lines.extend(ftn_debug_info) + out_lines.append('\n') + + out_stream = StdStreamWrapper(sys.stdout) \ + if out is None else open23(out, 'w') + out_stream.writelines(out_lines) + out_stream.close() + + +def gen_lc_deps(src_name, lc_files): + result = [] + if src_name and lc_files: + result.append('%s: %s\n' % (src_name, ' '.join(lc_files))) + return result + + +def gen_include_deps(src_name, obj_name, dep_name, + included_files): + result = [] + targets = ' '.join(filter(None, (obj_name, dep_name))) + if targets: + prereqs = ' '.join(filter(None, [src_name] + list(included_files))) + if prereqs: + result.append('%s: %s\n' % (targets, prereqs)) + return result + + +def gen_module_deps(obj_name, + provided_modules, required_modules, + mod_dir, mod_upper, mod_ext): + result = [] + if obj_name: + if provided_modules: + targets = ' '.join(modulenames_to_filenames( + provided_modules, mod_dir, mod_upper, mod_ext)) + result.append('%s: %s\n' % (targets, obj_name)) + + # Do not depend on the modules that are provided in the same file: + required_modules -= provided_modules + if required_modules: + prereqs = ' '.join(modulenames_to_filenames( + required_modules, mod_dir, mod_upper, mod_ext)) + result.append('%s: %s\n' % (obj_name, prereqs)) + return result + + +def modulenames_to_filenames(modules, directory, upprecase, extension): + result = modules + if upprecase: + result = map(lambda s: s.upper(), result) + if directory: + result = map(lambda s: os.path.join(directory, s), result) + if extension: + result = map(lambda s: '%s.%s' % (s, extension), result) + return result + + +if __name__ == "__main__": + main() Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/__init__.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/__init__.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/__init__.py (revision 6016) @@ -0,0 +1,150 @@ +import os +import sys + + +def open23(name, mode='r'): + if sys.version_info < (3, 0, 0): + return open(name, mode) + else: + return open(name, mode, encoding='latin-1') + + +def map23(foo, iterable): + if sys.version_info < (3, 0, 0): + return map(foo, iterable) + else: + return list(map(foo, iterable)) + + +def file_in_dir(f, d): + if d: + return os.path.abspath(f).startswith(os.path.abspath(d) + os.path.sep) + else: + return True + + +def find_unquoted_string(string, line, quotes='\'"'): + skip = 0 + quote = None + while 1: + idx = line.find(string, skip) + if idx < 0: + return idx + + escaped = False + for c in line[skip:idx]: + if escaped: + escaped = False + elif c in quotes: + if quote is None: + quote = c + elif quote == c: + quote = None + elif c == '\\' and quote: + escaped = True + + if quote: + skip = idx + len(string) + else: + return idx + + +class IncludeFinder: + def __init__(self, include_order=None, include_dirs=None): + self.include_order = include_order + self.include_dirs = include_dirs + + def find(self, filename, root_includer=None, current_includer=None): + if os.path.isabs(filename) and os.path.isfile(filename): + return filename + elif self.include_order: + for inc_type in self.include_order: + if inc_type == 'cwd' and os.path.isfile(filename): + return filename + elif inc_type == 'src' and root_includer: + candidate = os.path.join(os.path.dirname(root_includer), + filename) + if os.path.isfile(candidate): + return candidate + elif inc_type == 'inc' and current_includer: + candidate = os.path.join(os.path.dirname(current_includer), + filename) + if os.path.isfile(candidate): + return candidate + elif inc_type == 'flg' and self.include_dirs: + for d in self.include_dirs: + candidate = os.path.join(d, filename) + if os.path.isfile(candidate): + return candidate + return None + + +class StreamStack: + def __init__(self): + # Stack of file-like objects (i.e. objects implementing methods + # readline, close, and a property name: + self._stream_stack = [] + self._close_stack = [] + + def __enter__(self): + return self + + def __exit__(self, exc_type, exc_value, exc_traceback): + self.clear() + + @property + def root_name(self): + return self._stream_stack[0].name if self._stream_stack else None + + @property + def current_name(self): + return self._stream_stack[-1].name if self._stream_stack else None + + def add(self, stream, close=True): + self._stream_stack.append(stream) + self._close_stack.append(close) + + def clear(self): + for stream, close in zip(self._stream_stack, self._close_stack): + if close: + stream.close() + self._stream_stack *= 0 + self._close_stack *= 0 + + def readline(self): + while self._stream_stack: + line = self._stream_stack[-1].readline() + if line: + return line + else: + stream = self._stream_stack.pop() + if self._close_stack.pop(): + stream.close() + return '' + + +class StdStreamWrapper: + def __init__(self, stream, name=None): + self._stream = stream + self.name = stream.name if name is None else name + + def readline(self): + return self._stream.readline() + + def writelines(self, lines): + return self._stream.writelines(lines) + + def close(self): + pass + + +class DummyParser: + def __init__(self): + pass + + @staticmethod + def parse(stream): + while 1: + line = stream.readline() + if not line: + break Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/fortran_parser.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/fortran_parser.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/fortran_parser.py (revision 6016) @@ -0,0 +1,166 @@ +import re + +from depgen import IncludeFinder, StreamStack, file_in_dir, open23, \ + find_unquoted_string + + +class FortranParser: + _re_include = re.compile(r'^\s*include\s+(\'|")(.*?)\1', re.I) + _re_line_continue_start = re.compile(r'^(.*)&\s*$') + _re_line_continue_end = re.compile(r'^\s*&') + _re_module_provide = re.compile(r'^\s*module\s+(?!procedure\s)(\w+)', re.I) + _re_module_require = re.compile( + r'^\s*use(?:\s+|(?:\s*,\s*((?:non_)?intrinsic))?\s*::\s*)(\w+)', re.I) + + def __init__(self, + include_order=None, + include_dirs=None, + include_roots=None, + intrinsic_mods=None, + external_mods=None): + self.include_roots = include_roots + + if intrinsic_mods: + self.intrinsic_mods = set(intrinsic_mods) + else: + self.intrinsic_mods = set() + + if external_mods: + self.external_mods = set(external_mods) + else: + self.external_mods = set() + + # Callbacks: + self.include_callback = None + self.module_callback = None + self.use_module_callback = None + self.debug_callback = None + + self._include_finder = IncludeFinder(include_order, include_dirs) + + def parse(self, stream): + with StreamStack() as s: + s.add(stream) + while 1: + line = s.readline() + if not line: + break + + # delete comments + line = FortranParser._delete_comments(line) + if line.isspace(): + continue + + # line continuation + match = FortranParser._re_line_continue_start.match(line) + while match: + next_line = s.readline() + if not next_line: + break + + next_line = FortranParser._delete_comments(next_line) + + # If the line contains only comments, we need the next one + # TODO: implement a separate class FortranPrepcocessor + if next_line.isspace(): + continue + + line = match.group(1) + re.sub( + FortranParser._re_line_continue_end, '', next_line) + + match = FortranParser._re_line_continue_start.match(line) + + for line in FortranParser._split_semicolons(line): + # module provided + match = FortranParser._re_module_provide.match(line) + if match: + module_name = match.group(1).lower() + if self.module_callback: + self.module_callback(module_name) + if self.debug_callback: + self.debug_callback( + line, 'declared module \'%s\'' % module_name) + continue + + # module required + match = FortranParser._re_module_require.match(line) + if match: + module_nature = match.group(1).lower() \ + if match.group(1) is not None else '' + module_name = match.group(2).lower() + if module_nature == 'intrinsic': + if self.debug_callback: + self.debug_callback( + line, 'ignored module usage (\'%s\' ' + 'is explicitly intrinsic)' + % module_name) + elif (module_name in self.intrinsic_mods and + module_nature != 'non_intrinsic'): + if self.debug_callback: + self.debug_callback( + line, 'ignored module usage (\'%s\' ' + 'is implicitly intrinsic)' + % module_name) + elif module_name in self.external_mods: + if self.debug_callback: + self.debug_callback( + line, 'ignored module usage (\'%s\' ' + 'is external)' % module_name) + else: + if self.use_module_callback: + self.use_module_callback(module_name) + if self.debug_callback: + self.debug_callback( + line, 'used module \'%s\'' % module_name) + continue + + # include statement + match = FortranParser._re_include.match(line) + if match: + filename = match.group(2) + filepath = self._include_finder.find( + filename, + s.root_name, + s.current_name) + if filepath: + if not self.include_roots or any( + [file_in_dir(filepath, d) + for d in self.include_roots]): + s.add(open23(filepath, 'r')) + if self.include_callback: + self.include_callback(filepath) + if self.debug_callback: + self.debug_callback( + line, 'included file \'%s\'' + % filepath) + elif self.debug_callback: + self.debug_callback( + line, + 'ignored (file \'%s\' ' + 'is not in the source roots)' % filepath) + elif self.debug_callback: + self.debug_callback(line, + 'ignored (file not found)') + continue + + @staticmethod + def _split_semicolons(line): + while 1: + idx = find_unquoted_string(';', line) + if idx < 0: + if line and not line.isspace(): + yield line + break + else: + prefix = line[:idx] + if prefix and not prefix.isspace(): + yield prefix + '\n' + line = line[idx + 1:] + + @staticmethod + def _delete_comments(line): + comment_idx = find_unquoted_string('!', line) + if comment_idx >= 0: + line = line[:comment_idx] + return line + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/line_control.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/line_control.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/line_control.py (revision 6016) @@ -0,0 +1,53 @@ +import os +import re + +from depgen import file_in_dir + + +class LCProcessor: + _re_lc = re.compile(r'^#\s*[1-9]\d*\s*"(.*?)"\s*(?:[1-9]\d*)?') + + def __init__(self, stream, + include_roots=None): + self.include_roots = include_roots + + # Callbacks: + self.lc_callback = None + self.debug_callback = None + + self._stream = stream + + def readline(self): + while 1: + line = self._stream.readline() + if not line: + return line + + match = LCProcessor._re_lc.match(line) + if match: + filepath = match.group(1) + if os.path.isfile(filepath): + if not self.include_roots or any( + [file_in_dir(filepath, d) + for d in self.include_roots]): + if self.lc_callback: + self.lc_callback(filepath) + if self.debug_callback: + self.debug_callback( + line, 'accepted file \'%s\'' % filepath) + elif self.debug_callback: + self.debug_callback( + line, 'ignored (file \'%s\' ' + 'is not in the source roots)' % filepath) + elif self.debug_callback: + self.debug_callback(line, 'ignored (file not found)') + continue + + return line + + @property + def name(self): + return self._stream.name + + def close(self): + self._stream.close() Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/preprocessor.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/preprocessor.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/depgen/preprocessor.py (revision 6016) @@ -0,0 +1,342 @@ +import re + +from depgen import IncludeFinder, StreamStack, file_in_dir, open23, \ + find_unquoted_string + + +class Preprocessor: + _re_ifdef = re.compile(r'^\s*#\s*if(n)?def\s+([a-zA-Z_]\w*)') + _re_if_expr = re.compile(r'^\s*#\s*if((?:\s|\().*)') + + _re_elif = re.compile(r'^\s*#\s*elif((?:\s|\().*)') + _re_else = re.compile(r'^\s*#\s*else(?:\s.*)') + _re_endif = re.compile(r'^\s*#\s*endif(?:\s.*)') + + _re_include = re.compile(r'^\s*#\s*include\s+(?:"(.*?)"|<(.*?)>)') + _re_define = re.compile(r'^\s*#\s*define\s+([a-zA-Z_]\w*)(\(.*\))?\s+(.*)$') + _re_undef = re.compile(r'^\s*#\s*undef\s+([a-zA-Z_]\w*)') + + # matches "defined MACRO_NAME" and "defined (MACRO_NAME)" + _re_defined_call = re.compile( + r'(defined\s*(\(\s*)?([a-zA-Z_]\w*)(?(2)\s*\)))') + + _re_identifier = re.compile( + r'(([a-zA-Z_]\w*)(\s*\(\s*(\w+(?:\s*,\s*\w+)*)?\s*\))?)') + + def __init__(self, + stream, + include_order=None, + include_sys_order=None, + include_dirs=None, + include_roots=None, + try_eval_expr=False, + inc_sys=False, + predefined_macros=None): + self.include_roots = include_roots + self.try_eval_expr = try_eval_expr + self.inc_sys = inc_sys + + # Callbacks: + self.include_callback = None + self.debug_callback = None + + self._include_finder = IncludeFinder(include_order, include_dirs) + self._include_sys_finder = IncludeFinder(include_sys_order, + include_dirs) + self._include_stack = StreamStack() + self._include_stack.add(stream) + + if predefined_macros: + self._macros = dict(predefined_macros) + else: + self._macros = dict() + + # Stack of #if-#else blocks holds one of the following: + # 1 - keep current branch and ignore another + # -1 - ignore current branch and keep another + # 0 - keep both branches (if failed to evaluate expression) + self._if_state_stack = [] + + # Each #elif is interpreted as a combination of #else and #if. + # Thus, each #elif increments the number of #if blocks that are + # closed with #endif statement. This numbers are stored in a separate + # stack: + self._states_per_endif_stack = [] + + def readline(self): + while 1: + line = self._include_stack.readline() + + if not line: + return line + + line = self._replace_continuation(line) + line = self._remove_block_comments(line) + + if line.isspace(): + continue + + # if(n)def directive + match = Preprocessor._re_ifdef.match(line) + if match: + macro, negate, state = match.group(2), bool(match.group(1)), 0 + if not self._branch_is_dead(): + state = 1 if bool(macro in self._macros) ^ negate else -1 + if self.debug_callback: + self.debug_callback( + line, 'evaluated to {0}'.format(state > 0)) + elif self.debug_callback: + self.debug_callback( + line, 'was not evaluated (dead branch)') + self._if(state) + continue + + # if directive + match = Preprocessor._re_if_expr.match(line) + if match: + expr, state = match.group(1), 0 + if not self._branch_is_dead(): + if self.try_eval_expr: + state = self._evaluate_expr_to_state(expr) + if self.debug_callback: + self.debug_callback( + line, 'evaluated to {0}'.format( + 'Unknown (evaluation failed)' + if state == 0 else state > 0)) + elif self.debug_callback: + self.debug_callback( + line, 'was not evaluated (evaluation disabled)') + elif self.debug_callback: + self.debug_callback( + line, 'was not evaluated (dead branch)') + self._if(state) + continue + + # elif directive + match = Preprocessor._re_elif.match(line) + if match: + self._else() + expr, state = match.group(1), 0 + if not self._branch_is_dead(): + if self.try_eval_expr: + state = self._evaluate_expr_to_state(expr) + if self.debug_callback: + self.debug_callback( + line, 'evaluated to {0}'.format( + 'Unknown (evaluation failed)' + if state == 0 else state > 0)) + elif self.debug_callback: + self.debug_callback( + line, 'was not evaluated (evaluation disabled)') + elif self.debug_callback: + self.debug_callback( + line, 'was not evaluated (dead branch)') + self._elif(state) + continue + + # else directive + match = Preprocessor._re_else.match(line) + if match: + self._else() + continue + + # endif directive + match = Preprocessor._re_endif.match(line) + if match: + self._endif() + continue + + if self._branch_is_dead() and self.debug_callback is None: + continue + + # define directive + match = Preprocessor._re_define.match(line) + if match: + if not self._branch_is_dead(): + self._define(*match.group(1, 2, 3)) + if self.debug_callback: + self.debug_callback(line, 'accepted') + elif self.debug_callback: + self.debug_callback(line, 'ignored (dead branch)') + continue + + # undef directive + match = Preprocessor._re_undef.match(line) + if match: + if not self._branch_is_dead(): + self._macros.pop(match.group(1), None) + if self.debug_callback: + self.debug_callback(line, 'accepted') + elif self.debug_callback: + self.debug_callback(line, 'ignored (dead branch)') + continue + + # include directive + match = Preprocessor._re_include.match(line) + if match: + if not self._branch_is_dead(): + + if match.lastindex == 1: # quoted form + filepath = self._include_finder.find( + match.group(1), + self._include_stack.root_name, + self._include_stack.current_name) + elif match.lastindex == 2: # angle-bracket form + if self.inc_sys: + filepath = self._include_sys_finder.find( + match.group(2), + self._include_stack.root_name, + self._include_stack.current_name) + else: + if self.debug_callback: + self.debug_callback(line, + 'ignored (system header)') + continue + else: + if self.debug_callback: + self.debug_callback(line, + 'ignored (internal error)') + continue + + if filepath: + if not self.include_roots or any( + [file_in_dir(filepath, d) + for d in self.include_roots]): + self._include_stack.add(open23(filepath, 'r')) + if self.include_callback: + self.include_callback(filepath) + if self.debug_callback: + self.debug_callback( + line, + "included file '{0}'".format(filepath)) + elif self.debug_callback: + self.debug_callback( + line, + "ignored (file '{0}' " + "is not in the source roots)".format(filepath)) + elif self.debug_callback: + self.debug_callback(line, 'ignored (file not found)') + elif self.debug_callback: + self.debug_callback(line, 'ignored (dead branch)') + continue + + if self._branch_is_dead(): + continue + + return line + + @property + def name(self): + return self._include_stack.root_name + + def close(self): + self._include_stack.clear() + + def _define(self, name, args=None, body=None): + if name != 'defined': + self._macros[name] = (args, '' if body is None else body) + + def _if(self, state): + self._if_state_stack.append(state) + self._states_per_endif_stack.append(1) + + def _else(self): + if self._if_state_stack: + self._if_state_stack[-1] = -self._if_state_stack[-1] + + def _elif(self, state): + self._if_state_stack.append(state) + self._states_per_endif_stack[-1] += 1 + + def _endif(self): + if self._if_state_stack: + pop_count = self._states_per_endif_stack.pop() + for _ in range(pop_count): + self._if_state_stack.pop() + + def _branch_is_dead(self): + return any(state < 0 for state in self._if_state_stack) + + def _replace_continuation(self, line): + while line.endswith('\\\n'): + suffix = self._include_stack.readline() + line = line[:-2] + suffix + return line + + def _remove_block_comments(self, line): + while 1: + # Check whether the line contains an unquoted block comment + # initiator '/*': + start_idx = find_unquoted_string('/*', line) + if start_idx < 0: + return line + # Check whether the line contains a block comment + # terminator '*/' (even if it is quoted): + term_idx = line.find('*/', start_idx + 2) + while term_idx < 0: + # The block is not terminated yet, read the next line: + next_line = self._include_stack.readline() + line_length = len(line) + if next_line: + line += next_line + term_idx = line.find('*/', line_length) + else: + term_idx = line_length + else: + # Replace the block of comments with a single + # space: + line = '%s %s' % (line[:start_idx], line[term_idx + 2:]) + + def _evaluate_expr_to_state(self, expr): + prev_expr = expr + while 1: + # replace calls to function "defined" + defined_calls = re.findall(Preprocessor._re_defined_call, expr) + for call in defined_calls: + expr = expr.replace( + call[0], '1' if call[2] in self._macros else '0') + + identifiers = re.findall(Preprocessor._re_identifier, expr) + + for identifier in identifiers: + if identifier[1] == 'defined': + return 0 + + macro = self._macros.get(identifier[1], None) + if identifier[2]: + # potential call to a function + if macro is None: + # call to undefined function + return 0 + elif macro[0] is not None: + # we can't evaluate function-like macros + return 0 + else: + # identifier is defined as object-like macro + expr = expr.replace(identifier[0], + macro[1] + identifier[2]) + else: + # no function call + if macro is None or macro[0] is not None: + # macro is not defined or + # defined as function-like macro + expr = expr.replace(identifier[0], '0') + else: + # identifier is defined as object-like macro + expr = expr.replace(identifier[0], macro[1]) + + if prev_expr == expr: + break + else: + prev_expr = expr + + expr = expr.replace('||', ' or ') + expr = expr.replace('&&', ' and ') + expr = expr.replace('!', 'not ') + + try: + result = bool(eval(expr, {})) + return 1 if result else -1 + except: + return 0 + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/deplist.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/deplist.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/deplist.py (revision 6016) @@ -0,0 +1,417 @@ +#!/usr/bin/env python +import os +import re +import sys +import fnmatch +import collections + +try: + import argparse +except ImportError: + import _argparse as argparse + +_re_rule = re.compile( + r'^[ ]*([-+\w./]+(?:[ ]+[-+\w./]+)*)[ ]*' # targets + r':(?:[ ]*([-+\w./]+(?:[ ]+[-+\w./]+)*))?[ ]*' # normal prerequisites + r'(?:\|[ ]*([-+\w./]+(?:[ ]+[-+\w./]+)*))?') # order-only prerequisites +_meta_root = 0 +_term_colors = { + 'black': 90, + 'red': 91, + 'green': 92, + 'yellow': 93, + 'blue': 94, + 'magenta': 95, + 'cyan': 96, + 'white': 97 +} + + +def parse_args(): + class ArgumentParser(argparse.ArgumentParser): + def convert_arg_line_to_args(self, arg_line): + try: + # Drop everything after the first occurrence of #: + arg_line = arg_line[:arg_line.index('#')] + except ValueError: + pass + + result = [] + # Do not regard consecutive whitespaces as a single separator: + for arg in arg_line.split(' '): + if arg: + result.append(arg) + elif result: + # The previous argument has a significant space: + result[-1] += ' ' + return result + + parser = ArgumentParser( + fromfile_prefix_chars='@', + description='Reads a set of MAKEFILEs and prints a topologically ' + 'sorted list of TARGETs (PREREQuisites) together with ' + 'their dependencies (dependents).') + + parser.add_argument( + '-d', '--debug-file', + help='dump debug information to DEBUG_FILE') + parser.add_argument( + '-t', '--target', nargs='*', + help='names of the makefile targets to be printed together with their ' + 'dependencies; mutually exclusive with the argument ' + '\'-p/--prereq\'; if neither of the arguments is specified, all ' + 'targets and prerequisites found in the makefiles are sent to the ' + 'output') + parser.add_argument( + '-p', '--prereq', nargs='*', + help='names of the makefile prerequisites to be printed together with ' + 'their dependents; mutually exclusive with the argument ' + '\'-t/--target\'; if neither of the arguments is specified, all ' + 'targets and prerequisites found in the makefiles are sent to the ' + 'output') + parser.add_argument( + '--inc-oo', action='store_true', + help='include order-only prerequisites in the dependency graph') + parser.add_argument( + '-r', '--reverse', action='store_true', + help='print the output list in the reversed order') + parser.add_argument( + '--check-unique-prereq', action='append', nargs=2, metavar='PATTERN', + help='pair of shell-like wildcards; the option enables additional ' + 'consistency checks of the dependency graph: each target that ' + 'matches the first pattern of the pair is checked whether it has ' + 'no more than one prerequisite matching the second pattern; if ' + 'the check fails, a warning message is emitted to the standard ' + 'error stream') + parser.add_argument( + '--check-unique-basename', action='append', nargs='+', + metavar='PATTERN', + help='list of shell-like wildcards; the option enables additional ' + 'consistency checks of the dependency graph; all targets that ' + 'match at least one the patterns are checked whether none of them ' + 'have the same basename; if the check fails, a warning message is ' + 'emitted to the standard error stream') + parser.add_argument( + # Unfortunately, we cannot set nargs to 'two or more', therefore we + # set nargs to 'one or more': + '--check-exists-prereq', action='append', nargs='+', metavar='PATTERN', + help='list of two or more shell-like wildcards; the option enables ' + 'additional consistency checks of the dependency graph: each ' + 'target that matches the first pattern of the list is checked ' + 'whether it has at least one prerequisite matching any of the ' + 'rest of the patterns; if the check fails, a warning message is ' + 'emitted to the standard error stream') + parser.add_argument( + '--check-cycles', action='store_true', + help='check whether the dependency graph is acyclic, e.g. there is no ' + 'circular dependencies; if a cycle is found, a warning message is ' + 'emitted to the standard output') + parser.add_argument( + '--check-colour', choices=_term_colors.keys(), + help='colour the message output of the checks using ANSI escape ' + 'sequences; the argument is ignored if the standard error stream ' + 'is not associated with a terminal device') + parser.add_argument( + '-f', '--makefile', nargs='*', + help='paths to makefiles; a single dash (-) triggers reading from ' + 'the standard input stream') + + args = parser.parse_args() + + if args.target is not None and args.prereq is not None: + parser.error('arguments -t/--target and -p/--prereq are mutually ' + 'exclusive') + + if args.check_exists_prereq: + for pattern_list in args.check_exists_prereq: + if len(pattern_list) < 2: + parser.error('argument --check-exists-prereq: expected 2 or ' + 'more arguments') + + if not sys.stderr.isatty(): + args.check_colour = None + + return args + + +def read_makefile(makefile, inc_order_only): + result = collections.defaultdict(list) + + if makefile == '-': + stream = sys.stdin + elif not os.path.isfile(makefile): + return result + else: + stream = open(makefile, 'r') + + it = iter(stream) + + for line in it: + while line.endswith('\\\n'): + line = line[:-2] + try: + line += next(it) + except StopIteration: + break + + match = _re_rule.match(line) + if match: + targets = set(match.group(1).split()) + prereqs = [] + + if match.group(2): + prereqs.extend(match.group(2).split()) + + if match.group(3) and inc_order_only: + prereqs.extend(match.group(3).split()) + + for target in targets: + result[target].extend(prereqs) + + stream.close() + return result + + +def visit_dfs(dep_graph, vertex, + visited=None, + start_visit_cb_list=None, + finish_visit_cb_list=None, + skip_visit_cb_list=None): + if visited is None: + visited = set() + + if vertex in visited: + if skip_visit_cb_list: + for skip_visit_cb in skip_visit_cb_list: + skip_visit_cb(vertex) + return + + if start_visit_cb_list: + for start_visit_cb in start_visit_cb_list: + start_visit_cb(vertex) + + visited.add(vertex) + + if vertex in dep_graph: + for child in dep_graph[vertex]: + visit_dfs(dep_graph, child, visited, + start_visit_cb_list, + finish_visit_cb_list, + skip_visit_cb_list) + + if finish_visit_cb_list: + for finish_visit_cb in finish_visit_cb_list: + finish_visit_cb(vertex) + + +def build_graph(makefiles, inc_oo): + # Read makefiles: + result = collections.defaultdict(list) + for mkf in makefiles: + mkf_dict = read_makefile(mkf, inc_oo) + + for target, prereqs in mkf_dict.items(): + result[target].extend(prereqs) + + # Remove duplicates (we do not use sets as values of the dictionary to keep + # the order of prerequisites): + for target in result.keys(): + seen = set() + result[target] = [prereq for prereq in result[target] + if not (prereq in seen or seen.add(prereq))] + + # Make leaves (i.e. prerequisites without any prerequisites) explicit nodes + # of the graph: + leaves = set(prereq for prereqs in result.values() + for prereq in prereqs if prereq not in result) + result.update((prereq, result.default_factory()) for prereq in leaves) + + return result + + +def flip_edges(graph): + result = collections.defaultdict(list) + for parent, children in graph.items(): + for child in children: + result[child].append(parent) + else: + _ = result[parent] + return result + + +def warn(msg, colour=None): + sys.stderr.write("%s%s: WARNING: %s%s\n" + % (('\033[%dm' % _term_colors[colour]) if colour else '', + os.path.basename(__file__), + msg, + '\033[0m' if colour else '')) + + +def main(): + args = parse_args() + + if args.debug_file: + with open(args.debug_file, 'w') as debug_file: + debug_file.writelines([ + '# Python version: ', sys.version.replace('\n', ' '), '\n', + '#\n', + '# Command:\n', + '# ', ' '.join(sys.argv), '\n', + '#\n', + '# Parsed arguments:\n', + '# ', '\n# '.join( + [k + '=' + str(v) for k, v in vars(args).items()]), '\n']) + + if args.makefile is None: + return + + dep_graph = build_graph(args.makefile, args.inc_oo) + + if not dep_graph: + return + + if args.prereq is None: + traversed_graph = dep_graph + start_nodes = args.target + else: + traversed_graph = flip_edges(dep_graph) + start_nodes = args.prereq + + # Insert _meta_root, which will be the starting-point for the dependency + # graph traverse: + if start_nodes is None: + traversed_graph[_meta_root] = sorted(traversed_graph.keys()) + else: + traversed_graph[_meta_root] = [t for t in start_nodes + if t in traversed_graph] + + # Visitor callbacks: + start_visit_cb_list = [] + finish_visit_cb_list = [] + skip_visit_cb_list = [] + + # Callbacks that are called once the graph is traversed: + postprocess_cb_list = [] + + if args.check_unique_prereq: + def check_unique_prereq_start_visit_cb(vertex): + # Skip if the vertex is _meta_root or does not have descendants: + if vertex == _meta_root or vertex not in dep_graph: + return + for pattern_list in args.check_unique_prereq: + if fnmatch.fnmatch(vertex, pattern_list[0]): + vertex_prereqs = dep_graph[vertex] + for prereq_pattern in pattern_list[1:]: + matching_prereqs = fnmatch.filter(vertex_prereqs, + prereq_pattern) + if len(matching_prereqs) > 1: + warn("target '%s' has more than one immediate " + "prerequisite matching pattern '%s':\n\t%s" + % (vertex, + prereq_pattern, + "\n\t".join(matching_prereqs)), + args.check_colour) + + start_visit_cb_list.append(check_unique_prereq_start_visit_cb) + + if args.check_unique_basename: + basenames = [collections.defaultdict(set) for _ in + range(len(args.check_unique_basename))] + + def check_unique_basename_start_visit_cb(vertex): + # Skip if the vertex is _meta_root: + if vertex == _meta_root: + return + for i, pattern_list in enumerate(args.check_unique_basename): + for pattern in pattern_list: + if fnmatch.fnmatch(vertex, pattern): + basenames[i][os.path.basename(vertex)].add(vertex) + + start_visit_cb_list.append(check_unique_basename_start_visit_cb) + + def check_unique_basename_postprocess_cb(): + for basename_group in basenames: + for basename, paths in basename_group.items(): + if len(paths) > 1 and basename: + warn("the dependency graph contains more than one " + "target with basename '%s':\n\t%s" + % (basename, '\n\t'.join(paths)), + args.check_colour) + + postprocess_cb_list.append(check_unique_basename_postprocess_cb) + + if args.check_exists_prereq: + def check_exists_prereq_start_visit_cb(vertex): + # Skip if the vertex is _meta_root: + if vertex == _meta_root: + return + for pattern_list in args.check_exists_prereq: + if fnmatch.fnmatch(vertex, pattern_list[0]): + vertex_prereqs = dep_graph.get(vertex, set()) + prereq_patterns = pattern_list[1:] + if not any([fnmatch.filter(vertex_prereqs, prereq_pattern) + for prereq_pattern in prereq_patterns]): + warn("target '%s' does not have an immediate " + "prerequisite matching any of the patterns: '%s'" + % (vertex, + "', '".join(prereq_patterns)), + args.check_colour) + + start_visit_cb_list.append(check_exists_prereq_start_visit_cb) + + if args.check_cycles: + path = [] + + def check_cycles_start_visit_cb(vertex): + path.append(vertex) + + def check_cycles_skip_visit_cb(vertex): + if vertex in path: + start_cycle_idx = path.index(vertex) + + if args.prereq is None: + msg_lines = ( + path[1:start_cycle_idx] + + [path[start_cycle_idx] + ' <- start of cycle'] + + path[start_cycle_idx + 1:] + + [vertex + ' <- end of cycle']) + else: + msg_lines = ([vertex + ' <- start of cycle'] + + path[-1:start_cycle_idx:-1] + + [path[start_cycle_idx] + ' <- end of cycle'] + + path[start_cycle_idx - 1:0:-1]) + + warn('the dependency graph has a cycle:\n\t%s' + % '\n\t'.join(msg_lines), args.check_colour) + + def check_cycles_finish_visit_cb(vertex): + path.pop() + + start_visit_cb_list.append(check_cycles_start_visit_cb) + skip_visit_cb_list.append(check_cycles_skip_visit_cb) + finish_visit_cb_list.append(check_cycles_finish_visit_cb) + + toposort = [] + + def toposort_finish_visit_cb(vertex): + toposort.append(vertex) + finish_visit_cb_list.append(toposort_finish_visit_cb) + + visit_dfs(traversed_graph, _meta_root, + start_visit_cb_list=start_visit_cb_list, + finish_visit_cb_list=finish_visit_cb_list, + skip_visit_cb_list=skip_visit_cb_list) + + for postprocess_cb in postprocess_cb_list: + postprocess_cb() + + # The last element of toposort is _meta_root: + output = '\n'.join(toposort[-2::-1] + if (args.reverse ^ (args.prereq is not None)) + else toposort[:-1]) + if output: + print(output) + + +if __name__ == "__main__": + main() Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/fortmodcmp.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/fortmodcmp.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/mkhelper/fortmodcmp.py (revision 6016) @@ -0,0 +1,205 @@ +#!/usr/bin/env python +import sys + +BUF_MAX_SIZE = 512 + + +def _skip_sequence(stream, sequence): + """ + Finds the first occurrence of a sequence of bytes in a binary stream and + sets the streams's current position right after it. Returns True if the + sequence is found and False otherwise, The length of the sequence must not + exceed BUF_MAX_SIZE. + """ + sequence_size = len(sequence) + while 1: + buf = stream.read(BUF_MAX_SIZE) + idx = buf.find(sequence) + if idx < 0: + if len(buf) < BUF_MAX_SIZE: + return False + else: + stream.seek(1 - sequence_size, 1) + else: + stream.seek(idx + sequence_size - len(buf), 1) + return True + + +def _mods_differ_default(stream1, stream2): + # Simple byte comparison: + while 1: + buf1 = stream1.read(BUF_MAX_SIZE) + buf2 = stream2.read(BUF_MAX_SIZE) + if buf1 != buf2: + return True + if not buf1: + return False + + +def _mods_differ_intel(stream1, stream2): + # The first byte encodes the version of the module file format: + if stream1.read(1) != stream2.read(1): + return True + # The block before the following magic sequence might change from + # compilation to compilation, probably due to a second resolution timestamp + # in it: + magic_sequence = b'\x0A\x00' # the same as \n\0 + if not (_skip_sequence(stream1, magic_sequence) and + _skip_sequence(stream2, magic_sequence)): + return True + return _mods_differ_default(stream1, stream2) + + +def _mods_differ_gnu(stream1, stream2): + # The magic number of gzip to be found in the module files generated by + # GFortran 4.9 or later: + magic_sequence = b'\x1F\x8B' + stream1_sequence = stream1.read(len(magic_sequence)) + stream1.seek(0) + if stream1_sequence != magic_sequence: + # Older versions of GFortran generate module files in plain ASCII. Also, + # up to version 4.6.4, the first line of a module file contains a + # timestamp, therefore we ignore it. + stream1.readline() + stream2.readline() + return _mods_differ_default(stream1, stream2) + + +def _mods_differ_portland(stream1, stream2): + for _ in range(2): # the first two lines must be identical + if stream1.readline() != stream2.readline(): + return True + # The next line is a timestamp followed by the sequence '\nenduse\n': + magic_sequence = b'\x0A\x65\x6E\x64\x75\x73\x65\x0A' + if not (_skip_sequence(stream1, magic_sequence) and + _skip_sequence(stream2, magic_sequence)): + return True + return _mods_differ_default(stream1, stream2) + + +def _mods_differ_amd(stream1, stream2): + # AOCC is based on the Classic Flang, which has the same format as the PGI + # compiler + return _mods_differ_portland(stream1, stream2) + + +def _mods_differ_flang(stream1, stream2): + # The header of the module files generated by the new Flang compiler, + # formerly known as F18: + magic_sequence = (b'\xEF\xBB\xBF\x21' # UTF-8 BOM + b'\x6D\x6F\x64\x24') # the same as !mod$ + stream1_sequence = stream1.read(len(magic_sequence)) + stream1.seek(0) + if stream1_sequence != magic_sequence: + # The Classic Flang has the same format as the PGI compiler + return _mods_differ_portland(stream1, stream2) + return _mods_differ_default(stream1, stream2) + + +def _mods_differ_omni(stream1, stream2): + import xml.etree.ElementTree as eT + # Attributes that either declare or reference the type hashes. Each list + # contains a group of tags that reference "same things". + hash_attrs = [["imported_id"], + ["type", "ref", "return_type", "extends"]] + + tree1 = eT.parse(stream1) + tree2 = eT.parse(stream2) + + try: + it1 = tree1.iter() + it2 = tree2.iter() + except AttributeError: + it1 = iter(tree1.getiterator()) + it2 = iter(tree2.getiterator()) + + type_maps1 = [dict() for _ in hash_attrs] + type_maps2 = [dict() for _ in hash_attrs] + + for node1 in it1: + try: + node2 = next(it2) + except StopIteration: + # The second file is shorter: + return True + + if node1.tag != node2.tag: + # The nodes have different tags: + return True + + if node1.text != node2.text: + # The nodes have different texts: + return True + + for ii, attr_group in enumerate(hash_attrs): + type_map1 = type_maps1[ii] + type_map2 = type_maps2[ii] + + for attr in attr_group: + if (attr in node1.attrib) != (attr in node2.attrib): + # One of the files has the attribute and the second one + # does not: + return True + + hash1 = node1.attrib.pop(attr, None) + hash2 = node2.attrib.pop(attr, None) + + if hash1 == hash2: + # Either the attribute is missing in both nodes or they have + # the same value: + continue + elif (hash1 in type_map1) != (hash2 in type_map2): + # One of the files has already declared the respective hash + # and the second one has not: + return True + elif hash1 in type_map1 and \ + type_map1[hash1] != type_map2[hash2]: + # Both files have declared the respective hashes but they + # refer to different types: + return True + else: + # Declare the respective hashes for both files: + type_value = len(type_map1) + type_map1[hash1] = type_value + type_map2[hash2] = type_value + + if node1.attrib != node2.attrib: + # The rest of the attributes have different values: + return True + try: + next(it2) + # The first file is shorter: + return True + except StopIteration: + return False + + +def mods_differ(filename1, filename2, compiler_name=None): + """ + Checks whether two Fortran module files are essentially different. Some + compiler-specific logic is required for compilers that generate different + module files for the same source file (e.g. the module files might contain + timestamps). This implementation is inspired by CMake. + """ + with open(filename1, 'rb') as stream1: + with open(filename2, 'rb') as stream2: + if compiler_name == "intel": + return _mods_differ_intel(stream1, stream2) + elif compiler_name == "gnu": + return _mods_differ_gnu(stream1, stream2) + elif compiler_name == "portland": + return _mods_differ_portland(stream1, stream2) + elif compiler_name == "amd": + return _mods_differ_amd(stream1, stream2) + elif compiler_name == "flang": + return _mods_differ_flang(stream1, stream2) + elif compiler_name == "omni": + return _mods_differ_omni(stream1, stream2) + else: + return _mods_differ_default(stream1, stream2) + + +# We try to make this as fast as possible, therefore we do not parse arguments +# properly: +exit(mods_differ(sys.argv[1], sys.argv[2], + sys.argv[3].lower() if len(sys.argv) > 3 else None)) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/README =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/README (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/README (revision 6016) @@ -0,0 +1,4 @@ +This directory contains what you need to run the ecRad practical. Have +a look at ecrad_practical.pdf to see how to get started. The symbolic +links to the ecrad executable and data directory are only created when +you type "make" in the top-level directory. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/clean.sh =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/clean.sh (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/clean.sh (revision 6016) @@ -0,0 +1,33 @@ +#!/bin/bash +# +# (C) Copyright 2020- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + + +# This script cleans a directory that has been used for the ecRad +# practical + +set -x + +# Remove plots +rm -f era5slice*.png + +# Remove edited config files +rm -f config_*.nam + +# Remove ecRad output netCDF files, i.e. all netCDF files except for +# era5slice.nc +rm -f $(ls -1 *.nc | egrep -v "era5slice.nc|era5slice_hydromet.nc") + +# Remove Python cached files +rm -rf ecradplot/__pycache__ + +# Remove emacs autosave files +rm -f *~ + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output.py (revision 6016) @@ -0,0 +1,39 @@ +#!/usr/bin/env python3 + +def warn(*args, **kwargs): + pass + +import os, warnings +warnings.warn = warn + +from ecradplot import plot as eplt + +def main(input_srcfile, reference_output_srcfile, output_srcfile, dstdir): + """ + Plot radiation fields (fluxes, CRE, and heating rates) + """ + + import os + if not os.path.isdir(dstdir): + os.makedirs(dstdir) + + name_string = os.path.splitext(os.path.basename(input_srcfile))[0] + output_string = os.path.splitext(os.path.basename(output_srcfile))[0] + reference_name_string = os.path.splitext(os.path.basename(reference_output_srcfile))[0] + + dstfile = os.path.join(dstdir, f"{name_string}_{output_string}_vs_{reference_name_string}.png") + + print(f"Plotting output to {dstfile}") + eplt.compare_output(input_srcfile, reference_output_srcfile, output_srcfile, dstfile=dstfile) + + +if __name__ == "__main__": + import argparse + parser = argparse.ArgumentParser(description="Plot radiative fluxes and heating rates from ecRAD output file.") + parser.add_argument("input", help="ecRAD input file") + parser.add_argument("reference", help='ecRAD output file to use as a reference') + parser.add_argument("output", help="ecRAD output file") + parser.add_argument("--dstdir", help="Destination directory for plots", default="./") + args = parser.parse_args() + + main(args.input, args.reference, args.output, args.dstdir) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output_profile.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output_profile.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output_profile.py (revision 6016) @@ -0,0 +1,70 @@ +#!/usr/bin/env python3 +import os +import warnings + +import seaborn as sns + +from ecradplot import plot as eplt + +def warn(*args, **kwargs): + pass + +warnings.warn = warn + +def format_latitude(latitude): + if latitude<0: + return "f{abs(latitude):.0f}S" + + return "f{abs(latitude):.0f}N" + +def main(latitude, input_srcfile, reference_output_srcfile, output_srcfiles, dstdir): + """ + Plot input files + """ + + if not os.path.isdir(dstdir): + os.makedirs(dstdir) + + name_string = os.path.splitext(os.path.basename(input_srcfile))[0] + outputs_string = "_".join([os.path.splitext(os.path.basename(f))[0] for f in output_srcfiles]) + reference_string = os.path.splitext(os.path.basename(reference_output_srcfile))[0] + + styles = [{'lw':3, 'color':'k', 'ls':'-', 'zorder':10}, + #{'lw':4, 'color':'0.5', 'ls':'-'}, + #{'lw':4, 'color':'0.75', 'ls':'-'}, + {'lw':5, 'color':sns.color_palette()[0], 'ls':'-'}, + {'lw':5, 'color':sns.color_palette()[2], 'ls':'-'}, + {'lw':3, 'color':sns.color_palette()[3], 'ls':'--'}, + {'lw':3, 'color':sns.color_palette()[5], 'ls':'-.'}, + {'lw':5, 'color':sns.color_palette()[6], 'ls':'-'}, + {'lw':5, 'color':sns.color_palette()[9], 'ls':'-'}] + + dstfile = os.path.join( + dstdir, + f"{name_string}_{outputs_string}_vs_{reference_string}" + f"_profile_{format_latitude(latitude)}.png" + ) + + print(f"Plotting output profiles to {dstfile}") + eplt.compare_output_profile( + latitude, + input_srcfile, + reference_output_srcfile, + output_srcfiles, + styles, + dstfile=dstfile + ) +if __name__ == "__main__": + import argparse + parser = argparse.ArgumentParser( + description="Plot radiative fluxes and heating rates from ecRAD output file." + "If a reference file is given, plot differences with respect to the reference." + ) + parser.add_argument("latitude", help="Latitude at which to extract profiles", type=float) + parser.add_argument("input", help="ecRAD input file") + parser.add_argument("reference", help="ecRAD output file to use as a reference", default=None) + parser.add_argument("outputs", help="ecRAD output files", nargs='+') + parser.add_argument("--dstdir", help="Destination directory for plots", default="./") + args = parser.parse_args() + + main(args.latitude, args.input, args.reference, args.outputs, args.dstdir) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output_scalar.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output_scalar.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/compare_output_scalar.py (revision 6016) @@ -0,0 +1,48 @@ +#!/usr/bin/env python3 + +def warn(*args, **kwargs): + pass + +import os, warnings +warnings.warn = warn + +from ecradplot import plot as eplt + +def main(input_srcfile, reference_output_srcfile, output_srcfiles, dstdir): + """ + Plot input files + """ + + import os + if not os.path.isdir(dstdir): + os.makedirs(dstdir) + + import seaborn as sns + name_string = os.path.splitext(os.path.basename(input_srcfile))[0] + outputs_string = "_".join([os.path.splitext(os.path.basename(f))[0] for f in output_srcfiles]) + reference_string = os.path.splitext(os.path.basename(reference_output_srcfile))[0] + + styles = [{'lw':2, 'color':'k', 'ls':'-', 'zorder':10}, + {'lw':3, 'color':sns.color_palette()[0], 'ls':'-'}, + {'lw':3, 'color':sns.color_palette()[2], 'ls':'-'}, + {'lw':2, 'color':sns.color_palette()[3], 'ls':'--'}, + {'lw':2, 'color':sns.color_palette()[5], 'ls':'-.'}, + {'lw':4, 'color':sns.color_palette()[6], 'ls':'-'}, + {'lw':4, 'color':sns.color_palette()[9], 'ls':'-'}] + + reference_name_string = os.path.splitext(os.path.basename(reference_output_srcfile))[0] + dstfile = f"{dstdir}/{name_string}_{outputs_string}_vs_{reference_name_string}_scalar.png" + print(f"Plotting integrated, surface and TOA outputs to {dstfile}") + eplt.compare_output_scalar(input_srcfile, output_srcfiles, reference_output_srcfile, styles, dstfile=dstfile) + + +if __name__ == "__main__": + import argparse + parser = argparse.ArgumentParser(description="Plot radiative fluxes and heating rates from ecRAD output file.") + parser.add_argument("input", help="ecRAD input file") + parser.add_argument("reference", help="ecRAD output file to use as a reference") + parser.add_argument("outputs", help="ecRAD output files", nargs='+') + parser.add_argument("--dstdir", help="Destination directory for plots", default="./") + args = parser.parse_args() + + main(args.input, args.reference, args.outputs, args.dstdir) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/config.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/config.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/config.nam (revision 6016) @@ -0,0 +1,93 @@ +! Configuration namelists for ecRad radiation scheme +! +! The "radiation_driver" namelist controls the behaviour of the driver +! routine, including parallelization options and overriding numbers +! read from the NetCDF input file. The "radiation" namelist controls +! the behaviour of the radiative transfer algorithm itself. Any line +! prefixed by "!" is ignored. If a namelist parameter is missing then +! ecRad will use a default value. For most parameters you can see +! what ecRad has used from the output printed to the terminal when it +! runs. +! +! The "iverbose*" parameters specify the verbosity level: 0=none, +! 1=warning, 2=info, 3=progress, 4=detailed, 5=debug + +&radiation_driver +! +! GENERAL +! +iverbose = 2, +do_parallel = true, ! Use OpenMP parallelization, if possible? +nblocksize = 32, ! Number of columns to process per thread +experiment_name = "Control", ! Written to output file, used in plot legends +! +! SCALE OR OVERRIDE ECRAD INPUTS +! +fractional_std = 1, ! Fractional standard dev. of in-cloud water content +overlap_decorr_length_scaling = 1.0, ! Scale cloud overlap decorr. length +solar_irradiance_override = 1361.0, ! Top-of-atmosphere solar irradiance (W m-2) +!cos_solar_zenith_angle = 0.0, ! 0.0 = night-time, 1.0 = overhead sun +! +! SCALE GAS CONCENTRATIONS +! +h2o_scaling = 1.0, ! Scale water vapour concentration +co2_scaling = 1.0, ! Scale carbon dioxide concentration +o3_scaling = 1.0, ! Scale ozone concentration +ch4_scaling = 1.0, ! Scale methane concentration +n2o_scaling = 1.0, ! Scale nitrous oxide concentration +o2_scaling = 1.0, ! Scale molecular oxygen concentration +cfc11_scaling = 1.0, ! Scale CFC11 concentration +cfc12_scaling = 1.0, ! Scale CFC12 concentration +! +! The following settings configure the SPARTACUS solver +cloud_separation_scale_toa = 14000.0, +cloud_separation_scale_surface = 2500.0, +cloud_separation_scale_power = 3.5, +cloud_inhom_separation_factor = 0.75, +! + +! Writing fluxes in double precision removes noise from differences in +! mesospheric heating rates +do_write_double_precision = true, +/ + +&radiation +! +! GENERAL +! +iverbose = 1, +iverbosesetup = 1, +directory_name = "data", ! Location of configuration files +do_surface_sw_spectral_flux = false, ! Save surface fluxes in each band? +! +! CLOUDS +! +use_general_cloud_optics = false, +ice_model_name = "Fu-IFS", ! Can be "Fu-IFS" or "Yi" +sw_solver_name = "Tripleclouds", ! "Tripleclouds", "McICA" or "SPARTACUS" +lw_solver_name = "Tripleclouds", ! "Tripleclouds", "McICA" or "SPARTACUS" +overlap_scheme_name = "Exp-Ran", ! McICA also accepts Max-Ran or Exp-Exp +do_lw_cloud_scattering = true, ! Clouds scatter in the longwave? +gas_model_name = "RRTMG-IFS", ! "RRTMG-IFS" or "ECCKD" +! +! AEROSOLS +! +use_aerosols = true, ! Radiation sees aerosols? +use_general_aerosol_optics=false, +do_lw_aerosol_scattering = false, ! Aerosols scatter in the longwave? +! +! 11 IFS aerosol mixing ratios are stored in the ecRad input file: 1-3 +! Sea salt, 4-6 mineral dust, 7 hydrophilic organics, 8 hydrophobic +! organics, 9 hydrophilic black carbon, 10 hydrophobic black carbon, 11 +! ammonium sulfate +n_aerosol_types = 11, ! Number of aerosol types in input file +! +! The aerosol optical properties are in this file: +aerosol_optics_override_file_name = 'aerosol_ifs_rrtm_46R1_with_NI_AM.nc' +! +! For each of the 11 mixing ratios in the input file, we need to map to +! one of the optical properties, where negative numbers index +! hydrophilic aerosol types and positive numbers index hydrophobic +! aerosol types, e.g. 11=black carbon, -5=sulphate. +i_aerosol_type_map = -1, -2, -3, 1, 2, 3, -4, 10, 11, 11, -5, +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/general.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/general.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/general.py (revision 6016) @@ -0,0 +1,102 @@ +""" +Filename: general.py +Author: Shannon Mason, shannon.mason@ecmwf.int +Description: Common plotting functions. +""" + +import pandas as pd +import numpy as np + +#For loading and handling netCDF data +import xarray as xr + +def format_time(ax, format_string="%H:%M", label='Time (UTC)'): + """ + Format axes for time coordinates. + """ + import matplotlib.dates as mdates + ax.set_xticklabels(ax.xaxis.get_majorticklabels(), rotation=0, ha='center') + ax.xaxis.set_major_formatter(mdates.DateFormatter(format_string)) + ax.set_xlabel(label) + + +def format_height(ax, scale=1.0e3, label='Height [km]'): + """ + Format axes for height coordinates. + """ + import matplotlib.ticker as ticker + ticks_y = ticker.FuncFormatter(lambda x, pos: '${0:g}$'.format(x/scale)) + ax.yaxis.set_major_formatter(ticks_y) + ax.set_ylabel(label) + + +def format_temperature(ax, scale='K'): + """ + Format axes for temperature coordinates. + """ + import matplotlib.ticker as ticker + ticks_y = ticker.FuncFormatter(lambda x, pos: '${0:g}$'.format(x)) + ax.yaxis.set_major_formatter(ticks_y) + ymin, ymax = ax.get_ylim() + ax.set_ylim(ymax, ymin) + if scale == 'K': + ax.set_ylabel('Temperature [K]') + elif scale == 'C': + ax.set_ylabel('Temperature [K]') + else: + Error("Scale must be either K or C") + + +def format_pressure(ax, scale=100, label='Pressure [hPa]'): + """ + Format axes for pressure coordinates. + """ + import matplotlib.ticker as ticker + ticks_p = ticker.FuncFormatter(lambda x, pos: '${0:g}$'.format(x/scale)) + ax.yaxis.set_major_formatter(ticks_p) + ax.set_ylabel(label) + + +def format_latitude(ax): + """ + Format axes for latitude coordinates. + """ + import matplotlib.ticker as ticker + latFormatter = ticker.FuncFormatter(lambda x, pos: "${:g}^\circ$S".format(-1*x) if x < 0 else "${:g}^\circ$N".format(x)) + ax.xaxis.set_major_formatter(latFormatter) + +fancy_format_latitude = lambda x: r"${:.0f}^{{\circ}}$S".format(-1*x) if x < 0 else "${:.0f}^{{\circ}}$N".format(x) +unfancy_format_latitude = lambda x: r"{:.0f}S".format(-1*x) if x < 0 else "{:.0f}N".format(x) + +def snap_to_axis(ax, ax_ref): + """ + Align subplot ax with the bounds of subplot ax_ref + """ + pos_ref = ax_ref.get_position() + pos = ax.get_position() + ax.set_position([pos_ref.x0, pos.y0, pos_ref.width, pos.height]) + +def get_figure_center(ax): + bbox = ax.get_position() + return (bbox.get_points()[0][0] + bbox.get_points()[1][0])/2 + +def get_figure_top(fig, ax, include_hspace=True): + bbox = ax.get_position() + if include_hspace: + return bbox.get_points()[0][1] + fig.subplotpars.hspace + else: + return bbox.get_points()[0][1] + +def place_suptitle(fig, axes, suptitle, y=0.95, va='top'): + center = get_figure_center(axes[0]) + fig.suptitle(suptitle, ha='center', x=center, va=va, y=y) + +def add_subfigure_labels(axes, xloc=0.0, yloc=1.05, zorder=0, label_list=[], flatten_order='F'): + if label_list == []: + import string + labels = string.ascii_lowercase + else: + labels = label_list + + for i, ax in enumerate(axes.flatten(order=flatten_order)): + ax.text(xloc, yloc, "%s)" %(labels[i]), va='baseline', transform=ax.transAxes, fontweight='bold', zorder=zorder) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/io.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/io.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/io.py (revision 6016) @@ -0,0 +1,96 @@ +""" +Filename: io.py +Author: Shannon Mason, shannon.mason@ecmwf.int +Description: I/O functions for loading IFS data +""" + +#For loading and handling netCDF data +import xarray as xr + +def load_inputs(input_srcfile): + """ + Load ecRAD input files. + """ + + with xr.open_dataset(input_srcfile) as input_dset: + if 'lat' in input_dset: + input_dset = input_dset.rename({'lat':'latitude', 'lon':'longitude'}) + + input_dset['pressure_fl'] = xr.DataArray( + input_dset.pressure_hl[:,:-1] + 0.5*input_dset.pressure_hl.diff('half_level'), + coords={'column':input_dset.column, 'level':input_dset.level}, + dims=['column', 'level'] + ) + + #input_dset['p'] = input_dset.pressure_fl.median('column') + #input_dset['phl'] = input_dset.pressure_hl.median('column') + + if 'aerosol_mmr' in input_dset.data_vars: + input_dset['sea_salt'] = input_dset.aerosol_mmr.sel( + aerosol_type=slice(0,2)).sum('aerosol_type') + input_dset['dust'] = input_dset.aerosol_mmr.sel( + aerosol_type=slice(3,5)).sum('aerosol_type') + input_dset['organics'] = input_dset.aerosol_mmr.sel( + aerosol_type=slice(6,7)).sum('aerosol_type') + input_dset['black_carbon'] = input_dset.aerosol_mmr.sel( + aerosol_type=slice(8,9)).sum('aerosol_type') + input_dset['sulphate'] = input_dset.aerosol_mmr.sel(aerosol_type=10) + + input_dset = input_dset.set_coords(['latitude', 'longitude']) #, 'p', 'phl']) + + return input_dset.swap_dims({'column':'latitude'})# 'half_level':'phl', 'level':'p'}) + + +def load_ecRAD(output_srcfile, input_srcfile): + """ + Load an ecRAD output file and merge with inputs. + Calculate net fluxes and heating rates, including necessary pressures at full levels and half + levels. + """ + + with xr.open_dataset(output_srcfile) as rad_output, xr.open_dataset(input_srcfile) as ifs_input: + + if 'lat' in ifs_input: + ifs_input = ifs_input.rename({'lat':'latitude', 'lon':'longitude'}) + + input_dset = rad_output.merge(ifs_input) #, compat='override') + + input_dset['pressure_fl'] = xr.DataArray( + input_dset.pressure_hl[:,:-1] + 0.5*input_dset.pressure_hl.diff('half_level'), + coords={'column':input_dset.column, 'level':input_dset.level}, + dims=['column', 'level'] + ) + + #input_dset['p'] = input_dset.pressure_fl.median('column') + #input_dset['phl'] = input_dset.pressure_hl.median('column') + + input_dset = input_dset.set_coords(['latitude', 'longitude']) #, 'p', 'phl']) + + input_dset['cloud_radiative_effect_lw'] = ( + (input_dset.flux_dn_lw - input_dset.flux_dn_lw_clear) -\ + (input_dset.flux_up_lw - input_dset.flux_up_lw_clear) + ) + input_dset['cloud_radiative_effect_sw'] = ( + (input_dset.flux_dn_sw - input_dset.flux_dn_sw_clear) -\ + (input_dset.flux_up_sw - input_dset.flux_up_sw_clear) + ) + input_dset['flux_net_lw'] = input_dset.flux_dn_lw - input_dset.flux_up_lw + input_dset['flux_net_sw'] = input_dset.flux_dn_sw - input_dset.flux_up_sw + + input_dset['flux_net_lw_clear'] = input_dset.flux_dn_lw_clear - input_dset.flux_up_lw_clear + input_dset['flux_net_sw_clear'] = input_dset.flux_dn_sw_clear - input_dset.flux_up_sw_clear + + c_factor = 24*3600*(9.81/1004.) + input_dset['heating_rate_lw'] = (-1*c_factor*input_dset.flux_net_lw.diff('half_level')\ + /input_dset.pressure_hl.diff('half_level')).rename({'half_level':'level'}) + input_dset['heating_rate_sw'] = (-1*c_factor*input_dset.flux_net_sw.diff('half_level')\ + /input_dset.pressure_hl.diff('half_level')).rename({'half_level':'level'}) + + input_dset['heating_rate_lw_clear'] = \ + (-1*c_factor*input_dset.flux_net_lw_clear.diff('half_level')\ + /input_dset.pressure_hl.diff('half_level')).rename({'half_level':'level'}) + input_dset['heating_rate_sw_clear'] = \ + (-1*c_factor*input_dset.flux_net_sw_clear.diff('half_level')\ + /input_dset.pressure_hl.diff('half_level')).rename({'half_level':'level'}) + + return input_dset.swap_dims({'column':'latitude'}) # 'half_level':'phl', 'level':'p'}) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/plot.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/plot.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/ecradplot/plot.py (revision 6016) @@ -0,0 +1,2090 @@ +""" +Filename: plot.py +Author: Shannon Mason, shannon.mason@ecmwf.int +Description: Plotting functions +""" + +import pandas as pd +import numpy as np + +#For loading and handling netCDF data +import xarray as xr + +#Use seaborn to control matplotlib visual style +import matplotlib.pyplot as plt +import seaborn as sns + +#For log-scaled colormaps +from matplotlib.colors import LogNorm#, DivergingNorm + +#Plot formatting functions +from ecradplot.general import * + +#I/O functions +from ecradplot.io import * +import os + +#### Set plotting style #### +sns.set_style('ticks') +sns.set_context('poster') + +def warn(*args, **kwargs): + pass +import warnings +warnings.warn = warn +warnings.simplefilter(action = "ignore", category = RuntimeWarning) + + +def get_vextents(da, q=0.01, symmetric=False): + vmin = da.quantile(q=0.01).values + vmax = da.quantile(q=1-q).values + + #All negative + if (vmin < 0) & (vmax < 0) & ~symmetric: + return vmin, 0 + #All positive + elif (vmin > 0) & (vmax > 0) & ~symmetric: + return 0, vmax + else: + v = max(np.abs(vmin), np.abs(vmax)) + return -1*v, v + +def irregular_pcolor(ax, X, Y, C, args, cbar_kwargs=None): + _X, _Y, _C = xr.broadcast(X, Y, C) + _cm = ax.pcolor(_X.values, _Y.values, _C.values, **args) + + if cbar_kwargs: + try: + _cb = plt.colorbar(_cm, ax=ax, **cbar_kwargs) + except: + print("Bug with colorbars") + + if 'level' in C.dims: + ax.fill_between(_X.max('level'), _Y.max('level'), y2=1100e2, facecolor='0.67', + hatch='////', edgecolor='k', lw=0.0, zorder=-10) + elif 'half_level' in C.dims: + ax.fill_between(_X.max('half_level'), _Y.max('half_level'), y2=1100e2, facecolor='0.67', + hatch='////', edgecolor='k', lw=0.0, zorder=-10) + return _cm + +def irregular_contour(ax, X, Y, C, args, cbar_kwargs=None): + _X, _Y, _C = xr.broadcast(X, Y, C) + _cm = ax.contour(_X, _Y, _C, **args) + if cbar_kwargs: + _cb = plt.colorbar(_cm, ax=ax, **cbar_kwargs) + return _cm + +def add_temperature_contours(ax, ds, x_dim='latitude'): + """ + Draw contours of temperature (from ds) to ax. + """ + + _cn = irregular_contour(ax, ds.latitude, ds.pressure_hl, ds.temperature_hl-273.15, + dict(levels=np.arange(-80,41,20), + colors=['k'], + linewidths=[1.5, 0.5, 1.5, 0.5, 2.5, 0.5, 1.5])) + _labels = ax.clabel(_cn, [l for l in [-80,-60,-40,-20,0,20,40] if l in _cn.levels], inline=1, fmt='$%.0f^{\circ}$C', fontsize='xx-small', colors=['k']) + + for l in _labels: + l.set_rotation(0) + + +def plot_inputs_noncloud(IFS_srcfile, dstfile=None, line_ds='default'): + """ + Plot multiple-panel figure describing non-cloud inputs to ecRAD. + """ + + _ds = load_inputs(IFS_srcfile) + + #Set up figure and axes + nrows=4 + + fig, axes= plt.subplots(figsize=(25,4*nrows), nrows=nrows, sharex=True) + + #First panel: SW & surface fields + i=0 + _ds.cos_solar_zenith_angle.where(_ds.cos_solar_zenith_angle >= 0).plot(ax=axes[i], x='latitude', color='k', lw=3) + axes[i].set_xlabel('') + axes[i].set_ylabel(r'$\cos \theta_s$ [-]') + axes[i].set_yticks([0,0.5,1.]) + axes[i].set_title('Solar zenith angle and shortwave albedo') + if 'solar_irradiance' in _ds: + axes[i].text(0.001, 1.01, f"Solar irradiance\n$Q={_ds.solar_irradiance.values:5.1f}$ W m$^{{-2}}$", ha='left', va='bottom', fontsize='small', transform=axes[i].transAxes) + _ax0 = axes[i].twinx() + _ax0.yaxis.set_label_position("right") + _ax0.yaxis.tick_right() + + if hasattr(_ds, 'sw_albedo_band'): + _ds.sw_albedo.isel(sw_albedo_band=2).plot.step(ax=_ax0, x='latitude', color=sns.color_palette()[0], lw=4, drawstyle=line_ds) + else: + _ds.sw_albedo.plot(ax=_ax0, x='latitude', color=sns.color_palette()[0], lw=4, drawstyle=line_ds) + _ax0.set_yticks([0,0.5,1.0]) + _ax0.set_yticklabels([0,0.5,1.0], color=sns.color_palette()[0]) + _ax0.set_ylabel(r'$\alpha_{SW}$ [-]', color=sns.color_palette()[0]) + + #Second panel: LW surface fields + i+=1 + _ds.skin_temperature.plot(ax=axes[i], x='latitude', color='k', lw=3) + axes[i].set_xlabel('') + axes[i].set_ylabel(r'$T_s$ [K]') + axes[i].set_title('Skin temperature and longwave emissivity') + + _ax1 = axes[i].twinx() + _ax1.yaxis.set_label_position("right") + _ax1.yaxis.tick_right() + if hasattr(_ds, 'lw_emissivity_band'): + _ds.lw_emissivity.isel(lw_emissivity_band=1).plot.step(ax=_ax1, x='latitude', color=sns.color_palette()[3], lw=4, drawstyle=line_ds) + else: + _ds.lw_emissivity.plot(ax=_ax1, x='latitude', color=sns.color_palette()[3], lw=4, drawstyle=line_ds) + _ax1.set_yticks([0.9,0.95,1.0]) + _ax1.set_ylim(0.89,1.0) + _ax1.set_yticklabels([0.9,0.95,1.0], color=sns.color_palette()[3]) + _ax1.set_ylabel(r'$\epsilon_{LW}$ [-]', color=sns.color_palette()[3]) + + #Specific humidity + i+=1 + irregular_pcolor(axes[i], _ds.latitude, _ds.pressure_fl, _ds.q, + dict(norm=LogNorm(1e-6, 1e-2), cmap='Greens'), + cbar_kwargs={'pad':0.01, 'label':'mass mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-5,1e-4,1e-3,1e-2]}) + + axes[i].set_title('Specific humidity') + axes[i].set_xlabel('') + + axes[i].set_yscale('linear') + axes[i].set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + axes[i].set_ylim(1050e2,1) + + #Ozone + i+=1 + irregular_pcolor(axes[i], _ds.latitude, _ds.pressure_fl, _ds.o3_mmr, + dict(norm=LogNorm(1e-8, 1e-5), cmap='Blues'), + cbar_kwargs={'pad':0.01, 'label':'mass mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-8,1e-7,1e-6,1e-5]}) + + axes[i].set_title('Ozone') + axes[i].set_xlabel('') + + axes[i].set_yscale('log') + axes[i].set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + axes[i].set_ylim(1.1e5,1) + + for ax in axes[-2:]: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes[:-2]: + snap_to_axis(ax, axes[-1]) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + add_subfigure_labels(axes) + + if hasattr(_ds, 'experiment'): + fig.suptitle(_ds.attrs['experiment'] + "\nsurface properties and atmospheric composition", x=get_figure_center(axes[0]), y=get_figure_top(fig, axes[0]), va='bottom') + else: + fig.suptitle("surface properties and atmospheric composition", x=get_figure_center(axes[0]), y=get_figure_top(fig, axes[0]), va='bottom') + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def plot_inputs_cloud(IFS_srcfile, include_effective_radius=False, dstfile=None): + _ds = load_inputs(IFS_srcfile) + + if include_effective_radius: + nrows=5 + else: + nrows=3 + + fig, axes = plt.subplots(figsize=(25,4*nrows), nrows=nrows, sharex=True, sharey=True, subplot_kw={'facecolor':sns.xkcd_rgb['earth']}) + + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_fl, _ds.cloud_fraction, + dict(vmin=0, vmax=1, cmap='gray_r'), + cbar_kwargs={'pad':0.01, 'label':'fraction', 'ticks':[0, 0.2, 0.4, 0.6, 0.8, 1.0]}) + axes[0].set_title('Cloud fraction') + axes[0].set_xlabel('') + + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_fl, _ds.q_ice.where(_ds.q_ice > 1e-10).fillna(1e-10), + dict(norm=LogNorm(1e-8, 0.5e-2), cmap='Blues'), + cbar_kwargs={'pad':0.01, 'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-7, 1e-5, 1e-3]}) + axes[1].set_title('Cloud ice water content') + axes[1].set_xlabel('') + + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_fl, _ds.q_liquid.where(_ds.q_liquid > 1e-10).fillna(1e-10), + dict(norm=LogNorm(1e-8, 0.5e-2), cmap='Reds'), + cbar_kwargs={'pad':0.01, 'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-7, 1e-5, 1e-3]}) + axes[2].set_title('Cloud liquid water content') + format_latitude(axes[-1]) + + if include_effective_radius: + axes[2].set_xlabel('') + + irregular_pcolor(axes[3], _ds.latitude, _ds.pressure_fl, _ds.re_ice.where(_ds.q_ice > 1e-10).fillna(1e-10), + dict(norm=LogNorm(3e-6, 1e-4), cmap='Blues'), + cbar_kwargs={'pad':0.01, 'label':'$r_{\mathrm{eff}}$ [m]'}) + axes[3].set_title('Ice effective radius') + axes[3].set_xlabel('') + + irregular_pcolor(axes[4], _ds.latitude, _ds.re_liquid.where(_ds.q_liquid > 1e-10).fillna(1e-10), + dict(norm=LogNorm(3e-6, 1e-4), cmap='Reds'), + cbar_kwargs={'pad':0.01, 'label':'$r_{\mathrm{eff}}$ [m]'}) + axes[4].set_title('Liquid effective radius') + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + axes[-1].set_xlabel('Latitude') + + axes[0].set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + axes[0].set_ylim(1050e2,1) + + add_subfigure_labels(axes) + + if hasattr(_ds, 'experiment'): + fig.suptitle(_ds.attrs['experiment'] + "\ncloud fields", x=get_figure_center(axes[0]), y=get_figure_top(fig, axes[0])+ 0.1, va='bottom') + else: + fig.suptitle("cloud fields", x=get_figure_center(axes[0]), y=get_figure_top(fig, axes[0])+ 0.1, va='bottom') + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + +def plot_inputs_aerosols(IFS_srcfile, dstfile=None): + _ds = load_inputs(IFS_srcfile) + + nrows=5 + + fig, axes = plt.subplots(figsize=(25,4*nrows), nrows=nrows, sharex=True, sharey=True, ) + + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_fl, _ds.sea_salt.where(_ds.sea_salt > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-6), cmap='Blues'), + cbar_kwargs={'pad':0.01, 'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-9, 1e-6]}) + axes[0].set_title('Sea salt') + axes[0].set_xlabel('') + + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_fl, _ds.dust.where(_ds.dust > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-6), cmap='OrRd'), + cbar_kwargs={'pad':0.01, 'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-9, 1e-6]}) + axes[1].set_title('Dust') + axes[1].set_xlabel('') + + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_fl, _ds.organics.where(_ds.organics > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-7), cmap='Greens'), + cbar_kwargs={'pad':0.01, 'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-10, 1e-8]}) + axes[2].set_title('Organics') + format_latitude(axes[-1]) + axes[2].set_xlabel('') + + irregular_pcolor(axes[3], _ds.latitude, _ds.pressure_fl, _ds.black_carbon.where(_ds.black_carbon > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-7), cmap='Greys'), + cbar_kwargs={'pad':0.01, 'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-10, 1e-8]}) + axes[3].set_title('Black carbon') + axes[3].set_xlabel('') + + irregular_pcolor(axes[4], _ds.latitude, _ds.pressure_fl, _ds.sulphate.where(_ds.sulphate > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-7), cmap='Reds'), + cbar_kwargs={'pad':0.01, 'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-10, 1e-8]}) + axes[4].set_title('Sulphates') + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + axes[-1].set_xlabel('Latitude') + + axes[0].set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + axes[0].set_ylim(1050e2,1) + + add_subfigure_labels(axes) + + if hasattr(_ds, 'experiment'): + fig.suptitle(_ds.attrs['experiment'] + "\naerosols", x=get_figure_center(axes[0]), y=0.95, va='top') + else: + fig.suptitle("aerosols", x=get_figure_center(axes[0]), y=0.95, va='top') + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + +def plot_inputs(IFS_srcfile, dstfile=None, line_ds='default'): + with sns.plotting_context('notebook', font_scale=1.1), sns.axes_style('ticks'): + + _ds = load_inputs(IFS_srcfile) + + #Set up figure and axes + nrows=6 + ncols=2 + + cbar_kwargs = {'pad':0.0125, 'aspect':10} + + fig, axes= plt.subplots(figsize=(25,2.25*nrows), nrows=nrows, ncols=ncols, gridspec_kw={'wspace':0.0, 'hspace':0.25}) + + #First row + j=0 + + ###ATMOSPHERE AND RADIATION + #First panel SW & surface fields + i=0 + _ds.cos_solar_zenith_angle.where(_ds.cos_solar_zenith_angle >= 0).plot(ax=axes[i,j], x='latitude', color='k', lw=3) + axes[i,j].set_xlabel('') + axes[i,j].set_ylabel(r'$\cos \theta_s$ [-]') + axes[i,j].set_yticks([0,0.5,1.]) + axes[i,j].set_title('Solar zenith angle and shortwave albedo') + if 'solar_irradiance' in _ds: + axes[i,j].text(0.001, 1.01, f"Solar irradiance\n$Q={_ds.solar_irradiance.values:5.1f}$ W m$^{{-2}}$", ha='left', va='bottom', fontsize='small', transform=axes[i,j].transAxes) + + _ax0 = axes[i,j].twinx() + _ax0.yaxis.set_label_position("right") + _ax0.yaxis.tick_right() + if hasattr(_ds, 'sw_albedo_band'): + _ds.sw_albedo.isel(sw_albedo_band=2).plot.step(ax=_ax0, x='latitude', color=sns.color_palette()[0], lw=4, drawstyle=line_ds) + else: + _ds.sw_albedo.plot(ax=_ax0, x='latitude', color=sns.color_palette()[0], lw=4, drawstyle=line_ds) + _ax0.set_yticks([0,0.5,1.0]) + _ax0.set_yticklabels([0,0.5,1.0], color=sns.color_palette()[0]) + _ax0.set_ylabel(r'$\alpha_{SW}$ [-]', color=sns.color_palette()[0]) + + #Second panel: LW surface fields + i+=1 + _ds.skin_temperature.plot(ax=axes[i,j], x='latitude', color='k', lw=3) + axes[i,j].set_xlabel('') + axes[i,j].set_ylabel(r'$T_s$ [K]') + axes[i,j].set_title('Skin temperature and longwave emissivity') + + _ax1 = axes[i,j].twinx() + _ax1.yaxis.set_label_position("right") + _ax1.yaxis.tick_right() + if hasattr(_ds, 'lw_emissivity_band'): + _ds.lw_emissivity.isel(lw_emissivity_band=1).plot.step(ax=_ax1, x='latitude', color=sns.color_palette()[3], lw=4, drawstyle=line_ds) + else: + _ds.lw_emissivity.plot(ax=_ax1, x='latitude', color=sns.color_palette()[3], lw=4, drawstyle=line_ds) + _ax1.set_yticks([0.9,0.95,1.0]) + _ax1.set_ylim(0.89,1.0) + _ax1.set_yticklabels([0.9,0.95,1.0], color=sns.color_palette()[3]) + _ax1.set_ylabel(r'$\epsilon_{LW}$ [-]', color=sns.color_palette()[3]) + + #Specific humidity + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.q, + dict(norm=LogNorm(1e-6, 1e-2), cmap='Greens'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-5,1e-4,1e-3,1e-2]}}) + + axes[i,j].set_title('Specific humidity') + axes[i,j].set_xlabel('') + + axes[i,j].set_yscale('linear') + axes[i,j].set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + axes[i,j].set_ylim(1050e2,1) + + ### CLOUD + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.cloud_fraction, + dict(vmin=0, vmax=1, cmap='gray_r'), + cbar_kwargs={**cbar_kwargs, **{'label':'fraction [-]', 'ticks':[0, 0.2, 0.4, 0.6, 0.8, 1.0]}}) + axes[i,j].set_title('Cloud fraction') + axes[i,j].set_xlabel('') + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.q_ice.where(_ds.q_ice > 1e-10).fillna(1e-10), + dict(norm=LogNorm(1e-8, 0.5e-2), cmap='Blues'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-7, 1e-5, 1e-3]}}) + axes[i,j].set_title('Cloud ice water content') + axes[i,j].set_xlabel('') + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.q_liquid.where(_ds.q_liquid > 1e-10).fillna(1e-10), + dict(norm=LogNorm(1e-8, 0.5e-2), cmap='Reds'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-7, 1e-5, 1e-3]}}) + axes[i,j].set_title('Cloud liquid water content') + + ####SECOND COLUMN + j+=1 + + #Ozone + i=0 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.o3_mmr, + dict(norm=LogNorm(1e-8, 1e-5), cmap='Blues'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-8,1e-7,1e-6,1e-5]}}) + + axes[i,j].set_title('Ozone') + axes[i,j].set_xlabel('') + + axes[i,j].set_yscale('log') + axes[i,j].set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + axes[i,j].set_ylim(1.1e5,1) + + #Aerosols + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.sea_salt.where(_ds.sea_salt > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-6), cmap='Blues'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-9, 1e-6]}}) + axes[i,j].set_title('Sea salt') + axes[i,j].set_xlabel('') + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.dust.where(_ds.dust > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-6), cmap='OrRd'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-9, 1e-6]}}) + axes[i,j].set_title('Dust') + axes[i,j].set_xlabel('') + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.organics.where(_ds.organics > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-7), cmap='Greens'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-10, 1e-8]}}) + axes[i,j].set_title('Organics') + axes[i,j].set_xlabel('') + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.black_carbon.where(_ds.black_carbon > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-7), cmap='Greys'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-10, 1e-8]}}) + axes[i,j].set_title('Black carbon') + axes[i,j].set_xlabel('') + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, _ds.sulphate.where(_ds.sulphate > 1e-12).fillna(1e-12), + dict(norm=LogNorm(1e-12, 1e-7), cmap='Reds'), + cbar_kwargs={**cbar_kwargs, **{'label':'mixing ratio\n[kg kg$^{-1}$]', 'ticks':[1e-12, 1e-10, 1e-8]}}) + axes[i,j].set_title('Sulphates') + + for ax in axes[2:,0]: + add_temperature_contours(ax, _ds) + format_pressure(ax) + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + + for ax in axes[:2,0]: + snap_to_axis(ax, axes[-1,0]) + + for ax in axes[1:,1]: + add_temperature_contours(ax, _ds) + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + ax.set_yticklabels([]) + ax.set_ylabel("") + + format_pressure(axes[0,1]) + add_temperature_contours(axes[0,1], _ds) + + for ax in axes.flatten(): + ax.set_xlim(-90,90) + ax.set_xticks(np.arange(-90,91,15)) + ax.set_xlabel('') + ax.set_xticklabels([]) + + for ax in axes[-1,:].flatten(): + format_latitude(ax) + ax.set_xlabel('Latitude') + + import string + add_subfigure_labels(axes) + + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + + x = (get_figure_center(axes[0,0]) + get_figure_center(axes[0,1]))/2 + y = get_figure_top(fig, axes[0,0], include_hspace=True) + + #fig.suptitle(f"{name_string}\nIFS cloud, aerosol and radiation fields", x=x, y=y-0.025, va='top', fontsize=30) + + fig.suptitle(f"{name_string}\nIFS cloud, aerosol and radiation fields", x=x, y=y-0.07, va='bottom', fontsize=25) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + +def plot_LW_flux(IFS_srcfile, ecRAD_srcfile, dstfile=None, clearsky=False): + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + # LW fluxes + nrows=3 + fig, axes = plt.subplots(figsize=(25,nrows*4), nrows=nrows, sharex=True, sharey=True) + + if clearsky: + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, _ds.flux_dn_lw_clear, + dict(cmap='Reds', vmin=0, vmax=500), + cbar_kwargs={'pad':0.01, 'label':'flux [W m$^{-2}$]'}) + axes[0].set_title("Clear-sky downwelling") + else: + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, _ds.flux_dn_lw, + dict(cmap='Reds', vmin=0, vmax=500), + cbar_kwargs={'pad':0.01, 'label':'flux [W m$^{-2}$]'}) + axes[0].set_title("Downwelling") + axes[0].set_xlabel('') + + if clearsky: + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, _ds.flux_up_lw_clear, + dict(cmap='Reds', vmin=0, vmax=500), + cbar_kwargs={'pad':0.01, 'label':'flux [W m$^{-2}$]'}) + axes[1].set_title("Clear-sky upwelling") + else: + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, _ds.flux_up_lw, + dict(cmap='Reds', vmin=0, vmax=500), + cbar_kwargs={'pad':0.01, 'label':'flux [W m$^{-2}$]'}) + axes[1].set_title("Upwelling") + axes[1].set_xlabel('') + + if clearsky: + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, _ds.flux_net_lw_clear, + dict(cmap='RdBu_r', norm=DivergingNorm(vcenter=0)),#, center=0, robust=True), + cbar_kwargs={'pad':0.01, 'label':'flux [W m$^{-2}$]'}) + axes[2].set_title("Clear-sky net") + else: + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, _ds.flux_net_lw, + dict(cmap='RdBu_r', norm=DivergingNorm(vcenter=0)),#, center=0, robust=True), + cbar_kwargs={'pad':0.01, 'label':'flux [W m$^{-2}$]'}) + axes[2].set_title("Net") + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes: + if True: + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + else: + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + if hasattr(_ds, 'experiment'): + place_suptitle(fig, axes, _ds.attrs['experiment'] + "\nLongwave fluxes", y=1.0) + else: + place_suptitle(fig, axes, "Longwave fluxes") + + add_subfigure_labels(axes) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + +def plot_LW_flux_difference(IFS_srcfile, ecRAD_srcfile, reference_ecRAD_srcfile, title=None, dstfile=None, clearsky=False): + ds = load_ecRAD(reference_ecRAD_srcfile, IFS_srcfile) + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + # LW fluxes + nrows=3 + fig, axes = plt.subplots(figsize=(25,nrows*4), nrows=nrows, sharex=True, sharey=True) + + cbar_kwargs = {'pad':0.01, 'label':'$\Delta$ flux [W m$^{-2}$]'} + + if clearsky: + da = (_ds.flux_dn_lw_clear - ds.flux_dn_lw_clear) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[0].set_title("Clear-sky downwelling") + else: + da = (_ds.flux_dn_lw - ds.flux_dn_lw) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[0].set_title("Downwelling") + axes[0].set_xlabel('') + + if clearsky: + da = (_ds.flux_up_lw_clear - ds.flux_up_lw_clear) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[1].set_title("Clear-sky upwelling") + else: + da = (_ds.flux_up_lw - ds.flux_up_lw) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[1].set_title("Upwelling") + axes[1].set_xlabel('') + + if clearsky: + da = (_ds.flux_net_lw_clear - ds.flux_net_lw_clear) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[2].set_title("Clear-sky net") + else: + da = (_ds.flux_net_lw - ds.flux_net_lw) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[2].set_title("Net ") + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes: + if True: + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + else: + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + if hasattr(_ds, 'experiment'): + place_suptitle(fig, axes, f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\nLongwave fluxes", y=1.0) + else: + place_suptitle(fig, axes, "Longwave fluxes") + + add_subfigure_labels(axes) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + +def plot_SW_flux(IFS_srcfile, ecRAD_srcfile, title=None, dstfile=None, clearsky=False): + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + # SW fluxes + nrows=3 + fig, axes = plt.subplots(figsize=(25,nrows*4), nrows=nrows, sharex=True, sharey=True) + + cbar_kwargs = {'pad':0.01, 'label':'flux [W m$^{-2}$]'} + + if clearsky: + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, _ds.flux_dn_sw_clear, + dict(cmap='Blues', vmin=0), + cbar_kwargs=cbar_kwargs) + axes[0].set_title("Clear-sky downwelling") + else: + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, _ds.flux_dn_sw, + dict(cmap='Blues', vmin=0), + cbar_kwargs=cbar_kwargs) + axes[0].set_title("Downwelling") + axes[0].set_xlabel('') + + if clearsky: + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, _ds.flux_up_sw_clear, + dict(cmap='Blues', vmin=0), + cbar_kwargs=cbar_kwargs) + axes[1].set_title("Clear-sky upwelling") + else: + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, _ds.flux_up_sw, + dict(cmap='Blues', vmin=0), + cbar_kwargs=cbar_kwargs) + axes[1].set_title("Upwelling") + axes[1].set_xlabel('') + + if clearsky: + if (_ds.flux_net_sw_clear.quantile(q=0.01) < 0) & (0 < _ds.flux_net_sw_clear.quantile(q=0.99)): + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, _ds.flux_net_sw_clear, + dict(cmap='RdBu_r', norm=DivergingNorm(vcenter=0, vmin=_ds.flux_net_sw_clear.quantile(q=0.01), vmax=_ds.flux_net_sw_clear.quantile(q=0.99))), + cbar_kwargs=cbar_kwargs) + else: + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, _ds.flux_net_sw_clear, + dict(cmap='Blues_r', vmax=0), + cbar_kwargs=cbar_kwargs) + axes[2].set_title("Clear-sky net") + else: + if (_ds.flux_net_sw_clear.quantile(q=0.01) < 0) & (0 < _ds.flux_net_sw_clear.quantile(q=0.99)): + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, _ds.flux_net_sw, + dict(cmap='RdBu_r', norm=DivergingNorm(vcenter=0, vmin=_ds.flux_net_sw.quantile(q=0.01), vmax=_ds.flux_net_sw.quantile(q=0.99))), + cbar_kwargs=cbar_kwargs) + else: + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, _ds.flux_net_sw, + dict(cmap='Blues_r', vmax=0), + cbar_kwargs=cbar_kwargs) + axes[2].set_title("Net") + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes: + if True: + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + else: + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + if hasattr(_ds, 'experiment'): + place_suptitle(fig, axes, _ds.attrs['experiment'] + "\nShortwave fluxes", y=1.0) + else: + place_suptitle(fig, axes, "Shortwave fluxes") + + add_subfigure_labels(axes) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def plot_SW_flux_difference(IFS_srcfile, ecRAD_srcfile, reference_ecRAD_srcfile, title=None, dstfile=None, clearsky=False): + ds = load_ecRAD(reference_ecRAD_srcfile, IFS_srcfile).load() + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile).load() + + cbar_kwargs = {'pad':0.01, 'label':'$\Delta$ flux [W m$^{-2}$]'} + + nrows=3 + fig, axes = plt.subplots(figsize=(25,nrows*4), nrows=nrows, sharex=True, sharey=True) + + if clearsky: + da = (_ds.flux_dn_sw_clear - ds.flux_dn_sw_clear) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[0].set_title("Clear-sky downwelling") + + else: + da = (_ds.flux_dn_sw - ds.flux_dn_sw) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[0].set_title("Downwelling") + axes[0].set_xlabel('') + + if clearsky: + da = (_ds.flux_up_sw_clear - ds.flux_up_sw_clear) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + + axes[1].set_title("Clear-sky upwelling") + + else: + da = (_ds.flux_up_sw - ds.flux_up_sw) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[1].set_title("Upwelling") + axes[1].set_xlabel('') + + if clearsky: + da = (_ds.flux_net_sw_clear - ds.flux_net_sw_clear) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[2].set_title("Clear-sky net") + + else: + da = (_ds.flux_net_sw - ds.flux_net_sw) + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[2].set_title("Net") + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes: + if True: + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + else: + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + if hasattr(_ds, 'experiment'): + place_suptitle(fig, axes, f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\nShortwave fluxes", y=1.0) + else: + place_suptitle(fig, axes, "Shortwave fluxes") + + add_subfigure_labels(axes) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def plot_CRE(IFS_srcfile, ecRAD_srcfile, title=None, dstfile=None): + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + nrows=3 + fig, axes = plt.subplots(figsize=(25,nrows*4), nrows=nrows, sharex=True, sharey=True) + + da = _ds.cloud_radiative_effect_sw + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.01, 'label':'CRE$_{\mathrm{SW}}$ [W m$^{-2}$]'}) + + axes[0].set_xlabel('') + axes[0].set_title("Shortwave") + + da = _ds.cloud_radiative_effect_lw + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.01, 'label':'CRE$_{\mathrm{LW}}$ [W m$^{-2}$]'}) + axes[1].set_xlabel('') + axes[1].set_title("Longwave") + + da = (_ds.cloud_radiative_effect_sw + _ds.cloud_radiative_effect_lw) + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.01, 'label':'CRE$_{\mathrm{net}}$ [W m$^{-2}$]'}) + axes[2].set_title("Net") + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes: + if True: + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + else: + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + if hasattr(_ds, 'experiment'): + place_suptitle(fig, axes, _ds.attrs['experiment'] + "\nCloud radiative effects", y=1.0) + else: + place_suptitle(fig, axes, "Cloud radiative effects") + + add_subfigure_labels(axes) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def plot_CRE_difference(IFS_srcfile, ecRAD_srcfile, reference_ecRAD_srcfile, title=None, dstfile=None): + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + + ds = load_ecRAD(reference_ecRAD_srcfile, IFS_srcfile) + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + nrows=3 + fig, axes = plt.subplots(figsize=(25,nrows*4), nrows=nrows, sharex=True, sharey=True) + + da = (_ds.cloud_radiative_effect_sw - ds.cloud_radiative_effect_sw) + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.01, 'label':'$\Delta$ CRE$_{\mathrm{SW}}$ [W m$^{-2}$]'}) + axes[0].set_xlabel('') + axes[0].set_title("Shortwave") + + da = (_ds.cloud_radiative_effect_lw - ds.cloud_radiative_effect_lw) + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.01, 'label':'$\Delta$ CRE$_{\mathrm{SW}}$ [W m$^{-2}$]'}) + axes[1].set_xlabel('') + axes[1].set_title("Longwave") + + da = ((_ds.cloud_radiative_effect_sw + _ds.cloud_radiative_effect_lw) - (ds.cloud_radiative_effect_sw + ds.cloud_radiative_effect_lw)) + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.01, 'label':'$\Delta$ CRE$_\mathrm{net}$ [W m$^{-2}$]'}) + axes[2].set_title("Net") + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes: + if True: + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + else: + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + if hasattr(_ds, 'experiment'): + place_suptitle(fig, axes, f"{name_string}\n{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\nCloud radiative effects", y=1.0) + else: + place_suptitle(fig, axes, "Cloud radiative effects") + + add_subfigure_labels(axes) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def plot_heating_rate(IFS_srcfile, ecRAD_srcfile, title=None, linear_pressure=True, dstfile=None): + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + if linear_pressure: + vmax = 10 + else: + vmax = 30 + + nrows=3 + fig, axes = plt.subplots(figsize=(25,nrows*4), nrows=nrows, sharex=True, sharey=True) + + cbar_kwargs = {'pad':0.01, 'label':'$\dfrac{dT}{dt}$ [K d$^{-1}$]'} + + da = _ds.heating_rate_lw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[0].set_xlabel('') + axes[0].set_title("Longwave") + + da = _ds.heating_rate_sw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r',vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[1].set_xlabel('') + axes[1].set_title("Shortwave") + + da = (_ds.heating_rate_sw + _ds.heating_rate_lw) + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[2].set_title("Net") + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes: + if linear_pressure: + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + else: + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + if hasattr(_ds, 'experiment'): + place_suptitle(fig, axes, f"{name_string}\n{_ds.attrs['experiment']}\nHeating rates", y=1.0) + else: + place_suptitle(fig, axes, "Heating rates") + + add_subfigure_labels(axes) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def plot_heating_rate_difference(IFS_srcfile, ecRAD_srcfile, reference_ecRAD_srcfile, title=None, linear_pressure=True, dstfile=None): + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + + ds = load_ecRAD(reference_ecRAD_srcfile, IFS_srcfile) + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + if linear_pressure: + vmax = 10 + else: + vmax = 30 + + nrows=3 + fig, axes = plt.subplots(figsize=(25,nrows*4), nrows=nrows, sharex=True, sharey=True) + + cbar_kwargs = {'pad':0.01, 'label':'$\Delta \dfrac{dT}{dt}$ [K d$^{-1}$]'} + + da = (_ds.heating_rate_lw - ds.heating_rate_lw) + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[0], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[0].set_xlabel('') + axes[0].set_title("Longwave") + + da = (_ds.heating_rate_sw - ds.heating_rate_sw) + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[1], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[1].set_xlabel('') + axes[1].set_title("Shortwave") + + da = ((_ds.heating_rate_sw + _ds.heating_rate_lw) - (ds.heating_rate_sw + ds.heating_rate_lw)) + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[2], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[2].set_title("Net") + + for ax in axes: + add_temperature_contours(ax, _ds) + format_pressure(ax) + + for ax in axes: + if linear_pressure: + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + else: + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + format_pressure(ax) + + axes[-1].set_xlim(-90,90) + axes[-1].set_xticks(np.arange(-90,91,15)) + format_latitude(axes[-1]) + axes[-1].set_xlabel('Latitude') + + if hasattr(_ds, 'experiment'): + place_suptitle(fig, axes, f"{name_string}\n{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\nHeating rates", y=1.0) + else: + place_suptitle(fig, axes, "Heating rates") + + add_subfigure_labels(axes) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def plot_output(IFS_srcfile, ecRAD_srcfile, dstfile=None): + + with sns.plotting_context('notebook', font_scale=1.1), sns.axes_style('ticks'): + + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + # LW fluxes + nrows=5 + ncols=2 + + fig, axes = plt.subplots(figsize=(25,2.5*nrows), nrows=nrows, ncols=ncols, sharex=True, sharey='row', gridspec_kw={'hspace':0.25, 'wspace':0.0}) + + ### LW fluxes + j=0 + i=0 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, _ds.flux_dn_lw, + dict(cmap='Reds', vmin=0, vmax=500), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'flux [W m$^{-2}$]'}) + axes[i,j].set_title("Downwelling longwave flux") + axes[i,j].set_xlabel('') + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, _ds.flux_up_lw, + dict(cmap='Reds', vmin=0, vmax=500), + cbar_kwargs={'pad':0.0125, 'aspect':10,'label':'flux [W m$^{-2}$]'}) + axes[i,j].set_title("Upwelling longwave flux") + axes[i,j].set_xlabel('') + + #SW fluxes + j=1 + i=0 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, _ds.flux_dn_sw, + dict(cmap='Reds', vmin=0, vmax=1300), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'flux [W m$^{-2}$]'}) + axes[i,j].set_title("Downwelling shortwave flux") + axes[i,j].set_xlabel('') + + i+=1 + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, _ds.flux_up_sw, + dict(cmap='Reds', vmin=0, vmax=1300), + cbar_kwargs={'pad':0.0125, 'aspect':10,'label':'flux [W m$^{-2}$]'}) + axes[i,j].set_title("Upwelling shortwave flux") + axes[i,j].set_xlabel('') + + #Cloud radiative effects + j=0 + i+=1 + da = _ds.cloud_radiative_effect_lw + vmin, vmax = get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'CRE$_{\mathrm{LW}}$ [W m$^{-2}$]'}) + + axes[i,j].set_xlabel('') + axes[i,j].set_title("Longwave cloud radiative effect") + + j+=1 + da = _ds.cloud_radiative_effect_sw + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'CRE$_{\mathrm{SW}}$ [W m$^{-2}$]'}) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Shortwave cloud radiative effect") + + #Heating rates + cbar_kwargs = {'pad':0.0125, 'aspect':10, 'label':'$\dfrac{dT}{dt}$ [K d$^{-1}$]'} + j=0 + i+=1 + + linear_pressure=True + + da = _ds.heating_rate_lw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Longwave heating rate (troposphere)") + + j+=1 + da = _ds.heating_rate_sw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r',vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Shortwave heating rate (troposphere)") + + j=0 + i+=1 + + linear_pressure=False + + da = _ds.heating_rate_lw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Longwave heating rate (stratosphere)") + + j+=1 + da = _ds.heating_rate_sw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r',vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Shortwave heating rate (stratosphere)") + + for ax in axes[:-1,:].flatten(): + add_temperature_contours(ax, _ds) + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + + for ax in axes[-1,:].flatten(): + add_temperature_contours(ax, _ds) + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + + ax.set_xlim(-90,90) + ax.set_xticks(np.arange(-90,91,15)) + format_latitude(ax) + ax.set_xlabel('Latitude') + + for ax in axes[:,0]: + format_pressure(ax) + + x = (get_figure_center(axes[0,0]) + get_figure_center(axes[0,1]))/2 + y = get_figure_top(fig, axes[0,0], include_hspace=True) + + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + fig.suptitle(f"{name_string}\n{_ds.attrs['experiment']}\nFluxes, cloud radiative effects and heating rates", x=x, y=y-0.025, va='bottom', fontsize='xx-large') + + add_subfigure_labels(axes, flatten_order='C') + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def compare_output(IFS_srcfile, ctrl_srcfile, ecRAD_srcfile, dstfile=None): + + ds = load_ecRAD(ctrl_srcfile, IFS_srcfile) + + with sns.plotting_context('notebook', font_scale=1.1), sns.axes_style('ticks'): + + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile) + + # LW fluxes + nrows=5 + ncols=2 + + fig, axes = plt.subplots(figsize=(25,2.5*nrows), nrows=nrows, ncols=ncols, sharex=True, sharey='row', gridspec_kw={'hspace':0.25, 'wspace':0.0}) + + ### LW fluxes + j=0 + i=0 + da = _ds.flux_dn_lw - ds.flux_dn_lw + vmin, vmax = get_vextents(da, symmetric=True) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'flux [W m$^{-2}$]'}) + axes[i,j].set_title("Change to downwelling longwave flux") + axes[i,j].set_xlabel('') + + i+=1 + da = _ds.flux_up_lw - ds.flux_up_lw + vmin, vmax = get_vextents(da, symmetric=True) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'flux [W m$^{-2}$]'}) + axes[i,j].set_title("Change to upwelling longwave flux") + axes[i,j].set_xlabel('') + + #SW fluxes + j=1 + i=0 + da = _ds.flux_dn_sw - ds.flux_dn_sw + vmin, vmax = get_vextents(da, symmetric=True) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'flux [W m$^{-2}$]'}) + axes[i,j].set_title("Change to downwelling shortwave flux") + axes[i,j].set_xlabel('') + + i+=1 + da = _ds.flux_up_sw - ds.flux_up_sw + vmin, vmax = get_vextents(da, symmetric=True) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'flux [W m$^{-2}$]'}) + axes[i,j].set_title("Change to upwelling shortwave flux") + axes[i,j].set_xlabel('') + + #Cloud radiative effects + j=0 + i+=1 + da = _ds.cloud_radiative_effect_lw - ds.cloud_radiative_effect_lw + vmin, vmax = get_vextents(da, symmetric=True) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'CRE$_{\mathrm{LW}}$ [W m$^{-2}$]'}) + + axes[i,j].set_xlabel('') + axes[i,j].set_title("Change to longwave cloud radiative effect") + + j+=1 + da = _ds.cloud_radiative_effect_sw - ds.cloud_radiative_effect_sw + vmin, vmax= get_vextents(da, symmetric=True) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_hl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs={'pad':0.0125, 'aspect':10, 'label':'CRE$_{\mathrm{SW}}$ [W m$^{-2}$]'}) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Change to shortwave cloud radiative effect") + + #Heating rates + cbar_kwargs = {'pad':0.0125, 'aspect':10, 'label':'$\dfrac{dT}{dt}$ [K d$^{-1}$]'} + j=0 + i+=1 + + linear_pressure=True + + da = _ds.heating_rate_lw - ds.heating_rate_lw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Change to longwave heating rate (troposphere)") + + j+=1 + da = _ds.heating_rate_sw - ds.heating_rate_sw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r',vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Change to shortwave heating rate (troposphere)") + + j=0 + i+=1 + + linear_pressure=False + + da = _ds.heating_rate_lw - ds.heating_rate_lw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r', vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Change to longwave heating rate (stratosphere)") + + j+=1 + da = _ds.heating_rate_sw - ds.heating_rate_sw + if linear_pressure: + vmin, vmax= get_vextents(da.where(_ds.pressure_fl > 100e2)) + else: + vmin, vmax= get_vextents(da) + irregular_pcolor(axes[i,j], _ds.latitude, _ds.pressure_fl, da, + dict(cmap='RdBu_r',vmin=vmin, vmax=vmax), + cbar_kwargs=cbar_kwargs) + axes[i,j].set_xlabel('') + axes[i,j].set_title("Change to shortwave heating rate (stratosphere)") + + for ax in axes[:-1,:].flatten(): + add_temperature_contours(ax, _ds) + ax.set_yscale('linear') + ax.set_yticks([1000e2,800e2,600e2,400e2,200e2,1]) + ax.set_ylim(1050e2,1) + + for ax in axes[-1,:].flatten(): + add_temperature_contours(ax, _ds) + ax.set_yscale('log') + ax.set_yticks([1e5,1e4,1e3,1e2,1e1,1e0]) + ax.set_ylim(1.1e5,1) + + ax.set_xlim(-90,90) + ax.set_xticks(np.arange(-90,91,15)) + format_latitude(ax) + ax.set_xlabel('Latitude') + + for ax in axes[:,0]: + format_pressure(ax) + + x = (get_figure_center(axes[0,0]) + get_figure_center(axes[0,1]))/2 + y = get_figure_top(fig, axes[0,0], include_hspace=True) + + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + fig.suptitle(f"{name_string}\n{_ds.attrs['experiment']} minus {ds.attrs['experiment']}\nFluxes, cloud radiative effects and heating rates", + x=x, y=y-0.025, va='bottom', fontsize='xx-large') + + add_subfigure_labels(axes, flatten_order='C') # This will go across columns, then down rows + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def plot_output_scalar(IFS_srcfile, ecRAD_srcfiles, ecRAD_styles, dstfile=None, latitudes_to_highlight=None, line_ds='default', title=None): + + with sns.axes_style("ticks", {"xtick.major.size": 6, "ytick.major.size": 6}): + + nrows=4 + ncols=2 + fig, axes = plt.subplots(figsize=(11.0*ncols,3.*nrows), nrows=nrows, ncols=ncols, sharex=True, gridspec_kw={'wspace':0.05, 'hspace':0.25}) + + main_legend_labels = [] + main_legend_handles = [] + for i, (_style, _srcfile) in enumerate(zip(ecRAD_styles, ecRAD_srcfiles)): + _ds = load_ecRAD(_srcfile, IFS_srcfile) + + if i == 0: + + # LW upwelling at surface + _line = (_ds.flux_up_lw.isel(half_level=-1)).plot(ax=axes[0,0], color='0.85', zorder=-1, lw=3, **{'label':'Upwelling longwave\nflux at surface'})[0] + minor_legend_ax0 = axes[0,0].legend([_line], ['Longwave upwelling\nflux at surface'], loc='upper left', frameon=False, fontsize='x-small') + for text in minor_legend_ax0.get_texts(): + text.set_color("0.75") + + #SW downwelling at TOA + _line = (_ds.flux_dn_direct_sw_clear.isel(half_level=0)).plot(ax=axes[1,1], color='0.85', zorder=-1, lw=3, **{'label':'Shortwave downwelling\nflux at TOA'})[0] + minor_legend_ax1 = axes[1,1].legend([_line], ['Shortwave downwelling\nflux at TOA'], loc='upper left', frameon=False, fontsize='x-small') + for text in minor_legend_ax1.get_texts(): + text.set_color("0.75") + + main_legend_labels.append(_ds.attrs['experiment']) + + # LW up at TOA + main_legend_handles.append(_ds.flux_up_lw.isel(half_level=0).plot(ax=axes[0,0], x='latitude', drawstyle=line_ds, **{**_style, **{'label':_ds.attrs['experiment']}})) + + # LW down at surface + _ds.flux_dn_lw.isel(half_level=-1).plot(ax=axes[1,0], x='latitude', drawstyle=line_ds, **{**_style, **{'label':_ds.attrs['experiment']}}) + + # LW CRE at TOA + _ds.cloud_radiative_effect_lw.isel(half_level=0).plot(ax=axes[2,0], x='latitude', drawstyle=line_ds, **{**_style, **{'label':_ds.attrs['experiment']}}) + + # Cloud cover + _ds.cloud_cover_sw.plot(ax=axes[3,0], x='latitude', drawstyle=line_ds, **{**_style, **{'label':_ds.attrs['experiment']}}) + + #SW up at TOA + _ds.flux_up_sw.isel(half_level=0).plot(ax=axes[0,1], x='latitude', drawstyle=line_ds, **{**_style, **{'label':_ds.attrs['experiment']}}) + + #SW down at surface + _ds.flux_dn_sw.isel(half_level=-1).plot(ax=axes[1,1], x='latitude', drawstyle=line_ds, **{**_style, **{'label':_ds.attrs['experiment']}}) + + # SW CRE at TOA + _ds.cloud_radiative_effect_sw.isel(half_level=0).plot(ax=axes[2,1], x='latitude', drawstyle=line_ds, **{**_style, **{'label':_ds.attrs['experiment']}}) + + # SW direct dn at surface + _ds.flux_dn_direct_sw.isel(half_level=-1).plot(ax=axes[3,1], x='latitude', drawstyle=line_ds, **{**_style, **{'label':_ds.attrs['experiment']}}) + + for ax in axes[:,1]: + ax.yaxis.set_label_position("right") + ax.yaxis.tick_right() + + axes[0,0].set_ylabel('flux [W m$^{-2}$]') + axes[0,0].set_title('Longwave upwelling flux at TOA', color=sns.color_palette()[3]) + axes[0,0].set_xlabel('') + axes[0,0].add_artist(minor_legend_ax0) + axes[0,0].set_ylim(0, None) + + axes[1,0].set_ylabel('flux [W m$^{-2}$]') + axes[1,0].set_title('Longwave downwelling flux at surface', color=sns.color_palette()[3]) + axes[1,0].set_xlabel('') + axes[1,0].set_ylim(0, None) + + axes[2,0].set_ylabel('CRE [W m$^{-2}$]') + axes[2,0].set_title("Longwave cloud radiative effect at TOA", color=sns.color_palette()[3]) + axes[2,0].set_xlabel('') + + axes[0,1].set_ylabel('flux [W m$^{-2}$]') + axes[0,1].set_title('Shortwave upwelling flux at TOA', color=sns.color_palette()[0]) + axes[0,1].set_xlabel('') + + axes[1,1].set_ylabel('flux [W m$^{-2}$]') + axes[1,1].set_title('Shortwave downwelling flux at surface', color=sns.color_palette()[0]) + axes[1,1].set_xlabel('') + axes[1,1].add_artist(minor_legend_ax1) + + axes[2,1].set_ylabel('CRE [W m$^{-2}$]') + axes[2,1].set_title("Shortwave cloud radiative effect at TOA", color=sns.color_palette()[0]) + axes[2,1].set_xlabel('') + + axes[3,0].set_ylabel('$f_c$ [-]') + axes[3,0].set_title("Cloud cover", color='0.33') + axes[3,0].set_ylim(-0.1, 1.1) + axes[3,0].set_yticks([0, 0.5, 1]) + format_latitude(axes[3,0]) + axes[3,0].set_xlabel('Latitude') + + axes[3,1].set_ylabel('flux [W m$^{-2}$]') + axes[3,1].set_title("Shortwave direct downwelling at surface", color=sns.color_palette()[0]) + axes[3,1].set_xlabel('') + format_latitude(axes[3,1]) + axes[3,1].set_xlabel('Latitude') + + add_subfigure_labels(axes, yloc=1.04) + + if len(ecRAD_srcfiles) > 3: + legend = axes[0,1].legend(frameon=False, loc='upper right', bbox_to_anchor=(1,1.75), fontsize='xx-small', ncol=2) + else: + legend = axes[0,1].legend(frameon=False, loc='upper right', bbox_to_anchor=(1,1.75), fontsize='xx-small', ncol=1) + + fig.suptitle("Fluxes and cloud radiative effects\nat top-of-atmosphere and the surface", y=0.985, fontsize='large') + + axes[-1,0].set_xlim(-90,90) + axes[-1,0].set_xticks(np.arange(-90,91,30)[:-1]) + format_latitude(axes[-1,0]) + axes[-1,0].set_xlabel('Latitude') + + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def compare_output_scalar(IFS_srcfile, ecRAD_srcfiles, reference_ecRAD_srcfile, ecRAD_styles, reference_label="", latitudes_to_highlight=None, line_ds='default', title=None, dstfile=None): + + with sns.axes_style("ticks", {"xtick.major.size": 8, "ytick.major.size": 8}): + + nrows=3 + ncols=2 + + fig, axes = plt.subplots(figsize=(11.0*ncols,3.67*nrows), nrows=nrows, ncols=ncols, sharex=True, gridspec_kw={'hspace':0.4, 'wspace':0.05}) + + for ax in axes[:,1]: + ax.yaxis.set_label_position("right") + ax.yaxis.tick_right() + + ds = load_ecRAD(reference_ecRAD_srcfile, IFS_srcfile) + + for _style, _srcfile in zip(ecRAD_styles, ecRAD_srcfiles): + _ds = load_ecRAD(_srcfile, IFS_srcfile) + + #Longwave net flux at TOA + (_ds.flux_net_lw - ds.flux_net_lw).isel(half_level=0).plot(ax=axes[0,0], x='latitude', drawstyle=line_ds, + **{**_style, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + + #Longwave net flux at surface + (_ds.flux_net_lw - ds.flux_net_lw).isel(half_level=-1).plot(ax=axes[1,0], x='latitude', drawstyle=line_ds, + **{**_style, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + + #Change to cloud cover + (_ds.cloud_cover_sw - ds.cloud_cover_sw).plot(ax=axes[2,0], x='latitude', drawstyle=line_ds, + **{**_style, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + + #Shortwave net flux at TOA + (_ds.flux_net_sw - ds.flux_net_sw).isel(half_level=0).plot(ax=axes[0,1], x='latitude', drawstyle=line_ds, + **{**_style, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + + #Shortwave net flux at surface + (_ds.flux_net_sw - ds.flux_net_sw).isel(half_level=-1).plot(ax=axes[1,1], x='latitude', drawstyle=line_ds, + **{**_style, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + + #Shortwave direct downward at surface + (_ds.flux_dn_direct_sw - ds.flux_dn_direct_sw).isel(half_level=-1).plot(ax=axes[2,1], x='latitude', drawstyle=line_ds, + **{**_style, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + + axes[0,0].set_ylabel('$\Delta$ flux [W m$^{-2}$]') + axes[0,0].set_title('Change in net\nlongwave flux at TOA', color=sns.color_palette()[3]) + axes[0,0].set_xlabel('') + + axes[1,0].set_ylabel('$\Delta$ flux [W m$^{-2}$]') + axes[1,0].set_title('Change in net\nlongwave flux at surface', color=sns.color_palette()[3]) + axes[1,0].set_xlabel('') + + axes[2,0].set_ylabel('$\Delta$ cloud cover [-]') + axes[2,0].set_title("Change in cloud cover", color='0.33') + #axes[2,0].set_ylim(0,None) + + axes[0,1].set_ylabel('$\Delta$ flux [W m$^{-2}$]') + axes[0,1].set_title('Change in net\nshortwave flux at TOA', color=sns.color_palette()[0]) + axes[0,1].set_xlabel('') + if len(ecRAD_srcfiles) > 2: + legend = axes[0,1].legend(frameon=False, loc='upper right', bbox_to_anchor=(1.2,1.67), fontsize='xx-small', ncol=2) + else: + legend = axes[0,1].legend(frameon=False, loc='upper right', bbox_to_anchor=(1.2,1.67), fontsize='xx-small', ncol=1) + + axes[1,1].set_ylabel('$\Delta$ flux [W m$^{-2}$]') + axes[1,1].set_title('Change in net\nshortwave flux at surface', color=sns.color_palette()[0]) + axes[1,1].set_xlabel('') + + axes[2,1].set_ylabel('$\Delta$ flux [W m$^{-2}$]') + axes[2,1].set_title("Change in direct downwelling\nshortwave flux at surface", color=sns.color_palette()[0]) + + axes[2,0].set_xlim(-90,90) + axes[2,0].set_xticks(np.arange(-90,90,30)) + format_latitude(axes[2,0]) + axes[2,0].set_xlabel('Latitude') + axes[2,1].set_xlabel('Latitude') + + add_subfigure_labels(axes, yloc=1.04) + + fig.suptitle("Fluxes and cloud radiative effects\nat top-of-atmosphere and the surface", y=1.025, fontsize='large') + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + + +def plot_on_hybrid_pressure_axis(_axes, x, y, linedict, overwriting=False): + #Log part of the plot + _axes[0].plot(x, y, **linedict) + _axes[1].plot(x, y, **linedict) + + if not overwriting: + _axes[0].set_yscale('log') + format_pressure(_axes[0], label='') + _axes[0].set_yticks([1000,100,10,1]) + _axes[0].set_ylim(10000,1) + + #Linear part of the plot + format_pressure(_axes[1], label='') + _axes[1].set_yticks(np.linspace(9e4,1e4,5, dtype='float')) + _axes[1].set_ylim(101000,10000) + + # Hide the right and top spines + _axes[0].spines['bottom'].set_visible(False) + _axes[1].spines['top'].set_visible(False) + _axes[0].spines['bottom'].set_visible(False) + _axes[1].spines['top'].set_visible(False) + + _axes[0].axhline(10000, lw=3.5, color='0.67', ls='-', zorder=-11) + _axes[0].text(0.99, 0.03, 'log', color='0.67', fontsize='small', va='bottom', ha='right', transform=_axes[0].transAxes, zorder=-10) + _axes[1].text(0.99, 0.99, 'linear', color='0.67', fontsize='small', va='top', ha='right', transform=_axes[1].transAxes, zorder=-10) + + +def label_hybrid_pressure_axes(_axes): + l = _axes[0].set_ylabel('Pressure [hPa]') + x, y = l.get_position() + l.set_position((x, y - 1)) + + +def plot_input_profile(latitude, IFS_srcfile, dstfile=None, title=None): + + from ecradplot import io as eio + from ecradplot import plot as eplt + + with sns.plotting_context('talk'): + ncols=4 + nrows=5 + fig, axes = plt.subplots(figsize=(4.5*ncols,11.5), ncols=ncols, nrows=nrows, gridspec_kw={'hspace':0, 'height_ratios':[1,2,1,1,2]}) + + _ds = eio.load_inputs(IFS_srcfile).sel(latitude=latitude, method='nearest') + + #Temperature + i=0 + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.temperature_hl, _ds.pressure_hl, {'lw':5, 'color':sns.color_palette()[3]}) + + #Specific humidity + i+=1 + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.q, _ds.pressure_fl, {'lw':5, 'color':sns.color_palette()[0]}) + + #Cloud fraction + i+=1 + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.cloud_fraction, _ds.pressure_fl, {'lw':5, 'color':'0.5'}) + + #Water content + i+=1 + plot_on_hybrid_pressure_axis(axes[:2,i], 1e6*_ds.q_liquid.where(_ds.q_liquid > 1e-10).fillna(0), _ds.pressure_fl, + {'lw':5, 'color':sns.color_palette()[3], 'label':'liquid'}) + plot_on_hybrid_pressure_axis(axes[:2,i], 1e6*_ds.q_ice.where(_ds.q_ice > 1e-10).fillna(0), _ds.pressure_fl, + {'lw':5, 'color':sns.color_palette()[0], 'label':'ice'}, overwriting=True) + + #Ozone + i=0 + plot_on_hybrid_pressure_axis(axes[-2:,i], _ds.o3_mmr, _ds.pressure_fl, {'label':'O$_3$', 'lw':5, 'color':sns.color_palette()[1]}) + + #O2 + C02 + CH4 + N20 + CFC + i+=1 + plot_on_hybrid_pressure_axis(axes[-2:,i], _ds.ch4_vmr, _ds.pressure_fl, {'label':'CH$_4$', 'lw':5, 'color':sns.color_palette()[0]}) + plot_on_hybrid_pressure_axis(axes[-2:,i], _ds.n2o_vmr, _ds.pressure_fl, {'label':'N$_2$O', 'lw':5, 'color':sns.color_palette()[3]}, overwriting=True) + + i+=1 + plot_on_hybrid_pressure_axis(axes[-2:,i], 1e6*_ds.co2_vmr, _ds.pressure_fl, {'label':'CO$_2$', 'lw':5, 'color':sns.color_palette()[2]}) + + #Aerosols + i+=1 + plot_on_hybrid_pressure_axis(axes[-2:,i], _ds.sea_salt, _ds.pressure_fl, {'label':'sea salt', 'lw':5, 'color':sns.color_palette()[0]}) + plot_on_hybrid_pressure_axis(axes[-2:,i], _ds.dust, _ds.pressure_fl, {'label':'dust', 'lw':5, 'color':sns.color_palette()[1]}, overwriting=True) + plot_on_hybrid_pressure_axis(axes[-2:,i], _ds.organics, _ds.pressure_fl, {'label':'org.', 'lw':5, 'color':sns.color_palette()[2]}, overwriting=True) + plot_on_hybrid_pressure_axis(axes[-2:,i], _ds.black_carbon, _ds.pressure_fl, {'label':'carbon', 'lw':5, 'color':'0.5'}, overwriting=True) + plot_on_hybrid_pressure_axis(axes[-2:,i], _ds.sulphate, _ds.pressure_fl, {'label':'sulph.', 'lw':5, 'color':sns.color_palette()[3]}, overwriting=True) + + axes[0,0].set_title('Temperature') + axes[1,0].set_xlabel("$T$ [K]") + for ax in axes[:2,0]: + ax.set_xlim(170,320) + + axes[0,1].set_title('Specific\nhumidity') + axes[1,1].set_xlabel("$q$ [kg kg$^{-1}$]") + for ax in axes[:2,1]: + ax.set_xlim(1e-6,1e-1) + ax.set_xscale('log') + + axes[0,2].set_title('Cloud fraction') + axes[1,2].set_xlabel('$f_c$ [-]') + for ax in axes[:2,2]: + ax.set_xlim(0,1) + + axes[0,3].set_title('Cloud\nwater content') + axes[1,3].set_xlabel('$q$ [kg kg$^{-1}$]') + + axes[3,0].set_title('Ozone') + axes[4,0].set_xlabel("$q_i$ [kg kg$^{-1}$]") + for ax in axes[3:,0]: + ax.set_xscale('log') + ax.set_xticks([1e-7,1e-6,1e-5]) + + axes[3,1].set_title('Other gases') + axes[4,1].set_xlabel('$q_i$ [ppm]') + for ax in axes[3:,1]: + ax.set_xscale('log') + ax.set_xticks([1e-7,1e-6,1e-5]) + + axes[3,2].set_title('Other gases') + axes[4,2].set_xlabel('$q_i$ [ppm]') + for ax in axes[3:2]: + ax.set_xlim(395,415) + + axes[3,3].set_title('Aerosols') + for ax in axes[3:,3]: + ax.set_xscale('log') + ax.set_xticks([1e-12,1e-9,1e-6]) + axes[4,3].set_xlabel('mixing ratio\n[kg kg$^{-1}$]') + + axes[0,3].legend(frameon=False, fontsize='small') + axes[3,1].legend(frameon=False, loc='upper right', fontsize='small') + axes[3,2].legend(frameon=False, loc='upper right', fontsize='small') + axes[3,3].legend(frameon=False, loc='upper left', fontsize='x-small', handlelength=1.01, bbox_to_anchor=(1,1)) + + for ax in axes[2,:]: + ax.set_axis_off() + ax.get_xaxis().set_visible(False) + ax.get_xaxis().set_visible(False) + + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + + label_hybrid_pressure_axes(axes[:2,0]) + label_hybrid_pressure_axes(axes[-2:,0]) + + for ax in axes[:, 1:].flatten(): + ax.set_ylabel("") + ax.set_yticklabels([]) + + for ax in axes[0, :].flatten(): + ax.set_xlabel("") + ax.set_xticklabels([]) + + for ax in axes[3, :].flatten(): + ax.set_xlabel("") + ax.set_xticklabels([]) + + add_subfigure_labels(axes[0,:], xloc=0.015, yloc=0.85, zorder=10, flatten_order='C') + add_subfigure_labels(axes[3,:], xloc=0.015, yloc=0.85, zorder=10, flatten_order='C', label_list=['e','f','g','h']) + + fig.suptitle(f"{name_string}\nIFS cloud, aerosol and radiation fields\nProfile at {fancy_format_latitude(latitude)}", y=0.95, va='bottom', fontsize='x-large') + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + + +def plot_output_profile(latitude, IFS_srcfile, ecRAD_srcfiles, linedicts, dstfile=None, + clearsky_linedict={ 'ls':'--'}): + + with sns.plotting_context('talk'): + + ncols=4 + nrows=5 + fig, axes = plt.subplots(figsize=(4.5*ncols,12), nrows=nrows, ncols=ncols, gridspec_kw={'hspace':0, 'height_ratios':[1,2,1.1,1,2]}) + + for j, ecRAD_srcfile in enumerate(ecRAD_srcfiles): + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile).sel(latitude=latitude, method='nearest') + + i = 0 + if j == 0: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_dn_lw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}) + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_dn_lw_clear, _ds.pressure_hl, {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_up_lw, _ds.pressure_hl, {**linedicts[j], **{'label':'__nolabel__', 'alpha':0.0}}, overwriting=True) + else: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_dn_lw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}, overwriting=True) + + i+=1 + if j == 0: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_up_lw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}) + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_up_lw_clear, _ds.pressure_hl, {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_dn_lw, _ds.pressure_hl, {**linedicts[j], **{'label':'__nolabel__', 'alpha':0.0}}, overwriting=True) + else: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_up_lw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}, overwriting=True) + + i+=1 + if j == 0: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.cloud_radiative_effect_lw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}) + else: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.cloud_radiative_effect_lw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}, overwriting=True) + + i+=1 + if j == 0: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.heating_rate_lw, _ds.pressure_fl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}) + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.heating_rate_lw_clear, _ds.pressure_fl, {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + else: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.heating_rate_lw, _ds.pressure_fl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}, overwriting=True) + + + i=0 + if j == 0: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_dn_sw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}) + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_dn_sw_clear, _ds.pressure_hl, {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_up_sw, _ds.pressure_hl, {**linedicts[j], **{'label':'__nolabel__', 'alpha':0.0}}, overwriting=True) + else: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_dn_sw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}, overwriting=True) + + i+=1 + if j == 0: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_up_sw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}) + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_up_sw_clear, _ds.pressure_hl, {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_dn_sw, _ds.pressure_hl, {**linedicts[j], **{'label':'__nolabel__', 'alpha':0.0}}, overwriting=True) + else: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_up_sw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}, overwriting=True) + + i+=1 + if j == 0: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.cloud_radiative_effect_sw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}) + else: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.cloud_radiative_effect_sw, _ds.pressure_hl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}, overwriting=True) + + i+=1 + if j == 0: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.heating_rate_sw, _ds.pressure_fl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}) + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.heating_rate_sw_clear, _ds.pressure_fl, {**linedicts[j], **clearsky_linedict, **{'label':_ds.attrs['experiment']}}, overwriting=True) + else: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.heating_rate_sw, _ds.pressure_fl, {**linedicts[j], **{'label':_ds.attrs['experiment']}}, overwriting=True) + + heating_rate_min = np.floor(np.min(axes[0,-1].get_xlim() + axes[1,-1].get_xlim() + axes[3,-1].get_xlim() + axes[4,-1].get_xlim())) + heating_rate_max = np.ceil(np.max(axes[0,-1].get_xlim() + axes[1,-1].get_xlim() + axes[3,-1].get_xlim() + axes[4,-1].get_xlim())) + heating_rate_abs_lim = np.max([np.abs(heating_rate_min), heating_rate_max]) + + for ax in axes[:,:2].flatten(): + ax.set_xlim(0,None) + + axes[0,-1].set_xlim(-1*heating_rate_abs_lim, None) + axes[1,-1].set_xlim(-1*heating_rate_abs_lim, None) + axes[3,-1].set_xlim(None, heating_rate_abs_lim) + axes[4,-1].set_xlim(None, heating_rate_abs_lim) + + axes[0,0].set_title('Downwelling\nlongwave flux', color=sns.color_palette()[3]) + axes[0,1].set_title('Upwelling\nlongwave flux', color=sns.color_palette()[3]) + axes[0,2].set_title('Longwave CRE', color=sns.color_palette()[3]) + axes[0,3].set_title('Longwave\nheating rate', color=sns.color_palette()[3]) + + axes[3,0].set_title('Downwelling\nshortwave flux', color=sns.color_palette()[0]) + axes[3,1].set_title('Upwelling\nshortwave flux', color=sns.color_palette()[0]) + axes[3,2].set_title('Shortwave CRE', color=sns.color_palette()[0]) + axes[3,3].set_title('Shortwave\nheating rate', color=sns.color_palette()[0]) + + for ax in axes[1,:3]: + ax.set_xlabel('[W m$^{-2}$]') + for ax in axes[1,3:]: + ax.set_xlabel('[K d$^{-1}$]') + + for ax in axes[4,:3]: + ax.set_xlabel('[W m$^{-2}$]') + for ax in axes[4,3:]: + ax.set_xlabel('[K d$^{-1}$]') + + for ax in axes[2,:]: + ax.set_axis_off() + ax.get_xaxis().set_visible(False) + ax.get_xaxis().set_visible(False) + + axes[0,-1].legend(loc='upper left', frameon=False, bbox_to_anchor=(1,1)) + + label_hybrid_pressure_axes(axes[:2,0]) + label_hybrid_pressure_axes(axes[-2:,0]) + + for ax in axes[:, 1:].flatten(): + ax.set_ylabel("") + ax.set_yticklabels([]) + + for ax in axes[0, :].flatten(): + ax.set_xlabel("") + ax.set_xticklabels([]) + + for ax in axes[3, :].flatten(): + ax.set_xlabel("") + ax.set_xticklabels([]) + + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + fig.suptitle(f'{name_string}\nProfile at {fancy_format_latitude(latitude)}', y=0.95, va='bottom', fontsize='x-large') + + add_subfigure_labels(axes[0,:], xloc=0.025, yloc=0.85, zorder=10) + add_subfigure_labels(axes[3,:], xloc=0.025, yloc=0.85, zorder=10, label_list=['e','f','g','h']) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes + + +def compare_output_profile(latitude, IFS_srcfile, ecRAD_reference_srcfile, ecRAD_srcfiles, linedicts, dstfile=None, + clearsky_linedict={'ls':'--'}): + + with sns.plotting_context('talk'): + + ncols=4 + nrows=5 + fig, axes = plt.subplots(figsize=(4.5*ncols,12), nrows=nrows, ncols=ncols, gridspec_kw={'hspace':0, 'height_ratios':[1,2,1.2,1,2]}) + + ds = load_ecRAD(ecRAD_reference_srcfile, IFS_srcfile).sel(latitude=latitude, method='nearest') + + for j, ecRAD_srcfile in enumerate(ecRAD_srcfiles): + _ds = load_ecRAD(ecRAD_srcfile, IFS_srcfile).sel(latitude=latitude, method='nearest') + + i = 0 + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_dn_lw - ds.flux_dn_lw, _ds.pressure_hl, + {**linedicts[j], **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + if j == 0: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_dn_lw_clear - ds.flux_dn_lw_clear, _ds.pressure_hl, + {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + + i+=1 + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_up_lw - ds.flux_up_lw, _ds.pressure_hl, + {**linedicts[j], **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + if j == 0: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.flux_up_lw_clear - ds.flux_up_lw_clear, _ds.pressure_hl, + {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + + i+=1 + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.cloud_radiative_effect_lw - ds.cloud_radiative_effect_lw, _ds.pressure_hl, + {**linedicts[j], **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + + i+=1 + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.heating_rate_lw - ds.heating_rate_lw, _ds.pressure_fl, + {**linedicts[j], **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + if j == 0: + plot_on_hybrid_pressure_axis(axes[:2,i], _ds.heating_rate_lw_clear - ds.heating_rate_lw_clear, _ds.pressure_fl, + {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + + + i=0 + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_dn_sw - ds.flux_dn_sw, _ds.pressure_hl, + {**linedicts[j], **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + if j == 0: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_dn_sw_clear - ds.flux_dn_sw_clear, _ds.pressure_hl, + {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + + i+=1 + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_up_sw - ds.flux_up_sw, _ds.pressure_hl, + {**linedicts[j], **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + if j == 0: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.flux_up_sw_clear - ds.flux_up_sw_clear, _ds.pressure_hl, + {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + + i+=1 + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.cloud_radiative_effect_sw - ds.cloud_radiative_effect_sw, _ds.pressure_hl, + {**linedicts[j], **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + + i+=1 + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.heating_rate_sw - ds.heating_rate_sw, _ds.pressure_fl, + {**linedicts[j], **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}"}}) + if j == 0: + plot_on_hybrid_pressure_axis(axes[3:,i], _ds.heating_rate_sw_clear - ds.heating_rate_sw_clear, _ds.pressure_fl, + {**linedicts[j], **clearsky_linedict, **{'label':f"{_ds.attrs['experiment']} $-$ {ds.attrs['experiment']}\n(clearsky)"}}, overwriting=True) + + + axes[0,0].set_title('Change to downwelling\nlongwave flux', color=sns.color_palette()[3]) + axes[0,1].set_title('Change to upwelling\nlongwave flux', color=sns.color_palette()[3]) + axes[0,2].set_title('Change to \nlongwave CRE', color=sns.color_palette()[3]) + axes[0,3].set_title('Change to longwave\nheating rate', color=sns.color_palette()[3]) + + axes[3,0].set_title('Change to downwelling\nshortwave flux', color=sns.color_palette()[0]) + axes[3,1].set_title('Change to upwelling\nshortwave flux', color=sns.color_palette()[0]) + axes[3,2].set_title('Change to\nshortwave CRE', color=sns.color_palette()[0]) + axes[3,3].set_title('Change to shortwave\nheating rate', color=sns.color_palette()[0]) + + for ax in axes[1,:3]: + ax.set_xlabel('[W m$^{-2}$]') + for ax in axes[1,3:]: + ax.set_xlabel('[K d$^{-1}$]') + + for ax in axes[4,:3]: + ax.set_xlabel('[W m$^{-2}$]') + for ax in axes[4,3:]: + ax.set_xlabel('[K d$^{-1}$]') + + for ax in axes[2,:]: + ax.set_axis_off() + ax.get_xaxis().set_visible(False) + ax.get_xaxis().set_visible(False) + + axes[0,-1].legend(loc='upper left', frameon=False, bbox_to_anchor=(1,1)) + + label_hybrid_pressure_axes(axes[:2,0]) + label_hybrid_pressure_axes(axes[-2:,0]) + + for ax in axes[:, 1:].flatten(): + ax.set_ylabel("") + ax.set_yticklabels([]) + + for ax in axes[0, :].flatten(): + ax.set_xlabel("") + ax.set_xticklabels([]) + + for ax in axes[3, :].flatten(): + ax.set_xlabel("") + ax.set_xticklabels([]) + + name_string = os.path.splitext(os.path.basename(IFS_srcfile))[0] + fig.suptitle(f'{name_string}\nProfile at {fancy_format_latitude(latitude)}', y=0.95, va='bottom', fontsize='x-large') + + add_subfigure_labels(axes[0,:], xloc=0.015, yloc=0.85, zorder=10) + add_subfigure_labels(axes[3,:], xloc=0.015, yloc=0.85, zorder=10, label_list=['e','f','g','h']) + + if dstfile: + fig.savefig(dstfile, dpi=90, bbox_inches='tight') + else: + return fig, axes Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_input.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_input.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_input.py (revision 6016) @@ -0,0 +1,34 @@ +#!/usr/bin/env python3 + +def warn(*args, **kwargs): + pass + +import os, warnings +warnings.warn = warn + +from ecradplot import plot as eplt + +def main(input_srcfile, dstdir): + """ + Plot input files + """ + + if not os.path.isdir(dstdir): + os.makedirs(dstdir) + + #Get input file name + name_string = os.path.splitext(os.path.basename(input_srcfile))[0] + + dstfile = os.path.join(dstdir, name_string + ".png") + + print(f"Plotting inputs to {dstfile}") + eplt.plot_inputs(input_srcfile, dstfile=dstfile); + +if __name__ == "__main__": + import argparse + parser = argparse.ArgumentParser(description="Plot surface properties, atmospheric composition and clouds from input file to ecRAD.") + parser.add_argument("input", help="ecRAD input file") + parser.add_argument("--dstdir", help="Destination directory for plots", default="./") + args = parser.parse_args() + + main(args.input, args.dstdir) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_input_profile.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_input_profile.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_input_profile.py (revision 6016) @@ -0,0 +1,35 @@ +#!/usr/bin/env python3 + +def warn(*args, **kwargs): + pass + +import os, warnings +warnings.warn = warn + +from ecradplot import plot as eplt + +def main(latitude, input_srcfile, dstdir): + """ + Plot input files + """ + + import os + if not os.path.isdir(dstdir): + os.makedirs(dstdir) + + name_string = os.path.splitext(os.path.basename(input_srcfile))[0] + + dstfile = os.path.join(dstdir, name_string + f"_profile_{eplt.unfancy_format_latitude(latitude)}.png") + + print(f"Plotting inputs profile to {dstfile}") + eplt.plot_input_profile(latitude, input_srcfile, dstfile=dstfile); + +if __name__ == "__main__": + import argparse + parser = argparse.ArgumentParser(description="Plot profiles of atmospheric composition and clouds from input file to ecRAD.") + parser.add_argument("latitude", help="Latitude at which to extract profiles", type=float) + parser.add_argument("input", help="ecRAD input file") + parser.add_argument("--dstdir", help="Destination directory for plots", default="./") + args = parser.parse_args() + + main(args.latitude, args.input, args.dstdir) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output.py (revision 6016) @@ -0,0 +1,36 @@ +#!/usr/bin/env python3 + +def warn(*args, **kwargs): + pass + +import os, warnings +warnings.warn = warn + +from ecradplot import plot as eplt + +def main(input_srcfile, output_srcfile, dstdir): + """ + Plot radiation fields (fluxes, CRE, and heating rates) + """ + + import os + if not os.path.isdir(dstdir): + os.makedirs(dstdir) + + name_string = os.path.splitext(os.path.basename(input_srcfile))[0] + output_string = os.path.splitext(os.path.basename(output_srcfile))[0] + + dstfile = os.path.join(dstdir, f"{name_string}_{output_string}.png") + + print(f"Plotting output to {dstfile}") + eplt.plot_output(input_srcfile, output_srcfile, dstfile=dstfile); + +if __name__ == "__main__": + import argparse + parser = argparse.ArgumentParser(description="Plot radiative fluxes and heating rates from ecRAD output file.") + parser.add_argument("input", help="ecRAD input file") + parser.add_argument("output", help="ecRAD output file") + parser.add_argument("--dstdir", help="Destination directory for plots", default="./") + args = parser.parse_args() + + main(args.input, args.output, args.dstdir) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output_profile.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output_profile.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output_profile.py (revision 6016) @@ -0,0 +1,60 @@ +#!/usr/bin/env python3 +import os +import warnings +import seaborn as sns +from ecradplot import plot as eplt + +def warn(*args, **kwargs): + pass + +warnings.warn = warn + + +def format_latitude(latitude): + if latitude<0: + return f"{abs(latitude):.0f}S" + + return f"{abs(latitude):.0f}N" + +def main(latitude, input_srcfile, output_srcfiles, dstdir): + """ + Plot input files + """ + + if not os.path.isdir(dstdir): + os.makedirs(dstdir) + + name_string = os.path.splitext(os.path.basename(input_srcfile))[0] + outputs_string = "_".join([os.path.splitext(os.path.basename(f))[0] for f in output_srcfiles]) + + styles = [{'lw':3, 'color':'k', 'ls':'-', 'zorder':10}, + #{'lw':4, 'color':'0.5', 'ls':'-'}, + #{'lw':4, 'color':'0.75', 'ls':'-'}, + {'lw':5, 'color':sns.color_palette()[0], 'ls':'-'}, + {'lw':5, 'color':sns.color_palette()[2], 'ls':'-'}, + {'lw':3, 'color':sns.color_palette()[3], 'ls':'--'}, + {'lw':3, 'color':sns.color_palette()[5], 'ls':'-.'}, + {'lw':5, 'color':sns.color_palette()[6], 'ls':'-'}, + {'lw':5, 'color':sns.color_palette()[9], 'ls':'-'}] + + + dstfile = os.path.join( + dstdir, + f"{name_string}_{outputs_string}_profile_{format_latitude(latitude)}.png" + ) + print(f"Plotting output profiles to {dstfile}") + eplt.plot_output_profile(latitude, input_srcfile, output_srcfiles, styles, dstfile=dstfile) + +if __name__ == "__main__": + import argparse + parser = argparse.ArgumentParser( + description="Plot radiative fluxes and heating rates from ecRAD output file. \ + If a reference file is given, plot differences with respect to the reference." + ) + parser.add_argument("latitude", help="Latitude at which to extract profiles", type=float) + parser.add_argument("input", help="ecRAD input file") + parser.add_argument("outputs", help="ecRAD output files", nargs='+') + parser.add_argument("--dstdir", help="Destination directory for plots", default="./") + args = parser.parse_args() + + main(args.latitude, args.input, args.outputs, args.dstdir) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output_scalar.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output_scalar.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/plot_output_scalar.py (revision 6016) @@ -0,0 +1,44 @@ +#!/usr/bin/env python3 + +def warn(*args, **kwargs): + pass + +import os, warnings +warnings.warn = warn + +from ecradplot import plot as eplt + +def main(input_srcfile, output_srcfiles, dstdir): + """ + Plot input files + """ + + import os + if not os.path.isdir(dstdir): + os.makedirs(dstdir) + + import seaborn as sns + name_string = os.path.splitext(os.path.basename(input_srcfile))[0] + outputs_string = "_".join([os.path.splitext(os.path.basename(f))[0] for f in output_srcfiles]) + + styles = [{'lw':2, 'color':'k', 'ls':'-', 'zorder':10}, + {'lw':4, 'color':sns.color_palette()[0], 'ls':'-'}, + {'lw':4, 'color':sns.color_palette()[2], 'ls':'-'}, + {'lw':2, 'color':sns.color_palette()[3], 'ls':'--'}, + {'lw':2, 'color':sns.color_palette()[5], 'ls':'-.'}, + {'lw':4, 'color':sns.color_palette()[6], 'ls':'-'}, + {'lw':4, 'color':sns.color_palette()[9], 'ls':'-'}] + + dstfile = f"{dstdir}/{name_string}_{outputs_string}_surface_and_TOA.png" + print(f"Plotting integrated and TOA outputs to {dstfile}") + eplt.plot_output_scalar(input_srcfile, output_srcfiles, styles, dstfile=dstfile) + +if __name__ == "__main__": + import argparse + parser = argparse.ArgumentParser(description="Plot radiative fluxes and heating rates from ecRAD output file.") + parser.add_argument("input", help="ecRAD input file") + parser.add_argument("outputs", help="ecRAD output files", nargs='+') + parser.add_argument("--dstdir", help="Destination directory for plots", default="./") + args = parser.parse_args() + + main(args.input, args.outputs, args.dstdir) Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/radiation_practical.ipynb =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/radiation_practical.ipynb (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/practical/radiation_practical.ipynb (revision 6016) @@ -0,0 +1,630 @@ +{ + "cells": [ + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "# Modelling atmospheric radiative transfer\n", + "\n", + "**Robin J Hogan and Shannon L Mason**\n", + "\n", + "## 1. Introduction\n", + "\n", + "In this practical, the offline version of ECMWF’s atmospheric radiation scheme *ecRad* [(Hogan and Bozzo, 2018)](https://agupubs.onlinelibrary.wiley.com/doi/pdfdirect/10.1029/2018MS001364)\n", + "will be used to gain an understanding of how radiative transfer is modelled, and how both radiative fluxes and atmospheric heating rates are sensitive to gas concentrations, clouds and aerosols. \n", + "\n", + "The input data consist of a slice through the atmosphere from the North Pole to the South Pole at a longitude of 5$^{\\circ}$E at 12 UTC on 11 July 2019, as represented by ECMWF’s ERA5 reanalysis system. \n", + "The data are stored at 137 levels from the surface to the middle mesosphere (a pressure of 1 Pa), and have been extracted at every 0.5$^{\\circ}$ interval in latitude. \n", + "This slice includes a range of atmospheric and surface conditions, from marine stratocumulus to deep convection, sea ice to a hot desert surface, and pristine marine air over the Southern Ocean to the dust-laden Saharan boundary layer.\n", + "\n", + "**Visualise the input data along the slice by running the `plot_input` script.**\n", + "\n", + "***Note: we run the plotting scripts as Python modules, but they can also be run in the command-line if you wish.***" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [ + "#First we import all of our plotting scripts\n", + "import plot_input, plot_input_profile, plot_output, plot_output_profile, plot_output_scalar, compare_output, compare_output_profile, compare_output_scalar" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [ + "plot_input.main(\"era5slice.nc\")" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "Profiles of input data at a given latitude can be plotted using \n", + "\n", + " plot_input_profile.main(10, \"era5slice.nc\")\n", + "\n", + "**Try plotting profiles of the input data at a few different latitudes by copying and changing the lines below:**" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## 2. The Control experiment\n", + "\n", + "The contents of this directory will include the following files:\n", + "\n", + "- **`radiation_practical.ipynb`** \n", + "This notebook.\n", + "\n", + "- **`ecrad_1.3.1/`**\n", + "The ecrad source code.\n", + "\n", + "- **`ecrad`** \n", + "A symbolic link to the *ecRad* executable.\n", + "\n", + "- **`data/`** \n", + "A symbolic link to the *ecRad* data directory.\n", + "\n", + "- **`config.nam`** \n", + "A Fortran namelist file for configuring *ecRad* in its control configuration.\n", + "\n", + "- **`era5slice.nc`** \n", + "A netCDF file containing the input data; some of its contents are shown in Section 1 above.\n", + "\n", + "- **`*.py`** \n", + "Python scripts for plotting the data; see Section 6 for a description of all the scripts.\n", + "\n", + "- **`ecradplot/`** \n", + "A directory containing the Python library for plotting *ecRad* data.\n", + "\n", + "- **`clean.sh`**\n", + "A little script for cleaning up changes to the working directory, including reverting this Notebook back to a clean state (any changes you've made in the Notebook be coped with a timestamp)." + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### 2.1 Running *ecRad*\n", + "\n", + "Now the following runs *ecRad* on the input data using the configuration specified in `config.nam`, and writes the output to a NetCDF file `control.nc`:\n", + "\n", + " ./ecrad config.nam era5slice.nc control.nc\n", + " \n", + "***NOTE: This can be run from a terminal within Jupyter Lab (select \"terminal\" from the \"new launcher\" button), or within a cell in this Notebook by putting the \"!\" character at the front of the line.***" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": { + "scrolled": true + }, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### 2.2 Visualising *ecRad* outputs\n", + "\n", + "#### 2.2.1 Plotting 2D fields\n", + "\n", + "**To visualise some key fields from the output file `control.nc`, run the `plot_output.py` script with:**\n", + " \n", + " plot_output.main(\"era5slice.nc\", \"control.nc\")" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 2.2.2 Plotting profiles\n", + "\n", + "**Plot profiles of *ecRad* output at a specific latitude (e.g. 10N) by running `plot_output_profile.py`**\n", + "\n", + " plot_output_profile.main(10, \"era5slice.nc\", [\"control.nc\"])\n", + "\n", + "where `latitude` is a number in the range [-90,90]; e.g. 10, producing a file `era5slice_control_profile_10N.png`. " + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "**Try plotting a few different radiation profiles at the same locations you looked at above.**" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 2.2.3 Plotting 1D fields\n", + "\n", + "**Run `plot_output_scalar` to plots the surface and top-of-atmosphere fluxes along the slice:**\n", + "\n", + " plot_output_scalar.main(\"era5slice.nc\", [\"control.nc\"])\n", + "\n", + "producing the file `era5slice_control_surface_and_TOA.png`" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "***NOTE: if additional ecRad output files from other experiments (see later sections) are provided as arguments to `plot_output_scalar`, they will be overplotted in different colours.***" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "Have a look at the figures that have been created. There are three types of variable:\n", + "\n", + "- Upwelling and downwelling shortwave (solar) and longwave (thermal-infrared) irradiances, i.e. the radiativepower passing through a horizontal surface at a particular height in the atmosphere, with units of W m$^{−2}$. \n", + "The labels of the plots use the more common term \"flux\" instead of irradiance, and we will use the same for the remainder of this document. \n", + "The net flux is defined as the downwelling minus the upwelling flux.\n", + "\n", + "- Shortwave and longwave atmospheric heating rates (HR) computed from the vertical divergence of the netflux in pressure coordinates: $$\\mathrm{HR} = −\\dfrac{g_0}{C_p} \\dfrac{\\mathrm{d} F_n}{\\mathrm{d}p},$$ where $F_n$ is the net flux (shortwave or longwave), $p$ is pressure, $g_0$ is the acceleration due to gravity (standard gravity) and $C_p$ is the specific heat of dry air. \n", + "The plots use units of Kelvin per day (K d$^{−1}$).\n", + "\n", + "- Cloud radiative effect, which is a flux minus the equivalent flux computed without clouds present in the profile, and is commonly used to quantify the warming or cooling effect of clouds on the climate system. *ecRad* output files contain both all-sky and clear-sky fluxes." + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### 2.3 Questions\n", + "\n", + "#### 1. As anyone who has flown in an aeroplane knows, clouds (especially low-level clouds) are turbulent. Explain why, with reference to the radiation fields. Thick low-level clouds are present at 71$^\\circ$N and 15$^\\circ$S." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 2. The net (shortwave plus longwave) heating rate at the stratopause (around 1 hPa) in the Tropics is around +10 K d$^{−1}$. Explain why you would not expect the temperature here a week later to be much warmer." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 3. Explain why the shortwave cloud radiative effect drops sharply polewards of around 80$^\\circ$N, yet optically thick clouds are present all the way to the North Pole." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## 3. Greenhouse gases\n", + "\n", + "The remainder of the practical consists of running *ecRad* with different configurations, plotting the change to fluxes and heating rates, and trying to understand the differences. This section is concerned with investigating the effect of changing the concentration of absorbing gases, but the general procedure for performing an experiment is the same in the following two sections which concern perturbing clouds and aerosols.\n", + "\n", + "### 3.1 Doubled-CO2 experiment\n", + "\n", + "Let’s investigate the radiative impact of doubling the concentration of carbon dioxide. Usually in the context of climate change research, a doubled-CO2 experiment is with respect to preindustrial concentrations (surface volume mixing ratio of around 280 ppmv), but since our control experiment is from 2019 (surface volume mixing ratio ofaround 412 ppmv) we will double the 2019 value. \n", + "\n", + "**Make a new copy of the configuration file with for this experiment (`config_co2x2.name`) using the Jupyter file browser, or in the command-line, e.g.**\n", + "\n", + "``cp config.nam config_co2x2.nam``\n", + "\n", + "**and edit the new configuration file with the Jupyter editor to change these lines:**\n", + "\n", + " !co2_scaling = 1.0,\n", + " experiment_name = \"Control\",\n", + "\n", + "**to these:**\n", + "\n", + " co2_scaling = 2.0,\n", + " experiment_name = \"2x CO2\",\n", + "\n", + "**Then run *ecRad* on it, giving `co2x2.nc` as the filename for the output:**\n", + "\n", + "``./ecrad config_co2x2.nam era5slice.nc co2x2.nc``" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "For a full list of available namelist parameters, see the User Guide at the [*ecRad* web site](https://confluence.ecmwf.int/display/ECRAD). \n", + "In the namelist, lines starting with the `!` character are ignored.\n", + "\n", + "You can compare this experiment with the control as follows:\n", + "\n", + " compare_output.main(\"era5slice.nc\", \"control.nc\", \"co2x2.nc\")" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "and plot selected profiles at a latitude of 17$^{\\circ}$S with\n", + "\n", + " compare_output_profile.main(-17, \"era5slice.nc\", \"control.nc\", [\"co2x2.nc\"])\n", + "\n", + "***Note that if multiple output files are provided as arguments then they will be overplotted, each using the same control.*** " + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "To compare the fluxes and cloud radiative effect at the surface and top-of-atmosphere at all latitudes, use\n", + "\n", + " compare_output_scalar.main(\"era5slice.nc\", \"control.nc\", [\"co2x2.nc\"])\n", + "\n", + "where multiple output files can be provided as arguments." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### 3.2 Questions and exercises \n", + "\n", + "#### 1. Will the stratosphere warm or cool in response to increasing CO2 and why?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 2. By perturbing ozone concentrations (e.g. setting the namelist variable `o3_scaling` to `0.7`), explain the mechanisms by which stratospheric ozone depletion leads to a cooling of the Earth system in the shortwave and the longwave." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 3. By perturbing methane concentrations (e.g. setting the namelist variable `ch4_scaling` to `2.0`), estimate how many times stronger a greenhouse gas methane is than carbon dioxide, per molecule, in terms of instantaneous longwave radiative forcing at top-of-atmosphere. You need to know that the 2019 concentration of methane is around 1.905 ppmv, and that the number of molecules of an ideal gas is proportional its volume mixing ratio with no dependence on the molecular mass. The 5th IPCC report stated that methane has a global warming potential 28 times that of carbon dioxide over a 100-year time period. Why might this be different from your number?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## 4. Clouds \n", + "\n", + "Some of the following involve changing the algorithm used to perform the radiative transfer. The impact on computational cost (important for the configuration of a radiation scheme in a weather or climate model) can be estimated by prefixing the ``./ecrad`` command with `time` and looking at the `user` time reported after *ecRad* has finished." + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### 4.1 Questions and exercises\n", + " \n", + "#### 1. Many models neglect scattering of longwave radiation by clouds for computational expediency. What is the change to longwave cloud radiative effect when longwave scattering is turned off (set `do_lw_cloud_scattering` to `false`)? Why is it of this sign?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 2. The control simulation assumes sub-grid fluctuations in cloud water content such that the fractional standard deviation (the standard deviation divided by the mean) is one. What is the impact on shortwave and longwave cloud radiative effect when clouds are homogeneous (set `fractional_std` to `0.0`) and why?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 3. The control simulation makes the assumption of exponential-random vertical overlap of clouds, which means that vertically separated clouds are randomly overlapped with respect to each other, while vertically contiguous cloud layers decorrelate with separation distance according to an overlap decorrelation length that varies with latitude. What is the impact of making the clouds in all layers overlap randomly (set `overlap_decorr_length_scaling` to `0.0`) and why?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 4. The control simulation uses the *Tripleclouds* solver [(Shonk and Hogan, 2008)](https://git.ecmwf.int/projects/ECRAD/repos/ecrad/raw/practical/ecrad_practical.pdf?at=refs%2Fheads%2Fgithub#cite.Shonk+2008) for performing radiative transfer calculations in the presence of clouds, including the effect of sub-grid fluctuations incloud water content. The operational ECMWF model uses the *McICA* solver [(Pincus et al., 2003)](https://git.ecmwf.int/projects/ECRAD/repos/ecrad/raw/practical/ecrad_practical.pdf?t=refs%2Fheads%2Fgithub#cite.Pincus+2003), which uses a stochastic model to generate sub-grid cloud distributions and can be selected by changing `sw_solver_name` and `lw_solver_name` both to `McICA`. Looking at the atmospheric heating rates (e.g.using `plot_output_profile` at 7$^{\\circ}$N), and the overall computational cost, explain the pros and cons of using *McICA* versus *Tripleclouds* in an operational context." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 5. Ice optical properties are an uncertain part of a radiative transfer scheme. Investigate the size of this uncertainty by switching from the default Fu ice optics model to that of [Yi et al. (2013)](https://git.ecmwf.int/projects/ECRAD/repos/ecrad/raw/practical/ecrad_practical.pdf?at=refs%2Fheads%2Fgithub#cite.Yi+2013) (set `ice_model_name` to `Yi`). Is the main impact in the longwave or shortwave?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 6. A unique property of *ecRad* is the availability of the *SPARTACUS* solver [(Hogan et al., 2016)](https://git.ecmwf.int/projects/ECRAD/repos/ecrad/raw/practical/ecrad_practical.pdf?at=refs%2Fheads%2Fgithub#cite.Hogan+2016) for approximately representing the 3D radiative effects of clouds, available by changing `sw_solver_name` and `lw_solver_name` both to `SPARTACUS`. What is the effect on both the radiation fields and the computational cost?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## 5. Aerosols\n", + "\n", + "### 5.1 Questions and exercises\n", + "\n", + "#### 1. Turn off the interaction of radiation with aerosols by setting the namelist parameter `use_aerosols` to `false`. With reference to the surface fluxes, what do you think the impact of Saharan aerosols is on both daytime and nighttime surface temperature?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 2. The direct downwelling solar radiation is that part of the solar radiation field that has not yet been scattered, and to a first approximation its value at a particular point in the atmosphere is proportional to $\\exp(−\\tau)$, where $\\tau$ is the optical depth of the atmosphere above that point along a path towards the sun. Use a clear-sky profile of direct downwelling solar radiation over Africa to estimate the optical depth of the atmosphere with and without aerosols." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 3. Concentrating solar power installations focus the direct solar beam to generate energy, whereas photovoltaic power installations can use all downwelling solar radiation. Which of these installations is most sensitive to dust storms?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "#### 4. From the effect of aerosols on shortwave radiation at the top-of-atmosphere, do aerosols have a warming or cooling effect on climate? What would the effect on climate be if you turned all the aerosols into black carbon (set each of the elements of `i_aerosol_type_map` to `11` and check the output of *ecRad*)? Why?" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## 6. Quick guide to Python plotting scripts\n", + "\n", + "**``plot_input.main()``** \n", + "Plot the main fields in the input file (`era5slice.nc` in this practical) to the image file `.png`. \n", + "\n", + "**``plot_input_profile.main(,)``** \n", + "Plot profiles of a selection of properties in the input file at the specified latitude (in degrees north) to `_profile_.png`. \n", + "\n", + "**``plot_output.main(,)``**\n", + "Plot the fluxes and heating rates from the specified output file versus latitude and pressure, with the input file providing the temperature and latitude information, and save the result in `_.png`.\n", + "\n", + "**``plot_output_profile.main(,,[,, ...])``**\n", + "Plot profiles of variables from one or more output files at the specified latitude, saving the result in `_[_...]_profile_.png`. \n", + "\n", + "**``plot_output_scalar.main(,[,...])``**\n", + "Line plots versus latitude of upwelling fluxes at top-of-atmosphere, downwelling fluxes at the surface, top-of-atmosphere cloud radiative effect, cloud cover and surface direct shortwave flux, for one or more output files. The result is saved in `_[_...]_surface_and_TOA.png`. \n", + "\n", + "**``compare_output.main(,,)``**\n", + "Plot the difference between the fluxes and heating rates in second output file (the experiment) and the first (the control), saving the result in `__vs_.png.` \n", + "\n", + "**``compare_output_profile.main(,,, [,...])``** \n", + "Compare profiles at the specified latitude of the fluxes and heating rates in several output files, where the first is treated as the control, and write the output to `_[_...]_vs__profile_.png`. \n", + "\n", + "**``compare_output_scalar.main(,,[,...])``**\n", + "Compare net fluxes at top-of-atmosphere and the surface, as well as the cloud cover and surface direct shortwave flux, from several output files, where the first is treated as the control. The result is saved in `_[_...]_vs__scalar.png`. " + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "# References\n", + "\n", + "Hogan, R. J., and A. Bozzo, 2018: A flexible radiation scheme for the ECMWF model. *J. Adv. Model. Earth Syst.*, **10**, [doi:10.1029/2018MS001364](doi:10.1029/2018MS001364).\n", + "\n", + "Hogan, R. J., S. A. K. Schäfer, C. Klinger, J.-C. Chiu and B. Mayer, 2016: Representing 3D cloud-radiation effects in two-stream schemes: 2. Matrix formulation and broadband evaluation. *J. Geophys. Res.*, **121**, 8583–8599.\n", + "\n", + "Pincus, R., H. W. Barker, and J.-J. Morcrette, 2003: A fast, flexible, approximate technique for computing radiative transfer in inhomogeneous clouds. *J. Geophys. Res. Atmos.*, **108**, 4376, [doi:10.1029/2002JD003322](doi:10.1029/2002JD003322).\n", + "\n", + "Shonk, J. K. P., and R. J. Hogan, 2008: Tripleclouds: an efficient method for representing horizontal cloud inho-mogeneity in 1D radiation schemes by using three regions at each height. *J. Climate*, **21**, 2352–2370.\n", + "\n", + "Yi, B., P. Yang, B. A. Baum, T. L’Ecuyer, L. Oreopoulos, E. J. Mlawer, A. J. Heymsfield and K.-K. Liou, 2013: Influence of ice particle surface roughening on the global cloud radiative effect. *J. Atmos. Sci.*, **70**, 2794–2807." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + } + ], + "metadata": { + "kernelspec": { + "display_name": "Python 3", + "language": "python", + "name": "python3" + }, + "language_info": { + "codemirror_mode": { + "name": "ipython", + "version": 3 + }, + "file_extension": ".py", + "mimetype": "text/x-python", + "name": "python", + "nbconvert_exporter": "python", + "pygments_lexer": "ipython3", + "version": "3.6.10" + } + }, + "nbformat": 4, + "nbformat_minor": 4 +} Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/CONVENTIONS =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/CONVENTIONS (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/CONVENTIONS (revision 6016) @@ -0,0 +1,63 @@ +The Fortran conventions that the author of the code in this directory +aspired to are as follows: + + - Module names are prefixed by the static library name, in this case + "radiation" (no need to suffix by "_mod" since this is always + obvious from the context) + + - Names of derived types are suffixed by "_type" + + - Implicit none everywhere + + - Logicals are prefixed by "do_", "use_" or "is_" + + - All variables in SI units by default + + - Variables not in SI units have the units in the variable name, + e.g. pressure_hPa + + - Integers either prefixed by "j" to indicate loop counter, "n" to + indicate the size of an array dimension, or "i" otherwise. + + - Loop counters should be brief and contain no underscores + + - Integers variables beginning with "n" or "i" should either contain + no underscores (e.g. "naerosoltypes"), or should have an underscore + immediately after the "n" or "i" (e.g. "n_aerosol_types"). Thus, a + variable beginning with "n" or "i" containing an underscore but not + as its second character need not be an integer (would normally then + be a real or a derived type), in order to enable real variables + such as "ice_water_content". + + - All variables and procedure names in lower case using descriptive + names, and if not too long these will be composed of complete words + separated by underscores + + - All parameters are in CamelCase, and integer parameters are + prefixed by "I" or "N" + + - C-style enumerations are treated as integer parameters + + - Variable character strings are suffixed by "_name" or "_str", while + parameter character strings (in CamelCase) are suffixed by "Name" + or "Str" + + - Global data included in modules must be constant; any variable data + must be passed to procedures via dummy arguments + + - Long argument lists avoided by grouping variables thematically into + derived types + + - Any variable used in a source file should be defined in a comment + earlier in the source file (if this is not obvious from the + variable name) including its units if it has them (even if they are + SI units) + + - All functions and subroutines to be defined in modules and their + explicit interfaces to be revealed via the "use" command, which + should use "only". + + - Data are read in at run-time from NetCDF files rather than being + embedded in the code (e.g. using data statements). + + - Lots of comments! Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/Makefile (revision 6016) @@ -0,0 +1,114 @@ +SOURCES = radiation_aerosol.F90 radiation_config.F90 \ + radiation_flux.F90 radiation_cloud.F90 \ + radiation_thermodynamics.F90 radiation_lw_derivatives.F90 \ + radiation_gas.F90 radiation_single_level.F90 \ + radiation_cloud_optics_data.F90 \ + radiation_interface.F90 radiation_cloud_optics.F90 \ + radiation_overlap.F90 radiation_two_stream.F90 \ + radiation_save.F90 radiation_monochromatic.F90 \ + radiation_constants.F90 radiation_matrix.F90 \ + radiation_spartacus_sw.F90 radiation_cloud_cover.F90 \ + radiation_spartacus_lw.F90 radiation_pdf_sampler.F90 \ + radiation_aerosol_optics.F90 radiation_aerosol_optics_data.F90 \ + radiation_ifs_rrtm.F90 radiation_adding_ica_sw.F90 \ + radiation_mcica_sw.F90 radiation_cloud_generator.F90 \ + radiation_mcica_lw.F90 radiation_adding_ica_lw.F90 \ + radiation_homogeneous_sw.F90 radiation_homogeneous_lw.F90 \ + radiation_ice_optics_fu.F90 radiation_ice_optics_baran.F90 \ + radiation_ice_optics_baran2017.F90 radiation_ice_optics_yi.F90 \ + radiation_liquid_optics_socrates.F90 radiation_liquid_optics_slingo.F90 \ + radiation_tripleclouds_sw.F90 radiation_tripleclouds_lw.F90 \ + radiation_regions.F90 radiation_ecckd.F90 \ + radiation_cloudless_lw.F90 radiation_cloudless_sw.F90 \ + radiation_check.F90 radiation_ecckd_interface.F90 \ + radiation_gas_constants.F90 radiation_ecckd_gas.F90 \ + radiation_spectral_definition.F90 radiation_general_cloud_optics.F90 \ + radiation_general_cloud_optics_data.F90 radiation_random_numbers.F90 \ + radiation_aerosol_optics_description.F90 + +OBJECTS := $(SOURCES:.F90=.o) +LIBRAD = ../lib/libradiation.a + +all: $(LIBRAD) + +$(LIBRAD): $(OBJECTS) + ar r $(LIBRAD) $(OBJECTS) + +%.o: %.F90 + $(FC) $(FCFLAGS) -c $< + +clean: + rm -f *.o $(LIBRAD) + +radiation_flux.o radiation_aerosol.o: radiation_config.o +radiation_interface.o: radiation_aerosol.o radiation_config.o \ + radiation_flux.o radiation_cloud.o radiation_save.o \ + radiation_single_level.o radiation_gas.o radiation_monochromatic.o \ + radiation_thermodynamics.o radiation_spartacus_sw.o \ + radiation_spartacus_lw.o radiation_cloud_optics.o \ + radiation_aerosol_optics.o radiation_config.o \ + radiation_ifs_rrtm.o radiation_mcica_sw.o radiation_mcica_lw.o \ + radiation_homogeneous_lw.o radiation_homogeneous_sw.o \ + radiation_cloudless_lw.o radiation_cloudless_sw.o \ + radiation_tripleclouds_sw.o radiation_tripleclouds_lw.o \ + radiation_ecckd_interface.o radiation_general_cloud_optics.o +radiation_ifs_rrtm.o radiation_monochromatic.o: radiation_config.o \ + radiation_thermodynamics.o radiation_gas.o radiation_single_level.o +radiation_spartacus_sw.o radiation_spartacus_lw.o radiation_mcica_sw.o \ + radiation_mcica_lw.o radiation_homogeneous_sw.o radiation_homogeneous_lw.o \ + radiation_cloudless_sw.o radiation_cloudless_lw.o: \ + radiation_config.o \ + radiation_thermodynamics.o \ + radiation_single_level.o radiation_cloud.o \ + radiation_two_stream.o +radiation_cloud.o: radiation_thermodynamics.o +radiation_save.o: radiation_config.o \ + radiation_single_level.o radiation_thermodynamics.o \ + radiation_cloud.o +radiation_single_level.o: radiation_config.o +radiation_monochromatic.o radiation_aerosol_optics.o radiation_cloud_optics.o \ + radiation_homogeneous_sw.o radiation_spartacus_lw.o \ + radiation_cloudless_sw.o radiation_cloudless_lw.o \ + radiation_ecckd.o radiation_flux.o \ + radiation_spartacus_sw.o radiation_thermodynamics.o: radiation_constants.o +radiation_cloud_optics.o radiation_config.o: \ + radiation_cloud_optics_data.o +radiation_cloud_optics.o: radiation_ice_optics_baran.o radiation_ice_optics_fu.o \ + radiation_liquid_optics_socrates.o radiation_liquid_optics_slingo.o \ + radiation_ice_optics_baran2017.o radiation_ice_optics_yi.o +radiation_aerosol_optics.o radiation_config.o: \ + radiation_aerosol_optics_data.o +radiation_mcica_sw.o radiation_homogeneous_sw.o: radiation_adding_ica_sw.o radiation_cloud_generator.o +radiation_mcica_lw.o radiation_homogeneous_lw.o: radiation_adding_ica_lw.o radiation_cloud_generator.o \ + radiation_lw_derivatives.o +radiation_cloudless_sw.o: radiation_adding_ica_sw.o +radiation_cloudless_lw.o radiation_tripleclouds_lw.o: radiation_adding_ica_lw.o radiation_lw_derivatives.o +radiation_aerosol_optics.o radiation_cloud_optics.o: \ + radiation_config.o +radiation_cloud_generator.o radiation_config.o: radiation_pdf_sampler.o \ + radiation_cloud_cover.o radiation_random_numbers.o +radiation_lw_derivatives.o: radiation_matrix.o + +radiation_config.o: radiation_cloud_generator.o radiation_ecckd.o radiation_general_cloud_optics_data.o + +radiation_aerosol_optics.F90 radiation_cloud_optics.F90 radiation_homogeneous_sw.F90 \ + radiation_mcica_sw.F90 radiation_cloudless_sw.o: radiation_delta_eddington.h +radiation_spartacus_sw.o radiation_spartacus_lw.o \ + radiation_tripleclouds_sw.o radiation_tripleclouds_lw.o: \ + radiation_optical_depth_scaling.h radiation_overlap.o \ + radiation_matrix.o radiation_flux.o radiation_regions.o +radiation_ecckd.o: radiation_ecckd_gas.o radiation_spectral_definition.o +radiation_ecckd_gas.o: radiation_gas_constants.o +radiation_ecckd_interface.o: radiation_config.o radiation_single_level.o radiation_thermodynamics.o \ + radiation_gas.o radiation_gas_constants.o + +radiation_gas.o radiation_single_level.o radiation_thermodynamics.o \ + radiation_flux.o radiation_aerosol.o: radiation_check.o + +radiation_gas.o: radiation_gas_constants.o + +radiation_general_cloud_optics_data.o: radiation_spectral_definition.o + +radiation_general_cloud_optics.o: radiation_config.o radiation_cloud.o radiation_thermodynamics.o radiation_constants.o + +*.o: ecrad_config.h Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/README =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/README (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/README (revision 6016) @@ -0,0 +1,72 @@ +This directory contains the main part of the radiation scheme except +for the calculation of gas optics. It is compiled into static library +../lib/libradiation.a and module files ../mod/radiation_*.mod. The +coding conventions are described in the CONVENTIONS file. See the +file ../driver/radiation_driver.f90 for an example of how the +radiation scheme is called. The code is arranged as follows. + +The configuration information for the radiation scheme is stored in a +"config" object (type defined in *radiation_config.f90*). After this +has been populated depending on how the radiation scheme is to be +configured, the subroutine "setup_radiation" in +*radiation_interface.f90* is called. This sets up the gas, cloud and +aerosol optics, all of which involve reading data from NetCDF files. +The cloud and aerosol optics data are described in +*radiation_aerosol_optics_data.f90* and +*radiation_cloud_optics_data.f90*. + +The main interface to the radiation scheme is via the "radiation" +subroutine in radiation_interface.f90, which takes six objects as +input (noting that multiple columns are processed at once): + + single_level - all single-level fields such as skin temperature and + surface albedo (type defined in *radiation_single_level.f90*) + + thermodynamics - pressure and temperature (type defined in + *radiation_thermodynamics.f90*) + + gas - mixing ratios of gases (type defined in *radiation_gas.f90*) + + cloud - cloud fraction, water content and other information (type + defined in *radiation_cloud.f90*) + + aerosol - mixing ratios of different aerosol species (type defined + in *radiation_aerosol.f90*) + +The output is stored in the following object: + + flux - upwelling and downwelling shortwave and longwave fluxes (type + defined in *radiation_flux.f90*) + +The "radiation" subroutine first computes the gas optical properties +(in the form of 3D arrays of dimension column, height and spectral +g-point), via a call to the "gas_optics" subroutine in +*radiation_ifsrrtm.f90*, which provides an interface to the IFS +implementation of the RRTM-G gas optics model in the ../ifsrrtm +directory. For testing, a simple monochromatic gas model is also +provided in *radiation_monochromatic.f90*. + +To these fields are added the contribution from aerosols via a call to +the "aerosol_optics" subroutine, from *radiation_aerosol_optics.f90*. + +Cloud optical properties are computed (in the form of 3D arrays of +dimension column, height and spectral band), via a call to the +"cloud_optics" subroutine in *radiation_cloud_optics.f90*. + +The optical properties may then be saved to an intermediate NetCDF +file via a routine in *radiation_save.f90*. + +Finally, the optics data are passed to the solver, which computes the +flux profiles. Currently McICA nad SPARTACUS solvers are +available. In the case of SPARTACUS, the longwave and shortwave +versions are in *radiation_spartacus_lw.f90* and +*radiation_spartacus_sw.f90*, respectively. These make use of +routines in the following files: + + *radiation_two_stream.f90* - compute two-stream coefficients + + *radiation_matrix.f90* - matrix operations needed by SPARTACUS + + *radiation_overlap.f90* - compute cloud overlap matrices. + +Physical constants are provided in *radiation_constants.f90*. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/ecrad_config.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/ecrad_config.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/ecrad_config.h (revision 6016) @@ -0,0 +1,39 @@ +! ecrad_config.h - Preprocessor definitions to configure compilation ecRad -*- f90 -*- +! +! (C) Copyright 2023- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! This file should be included in Fortran source files that require +! different optimizations or settings for different architectures and +! platforms. Feel free to maintain a site-specific version of it. + +! The following settings turn on optimizations specific to the +! long-vector NEC SX (the short-vector x86-64 architecture is assumed +! otherwise). + +#if defined (__SX__) || defined (_OPENACC) +#define DWD_TWO_STREAM_OPTIMIZATIONS 1 +#endif + +#if defined (__SX__) +#define DWD_REDUCTION_OPTIMIZATIONS 1 +#endif + +#if defined (__SX__) +#define DWD_VECTOR_OPTIMIZATIONS 1 +#endif + +! In the IFS, an MPI version of easy_netcdf capability is used so that +! only one MPI task reads the data files and shares with the other +! tasks. The MPI version is not used for writing files. + +!#define EASY_NETCDF_READ_MPI 1 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_adding_ica_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_adding_ica_lw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_adding_ica_lw.F90 (revision 6016) @@ -0,0 +1,363 @@ +! This file has been modified for the use in ICON + +! radiation_adding_ica_lw.F90 - Longwave adding method in independent column approximation +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive emission/albedo rather than planck/emissivity +! 2017-07-12 R. Hogan Fast adding method for if only clouds scatter +! 2017-10-23 R. Hogan Renamed single-character variables + +module radiation_adding_ica_lw + + public + +contains + + !--------------------------------------------------------------------- + ! Use the scalar "adding" method to compute longwave flux profiles, + ! including scattering, by successively adding the contribution of + ! layers starting from the surface to compute the total albedo and + ! total upward emission of the increasingly larger block of + ! atmospheric layers. + subroutine adding_ica_lw(ncol, nlev, & + & reflectance, transmittance, source_up, source_dn, emission_surf, albedo_surf, & + & flux_up, flux_dn) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + implicit none + + ! Inputs + integer, intent(in) :: ncol ! number of columns (may be spectral intervals) + integer, intent(in) :: nlev ! number of levels + + ! Surface emission (W m-2) and albedo + real(jprb), intent(in), dimension(ncol) :: emission_surf, albedo_surf + + ! Diffuse reflectance and transmittance of each layer + real(jprb), intent(in), dimension(ncol, nlev) :: reflectance, transmittance + + ! Emission from each layer in an upward and downward direction + real(jprb), intent(in), dimension(ncol, nlev) :: source_up, source_dn + + ! Resulting fluxes (W m-2) at half-levels: diffuse upwelling and + ! downwelling + real(jprb), intent(out), dimension(ncol, nlev+1) :: flux_up, flux_dn + + ! Albedo of the entire earth/atmosphere system below each half + ! level + real(jprb), dimension(ncol, nlev+1) :: albedo + + ! Upwelling radiation at each half-level due to emission below + ! that half-level (W m-2) + real(jprb), dimension(ncol, nlev+1) :: source + + ! Equal to 1/(1-albedo*reflectance) + real(jprb), dimension(ncol, nlev) :: inv_denominator + + ! Loop index for model level and column + integer :: jlev, jcol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_adding_ica_lw:adding_ica_lw',0,hook_handle) + + albedo(:,nlev+1) = albedo_surf + + ! At the surface, the source is thermal emission + source(:,nlev+1) = emission_surf + + ! Work back up through the atmosphere and compute the albedo of + ! the entire earth/atmosphere system below that half-level, and + ! also the "source", which is the upwelling flux due to emission + ! below that level + do jlev = nlev,1,-1 + ! Next loop over columns. We could do this by indexing the + ! entire inner dimension as follows, e.g. for the first line: + ! inv_denominator(:,jlev) = 1.0_jprb / (1.0_jprb-albedo(:,jlev+1)*reflectance(:,jlev)) + ! and similarly for subsequent lines, but this slows down the + ! routine by a factor of 2! Rather, we do it with an explicit + ! loop. + do jcol = 1,ncol + ! Lacis and Hansen (1974) Eq 33, Shonk & Hogan (2008) Eq 10: + inv_denominator(jcol,jlev) = 1.0_jprb & + & / (1.0_jprb-albedo(jcol,jlev+1)*reflectance(jcol,jlev)) + ! Shonk & Hogan (2008) Eq 9, Petty (2006) Eq 13.81: + albedo(jcol,jlev) = reflectance(jcol,jlev) + transmittance(jcol,jlev)*transmittance(jcol,jlev) & + & * albedo(jcol,jlev+1) * inv_denominator(jcol,jlev) + ! Shonk & Hogan (2008) Eq 11: + source(jcol,jlev) = source_up(jcol,jlev) & + & + transmittance(jcol,jlev) * (source(jcol,jlev+1) & + & + albedo(jcol,jlev+1)*source_dn(jcol,jlev)) & + & * inv_denominator(jcol,jlev) + end do + end do + + ! At top-of-atmosphere there is no diffuse downwelling radiation + flux_dn(:,1) = 0.0_jprb + + ! At top-of-atmosphere, all upwelling radiation is due to emission + ! below that level + flux_up(:,1) = source(:,1) + + ! Work back down through the atmosphere computing the fluxes at + ! each half-level + do jlev = 1,nlev + do jcol = 1,ncol + ! Shonk & Hogan (2008) Eq 14 (after simplification): + flux_dn(jcol,jlev+1) & + & = (transmittance(jcol,jlev)*flux_dn(jcol,jlev) & + & + reflectance(jcol,jlev)*source(jcol,jlev+1) & + & + source_dn(jcol,jlev)) * inv_denominator(jcol,jlev) + ! Shonk & Hogan (2008) Eq 12: + flux_up(jcol,jlev+1) = albedo(jcol,jlev+1)*flux_dn(jcol,jlev+1) & + & + source(jcol,jlev+1) + end do + end do + + if (lhook) call dr_hook('radiation_adding_ica_lw:adding_ica_lw',1,hook_handle) + + end subroutine adding_ica_lw + + + !--------------------------------------------------------------------- + ! Use the scalar "adding" method to compute longwave flux profiles, + ! including scattering in cloudy layers only. + subroutine fast_adding_ica_lw(ncol, nlev, & + & reflectance, transmittance, source_up, source_dn, emission_surf, albedo_surf, & + & is_clear_sky_layer, i_cloud_top, flux_dn_clear, & + & flux_up, flux_dn, albedo, source, inv_denominator) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + implicit none + + ! Inputs + integer, intent(in) :: ncol ! number of columns (may be spectral intervals) + integer, intent(in) :: nlev ! number of levels + + ! Surface emission (W m-2) and albedo + real(jprb), intent(in), dimension(ncol) :: emission_surf, albedo_surf + + ! Diffuse reflectance and transmittance of each layer + real(jprb), intent(in), dimension(ncol, nlev) :: reflectance, transmittance + + ! Emission from each layer in an upward and downward direction + real(jprb), intent(in), dimension(ncol, nlev) :: source_up, source_dn + + ! Determine which layers are cloud-free + logical, intent(in) :: is_clear_sky_layer(nlev) + + ! Index to highest cloudy layer + integer, intent(in) :: i_cloud_top + + ! Pre-computed clear-sky downwelling fluxes (W m-2) at half-levels + real(jprb), intent(in), dimension(ncol, nlev+1) :: flux_dn_clear + + ! Resulting fluxes (W m-2) at half-levels: diffuse upwelling and + ! downwelling + real(jprb), intent(out), dimension(ncol, nlev+1) :: flux_up, flux_dn + + ! Albedo of the entire earth/atmosphere system below each half + ! level + real(jprb), intent(out), dimension(ncol, nlev+1) :: albedo + + ! Upwelling radiation at each half-level due to emission below + ! that half-level (W m-2) + real(jprb), intent(out), dimension(ncol, nlev+1) :: source + + ! Equal to 1/(1-albedo*reflectance) + real(jprb), intent(out), dimension(ncol, nlev) :: inv_denominator + + ! Loop index for model level and column + integer :: jlev, jcol + + real(jphook) :: hook_handle + + !$ACC ROUTINE WORKER + +#ifndef _OPENACC + if (lhook) call dr_hook('radiation_adding_ica_lw:fast_adding_ica_lw',0,hook_handle) +#endif + + ! Copy over downwelling fluxes above cloud from clear sky + flux_dn(:,1:i_cloud_top) = flux_dn_clear(:,1:i_cloud_top) + + albedo(:,nlev+1) = albedo_surf + + ! At the surface, the source is thermal emission + source(:,nlev+1) = emission_surf + + ! Work back up through the atmosphere and compute the albedo of + ! the entire earth/atmosphere system below that half-level, and + ! also the "source", which is the upwelling flux due to emission + ! below that level + !$ACC LOOP SEQ + do jlev = nlev,i_cloud_top,-1 + if (is_clear_sky_layer(jlev)) then + ! Reflectance of this layer is zero, simplifying the expression + !$ACC LOOP WORKER VECTOR + do jcol = 1,ncol + albedo(jcol,jlev) = transmittance(jcol,jlev)*transmittance(jcol,jlev)*albedo(jcol,jlev+1) + source(jcol,jlev) = source_up(jcol,jlev) & + & + transmittance(jcol,jlev) * (source(jcol,jlev+1) & + & + albedo(jcol,jlev+1)*source_dn(jcol,jlev)) + end do + else + ! Loop over columns; explicit loop seems to be faster + !$ACC LOOP WORKER VECTOR + do jcol = 1,ncol + ! Lacis and Hansen (1974) Eq 33, Shonk & Hogan (2008) Eq 10: + inv_denominator(jcol,jlev) = 1.0_jprb & + & / (1.0_jprb-albedo(jcol,jlev+1)*reflectance(jcol,jlev)) + ! Shonk & Hogan (2008) Eq 9, Petty (2006) Eq 13.81: + albedo(jcol,jlev) = reflectance(jcol,jlev) + transmittance(jcol,jlev)*transmittance(jcol,jlev) & + & * albedo(jcol,jlev+1) * inv_denominator(jcol,jlev) + ! Shonk & Hogan (2008) Eq 11: + source(jcol,jlev) = source_up(jcol,jlev) & + & + transmittance(jcol,jlev) * (source(jcol,jlev+1) & + & + albedo(jcol,jlev+1)*source_dn(jcol,jlev)) & + & * inv_denominator(jcol,jlev) + end do + end if + end do + + ! Compute the fluxes above the highest cloud + flux_up(:,i_cloud_top) = source(:,i_cloud_top) & + & + albedo(:,i_cloud_top)*flux_dn(:,i_cloud_top) + !$ACC LOOP SEQ + do jlev = i_cloud_top-1,1,-1 + flux_up(:,jlev) = transmittance(:,jlev)*flux_up(:,jlev+1) + source_up(:,jlev) + end do + + ! Work back down through the atmosphere from cloud top computing + ! the fluxes at each half-level + !$ACC LOOP SEQ + do jlev = i_cloud_top,nlev + if (is_clear_sky_layer(jlev)) then + !$ACC LOOP WORKER VECTOR + do jcol = 1,ncol + flux_dn(jcol,jlev+1) = transmittance(jcol,jlev)*flux_dn(jcol,jlev) & + & + source_dn(jcol,jlev) + flux_up(jcol,jlev+1) = albedo(jcol,jlev+1)*flux_dn(jcol,jlev+1) & + & + source(jcol,jlev+1) + end do + else + !$ACC LOOP WORKER VECTOR + do jcol = 1,ncol + ! Shonk & Hogan (2008) Eq 14 (after simplification): + flux_dn(jcol,jlev+1) & + & = (transmittance(jcol,jlev)*flux_dn(jcol,jlev) & + & + reflectance(jcol,jlev)*source(jcol,jlev+1) & + & + source_dn(jcol,jlev)) * inv_denominator(jcol,jlev) + ! Shonk & Hogan (2008) Eq 12: + flux_up(jcol,jlev+1) = albedo(jcol,jlev+1)*flux_dn(jcol,jlev+1) & + & + source(jcol,jlev+1) + end do + end if + end do + +#ifndef _OPENACC + if (lhook) call dr_hook('radiation_adding_ica_lw:fast_adding_ica_lw',1,hook_handle) +#endif + + end subroutine fast_adding_ica_lw + + + !--------------------------------------------------------------------- + ! If there is no scattering then fluxes may be computed simply by + ! passing down through the atmosphere computing the downwelling + ! fluxes from the transmission and emission of each layer, and then + ! passing back up through the atmosphere to compute the upwelling + ! fluxes in the same way. + subroutine calc_fluxes_no_scattering_lw(ncol, nlev, & + & transmittance, source_up, source_dn, emission_surf, albedo_surf, flux_up, flux_dn) + + use parkind1, only : jprb +#ifndef _OPENACC + use yomhook, only : lhook, dr_hook, jphook +#endif + + implicit none + + ! Inputs + integer, intent(in) :: ncol ! number of columns (may be spectral intervals) + integer, intent(in) :: nlev ! number of levels + + ! Surface emission (W m-2) and albedo + real(jprb), intent(in), dimension(ncol) :: emission_surf, albedo_surf + + ! Diffuse reflectance and transmittance of each layer + real(jprb), intent(in), dimension(ncol, nlev) :: transmittance + + ! Emission from each layer in an upward and downward direction + real(jprb), intent(in), dimension(ncol, nlev) :: source_up, source_dn + + ! Resulting fluxes (W m-2) at half-levels: diffuse upwelling and + ! downwelling + real(jprb), intent(out), dimension(ncol, nlev+1) :: flux_up, flux_dn + + ! Loop index for model level + integer :: jlev, jcol + +#ifndef _OPENACC + real(jphook) :: hook_handle +#endif + + !$ACC ROUTINE WORKER + +#ifndef _OPENACC + if (lhook) call dr_hook('radiation_adding_ica_lw:calc_fluxes_no_scattering_lw',0,hook_handle) +#endif + + ! At top-of-atmosphere there is no diffuse downwelling radiation + flux_dn(:,1) = 0.0_jprb + + ! Work down through the atmosphere computing the downward fluxes + ! at each half-level +!$ACC LOOP SEQ +! Added for DWD (2020) +!NEC$ outerloop_unroll(8) + do jlev = 1,nlev + !$ACC LOOP WORKER VECTOR + do jcol = 1,ncol + flux_dn(jcol,jlev+1) = transmittance(jcol,jlev)*flux_dn(jcol,jlev) + source_dn(jcol,jlev) + end do + end do + + ! Surface reflection and emission + flux_up(:,nlev+1) = emission_surf + albedo_surf * flux_dn(:,nlev+1) + + ! Work back up through the atmosphere computing the upward fluxes + ! at each half-level +!$ACC LOOP SEQ +! Added for DWD (2020) +!NEC$ outerloop_unroll(8) + do jlev = nlev,1,-1 + !$ACC LOOP WORKER VECTOR + do jcol = 1,ncol + flux_up(jcol,jlev) = transmittance(jcol,jlev)*flux_up(jcol,jlev+1) + source_up(jcol,jlev) + end do + end do + +#ifndef _OPENACC + if (lhook) call dr_hook('radiation_adding_ica_lw:calc_fluxes_no_scattering_lw',1,hook_handle) +#endif + + end subroutine calc_fluxes_no_scattering_lw + +end module radiation_adding_ica_lw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_adding_ica_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_adding_ica_sw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_adding_ica_sw.F90 (revision 6016) @@ -0,0 +1,167 @@ +! This file has been modified for the use in ICON + +! radiation_adding_ica_sw.F90 - Shortwave adding method in independent column approximation +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-10-23 R. Hogan Renamed single-character variables + +module radiation_adding_ica_sw + + public + +contains + + subroutine adding_ica_sw(ncol, nlev, incoming_toa, & + & albedo_surf_diffuse, albedo_surf_direct, cos_sza, & + & reflectance, transmittance, ref_dir, trans_dir_diff, trans_dir_dir, & + & flux_up, flux_dn_diffuse, flux_dn_direct, & + & albedo, source, inv_denominator) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + implicit none + + ! Inputs + integer, intent(in) :: ncol ! number of columns (may be spectral intervals) + integer, intent(in) :: nlev ! number of levels + + ! Incoming downwelling solar radiation at top-of-atmosphere (W m-2) + real(jprb), intent(in), dimension(ncol) :: incoming_toa + + ! Surface albedo to diffuse and direct radiation + real(jprb), intent(in), dimension(ncol) :: albedo_surf_diffuse, & + & albedo_surf_direct + + ! Cosine of the solar zenith angle + real(jprb), intent(in) :: cos_sza + + ! Diffuse reflectance and transmittance of each layer + real(jprb), intent(in), dimension(ncol, nlev) :: reflectance, transmittance + + ! Fraction of direct-beam solar radiation entering the top of a + ! layer that is reflected back up or scattered forward into the + ! diffuse stream at the base of the layer + real(jprb), intent(in), dimension(ncol, nlev) :: ref_dir, trans_dir_diff + + ! Direct transmittance, i.e. fraction of direct beam that + ! penetrates a layer without being scattered or absorbed + real(jprb), intent(in), dimension(ncol, nlev) :: trans_dir_dir + + ! Resulting fluxes (W m-2) at half-levels: diffuse upwelling, + ! diffuse downwelling and direct downwelling + real(jprb), intent(out), dimension(ncol, nlev+1) :: flux_up, flux_dn_diffuse, & + & flux_dn_direct + + ! Albedo of the entire earth/atmosphere system below each half + ! level + real(jprb), intent(out), dimension(ncol, nlev+1) :: albedo + + ! Upwelling radiation at each half-level due to scattering of the + ! direct beam below that half-level (W m-2) + real(jprb), intent(out), dimension(ncol, nlev+1) :: source + + ! Equal to 1/(1-albedo*reflectance) + real(jprb), intent(out), dimension(ncol, nlev) :: inv_denominator + + ! Loop index for model level and column + integer :: jlev, jcol + + real(jphook) :: hook_handle + +#ifndef _OPENACC + if (lhook) call dr_hook('radiation_adding_ica_sw:adding_ica_sw',0,hook_handle) +#endif + + !$ACC ROUTINE WORKER + + ! Compute profile of direct (unscattered) solar fluxes at each + ! half-level by working down through the atmosphere + flux_dn_direct(:,1) = incoming_toa + !$ACC LOOP SEQ + do jlev = 1,nlev + flux_dn_direct(:,jlev+1) = flux_dn_direct(:,jlev)*trans_dir_dir(:,jlev) + end do + + albedo(:,nlev+1) = albedo_surf_diffuse + + ! At the surface, the direct solar beam is reflected back into the + ! diffuse stream + source(:,nlev+1) = albedo_surf_direct * flux_dn_direct(:,nlev+1) * cos_sza + + ! Work back up through the atmosphere and compute the albedo of + ! the entire earth/atmosphere system below that half-level, and + ! also the "source", which is the upwelling flux due to direct + ! radiation that is scattered below that level +!$ACC LOOP SEQ +! Added for DWD (2020) +!NEC$ outerloop_unroll(8) + do jlev = nlev,1,-1 + ! Next loop over columns. We could do this by indexing the + ! entire inner dimension as follows, e.g. for the first line: + ! inv_denominator(:,jlev) = 1.0_jprb / (1.0_jprb-albedo(:,jlev+1)*reflectance(:,jlev)) + ! and similarly for subsequent lines, but this slows down the + ! routine by a factor of 2! Rather, we do it with an explicit + ! loop. + !$ACC LOOP WORKER VECTOR + do jcol = 1,ncol + ! Lacis and Hansen (1974) Eq 33, Shonk & Hogan (2008) Eq 10: + inv_denominator(jcol,jlev) = 1.0_jprb / (1.0_jprb-albedo(jcol,jlev+1)*reflectance(jcol,jlev)) + ! Shonk & Hogan (2008) Eq 9, Petty (2006) Eq 13.81: + albedo(jcol,jlev) = reflectance(jcol,jlev) + transmittance(jcol,jlev) * transmittance(jcol,jlev) & + & * albedo(jcol,jlev+1) * inv_denominator(jcol,jlev) + ! Shonk & Hogan (2008) Eq 11: + source(jcol,jlev) = ref_dir(jcol,jlev)*flux_dn_direct(jcol,jlev) & + & + transmittance(jcol,jlev)*(source(jcol,jlev+1) & + & + albedo(jcol,jlev+1)*trans_dir_diff(jcol,jlev)*flux_dn_direct(jcol,jlev)) & + & * inv_denominator(jcol,jlev) + end do + end do + + ! At top-of-atmosphere there is no diffuse downwelling radiation + flux_dn_diffuse(:,1) = 0.0_jprb + + ! At top-of-atmosphere, all upwelling radiation is due to + ! scattering by the direct beam below that level + flux_up(:,1) = source(:,1) + + ! Work back down through the atmosphere computing the fluxes at + ! each half-level +!$ACC LOOP SEQ +! Added for DWD (2020) +!NEC$ outerloop_unroll(8) + do jlev = 1,nlev + !$ACC LOOP WORKER VECTOR + do jcol = 1,ncol + ! Shonk & Hogan (2008) Eq 14 (after simplification): + flux_dn_diffuse(jcol,jlev+1) & + & = (transmittance(jcol,jlev)*flux_dn_diffuse(jcol,jlev) & + & + reflectance(jcol,jlev)*source(jcol,jlev+1) & + & + trans_dir_diff(jcol,jlev)*flux_dn_direct(jcol,jlev)) * inv_denominator(jcol,jlev) + ! Shonk & Hogan (2008) Eq 12: + flux_up(jcol,jlev+1) = albedo(jcol,jlev+1)*flux_dn_diffuse(jcol,jlev+1) & + & + source(jcol,jlev+1) + flux_dn_direct(jcol,jlev) = flux_dn_direct(jcol,jlev)*cos_sza + end do + end do + flux_dn_direct(:,nlev+1) = flux_dn_direct(:,nlev+1)*cos_sza + +#ifndef _OPENACC + if (lhook) call dr_hook('radiation_adding_ica_sw:adding_ica_sw',1,hook_handle) +#endif + + end subroutine adding_ica_sw + +end module radiation_adding_ica_sw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol.F90 (revision 6016) @@ -0,0 +1,268 @@ +! This file has been modified for the use in ICON + +! radiation_aerosol.F90 - Derived type describing aerosol +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2018-04-15 R. Hogan Add "direct" option +! 2019-01-14 R. Hogan Added out_of_physical_bounds routine + +module radiation_aerosol + + use parkind1, only : jprb + use radiation_io, only : nulerr, radiation_abort + + implicit none + public + + !--------------------------------------------------------------------- + ! Type describing the aerosol content in the atmosphere + type aerosol_type + ! The mass mixing ratio of config%n_aerosol_types different + ! aerosol types dimensioned + ! (ncol,istartlev:iendlev,config%n_aerosol_types), where ncol is + ! the number of columns, istartlev:iendlev is the range of model + ! levels where aerosols are present + real(jprb), allocatable, dimension(:,:,:) :: & + & mixing_ratio ! mass mixing ratio (kg/kg) + + ! Alternatively, if is_direct=true, the optical properties are + ! provided directly and are dimensioned + ! (nband,istartlev:iendlev,ncol) + real(jprb), allocatable, dimension(:,:,:) :: & + & od_sw, ssa_sw, g_sw, & ! Shortwave optical properties + & od_lw, ssa_lw, g_lw ! Longwave optical properties + + ! Range of levels in which the aerosol properties are provided + integer :: istartlev, iendlev + + ! Are the optical properties going to be provided directly by the + ! user? + logical :: is_direct = .false. + + contains + procedure :: allocate => allocate_aerosol_arrays + procedure :: allocate_direct => allocate_aerosol_arrays_direct + procedure :: deallocate => deallocate_aerosol_arrays + procedure :: out_of_physical_bounds +#ifdef _OPENACC + procedure :: update_host + procedure :: update_device +#endif + end type aerosol_type + +contains + + !--------------------------------------------------------------------- + ! Allocate array for describing aerosols, although in the offline + ! code these are allocated when they are read from the NetCDF file + subroutine allocate_aerosol_arrays(this, ncol, istartlev, iendlev, ntype) + + use yomhook, only : lhook, dr_hook, jphook + + class(aerosol_type), intent(inout) :: this + integer, intent(in) :: ncol ! Number of columns + integer, intent(in) :: istartlev, iendlev ! Level range + integer, intent(in) :: ntype ! Number of aerosol types + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol:allocate',0,hook_handle) + + allocate(this%mixing_ratio(ncol,istartlev:iendlev,ntype)) + !$ACC ENTER DATA CREATE(this%mixing_ratio) + this%is_direct = .false. + this%istartlev = istartlev + this%iendlev = iendlev + +#ifdef _OPENACC + write(nulerr,'(a)') '*** Error: radiation_aerosol:allocate aerosol%is_direct==.false. is not ported to GPU' + call radiation_abort() +#endif + + if (lhook) call dr_hook('radiation_aerosol:allocate',1,hook_handle) + + end subroutine allocate_aerosol_arrays + + + !--------------------------------------------------------------------- + ! Allocate arrays for describing aerosol optical properties + subroutine allocate_aerosol_arrays_direct(this, config, & + & ncol, istartlev, iendlev) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_config, only : config_type + + class(aerosol_type), intent(inout) :: this + type(config_type), intent(in) :: config + integer, intent(in) :: ncol ! Number of columns + integer, intent(in) :: istartlev, iendlev ! Level range + integer :: jband, jlev, jcol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol:allocate_direct',0,hook_handle) + + this%is_direct = .true. + this%istartlev = istartlev + this%iendlev = iendlev + + if (config%do_sw) then + allocate(this%od_sw (config%n_bands_sw,istartlev:iendlev,ncol)) + allocate(this%ssa_sw(config%n_bands_sw,istartlev:iendlev,ncol)) + allocate(this%g_sw (config%n_bands_sw,istartlev:iendlev,ncol)) + !$ACC ENTER DATA CREATE(this%od_sw, this%ssa_sw, this%g_sw) ASYNC(1) + end if + + if (config%do_lw) then + allocate(this%od_lw (config%n_bands_lw,istartlev:iendlev,ncol)) + allocate(this%ssa_lw(config%n_bands_lw,istartlev:iendlev,ncol)) + allocate(this%g_lw (config%n_bands_lw,istartlev:iendlev,ncol)) + !$ACC ENTER DATA CREATE(this%od_lw, this%ssa_lw, this%g_lw) ASYNC(1) + ! If longwave scattering by aerosol is not to be represented, + ! then the user may wish to just provide absorption optical + ! depth in od_lw, in which case we must set the following two + ! variables to zero + + !$ACC WAIT ! ACCWA (nvhpc 22.7) crashes otherwise + + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this, config) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + do jcol = 1,ncol + do jlev = istartlev,iendlev + do jband = 1,config%n_bands_lw + this%ssa_lw(jband,jlev,jcol) = 0.0_jprb + this%g_lw(jband,jlev,jcol) = 0.0_jprb + end do + end do + end do + !$ACC END PARALLEL + end if + + if (lhook) call dr_hook('radiation_aerosol:allocate_direct',1,hook_handle) + + end subroutine allocate_aerosol_arrays_direct + + + !--------------------------------------------------------------------- + ! Deallocate array + subroutine deallocate_aerosol_arrays(this) + + use yomhook, only : lhook, dr_hook, jphook + + class(aerosol_type), intent(inout) :: this + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol:deallocate',0,hook_handle) + + !$ACC EXIT DATA DELETE(this%mixing_ratio) ASYNC(1) IF(allocated(this%mixing_ratio)) + !$ACC EXIT DATA DELETE(this%od_sw) ASYNC(1) IF(allocated(this%od_sw)) + !$ACC EXIT DATA DELETE(this%ssa_sw) ASYNC(1) IF(allocated(this%ssa_sw)) + !$ACC EXIT DATA DELETE(this%g_sw) ASYNC(1) IF(allocated(this%g_sw)) + !$ACC EXIT DATA DELETE(this%od_lw) ASYNC(1) IF(allocated(this%od_lw)) + !$ACC EXIT DATA DELETE(this%ssa_lw) ASYNC(1) IF(allocated(this%ssa_lw)) + !$ACC EXIT DATA DELETE(this%g_lw) ASYNC(1) IF(allocated(this%g_lw)) + !$ACC WAIT + if (allocated(this%mixing_ratio)) deallocate(this%mixing_ratio) + if (allocated(this%od_sw)) deallocate(this%od_sw) + if (allocated(this%ssa_sw)) deallocate(this%ssa_sw) + if (allocated(this%g_sw)) deallocate(this%g_sw) + if (allocated(this%od_lw)) deallocate(this%od_lw) + if (allocated(this%ssa_lw)) deallocate(this%ssa_lw) + if (allocated(this%g_lw)) deallocate(this%g_lw) + + if (lhook) call dr_hook('radiation_aerosol:deallocate',1,hook_handle) + + end subroutine deallocate_aerosol_arrays + + + !--------------------------------------------------------------------- + ! Return .true. if variables are out of a physically sensible range, + ! optionally only considering columns between istartcol and iendcol + function out_of_physical_bounds(this, istartcol, iendcol, do_fix) result(is_bad) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_check, only : out_of_bounds_3d + + class(aerosol_type), intent(inout) :: this + integer, optional,intent(in) :: istartcol, iendcol + logical, optional,intent(in) :: do_fix + logical :: is_bad + + logical :: do_fix_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol:out_of_physical_bounds',0,hook_handle) + + if (present(do_fix)) then + do_fix_local = do_fix + else + do_fix_local = .false. + end if + + is_bad = out_of_bounds_3d(this%mixing_ratio, 'aerosol%mixing_ratio', & + & 0.0_jprb, 1.0_jprb, do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_3d(this%od_sw, 'aerosol%od_sw', & + & 0.0_jprb, 100.0_jprb, do_fix_local, k1=istartcol, k2=iendcol) & + & .or. out_of_bounds_3d(this%od_lw, 'aerosol%od_lw', & + & 0.0_jprb, 100.0_jprb, do_fix_local, k1=istartcol, k2=iendcol) & + & .or. out_of_bounds_3d(this%ssa_sw, 'aerosol%ssa_sw', & + & 0.0_jprb, 1.0_jprb, do_fix_local, k1=istartcol, k2=iendcol) & + & .or. out_of_bounds_3d(this%ssa_lw, 'aerosol%ssa_lw', & + & 0.0_jprb, 1.0_jprb, do_fix_local, k1=istartcol, k2=iendcol) & + & .or. out_of_bounds_3d(this%g_sw, 'aerosol%g_sw', & + & 0.0_jprb, 1.0_jprb, do_fix_local, k1=istartcol, k2=iendcol) & + & .or. out_of_bounds_3d(this%g_lw, 'aerosol%g_lw', & + & 0.0_jprb, 1.0_jprb, do_fix_local, k1=istartcol, k2=iendcol) + + if (lhook) call dr_hook('radiation_aerosol:out_of_physical_bounds',1,hook_handle) + + end function out_of_physical_bounds + +#ifdef _OPENACC + !--------------------------------------------------------------------- + ! updates fields on host + subroutine update_host(this) + + class(aerosol_type), intent(inout) :: this + + !$ACC UPDATE HOST(this%mixing_ratio) IF(allocated(this%mixing_ratio)) + !$ACC UPDATE HOST(this%od_sw) IF(allocated(this%od_sw)) + !$ACC UPDATE HOST(this%ssa_sw) IF(allocated(this%ssa_sw)) + !$ACC UPDATE HOST(this%g_sw) IF(allocated(this%g_sw)) + !$ACC UPDATE HOST(this%od_lw) IF(allocated(this%od_lw)) + !$ACC UPDATE HOST(this%ssa_lw) IF(allocated(this%ssa_lw)) + !$ACC UPDATE HOST(this%g_lw) IF(allocated(this%g_lw)) + + end subroutine update_host + + !--------------------------------------------------------------------- + ! updates fields on device + subroutine update_device(this) + + class(aerosol_type), intent(inout) :: this + + !$ACC UPDATE DEVICE(this%mixing_ratio) IF(allocated(this%mixing_ratio)) + !$ACC UPDATE DEVICE(this%od_sw) IF(allocated(this%od_sw)) + !$ACC UPDATE DEVICE(this%ssa_sw) IF(allocated(this%ssa_sw)) + !$ACC UPDATE DEVICE(this%g_sw) IF(allocated(this%g_sw)) + !$ACC UPDATE DEVICE(this%od_lw) IF(allocated(this%od_lw)) + !$ACC UPDATE DEVICE(this%ssa_lw) IF(allocated(this%ssa_lw)) + !$ACC UPDATE DEVICE(this%g_lw) IF(allocated(this%g_lw)) + + end subroutine update_device +#endif + +end module radiation_aerosol Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics.F90 (revision 6016) @@ -0,0 +1,1222 @@ +! This file has been modified for the use in ICON + +! radiation_aerosol_optics.F90 - Computing aerosol optical properties +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2018-04-15 R. Hogan Add "direct" option +! 2020-11-14 R. Hogan Add setup_general_aerosol_optics for ecCKD compatibility +! 2022-03-27 R. Hogan Add setup_general_aerosol_optics_legacy to use RRTM aerosol files with ecCKD +! 2022-11-22 P. Ukkonen / R. Hogan Optimizations to enhance vectorization + +#include "ecrad_config.h" + +module radiation_aerosol_optics + + implicit none + public + +contains + + ! Provides the elemental function "delta_eddington_extensive" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Load aerosol scattering data; this subroutine delegates to one + ! in radiation_aerosol_optics_data.F90 + subroutine setup_aerosol_optics(config) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + use radiation_config, only : config_type + use radiation_aerosol_optics_data, only : aerosol_optics_type + use radiation_io, only : nulerr, radiation_abort + + type(config_type), intent(inout) :: config + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_aerosol_optics',0,hook_handle) + + if (config%n_aerosol_types > 0) then + ! Load data from file and prepare to map config%n_aerosol_types + ! aerosol types + if (config%use_general_aerosol_optics) then + ! Read file containing high spectral resolution optical + ! properties and average to the spectral intervals of the + ! current gas-optics scheme + call setup_general_aerosol_optics(config) + else + ! Read file containing optical properties already in the bands + ! of the gas-optics scheme + call config%aerosol_optics%setup(trim(config%aerosol_optics_file_name), & + & iverbose=config%iverbosesetup) + end if + + call config%aerosol_optics%initialize_types(config%n_aerosol_types) + + ! Check agreement in number of bands + if (config%n_bands_lw /= config%aerosol_optics%n_bands_lw) then + write(nulerr,'(a,i0,a,i0,a)') '*** Error: number of longwave bands (', & + & config%n_bands_lw, ') does not match aerosol optics look-up table (', & + & config%aerosol_optics%n_bands_lw, ')' + call radiation_abort() + end if + if (config%n_bands_sw /= config%aerosol_optics%n_bands_sw) then + write(nulerr,'(a)') '*** Error: number of shortwave bands does not match aerosol optics look-up table' + call radiation_abort() + end if + + ! Map aerosol types to those loaded from the data file + call config%aerosol_optics%set_types(config%i_aerosol_type_map(1:config%n_aerosol_types)) + end if + + if (config%iverbosesetup >= 1) then + call config%aerosol_optics%print_description(config%i_aerosol_type_map(1:config%n_aerosol_types)) + end if + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_aerosol_optics',1,hook_handle) + + end subroutine setup_aerosol_optics + + + !--------------------------------------------------------------------- + ! Read file containing high spectral resolution optical properties + ! and average to the spectral intervals of the current gas-optics + ! scheme + subroutine setup_general_aerosol_optics(config) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + use radiation_config, only : config_type + use radiation_aerosol_optics_data, only : aerosol_optics_type + use radiation_spectral_definition, only : SolarReferenceTemperature, & + & TerrestrialReferenceTemperature + use radiation_io, only : nulout + + type(config_type), intent(inout), target :: config + + ! The NetCDF file containing the aerosol optics data + type(netcdf_file) :: file + + ! Wavenumber points in NetCDF file + real(jprb), allocatable :: wavenumber(:) ! cm-1 + + ! Hydrophilic aerosol properties + real(jprb), allocatable :: mass_ext_philic(:,:,:) ! Mass-ext coefficient (m2 kg-1) + real(jprb), allocatable :: ssa_philic(:,:,:) ! Single-scattering albedo + real(jprb), allocatable :: g_philic(:,:,:) ! Asymmetry factor + real(jprb), allocatable :: lidar_ratio_philic(:,:,:) ! Lidar ratio (sr) + + ! Hydrophobic aerosol properties + real(jprb), allocatable :: mass_ext_phobic(:,:) ! Mass-ext coefficient (m2 kg-1) + real(jprb), allocatable :: ssa_phobic(:,:) ! Single-scattering albedo + real(jprb), allocatable :: g_phobic(:,:) ! Asymmetry factor + real(jprb), allocatable :: lidar_ratio_phobic(:,:) ! Lidar ratio (sr) + + ! Mapping matrix between optical properties at the wavenumbers in + ! the file, and spectral intervals used by the gas-optics scheme + real(jprb), allocatable :: mapping(:,:) + + ! Target monochromatic wavenumber for interpolation (cm-1) + real(jprb) :: wavenumber_target + + ! Number of spectral points describing aerosol properties in the + ! shortwave and longwave + integer :: nspecsw, nspeclw + + ! Number of monochromatic wavelengths required + integer :: nmono + + integer :: n_type_philic, n_type_phobic, nrh, nwn + integer :: jtype, jwl, iwn + + ! Weight of first point in interpolation + real(jprb) :: weight1 + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',0,hook_handle) + + associate(ao => config%aerosol_optics) + + call file%open(trim(config%aerosol_optics_file_name), iverbose=config%iverbosesetup) + + if (.not. file%exists('wavenumber')) then + ! Assume we have an old-style aerosol optics file with optical + ! properties provided per pre-defined band + call file%close() + if (config%iverbosesetup >= 2) then + write(nulout,'(a)') 'Legacy aerosol optics file: mapping between bands' + end if + call setup_general_aerosol_optics_legacy(config, trim(config%aerosol_optics_file_name)) + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',1,hook_handle) + return + end if + + if (file%exists('mass_ext_hydrophilic')) then + ao%use_hydrophilic = .true. + else + ao%use_hydrophilic = .false. + end if + + call file%get('wavenumber', wavenumber) + nwn = size(wavenumber) + + ! Read the raw scattering data + call file%get('mass_ext_hydrophobic', mass_ext_phobic) + call file%get('ssa_hydrophobic', ssa_phobic) + call file%get('asymmetry_hydrophobic', g_phobic) + call file%get('lidar_ratio_hydrophobic', lidar_ratio_phobic) + + call file%get_global_attribute('description_hydrophobic', & + & ao%description_phobic_str) + + if (ao%use_hydrophilic) then + call file%get('mass_ext_hydrophilic', mass_ext_philic) + call file%get('ssa_hydrophilic', ssa_philic) + call file%get('asymmetry_hydrophilic', g_philic) + call file%get('lidar_ratio_hydrophilic', lidar_ratio_philic) + + call file%get('relative_humidity1', ao%rh_lower) + + call file%get_global_attribute('description_hydrophilic', & + & ao%description_philic_str) + end if + + ! Close aerosol scattering file + call file%close() + + n_type_phobic = size(mass_ext_phobic, 2) + if (ao%use_hydrophilic) then + n_type_philic = size(mass_ext_philic, 3) + nrh = size(ao%rh_lower) + else + n_type_philic = 0 + nrh = 0 + end if + + if (config%do_cloud_aerosol_per_sw_g_point) then + nspecsw = config%gas_optics_sw%spectral_def%ng + else + nspecsw = config%gas_optics_sw%spectral_def%nband + end if + + if (config%do_cloud_aerosol_per_lw_g_point) then + nspeclw = config%gas_optics_lw%spectral_def%ng + else + nspeclw = config%gas_optics_lw%spectral_def%nband + end if + + if (allocated(ao%wavelength_mono)) then + ! Monochromatic wavelengths also required + nmono = size(ao%wavelength_mono) + else + nmono = 0 + end if + + call ao%allocate(n_type_phobic, n_type_philic, nrh, nspeclw, nspecsw, nmono) + + if (config%do_sw) then + call config%gas_optics_sw%spectral_def%calc_mapping(wavenumber, mapping, & + & use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point)) + + ao%mass_ext_sw_phobic = matmul(mapping, mass_ext_phobic) + ao%ssa_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) & + & / ao%mass_ext_sw_phobic + ao%g_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) & + & / (ao%mass_ext_sw_phobic*ao%ssa_sw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,n_type_philic + ao%mass_ext_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype)) + ao%ssa_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)) & + & / ao%mass_ext_sw_philic(:,:,jtype) + ao%g_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) & + & / (ao%mass_ext_sw_philic(:,:,jtype)*ao%ssa_sw_philic(:,:,jtype)) + end do + end if + end if + + if (config%do_lw) then + call config%gas_optics_lw%spectral_def%calc_mapping(wavenumber, mapping, & + & use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point)) + + ao%mass_ext_lw_phobic = matmul(mapping, mass_ext_phobic) + ao%ssa_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) & + & / ao%mass_ext_lw_phobic + ao%g_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) & + & / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,n_type_philic + ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype)) + ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)) & + & / ao%mass_ext_lw_philic(:,:,jtype) + ao%g_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) & + & / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype)) + end do + end if + end if + + if (allocated(ao%wavelength_mono)) then + ! Monochromatic wavelengths also required + do jwl = 1,nmono + ! Wavelength (m) to wavenumber (cm-1) + wavenumber_target = 0.01_jprb / ao%wavelength_mono(jwl) + ! Find index to first interpolation point, and its weight + if (wavenumber_target <= wavenumber(1)) then + weight1 = 1.0_jprb + iwn = 1 + else if (wavenumber_target >= wavenumber(nwn)) then + iwn = nwn-1 + weight1 = 0.0_jprb + else + iwn = 1 + do while (wavenumber(iwn+1) < wavenumber_target .and. iwn < nwn-1) + iwn = iwn + 1 + end do + weight1 = (wavenumber(iwn+1)-wavenumber_target) & + & / (wavenumber(iwn+1)-wavenumber(iwn)) + end if + ! Linear interpolation + ao%mass_ext_mono_phobic(jwl,:) = weight1 * mass_ext_phobic(iwn,:) & + & + (1.0_jprb - weight1)* mass_ext_phobic(iwn+1,:) + ao%ssa_mono_phobic(jwl,:) = weight1 * ssa_phobic(iwn,:) & + & + (1.0_jprb - weight1)* ssa_phobic(iwn+1,:) + ao%g_mono_phobic(jwl,:) = weight1 * g_phobic(iwn,:) & + & + (1.0_jprb - weight1)* g_phobic(iwn+1,:) + ao%lidar_ratio_mono_phobic(jwl,:) = weight1 * lidar_ratio_phobic(iwn,:) & + & + (1.0_jprb - weight1)* lidar_ratio_phobic(iwn+1,:) + if (ao%use_hydrophilic) then + ao%mass_ext_mono_philic(jwl,:,:) = weight1 * mass_ext_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* mass_ext_philic(iwn+1,:,:) + ao%ssa_mono_philic(jwl,:,:) = weight1 * ssa_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* ssa_philic(iwn+1,:,:) + ao%g_mono_philic(jwl,:,:) = weight1 * g_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* g_philic(iwn+1,:,:) + ao%lidar_ratio_mono_philic(jwl,:,:) = weight1 * lidar_ratio_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* lidar_ratio_philic(iwn+1,:,:) + end if + end do + end if + + ! Deallocate memory local to this routine + deallocate(mass_ext_phobic) + deallocate(ssa_phobic) + deallocate(g_phobic) + deallocate(lidar_ratio_phobic) + if (ao%use_hydrophilic) then + deallocate(mass_ext_philic) + deallocate(ssa_philic) + deallocate(g_philic) + deallocate(lidar_ratio_philic) + end if + + end associate + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',1,hook_handle) + + end subroutine setup_general_aerosol_optics + + + !--------------------------------------------------------------------- + ! Read file containing legacy-style band-wise aerosol optical + ! properties and average to the spectral intervals of the current + ! gas-optics scheme + subroutine setup_general_aerosol_optics_legacy(config, file_name) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + use radiation_config, only : config_type + use radiation_aerosol_optics_data, only : aerosol_optics_type + use radiation_spectral_definition, only : SolarReferenceTemperature, & + & TerrestrialReferenceTemperature + + type(config_type), intent(inout), target :: config + + ! The NetCDF file containing the aerosol optics data + character(len=*), intent(in) :: file_name + + ! Mapping matrix between optical properties at the wavenumbers in + ! the file, and spectral intervals used by the gas-optics scheme + real(jprb), allocatable :: mapping(:,:), mapping_transp(:,:) + + ! Pointer to the aerosol optics coefficients for brevity of access + type(aerosol_optics_type), pointer :: ao + + ! Local copy of aerosol optical properties in the spectral + ! intervals of the file, which is deallocated when it goes out of + ! scope + type(aerosol_optics_type) :: ao_legacy + + integer :: jtype + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics_legacy',0,hook_handle) + ao => config%aerosol_optics + + ! Load file into a local structure + call ao_legacy%setup(file_name, iverbose=config%iverbosesetup) + + ! Copy over scalars and coordinate variables + call ao%allocate(ao_legacy%n_type_phobic, ao_legacy%n_type_philic, ao_legacy%nrh, & + & config%n_bands_lw, config%n_bands_sw, ao_legacy%n_mono_wl) + ao%description_phobic_str = ao_legacy%description_phobic_str + if (ao_legacy%use_hydrophilic) then + ao%description_philic_str = ao_legacy%description_philic_str + ao%rh_lower = ao_legacy%rh_lower + end if + + ! use_hydrophilic = ao_legacy%use_hydrophilic + ! ao%iclass = ao_legacy%iclass + ! ao%itype = ao_legacy%itype + ! ao%ntype = ao_legacy%ntype + ! ao%n_type_phobic = ao_legacy%n_type_phobic + ! ao%n_type_philic = ao_legacy%n_type_philic + ! ao%n_mono_wl = ao_legacy%n_mono_wl + ! ao%use_monochromatic = ao_legacy%use_monochromatic + + if (config%do_sw) then + call config%gas_optics_sw%spectral_def%calc_mapping_from_wavenumber_bands( & + & ao_legacy%wavenumber1_sw, ao_legacy%wavenumber2_sw, mapping_transp, & + & use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point)) + if (allocated(mapping)) then + deallocate(mapping) + end if + allocate(mapping(config%n_bands_sw,ao_legacy%n_bands_sw)) + mapping = transpose(mapping_transp) + ao%mass_ext_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic) + ao%ssa_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic*ao_legacy%ssa_sw_phobic) & + & / ao%mass_ext_sw_phobic + ao%g_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic*ao_legacy%ssa_sw_phobic & + & *ao_legacy%g_sw_phobic) & + & / (ao%mass_ext_sw_phobic*ao%ssa_sw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,ao%n_type_philic + ao%mass_ext_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype)) + ao%ssa_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype) & + & *ao_legacy%ssa_sw_philic(:,:,jtype)) & + & / ao%mass_ext_sw_philic(:,:,jtype) + ao%g_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype) & + & *ao_legacy%ssa_sw_philic(:,:,jtype)*ao_legacy%g_sw_philic(:,:,jtype)) & + & / (ao%mass_ext_sw_philic(:,:,jtype)*ao%ssa_sw_philic(:,:,jtype)) + end do + end if + end if + + if (config%do_lw) then + if (allocated(mapping_transp)) then + deallocate(mapping_transp) + end if + call config%gas_optics_lw%spectral_def%calc_mapping_from_wavenumber_bands( & + & ao_legacy%wavenumber1_lw, ao_legacy%wavenumber2_lw, mapping_transp, & + & use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point)) + if (allocated(mapping)) then + deallocate(mapping) + end if + allocate(mapping(config%n_bands_lw,ao_legacy%n_bands_lw)) + mapping = transpose(mapping_transp) + ao%mass_ext_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic) + + where (ao%mass_ext_lw_phobic /= 0) + ao%ssa_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic) & + & / ao%mass_ext_lw_phobic + ao%g_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic & + & *ao_legacy%g_lw_phobic) & + & / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic) + elsewhere + ao%ssa_lw_phobic = 1. + ao%g_lw_phobic = 0. + end where + + if (ao%use_hydrophilic) then + do jtype = 1,ao%n_type_philic + ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype)) + + where (ao%mass_ext_lw_philic(:,:,jtype) /= 0.) + ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) & + & *ao_legacy%ssa_lw_philic(:,:,jtype)) & + & / ao%mass_ext_lw_philic(:,:,jtype) + ao%g_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) & + & *ao_legacy%ssa_lw_philic(:,:,jtype)*ao_legacy%g_lw_philic(:,:,jtype)) & + & / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype)) + elsewhere + ao%ssa_lw_philic(:,:,jtype) = 1. + ao%g_lw_philic(:,:,jtype) = 0. + end where + end do + end if + end if + + if (allocated(ao_legacy%wavelength_mono)) then + ao%wavelength_mono = ao_legacy%wavelength_mono + ao%mass_ext_mono_phobic = ao_legacy%mass_ext_mono_phobic + ao%ssa_mono_phobic = ao_legacy%ssa_mono_phobic + ao%g_mono_phobic = ao_legacy%g_mono_phobic + ao%lidar_ratio_mono_phobic = ao_legacy%lidar_ratio_mono_phobic + if (ao%use_hydrophilic) then + ao%mass_ext_mono_philic = ao_legacy%mass_ext_mono_philic + ao%ssa_mono_philic = ao_legacy%ssa_mono_philic + ao%g_mono_philic = ao_legacy%g_mono_philic + ao%lidar_ratio_mono_philic = ao_legacy%lidar_ratio_mono_philic + end if + end if + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics_legacy',1,hook_handle) + + end subroutine setup_general_aerosol_optics_legacy + + + !--------------------------------------------------------------------- + ! Compute aerosol optical properties and add to existing gas optical + ! depth and scattering properties + subroutine add_aerosol_optics(nlev,istartcol,iendcol, & + & config, thermodynamics, gas, aerosol, & + & od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw) + + use parkind1, only : jprb + use radiation_io, only : nulout, nulerr, radiation_abort + use yomhook, only : lhook, dr_hook, jphook + use radiation_config, only : config_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type, IH2O, IMassMixingRatio + use radiation_aerosol, only : aerosol_type + use radiation_constants, only : AccelDueToGravity + use radiation_aerosol_optics_data, only : aerosol_optics_type, & + & IAerosolClassUndefined, IAerosolClassIgnored, & + & IAerosolClassHydrophobic, IAerosolClassHydrophilic + + real(jprb), parameter :: OneOverAccelDueToGravity = 1.0_jprb / AccelDueToGravity + + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in), target :: config + type(thermodynamics_type),intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + type(aerosol_type), intent(in) :: aerosol + ! Optical depth, single scattering albedo and asymmetry factor of + ! the atmosphere (gases on input, gases and aerosols on output) + ! for each g point. Note that longwave ssa and asymmetry and + ! shortwave asymmetry are all zero for gases, so are not yet + ! defined on input and are therefore intent(out). + real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol), & + & intent(inout) :: od_lw + real(jprb), dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol), & + & intent(out) :: ssa_lw, g_lw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), & + & intent(inout) :: od_sw, ssa_sw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), & + & intent(out) :: g_sw + + ! Extinction optical depth, scattering optical depth and + ! asymmetry-times-scattering-optical-depth for all the aerosols in + ! a column for each spectral band of the shortwave and longwave + ! spectrum + real(jprb), dimension(config%n_bands_sw,nlev) & + & :: od_sw_aerosol, scat_sw_aerosol, scat_g_sw_aerosol + real(jprb), dimension(config%n_bands_lw,nlev) & + & :: od_lw_aerosol + real(jprb), dimension(config%n_bands_lw_if_scattering,nlev) & + & :: scat_lw_aerosol, scat_g_lw_aerosol + + real(jprb) :: local_od_sw, local_od_lw + + real(jprb) :: h2o_mmr(istartcol:iendcol,nlev) + + real(jprb) :: rh ! Relative humidity with respect to liquid water + + ! Factor (kg m-2) to convert mixing ratio (kg kg-1) to mass in + ! path (kg m-2) + real(jprb) :: factor(nlev) + + ! Temporary extinction and scattering optical depths of aerosol + ! plus gas + real(jprb) :: local_od, local_scat + + ! Aerosol mixing ratio as a scalar + real(jprb) :: mixing_ratio + + ! Loop indices for column, level, g point, band and aerosol type + integer :: jcol, jlev, jg, jtype, jband + + ! Range of levels over which aerosols are present + integer :: istartlev, iendlev + + ! Indices to spectral band and relative humidity look-up table + integer :: iband, irh, irhs(nlev) + + ! Short cut for ao%itype(jtype) + integer :: itype + + ! Pointer to the aerosol optics coefficients for brevity of access + type(aerosol_optics_type), pointer :: ao + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics:add_aerosol_optics',0,hook_handle) + + if (aerosol%is_direct) then + ! Aerosol optical properties have been provided in each band + ! directly by the user + call add_aerosol_optics_direct(nlev,istartcol,iendcol, & + & config, aerosol, & + & od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw) + else + ! Aerosol mixing ratios have been provided +#ifdef _OPENACC + write(nulerr,'(a)') '*** Error: radiation_aerosol_optics:add_aerosol_optics aerosol%is_direct==.false. is not ported to GPU' + call radiation_abort() +#endif + + do jtype = 1,config%n_aerosol_types + if (config%aerosol_optics%iclass(jtype) == IAerosolClassUndefined) then + write(nulerr,'(a)') '*** Error: not all aerosol types are defined' + call radiation_abort() + end if + end do + + if (config%iverbose >= 2) then + write(nulout,'(a)') 'Computing aerosol absorption/scattering properties' + end if + + ao => config%aerosol_optics + + istartlev = lbound(aerosol%mixing_ratio,2) + iendlev = ubound(aerosol%mixing_ratio,2) + + if (ubound(aerosol%mixing_ratio,3) /= config%n_aerosol_types) then + write(nulerr,'(a,i0,a,i0)') '*** Error: aerosol%mixing_ratio contains ', & + & ubound(aerosol%mixing_ratio,3), ' aerosol types, expected ', & + & config%n_aerosol_types + call radiation_abort() + end if + + ! Set variables to zero that may not have been previously + g_sw(:,:,istartcol:iendcol) = 0.0_jprb + if (config%do_lw_aerosol_scattering) then + ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb + g_lw(:,:,istartcol:iendcol) = 0.0_jprb + end if + + call gas%get(IH2O, IMassMixingRatio, h2o_mmr, istartcol=istartcol) + + ! Loop over column + do jcol = istartcol,iendcol + + ! Reset temporary arrays + od_sw_aerosol = 0.0_jprb + scat_sw_aerosol = 0.0_jprb + scat_g_sw_aerosol = 0.0_jprb + od_lw_aerosol = 0.0_jprb + scat_lw_aerosol = 0.0_jprb + scat_g_lw_aerosol = 0.0_jprb + + do jlev = istartlev,iendlev + ! Compute relative humidity with respect to liquid + ! saturation and the index to the relative-humidity index of + ! hydrophilic-aerosol data + rh = h2o_mmr(jcol,jlev) / thermodynamics%h2o_sat_liq(jcol,jlev) + irhs(jlev) = ao%calc_rh_index(rh) + + factor(jlev) = ( thermodynamics%pressure_hl(jcol,jlev+1) & + & -thermodynamics%pressure_hl(jcol,jlev ) ) & + & * OneOverAccelDueToGravity + end do + + do jtype = 1,config%n_aerosol_types + itype = ao%itype(jtype) + + ! Add the optical depth, scattering optical depth and + ! scattering optical depth-weighted asymmetry factor for + ! this aerosol type to the total for all aerosols. Note + ! that the following expressions are array-wise, the + ! dimension being spectral band. + if (ao%iclass(jtype) == IAerosolClassHydrophobic) then + do jlev = istartlev,iendlev + mixing_ratio = aerosol%mixing_ratio(jcol,jlev,jtype) + do jband = 1,config%n_bands_sw + local_od_sw = factor(jlev) * mixing_ratio & + & * ao%mass_ext_sw_phobic(jband,itype) + od_sw_aerosol(jband,jlev) = od_sw_aerosol(jband,jlev) + local_od_sw + scat_sw_aerosol(jband,jlev) = scat_sw_aerosol(jband,jlev) & + & + local_od_sw * ao%ssa_sw_phobic(jband,itype) + scat_g_sw_aerosol(jband,jlev) = scat_g_sw_aerosol(jband,jlev) & + & + local_od_sw * ao%ssa_sw_phobic(jband,itype) & + & * ao%g_sw_phobic(jband,itype) + end do + if (config%do_lw_aerosol_scattering) then + do jband = 1,config%n_bands_lw + local_od_lw = factor(jlev) * mixing_ratio & + & * ao%mass_ext_lw_phobic(jband,itype) + od_lw_aerosol(jband,jlev) = od_lw_aerosol(jband,jlev) + local_od_lw + scat_lw_aerosol(jband,jlev) = scat_lw_aerosol(jband,jlev) & + & + local_od_lw * ao%ssa_lw_phobic(jband,itype) + scat_g_lw_aerosol(jband,jlev) = scat_g_lw_aerosol(jband,jlev) & + & + local_od_lw * ao%ssa_lw_phobic(jband,itype) & + & * ao%g_lw_phobic(jband,itype) + end do + else + ! If aerosol longwave scattering is not included then we + ! weight the optical depth by the single scattering + ! co-albedo + do jband = 1,config%n_bands_lw + od_lw_aerosol(jband,jlev) = od_lw_aerosol(jband,jlev) & + & + factor(jlev) * mixing_ratio & + & * ao%mass_ext_lw_phobic(jband,itype) & + & * (1.0_jprb - ao%ssa_lw_phobic(jband,itype)) + end do + end if + end do + + else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then + ! Hydrophilic aerosols require the look-up tables to + ! be indexed with irh + do jlev = istartlev,iendlev + mixing_ratio = aerosol%mixing_ratio(jcol,jlev,jtype) + irh = irhs(jlev) + do jband = 1,config%n_bands_sw + local_od_sw = factor(jlev) * mixing_ratio & + & * ao%mass_ext_sw_philic(jband,irh,itype) + od_sw_aerosol(jband,jlev) = od_sw_aerosol(jband,jlev) + local_od_sw + scat_sw_aerosol(jband,jlev) = scat_sw_aerosol(jband,jlev) & + & + local_od_sw * ao%ssa_sw_philic(jband,irh,itype) + scat_g_sw_aerosol(jband,jlev) = scat_g_sw_aerosol(jband,jlev) & + & + local_od_sw * ao%ssa_sw_philic(jband,irh,itype) & + & * ao%g_sw_philic(jband,irh,itype) + end do + if (config%do_lw_aerosol_scattering) then + do jband = 1,config%n_bands_lw + local_od_lw = factor(jlev) * mixing_ratio & + & * ao%mass_ext_lw_philic(jband,irh,itype) + od_lw_aerosol(jband,jlev) = od_lw_aerosol(jband,jlev) + local_od_lw + scat_lw_aerosol(jband,jlev) = scat_lw_aerosol(jband,jlev) & + & + local_od_lw * ao%ssa_lw_philic(jband,irh,itype) + scat_g_lw_aerosol(jband,jlev) = scat_g_lw_aerosol(jband,jlev) & + & + local_od_lw * ao%ssa_lw_philic(jband,irh,itype) & + & * ao%g_lw_philic(jband,irh,itype) + end do + else + ! If aerosol longwave scattering is not included then we + ! weight the optical depth by the single scattering + ! co-albedo + do jband = 1,config%n_bands_lw + od_lw_aerosol(jband,jlev) = od_lw_aerosol(jband,jlev) & + & + factor(jlev) * mixing_ratio & + & * ao%mass_ext_lw_philic(jband,irh,itype) & + & * (1.0_jprb - ao%ssa_lw_philic(jband,irh,itype)) + end do + end if + end do + + ! Implicitly, if ao%iclass(jtype) == IAerosolClassNone, then + ! no aerosol scattering properties are added + end if + + end do ! Loop over aerosol type + + if (.not. config%do_sw_delta_scaling_with_gases) then + ! Delta-Eddington scaling on aerosol only. Note that if + ! do_sw_delta_scaling_with_gases==.true. then the delta + ! scaling is done to the cloud-aerosol-gas mixture inside + ! the solver + call delta_eddington_extensive_vec(config%n_bands_sw*nlev, od_sw_aerosol, & + & scat_sw_aerosol, scat_g_sw_aerosol) + end if + + ! Combine aerosol shortwave scattering properties with gas + ! properties (noting that any gas scattering will have an + ! asymmetry factor of zero) + if (config%do_cloud_aerosol_per_sw_g_point) then + + ! We can assume the band and g-point indices are the same + do jlev = 1,nlev + do jg = 1,config%n_g_sw + local_scat = ssa_sw(jg,jlev,jcol)*od_sw(jg,jlev,jcol) + scat_sw_aerosol(jg,jlev) + od_sw(jg,jlev,jcol) = od_sw(jg,jlev,jcol) + od_sw_aerosol(jg,jlev) + g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(jg,jlev) / max(local_scat, 1.0e-24_jprb) + ssa_sw(jg,jlev,jcol) = min(local_scat / max(od_sw(jg,jlev,jcol), 1.0e-24_jprb), 1.0_jprb) + end do + end do + + else + + do jlev = 1,nlev + do jg = 1,config%n_g_sw + ! Need to map between bands and g-points + iband = config%i_band_from_reordered_g_sw(jg) + local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband,jlev) + if (local_od > 0.0_jprb .and. od_sw_aerosol(iband,jlev) > 0.0_jprb) then + local_scat = ssa_sw(jg,jlev,jcol) * od_sw(jg,jlev,jcol) & + & + scat_sw_aerosol(iband,jlev) + ! Note that asymmetry_sw of gases is zero so the following + ! simply weights the aerosol asymmetry by the scattering + ! optical depth + if (local_scat > 0.0_jprb) then + g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband,jlev) / local_scat + end if + ssa_sw(jg,jlev,jcol) = local_scat / local_od + od_sw (jg,jlev,jcol) = local_od + end if + end do + end do + + end if + + ! Combine aerosol longwave scattering properties with gas + ! properties, noting that in the longwave, gases do not + ! scatter at all + if (config%do_lw_aerosol_scattering) then + + call delta_eddington_extensive_vec(config%n_bands_lw*nlev, od_lw_aerosol, & + & scat_lw_aerosol, scat_g_lw_aerosol) + + do jlev = istartlev,iendlev + do jg = 1,config%n_g_lw + iband = config%i_band_from_reordered_g_lw(jg) + local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband,jlev) + if (local_od > 0.0_jprb .and. od_lw_aerosol(iband,jlev) > 0.0_jprb) then + ! All scattering is due to aerosols, therefore the + ! asymmetry factor is equal to the value for aerosols + if (scat_lw_aerosol(iband,jlev) > 0.0_jprb) then + g_lw(jg,jlev,jcol) = scat_g_lw_aerosol(iband,jlev) & + & / scat_lw_aerosol(iband,jlev) + end if + ssa_lw(jg,jlev,jcol) = scat_lw_aerosol(iband,jlev) / local_od + od_lw (jg,jlev,jcol) = local_od + end if + end do + end do + + else + + if (config%do_cloud_aerosol_per_lw_g_point) then + ! We can assume band and g-point indices are the same + do jlev = istartlev,iendlev + do jg = 1,config%n_g_lw + od_lw(jg,jlev,jcol) = od_lw(jg,jlev,jcol) + od_lw_aerosol(jg,jlev) + end do + end do + else + do jlev = istartlev,iendlev + do jg = 1,config%n_g_lw + od_lw(jg,jlev,jcol) = od_lw(jg,jlev,jcol) & + & + od_lw_aerosol(config%i_band_from_reordered_g_lw(jg),jlev) + end do + end do + end if + + end if + + end do ! Loop over column + + end if + + if (lhook) call dr_hook('radiation_aerosol_optics:add_aerosol_optics',1,hook_handle) + + end subroutine add_aerosol_optics + + + !--------------------------------------------------------------------- + ! Add precomputed optical properties to gas optical depth and + ! scattering properties + subroutine add_aerosol_optics_direct(nlev,istartcol,iendcol, & + & config, aerosol, & + & od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw) + + use parkind1, only : jprb + use radiation_io, only : nulerr, radiation_abort + use yomhook, only : lhook, dr_hook, jphook + use radiation_config, only : config_type + use radiation_aerosol, only : aerosol_type + + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in), target :: config + type(aerosol_type), intent(in) :: aerosol + ! Optical depth, single scattering albedo and asymmetry factor of + ! the atmosphere (gases on input, gases and aerosols on output) + ! for each g point. Note that longwave ssa and asymmetry and + ! shortwave asymmetry are all zero for gases, so are not yet + ! defined on input and are therefore intent(out). + real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol), & + & intent(inout) :: od_lw + real(jprb), dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol), & + & intent(out) :: ssa_lw, g_lw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), & + & intent(inout) :: od_sw, ssa_sw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), & + & intent(out) :: g_sw + + ! Temporary extinction and scattering optical depths of aerosol + ! plus gas + real(jprb) :: local_od, local_scat + + ! Extinction optical depth, scattering optical depth and + ! asymmetry-times-scattering-optical-depth for all the aerosols at + ! a point in space for each spectral band of the shortwave and + ! longwave spectrum + real(jprb), dimension(config%n_bands_sw,nlev) & + & :: od_sw_aerosol, scat_sw_aerosol, scat_g_sw_aerosol + real(jprb), dimension(config%n_bands_lw,nlev) :: od_lw_aerosol + real(jprb), dimension(config%n_bands_lw_if_scattering,nlev) & + & :: scat_lw_aerosol, scat_g_lw_aerosol + + ! Loop indices for column, level, g point and band + integer :: jcol, jlev, jg, jb + + ! Range of levels over which aerosols are present + integer :: istartlev, iendlev + + ! Indices to spectral band + integer :: iband + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics:add_aerosol_optics_direct',0,hook_handle) + + !$ACC DATA PRESENT(config, aerosol) + + if (config%do_sw) then + ! Check array dimensions + if (ubound(aerosol%od_sw,1) /= config%n_bands_sw) then + write(nulerr,'(a,i0,a,i0)') '*** Error: aerosol%od_sw contains ', & + & ubound(aerosol%od_sw,1), ' band, expected ', & + & config%n_bands_sw + call radiation_abort() + end if + + istartlev = lbound(aerosol%od_sw,2) + iendlev = ubound(aerosol%od_sw,2) + + !$ACC DATA PRESENT(od_sw, ssa_sw, g_sw) + + ! Set variables to zero that may not have been previously + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + do jcol = istartcol,iendcol + do jlev = 1,nlev + do jg = 1,config%n_g_sw + g_sw(jg,jlev,jcol) = 0.0_jprb + end do + end do + end do + !$ACC END PARALLEL + + ! Loop over position + !$ACC PARALLEL DEFAULT(NONE) & + !$ACC NUM_GANGS(iendcol-istartcol+1) & + !$ACC VECTOR_LENGTH(((config%n_g_sw-1)/32+1)*32) ASYNC(1) + !$ACC LOOP GANG PRIVATE(od_sw_aerosol, scat_sw_aerosol, scat_g_sw_aerosol) + do jcol = istartcol,iendcol +! Added for DWD (2020) +!NEC$ forced_collapse + !$ACC LOOP VECTOR COLLAPSE(2) + do jlev = istartlev,iendlev + do jb = 1,config%n_bands_sw + od_sw_aerosol(jb,jlev) = aerosol%od_sw(jb,jlev,jcol) + scat_sw_aerosol(jb,jlev) = aerosol%ssa_sw(jb,jlev,jcol) * od_sw_aerosol(jb,jlev) + scat_g_sw_aerosol(jb,jlev) = aerosol%g_sw(jb,jlev,jcol) * scat_sw_aerosol(jb,jlev) + + if (.not. config%do_sw_delta_scaling_with_gases) then + ! Delta-Eddington scaling on aerosol only. Note that if + ! do_sw_delta_scaling_with_gases==.true. then the delta + ! scaling is done to the cloud-aerosol-gas mixture + ! inside the solver + call delta_eddington_extensive(od_sw_aerosol(jb,jlev), scat_sw_aerosol(jb,jlev), & + & scat_g_sw_aerosol(jb,jlev)) + end if + end do + end do + ! Combine aerosol shortwave scattering properties with gas + ! properties (noting that any gas scattering will have an + ! asymmetry factor of zero) + !$ACC LOOP VECTOR COLLAPSE(2) PRIVATE(iband, local_od, local_scat) + do jlev = istartlev,iendlev +#ifdef _OPENACC + do jg = 1,config%n_g_sw + if (od_sw_aerosol(1,jlev) > 0.0_jprb) then +#else + if (od_sw_aerosol(1,jlev) > 0.0_jprb) then + do jg = 1,config%n_g_sw +#endif + iband = config%i_band_from_reordered_g_sw(jg) + local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband,jlev) + local_scat = ssa_sw(jg,jlev,jcol) * od_sw(jg,jlev,jcol) & + & + scat_sw_aerosol(iband,jlev) + ! Note that asymmetry_sw of gases is zero so the following + ! simply weights the aerosol asymmetry by the scattering + ! optical depth + g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband,jlev) / local_scat + local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband,jlev) + ssa_sw(jg,jlev,jcol) = local_scat / local_od + od_sw (jg,jlev,jcol) = local_od +#ifdef _OPENACC + end if + end do +#else + end do + end if +#endif + end do + end do + !$ACC END PARALLEL + + !$ACC END DATA + end if + + if (config%do_lw) then + + if (ubound(aerosol%od_lw,1) /= config%n_bands_lw) then + write(nulerr,'(a,i0,a,i0)') '*** Error: aerosol%od_lw contains ', & + & ubound(aerosol%od_lw,1), ' band, expected ', & + & config%n_bands_lw + call radiation_abort() + end if + + istartlev = lbound(aerosol%od_lw,2) + iendlev = ubound(aerosol%od_lw,2) + + if (config%do_lw_aerosol_scattering) then + ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb + g_lw(:,:,istartcol:iendcol) = 0.0_jprb + + ! Loop over position + do jcol = istartcol,iendcol +! Added for DWD (2020) +!NEC$ forced_collapse + do jlev = istartlev,iendlev + do jb = 1,config%n_bands_lw + od_lw_aerosol(jb,jlev) = aerosol%od_lw(jb,jlev,jcol) + scat_lw_aerosol(jb,jlev) = aerosol%ssa_lw(jb,jlev,jcol) * od_lw_aerosol(jb,jlev) + scat_g_lw_aerosol(jb,jlev) = aerosol%g_lw(jb,jlev,jcol) * scat_lw_aerosol(jb,jlev) + + call delta_eddington_extensive(od_lw_aerosol(jb,jlev), scat_lw_aerosol(jb,jlev), & + & scat_g_lw_aerosol(jb,jlev)) + end do + end do + do jlev = istartlev,iendlev + do jg = 1,config%n_g_lw + iband = config%i_band_from_reordered_g_lw(jg) + if (od_lw_aerosol(iband,jlev) > 0.0_jprb) then + ! All scattering is due to aerosols, therefore the + ! asymmetry factor is equal to the value for aerosols + if (scat_lw_aerosol(iband,jlev) > 0.0_jprb) then + g_lw(jg,jlev,jcol) = scat_g_lw_aerosol(iband,jlev) & + & / scat_lw_aerosol(iband,jlev) + end if + local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband,jlev) + ssa_lw(jg,jlev,jcol) = scat_lw_aerosol(iband,jlev) / local_od + od_lw (jg,jlev,jcol) = local_od + end if + end do + end do + end do + + else ! No longwave scattering + + !$ACC WAIT + ! Loop over position + !$ACC PARALLEL DEFAULT(NONE) PRESENT(od_lw) & + !$ACC NUM_GANGS(iendcol-istartcol+1) & + !$ACC VECTOR_LENGTH(((config%n_g_lw-1)/32+1)*32) ASYNC(1) + !$ACC LOOP GANG PRIVATE(od_lw_aerosol) + do jcol = istartcol,iendcol + !$ACC LOOP WORKER +! Added for DWD (2020) +!NEC$ forced_collapse + do jlev = istartlev,iendlev + ! If aerosol longwave scattering is not included then we + ! weight the optical depth by the single scattering + ! co-albedo + !$ACC LOOP VECTOR + do jb = 1, config%n_bands_lw + od_lw_aerosol(jb,jlev) = aerosol%od_lw(jb,jlev,jcol) & + & * (1.0_jprb - aerosol%ssa_lw(jb,jlev,jcol)) + end do + end do + !$ACC LOOP WORKER + do jlev = istartlev,iendlev + !$ACC LOOP VECTOR + do jg = 1,config%n_g_lw + od_lw(jg,jlev,jcol) = od_lw(jg,jlev,jcol) & + & + od_lw_aerosol(config%i_band_from_reordered_g_lw(jg),jlev) + end do + end do + end do + !$ACC END PARALLEL + + end if + end if + + !$ACC END DATA + + if (lhook) call dr_hook('radiation_aerosol_optics:add_aerosol_optics_direct',1,hook_handle) + + end subroutine add_aerosol_optics_direct + + + !--------------------------------------------------------------------- + ! Sometimes it is useful to specify aerosol in terms of its optical + ! depth at a particular wavelength. This function returns the dry + ! mass-extinction coefficient, i.e. the extinction cross section per + ! unit mass, for aerosol of type "itype" at the specified wavelength + ! (m). For hydrophilic types, the value at the first relative + ! humidity bin is taken. + function dry_aerosol_mass_extinction(config, itype, wavelength) + + use parkind1, only : jprb + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type + use radiation_aerosol_optics_data, only : aerosol_optics_type, & + & IAerosolClassUndefined, IAerosolClassIgnored, & + & IAerosolClassHydrophobic, IAerosolClassHydrophilic + + type(config_type), intent(in), target :: config + + ! Aerosol type + integer, intent(in) :: itype + + ! Wavelength (m) + real(jprb), intent(in) :: wavelength + + real(jprb) :: dry_aerosol_mass_extinction + + ! Index to the monochromatic wavelength requested + integer :: imono + + ! Pointer to the aerosol optics coefficients for brevity of access + type(aerosol_optics_type), pointer :: ao + + ao => config%aerosol_optics + + imono = minloc(abs(wavelength - ao%wavelength_mono), 1) + + if (abs(wavelength - ao%wavelength_mono(imono))/wavelength > 0.02_jprb) then + write(nulerr,'(a,e11.4,a)') '*** Error: requested wavelength ', & + & wavelength, ' not within 2% of stored wavelengths' + call radiation_abort() + end if + + if (ao%iclass(itype) == IAerosolClassHydrophobic) then + dry_aerosol_mass_extinction = ao%mass_ext_mono_phobic(imono,ao%itype(itype)) + else if (ao%iclass(itype) == IAerosolClassHydrophilic) then + ! Take the value at the first relative-humidity bin for the + ! "dry" aerosol value + dry_aerosol_mass_extinction = ao%mass_ext_mono_philic(imono,1,ao%itype(itype)) + else + dry_aerosol_mass_extinction = 0.0_jprb + end if + + end function dry_aerosol_mass_extinction + + + !--------------------------------------------------------------------- + ! Compute aerosol extinction coefficient at a particular wavelength + ! and a single height - this is useful for visibility diagnostics + subroutine aerosol_extinction(ncol,istartcol,iendcol, & + & config, wavelength, mixing_ratio, relative_humidity, extinction) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type + use radiation_aerosol_optics_data, only : aerosol_optics_type, & + & IAerosolClassUndefined, IAerosolClassIgnored, & + & IAerosolClassHydrophobic, IAerosolClassHydrophilic + + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in), target :: config + real(jprb), intent(in) :: wavelength ! Requested wavelength (m) + real(jprb), intent(in) :: mixing_ratio(ncol,config%n_aerosol_types) + real(jprb), intent(in) :: relative_humidity(ncol) + real(jprb), intent(out) :: extinction(ncol) + + ! Local aerosol extinction + real(jprb) :: ext + + ! Index to the monochromatic wavelength requested + integer :: imono + + ! Pointer to the aerosol optics coefficients for brevity of access + type(aerosol_optics_type), pointer :: ao + + ! Loop indices for column and aerosol type + integer :: jcol, jtype + + ! Relative humidity index + integer :: irh + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_extinction',0,hook_handle) + + do jtype = 1,config%n_aerosol_types + if (config%aerosol_optics%iclass(jtype) == IAerosolClassUndefined) then + write(nulerr,'(a)') '*** Error: not all aerosol types are defined' + call radiation_abort() + end if + end do + + ao => config%aerosol_optics + + imono = minloc(abs(wavelength - ao%wavelength_mono), 1) + + if (abs(wavelength - ao%wavelength_mono(imono))/wavelength > 0.02_jprb) then + write(nulerr,'(a,e11.4,a)') '*** Error: requested wavelength ', & + & wavelength, ' not within 2% of stored wavelengths' + call radiation_abort() + end if + + ! Loop over position + do jcol = istartcol,iendcol + ext = 0.0_jprb + ! Get relative-humidity index + irh = ao%calc_rh_index(relative_humidity(jcol)) + ! Add extinction coefficients from each aerosol type + do jtype = 1,config%n_aerosol_types + if (ao%iclass(jtype) == IAerosolClassHydrophobic) then + ext = ext + mixing_ratio(jcol,jtype) & + & * ao%mass_ext_mono_phobic(imono,ao%itype(jtype)) + else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then + ext = ext + mixing_ratio(jcol,jtype) & + & * ao%mass_ext_mono_philic(imono,irh,ao%itype(jtype)) + end if + end do + + extinction(jcol) = ext + end do + + if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_extinction',1,hook_handle) + + end subroutine aerosol_extinction + +end module radiation_aerosol_optics Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics_data.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics_data.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics_data.F90 (revision 6016) @@ -0,0 +1,750 @@ +! radiation_aerosol_optics_data.F90 - Type to store aerosol optical properties +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-10-23 R. Hogan Renamed single-character variables +! 2018-04-20 A. Bozzo Read optical properties at selected wavelengths + +#include "ecrad_config.h" + +module radiation_aerosol_optics_data + + use parkind1, only : jprb + use radiation_io, only : nulerr, radiation_abort + + implicit none + public + + private :: get_line + + ! The following provide possible values for + ! aerosol_optics_type%iclass, which is used to map the user's type + ! index to the hydrophobic or hydrophilic types loaded from the + ! aerosol optics file. Initially iclass is equal to + ! AerosolClassUndefined, which will throw an error if ever the user + ! tries to use this aerosol type. The user may specify that an + ! aerosol type is to be ignored in the radiation calculation, in + ! which case iclass will be set equal to AerosolClassIgnored. + enum, bind(c) + enumerator IAerosolClassUndefined, IAerosolClassIgnored, & + & IAerosolClassHydrophobic, IAerosolClassHydrophilic + end enum + + integer, parameter :: NMaxStringLength = 2000 + integer, parameter :: NMaxLineLength = 200 + + !--------------------------------------------------------------------- + ! This type holds the configuration information to compute + ! aerosol optical properties + type aerosol_optics_type + ! A vector of length ntype, iclass maps user-defined types on to + ! the hydrophilic or hydrophobic aerosol classes using the + ! enumerators above + integer, allocatable, dimension(:) :: iclass + + ! Also a vector of length ntype, itype maps user-defined types on + ! to specific hydrophilic or hydrophobic aerosol types + integer, allocatable, dimension(:) :: itype + + ! Wavenumber (cm-1) upper and lower bounds of each spectral + ! interval, which if used in the RRTMG gas optics scheme should + ! match its band bounds + real(jprb), allocatable, dimension(:) :: wavenumber1_sw, wavenumber2_sw + real(jprb), allocatable, dimension(:) :: wavenumber1_lw, wavenumber2_lw + + ! Scattering properties are provided separately in the shortwave + ! and longwave for hydrophobic and hydrophilic aerosols. + ! Hydrophobic aerosols are dimensioned (nband,n_type_phobic): + real(jprb), allocatable, dimension(:,:) :: & + & mass_ext_sw_phobic, & ! Mass-extinction coefficient (m2 kg-1) + & ssa_sw_phobic, & ! Single scattering albedo + & g_sw_phobic, & ! Asymmetry factor +! & ssa_g_sw_phobic, & ! ssa*g + & mass_ext_lw_phobic, & ! Mass-extinction coefficient (m2 kg-1) +! & mass_abs_lw_phobic, & ! Mass-absorption coefficient (m2 kg-1) + & ssa_lw_phobic, & ! Single scattering albedo + & g_lw_phobic ! Asymmetry factor + + ! Hydrophilic aerosols are dimensioned (nband,nrh,n_type_philic): + real(jprb), allocatable, dimension(:,:,:) :: & + & mass_ext_sw_philic, & ! Mass-extinction coefficient (m2 kg-1) + & ssa_sw_philic, & ! Single scattering albedo + & g_sw_philic, & ! Asymmetry factor + ! & ssa_g_sw_philic, & ! ssa*g + & mass_ext_lw_philic, & ! Mass-extinction coefficient (m2 kg-1) + ! & mass_abs_lw_philic, & ! Mass-absorption coefficient (m2 kg-1) + & ssa_lw_philic, & ! Single scattering albedo + & g_lw_philic ! Asymmetry factor + + ! Wavelengths at which monochromatic properties are stored, + ! dimensioned (n_mono_wl), units metres + real(jprb), allocatable :: wavelength_mono(:) + + ! Scattering properties at selected monochromatic wavelengths + ! (n_mono_wl,n_type_phobic) + real(jprb), allocatable, dimension(:,:) :: & + & mass_ext_mono_phobic, & ! Mass-extinction coefficient (m2 kg-1) + & ssa_mono_phobic, & ! Single scattering albedo + & g_mono_phobic, & ! Asymmetry factor + & lidar_ratio_mono_phobic ! Lidar Ratio + ! ...hydrophilic aerosols dimensioned (n_mono_wl,nrh,n_type_philic): + real(jprb), allocatable, dimension(:,:,:) :: & + & mass_ext_mono_philic, & ! Mass-extinction coefficient (m2 kg-1) + & ssa_mono_philic, & ! Single scattering albedo + & g_mono_philic, & ! Asymmetry factor + & lidar_ratio_mono_philic ! Lidar Ratio + + ! For hydrophilic aerosols, the lower bounds of the relative + ! humidity bins is a vector of length nrh: + real(jprb), allocatable, dimension(:) :: & + & rh_lower ! Dimensionless (1.0 = 100% humidity) + + ! Strings describing the aerosol types + character(len=NMaxStringLength) :: description_phobic_str = ' ' + character(len=NMaxStringLength) :: description_philic_str = ' ' + + ! The number of user-defined aerosol types + integer :: ntype + + ! The number of hydrophobic and hydrophilic types read from the + ! aerosol optics file + integer :: n_type_phobic = 0 + integer :: n_type_philic = 0 + + ! Number of relative humidity bins + integer :: nrh = 0 + + ! Number of longwave and shortwave bands of the data in the file, + ! and monochromatic wavelengths + integer :: n_bands_lw = 0, n_bands_sw = 0, n_mono_wl = 0 + + ! Do we have any hydrophilic types? + logical :: use_hydrophilic = .true. + + ! Do we have monochromatic optical properties + logical :: use_monochromatic = .false. + + contains + procedure :: setup => setup_aerosol_optics + procedure :: save => save_aerosol_optics + procedure :: allocate + procedure :: initialize_types + procedure :: set_hydrophobic_type + procedure :: set_hydrophilic_type + procedure :: set_empty_type + procedure :: set_types + procedure :: calc_rh_index + procedure :: print_description + + end type aerosol_optics_type + +contains + + + !--------------------------------------------------------------------- + ! Setup aerosol optics coefficients by reading them from a file + subroutine setup_aerosol_optics(this, file_name, iverbose) + + use yomhook, only : lhook, dr_hook, jphook +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + use radiation_io, only : nulerr, radiation_abort + + class(aerosol_optics_type), intent(inout) :: this + character(len=*), intent(in) :: file_name + integer, intent(in), optional :: iverbose + + ! The NetCDF file containing the aerosol optics data + type(netcdf_file) :: file + + real(jprb), allocatable :: wavelength_tmp(:) + integer :: iverb + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:setup',0,hook_handle) + + if (present(iverbose)) then + iverb = iverbose + else + iverb = 2 + end if + + ! Open the aerosol scattering file and configure the way it is + ! read + call file%open(trim(file_name), iverbose=iverb) + + if (file%exists('mass_ext_sw_hydrophilic')) then + this%use_hydrophilic = .true. + else + this%use_hydrophilic = .false. + end if + + ! Read the wavenumber bounds + call file%get('wavenumber1_sw', this%wavenumber1_sw) + call file%get('wavenumber2_sw', this%wavenumber2_sw) + call file%get('wavenumber1_lw', this%wavenumber1_lw) + call file%get('wavenumber2_lw', this%wavenumber2_lw) + + ! Read the raw scattering data + call file%get('mass_ext_sw_hydrophobic', this%mass_ext_sw_phobic) + call file%get('ssa_sw_hydrophobic', this%ssa_sw_phobic) + call file%get('asymmetry_sw_hydrophobic',this%g_sw_phobic) + call file%get('mass_ext_lw_hydrophobic', this%mass_ext_lw_phobic) + call file%get('ssa_lw_hydrophobic', this%ssa_lw_phobic) + call file%get('asymmetry_lw_hydrophobic',this%g_lw_phobic) + + call file%get_global_attribute('description_hydrophobic', & + & this%description_phobic_str) + + ! Precompute ssa*g for the shortwave and mass-absorption for the + ! longwave - TBD FIX + !allocate(this%ssa_g_sw_phobic(... + + if (this%use_hydrophilic) then + call file%get('mass_ext_sw_hydrophilic', this%mass_ext_sw_philic) + call file%get('ssa_sw_hydrophilic', this%ssa_sw_philic) + call file%get('asymmetry_sw_hydrophilic',this%g_sw_philic) + call file%get('mass_ext_lw_hydrophilic', this%mass_ext_lw_philic) + call file%get('ssa_lw_hydrophilic', this%ssa_lw_philic) + call file%get('asymmetry_lw_hydrophilic',this%g_lw_philic) + + call file%get('relative_humidity1', this%rh_lower) + + call file%get_global_attribute('description_hydrophilic', & + & this%description_philic_str) + end if + + ! Read the monochromatic scattering data at selected wavelengths + ! if available in the input file + if (file%exists('mass_ext_mono_hydrophobic')) then + this%use_monochromatic = .true. + + if (allocated(this%wavelength_mono)) then + ! User has provided required monochromatic wavelengths, which + ! must match those in the file (in the more recent "general" + ! aerosol optics, interpolation provides optical properties at + ! the requested wavelengths) + call file%get('wavelength_mono', wavelength_tmp) + if (size(wavelength_tmp) /= size(this%wavelength_mono)) then + write(nulerr,'(a,i0,a,i0,a)') '*** Error: ', size(this%wavelength_mono), & + & ' monochromatic wavelengths requested but ', & + & size(wavelength_tmp), ' in file' + call radiation_abort('Radiation configuration error') + end if + if (any(abs(this%wavelength_mono-wavelength_tmp) & + & / this%wavelength_mono > 0.01_jprb)) then + write(nulerr,'(a,a)') '*** Error: requested monochromatic wavelengths', & + & 'must all be within 1% of values in file' + call radiation_abort('Radiation configuration error') + end if + else + ! User has not provided required wavelengths, so we save the + ! monochromatic wavelengths in the file + call file%get('wavelength_mono', this%wavelength_mono) + end if + + call file%get('mass_ext_mono_hydrophobic', this%mass_ext_mono_phobic) + call file%get('ssa_mono_hydrophobic', this%ssa_mono_phobic) + call file%get('asymmetry_mono_hydrophobic',this%g_mono_phobic) + call file%get('lidar_ratio_mono_hydrophobic',this%lidar_ratio_mono_phobic) + if (this%use_hydrophilic) then + call file%get('mass_ext_mono_hydrophilic', this%mass_ext_mono_philic) + call file%get('ssa_mono_hydrophilic', this%ssa_mono_philic) + call file%get('asymmetry_mono_hydrophilic',this%g_mono_philic) + call file%get('lidar_ratio_mono_hydrophilic',this%lidar_ratio_mono_philic) + end if + else + this%use_monochromatic = .false. + end if + + ! Close aerosol scattering file + call file%close() + + ! Get array sizes + this%n_bands_lw = size(this%mass_ext_lw_phobic, 1) + this%n_bands_sw = size(this%mass_ext_sw_phobic, 1) + if (this%use_monochromatic) then + this%n_mono_wl = size(this%mass_ext_mono_phobic, 1) + else + this%n_mono_wl = 0 + end if + this%n_type_phobic = size(this%mass_ext_lw_phobic, 2) + + if (this%use_hydrophilic) then + this%n_type_philic = size(this%mass_ext_lw_philic, 3) + this%nrh = size(this%mass_ext_lw_philic, 2) + + ! Check agreement of dimensions + if (size(this%mass_ext_lw_philic,1) /= this%n_bands_lw) then + write(nulerr,'(a,a)') '*** Error: mass extinction for hydrophilic and hydrophobic ', & + & 'aerosol have different numbers of longwave bands' + call radiation_abort('Radiation configuration error') + end if + if (size(this%mass_ext_sw_philic,1) /= this%n_bands_sw) then + write(nulerr,'(a,a)') '*** Error: mass extinction for hydrophilic and hydrophobic ', & + & 'aerosol have different numbers of shortwave bands' + call radiation_abort('Radiation configuration error') + end if + if (size(this%rh_lower) /= this%nrh) then + write(nulerr,'(a)') '*** Error: size(relative_humidity1) /= size(mass_ext_sw_hydrophilic,2)' + call radiation_abort('Radiation configuration error') + end if + + else + this%n_type_philic = 0 + this%nrh = 0 + end if + + if (lhook) call dr_hook('radiation_aerosol_optics_data:setup',1,hook_handle) + + end subroutine setup_aerosol_optics + + + !--------------------------------------------------------------------- + ! Initialize the arrays describing the user's aerosol types + subroutine initialize_types(this, ntype) + + class(aerosol_optics_type), intent(inout) :: this + integer, intent(in) :: ntype + + ! Allocate memory for mapping arrays + this%ntype = ntype + allocate(this%iclass(ntype)) + allocate(this%itype(ntype)) + + this%iclass = IAerosolClassUndefined + this%itype = 0 + + end subroutine initialize_types + + !--------------------------------------------------------------------- + ! Allocate arrays for aerosol optics data type + subroutine allocate(this, n_type_phobic, n_type_philic, nrh, & + & n_bands_lw, n_bands_sw, n_mono_wl) + + use yomhook, only : lhook, dr_hook, jphook + + class(aerosol_optics_type), intent(inout) :: this + integer, intent(in) :: n_type_phobic, n_type_philic, nrh + integer, intent(in) :: n_bands_lw, n_bands_sw, n_mono_wl + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:allocate',0,hook_handle) + + this%n_type_phobic = n_type_phobic + this%n_type_philic = n_type_philic + this%nrh = nrh + this%n_bands_lw = n_bands_lw + this%n_bands_sw = n_bands_sw + this%n_mono_wl = n_mono_wl + + if (n_type_philic > 0) then + this%use_hydrophilic = .true. + else + this%use_hydrophilic = .false. + end if + + if (n_bands_sw > 0) then + allocate(this%mass_ext_sw_phobic(n_bands_sw, n_type_phobic)) + allocate(this%ssa_sw_phobic(n_bands_sw, n_type_phobic)) + allocate(this%g_sw_phobic(n_bands_sw, n_type_phobic)) + end if + if (n_bands_lw > 0) then + allocate(this%mass_ext_lw_phobic(n_bands_lw, n_type_phobic)) + allocate(this%ssa_lw_phobic(n_bands_lw, n_type_phobic)) + allocate(this%g_lw_phobic(n_bands_lw, n_type_phobic)) + end if + if (n_mono_wl > 0) then + allocate(this%mass_ext_mono_phobic(n_mono_wl, n_type_phobic)) + allocate(this%ssa_mono_phobic(n_mono_wl, n_type_phobic)) + allocate(this%g_mono_phobic(n_mono_wl, n_type_phobic)) + allocate(this%lidar_ratio_mono_phobic(n_mono_wl, n_type_phobic)) + end if + + if (n_type_philic > 0 .and. nrh > 0) then + if (n_bands_sw > 0) then + allocate(this%mass_ext_sw_philic(n_bands_sw, nrh, n_type_philic)) + allocate(this%ssa_sw_philic(n_bands_sw, nrh, n_type_philic)) + allocate(this%g_sw_philic(n_bands_sw, nrh, n_type_philic)) + end if + if (n_bands_lw > 0) then + allocate(this%mass_ext_lw_philic(n_bands_lw, nrh, n_type_philic)) + allocate(this%ssa_lw_philic(n_bands_lw, nrh, n_type_philic)) + allocate(this%g_lw_philic(n_bands_lw, nrh, n_type_philic)) + end if + if (n_mono_wl > 0) then + allocate(this%mass_ext_mono_philic(n_mono_wl, nrh, n_type_philic)) + allocate(this%ssa_mono_philic(n_mono_wl, nrh, n_type_philic)) + allocate(this%g_mono_philic(n_mono_wl, nrh, n_type_philic)) + allocate(this%lidar_ratio_mono_philic(n_mono_wl, nrh, n_type_philic)) + end if + end if + + if (lhook) call dr_hook('radiation_aerosol_optics_data:allocate',1,hook_handle) + + end subroutine allocate + + + !--------------------------------------------------------------------- + ! Save aerosol optical properties in the named file + subroutine save_aerosol_optics(this, file_name, iverbose) + + use yomhook, only : lhook, dr_hook, jphook + use easy_netcdf, only : netcdf_file + + class(aerosol_optics_type), intent(inout) :: this + character(len=*), intent(in) :: file_name + integer, optional, intent(in) :: iverbose + + ! Object for output NetCDF file + type(netcdf_file) :: out_file + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:save',0,hook_handle) + + ! Create the file + call out_file%create(trim(file_name), iverbose=iverbose) + + ! Define dimensions + call out_file%define_dimension("band_lw", this%n_bands_lw) + call out_file%define_dimension("band_sw", this%n_bands_sw) + call out_file%define_dimension("hydrophilic", this%n_type_philic) + call out_file%define_dimension("hydrophobic", this%n_type_phobic) + call out_file%define_dimension("relative_humidity", this%nrh) + !if (this%use_monochromatic) then + ! call out_file%define_dimension("wavelength_mono", this%n_mono_wl) + !end if + + ! Put global attributes + call out_file%put_global_attributes( & + & title_str="Aerosol optical properties in the spectral intervals of the gas-optics scheme for ecRad", & + & source_str="ecRad offline radiation model") + call out_file%put_global_attribute( & + & "description_hydrophobic", this%description_phobic_str) + call out_file%put_global_attribute( & + & "description_hydrophilic", this%description_philic_str) + + ! Define variables + call out_file%define_variable("mass_ext_sw_hydrophobic", units_str="m2 kg-1", & + & long_name="Shortwave mass-extinction coefficient of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_sw") + call out_file%define_variable("ssa_sw_hydrophobic", units_str="1", & + & long_name="Shortwave single scattering albedo of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_sw") + call out_file%define_variable("asymmetry_sw_hydrophobic", units_str="1", & + & long_name="Shortwave asymmetry factor of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_sw") + + call out_file%define_variable("mass_ext_lw_hydrophobic", units_str="m2 kg-1", & + & long_name="Longwave mass-extinction coefficient of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_lw") + call out_file%define_variable("ssa_lw_hydrophobic", units_str="1", & + & long_name="Longwave single scattering albedo of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_lw") + call out_file%define_variable("asymmetry_lw_hydrophobic", units_str="1", & + & long_name="Longwave asymmetry factor of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_lw") + + call out_file%define_variable("mass_ext_sw_hydrophilic", units_str="m2 kg-1", & + & long_name="Shortwave mass-extinction coefficient of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw") + call out_file%define_variable("ssa_sw_hydrophilic", units_str="1", & + & long_name="Shortwave single scattering albedo of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw") + call out_file%define_variable("asymmetry_sw_hydrophilic", units_str="1", & + & long_name="Shortwave asymmetry factor of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw") + + call out_file%define_variable("mass_ext_lw_hydrophilic", units_str="m2 kg-1", & + & long_name="Longwave mass-extinction coefficient of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw") + call out_file%define_variable("ssa_lw_hydrophilic", units_str="1", & + & long_name="Longwave single scattering albedo of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw") + call out_file%define_variable("asymmetry_lw_hydrophilic", units_str="1", & + & long_name="Longwave asymmetry factor of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw") + + ! Write variables + call out_file%put("mass_ext_sw_hydrophobic", this%mass_ext_sw_phobic) + call out_file%put("ssa_sw_hydrophobic", this%ssa_sw_phobic) + call out_file%put("asymmetry_sw_hydrophobic", this%g_sw_phobic) + call out_file%put("mass_ext_lw_hydrophobic", this%mass_ext_lw_phobic) + call out_file%put("ssa_lw_hydrophobic", this%ssa_lw_phobic) + call out_file%put("asymmetry_lw_hydrophobic", this%g_lw_phobic) + call out_file%put("mass_ext_sw_hydrophilic", this%mass_ext_sw_philic) + call out_file%put("ssa_sw_hydrophilic", this%ssa_sw_philic) + call out_file%put("asymmetry_sw_hydrophilic", this%g_sw_philic) + call out_file%put("mass_ext_lw_hydrophilic", this%mass_ext_lw_philic) + call out_file%put("ssa_lw_hydrophilic", this%ssa_lw_philic) + call out_file%put("asymmetry_lw_hydrophilic", this%g_lw_philic) + + call out_file%close() + + if (lhook) call dr_hook('radiation_aerosol_optics_data:save',1,hook_handle) + + end subroutine save_aerosol_optics + + + !--------------------------------------------------------------------- + ! Map user type "itype" onto stored hydrophobic type "i_type_phobic" + subroutine set_hydrophobic_type(this, itype, i_type_phobic) + + use yomhook, only : lhook, dr_hook, jphook + + class(aerosol_optics_type), intent(inout) :: this + integer, intent(in) :: itype, i_type_phobic + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:set_hydrophobic_type',0,hook_handle) + + if (itype < 1 .or. itype > this%ntype) then + write(nulerr,'(a,i0)') '*** Error: aerosol type must be in the range 1 to ', & + & this%ntype + call radiation_abort('Error setting up aerosols') + end if + if (i_type_phobic < 1 .or. i_type_phobic > this%n_type_phobic) then + write(nulerr,'(a,i0)') '*** Error: hydrophobic type must be in the range 1 to ', & + & this%n_type_phobic + call radiation_abort('Error setting up aerosols') + end if + + this%iclass(itype) = IAerosolClassHydrophobic + this%itype (itype) = i_type_phobic + + if (lhook) call dr_hook('radiation_aerosol_optics_data:set_hydrophobic_type',1,hook_handle) + + end subroutine set_hydrophobic_type + + + !--------------------------------------------------------------------- + ! Map user type "itype" onto stored hydrophilic type "i_type_philic" + subroutine set_hydrophilic_type(this, itype, i_type_philic) + + use yomhook, only : lhook, dr_hook, jphook + + class(aerosol_optics_type), intent(inout) :: this + integer, intent(in) :: itype, i_type_philic + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:set_hydrophilic_type',0,hook_handle) + + if (.not. this%use_hydrophilic) then + write(nulerr,'(a)') '*** Error: attempt to set hydrophilic aerosol type when no such types present' + call radiation_abort('Error setting up aerosols') + end if + + if (itype < 1 .or. itype > this%ntype) then + write(nulerr,'(a,i0)') '*** Error: aerosol type must be in the range 1 to ', & + & this%ntype + call radiation_abort('Error setting up aerosols') + end if + if (i_type_philic < 1 .or. i_type_philic > this%n_type_philic) then + write(nulerr,'(a,i0)') '*** Error: hydrophilic type must be in the range 1 to ', & + & this%n_type_philic + call radiation_abort('Error setting up aerosols') + end if + + this%iclass(itype) = IAerosolClassHydrophilic + this%itype (itype) = i_type_philic + + if (lhook) call dr_hook('radiation_aerosol_optics_data:set_hydrophilic_type',1,hook_handle) + + end subroutine set_hydrophilic_type + + + !--------------------------------------------------------------------- + ! Set a user type "itype" to be ignored in the radiation scheme + subroutine set_empty_type(this, itype) + + use yomhook, only : lhook, dr_hook, jphook + + class(aerosol_optics_type), intent(inout) :: this + integer, intent(in) :: itype + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:set_empty_type',0,hook_handle) + + if (itype < 1 .or. itype > this%ntype) then + write(nulerr,'(a,i0)') '*** Error: aerosol type must be in the range 1 to ', & + & this%ntype + call radiation_abort('Error setting up aerosols') + end if + + this%iclass(itype) = IAerosolClassIgnored + + if (lhook) call dr_hook('radiation_aerosol_optics_data:set_empty_type',1,hook_handle) + + end subroutine set_empty_type + + + !--------------------------------------------------------------------- + ! Set user types "itypes" to map onto the stored hydrophobic and + ! hydrophilic types according to its sign and value, with a value of + ! 0 indicating that this type is to be ignored. Thus if itypes=(/ + ! 3, 4, -6, 0 /) then user types 1 and 2 map on to hydrophobic types + ! 3 and 4, user type 3 maps on to hydrophilic type 6 and user type 4 + ! is ignored. + subroutine set_types(this, itypes) + + use yomhook, only : lhook, dr_hook, jphook + + class(aerosol_optics_type), intent(inout) :: this + integer, dimension(:), intent(in) :: itypes + + integer :: jtype + integer :: istart, iend + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:set_types',0,hook_handle) + + istart = lbound(itypes,1) + iend = ubound(itypes,1) + + do jtype = istart, iend + if (itypes(jtype) == 0) then + call this%set_empty_type(jtype) + else if (itypes(jtype) > 0) then + call this%set_hydrophobic_type(jtype, itypes(jtype)) + else + call this%set_hydrophilic_type(jtype, -itypes(jtype)) + end if + end do + + if (lhook) call dr_hook('radiation_aerosol_optics_data:set_types',1,hook_handle) + + end subroutine set_types + + + !--------------------------------------------------------------------- + ! Return an index to the relative-humdity array, or zero if no + ! hydrophilic types are present. This function does so little that + ! it is best to remove the Dr Hook call. + function calc_rh_index(this, rh) + + !use yomhook, only : lhook, dr_hook, jphook + + class(aerosol_optics_type), intent(in) :: this + real(jprb), intent(in) :: rh + integer :: calc_rh_index + !real(jphook) :: hook_handle + + !if (lhook) call dr_hook('radiation_aerosol_optics_data:calc_rh_index',0,hook_handle) + + if (.not. this%use_hydrophilic) then + calc_rh_index = 0 + else if (rh > this%rh_lower(this%nrh)) then + calc_rh_index = this%nrh + else + calc_rh_index = 1 + do while (rh > this%rh_lower(calc_rh_index + 1)) + calc_rh_index = calc_rh_index + 1 + end do + end if + + !if (lhook) call dr_hook('radiation_aerosol_optics_data:calc_rh_index',1,hook_handle) + + end function calc_rh_index + + + !--------------------------------------------------------------------- + ! Print a description of the aerosol types to nulout + subroutine print_description(this, i_type_map) + + use radiation_io, only : nulout + + class(aerosol_optics_type), intent(in) :: this + integer, intent(in) :: i_type_map(:) + + integer :: jtype + + if (size(i_type_map) > 0) then + write(nulout,'(a)') 'Aerosol mapping:' + else + write(nulout,'(a)') 'No aerosol types in radiation scheme' + end if + + do jtype = 1,size(i_type_map) + if (i_type_map(jtype) > 0) then + write(nulout,'(i4,a,a)') jtype, ' -> hydrophobic type ', & + & trim(get_line(this%description_phobic_str, i_type_map(jtype))) + else if (i_type_map(jtype) < 0) then + write(nulout,'(i4,a,a)') jtype, ' -> hydrophilic type ', & + & trim(get_line(this%description_philic_str, -i_type_map(jtype))) + else + write(nulout,'(i4,a)') jtype, ' is unused' + end if + end do + + end subroutine print_description + + + !--------------------------------------------------------------------- + ! Private helper function for print_description + pure function get_line(str,iline) result(line_str) + character(len=*), intent(in) :: str + integer, intent(in) :: iline + character(len=NMaxLineLength) :: line_str + + integer :: istart, iend, i_start_new, ioffset, ilength, i_line_current + logical :: is_fail + + i_line_current = 1 + istart = 1 + iend = len(str) + is_fail = .false. + line_str = ' ' + + ! Find index of first character + do while (i_line_current < iline) + i_start_new = scan(str(istart:iend), new_line(' ')) + if (i_start_new == 0) then + is_fail = .true. + ! https://github.com/ecmwf-ifs/ecrad/issues/14 + ! cycle + exit + else + istart = istart + i_start_new + end if + i_line_current = i_line_current + 1 + end do + + if (.not. is_fail) then + ! Find index of last character + ioffset = scan(str(istart:iend), new_line(' ')) + if (ioffset == 0) then + ilength = len(trim(str(istart:iend))) + else + ilength = ioffset - 1 + end if + + if (ilength > NMaxLineLength) then + ilength = NMaxLineLength + end if + iend = istart + ilength - 1 + + line_str = str(istart:iend) + else + write(line_str,'(i0,a)') iline, ': ' + end if + + end function get_line + +end module radiation_aerosol_optics_data Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics_description.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics_description.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_aerosol_optics_description.F90 (revision 6016) @@ -0,0 +1,388 @@ +! radiation_aerosol_optics_description.F90 - Type to store aerosol optics metadata +! +! (C) Copyright 2022- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +#include "ecrad_config.h" + +module radiation_aerosol_optics_description + + use parkind1, only : jprb + + implicit none + public + + !--------------------------------------------------------------------- + ! This type holds the metadata from an aerosol optical property + ! file, enabling the user to request the index to the aerosol type + ! with particular properties. Note that string information is held + ! in the form of 2D arrays of single characters, so comparison to + ! character strings requires the to_string helper function at the + ! end of this file. + type aerosol_optics_description_type + + ! Two-character code describing the aerosol family, dimensioned + ! (2,naer), e.g. + ! SS: Sea salt + ! OM: Organic matter + ! SU: Sulfate + ! OB: Secondary organic biogenic + ! OA: Secondary organic anthropogenic + ! AM: Fine-mode ammonium sulfate + ! NI: Nitrate + ! DD: Desert dust + ! BC: Black carbon + character(len=1), allocatable :: code_phobic(:,:) + character(len=1), allocatable :: code_philic(:,:) + + ! Size bin, typically 1-2 or 1-3 in order fine to coarse, or zero + ! if no division by size is used, dimensioned (naer) + integer, allocatable :: bin_phobic(:) + integer, allocatable :: bin_philic(:) + + ! Character string characterizing the optical model, e.g. OPAC, + ! GACP, GLOMAP, Dubovik2002 etc. + character(len=1), allocatable :: optical_model_phobic(:,:) + character(len=1), allocatable :: optical_model_philic(:,:) + + ! The user can call preferred_optical_model to specify that a + ! certain optical model for a certain aerosol family is to be + ! preferred when get_index is called + logical, allocatable :: is_preferred_phobic(:) + logical, allocatable :: is_preferred_philic(:) + + ! Verbosity level + integer :: iverbose + + contains + procedure :: read + procedure :: preferred_optical_model + procedure :: get_index + + end type aerosol_optics_description_type + +contains + + !--------------------------------------------------------------------- + ! Read optical property file file_name into an + ! aerosol_optics_description_type object + subroutine read(this, file_name, iverbose) + + use yomhook, only : lhook, dr_hook, jphook +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + + class(aerosol_optics_description_type), intent(inout) :: this + character(len=*), intent(in) :: file_name + integer, intent(in), optional :: iverbose + + ! The NetCDF file containing the aerosol optics data + type(netcdf_file) :: file + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_description:load',0,hook_handle) + + ! Open the aerosol scattering file and configure the way it is + ! read + call file%open(trim(file_name), iverbose=iverbose) + + ! Read metadata variables + call file%get('code_hydrophilic', this%code_philic) + call file%get('code_hydrophobic', this%code_phobic) + call file%get('bin_hydrophilic', this%bin_philic) + call file%get('bin_hydrophobic', this%bin_phobic) + call file%get('optical_model_hydrophilic', this%optical_model_philic) + call file%get('optical_model_hydrophobic', this%optical_model_phobic) + + ! Allocate logical arrays of the appropriate size and set to FALSE + allocate(this%is_preferred_philic(size(this%bin_philic))) + allocate(this%is_preferred_phobic(size(this%bin_phobic))) + this%is_preferred_philic = .false. + this%is_preferred_phobic = .false. + + call file%close() + + if (present(iverbose)) then + this%iverbose = iverbose + else + this%iverbose = 3 + end if + + if (lhook) call dr_hook('radiation_aerosol_optics_description:load',1,hook_handle) + + end subroutine read + + !--------------------------------------------------------------------- + ! Specify the preferred optical model for a particular aerosol + ! family, e.g. "call + ! aer_desc%preferred_optical_model('DD','Woodward2001')" would mean + ! that subsequent calls to get_index in which the optical model is + ! not specified would return the Woodward model rather than the + ! first matching model in the file. The check is only done on the + ! first len(optical_model_str) characters, so "Woodward" and + ! "Woodward2001" would both match the Woodward2001 model. + subroutine preferred_optical_model(this, code_str, optical_model_str) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulout, nulerr, radiation_abort + + class(aerosol_optics_description_type), intent(inout) :: this + character(len=2), intent(in) :: code_str + character(len=*), intent(in) :: optical_model_str + + ! Aerosol loop counter + integer :: ja + + logical :: is_found, is_philic, is_phobic + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_description:preferred_optical_model',0,hook_handle) + + ! Check for empty string + if (optical_model_str == ' ') then + if (lhook) call dr_hook('radiation_aerosol_optics_description:preferred_optical_model',1,hook_handle) + return + end if + + is_found = .false. + is_philic = .false. + is_phobic = .false. + + ! Loop over hydrophilic types + do ja = 1,size(this%bin_philic) + ! Check if we have a match + if (to_string(this%code_philic(:,ja)) == code_str & + & .and. trim(to_string(this%optical_model_philic(:,ja))) & + & == optical_model_str) then + this%is_preferred_philic(ja) = .true. + is_found = .true. + is_philic = .true. + end if + end do + ! Repeat for the hydrophobic types + do ja = 1,size(this%bin_phobic) + if (to_string(this%code_phobic(:,ja)) == code_str & + & .and. trim(to_string(this%optical_model_phobic(:,ja))) & + & == optical_model_str) then + this%is_preferred_phobic(ja) = .true. + is_found = .true. + is_phobic = .true. + end if + end do + + if (.not. is_found) then + write(nulerr,'(a,a2,a,a,a)') '*** Error: Preferred "', code_str ,'" aerosol optical model "', & + & trim(optical_model_str), '" not found in file' + call radiation_abort() + else if (this%iverbose > 2) then + write(nulout,'(a,a2,a,a,a)',advance='no') 'Preferred "', code_str, '" aerosol optical model set to "', & + & trim(optical_model_str), '" (' + if (is_phobic) then + write(nulout,'(a)',advance='no') ' hydrophobic' + end if + if (is_philic) then + write(nulout,'(a)',advance='no') ' hydrophilic' + end if + write(nulout,'(a)') ' )' + end if + + if (lhook) call dr_hook('radiation_aerosol_optics_description:preferred_optical_model',1,hook_handle) + + end subroutine preferred_optical_model + + + !--------------------------------------------------------------------- + ! Return the index to the aerosol optical properties corresponding + ! to the aerosol family in code_str (e.g. SS, DD etc), whether or + ! not the requested aerosol is hydrophilic in the logical + ! lhydrophilic, and optionally the size bin ibin and optical model + ! in optical_model_str. The return value may be used to populate the + ! radiation_config%i_aerosol_map vector, where a positive number is + ! a hydrophobic index, a negative number is a hydrophilic index and + ! zero indicates that the aerosol type was not found in the file. + ! This is a valid entry in i_aerosol_map meaning the aerosol is + ! ignored, but the calling routine to get_index might wish to throw + ! a warning or error. This routine works by assigning a score based + ! on the closeness of the match. + function get_index(this, code_str, lhydrophilic, ibin, optical_model_str) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulout + + class(aerosol_optics_description_type), intent(in) :: this + character(len=2), intent(in) :: code_str + logical, intent(in) :: lhydrophilic + integer, intent(in), optional :: ibin + character(len=*), intent(in), optional :: optical_model_str + + ! Score of the currently selected aerosol index, and the score of + ! the current one under consideration + integer :: score, current_score + + ! Loop index for aerosol type + integer :: ja + + ! Return value + integer :: get_index + + ! Issue a warning if there is more than one equal match + logical :: is_ambiguous + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_description:get_index',0,hook_handle) + + ! Initial values + get_index = 0 + score = 0 + is_ambiguous = .false. + + if (lhydrophilic) then + ! Loop over hydrophilic aerosol types + do ja = 1,size(this%bin_philic) + current_score = 0 + if (to_string(this%code_philic(:,ja)) == code_str) then + ! Aerosol code matches + if (present(ibin) .and. this%bin_philic(ja) > 0) then + if (ibin > 0) then + if (ibin == this%bin_philic(ja)) then + ! Requested bin number matches + current_score = 4 + else + ! Requested bin number does not match + current_score = -1 + end if + else + ! Bin number is zero: no request + current_score = 2 + end if + else + ! No bin number present + current_score = 2 + end if + if (present(optical_model_str)) then + if (trim(to_string(this%optical_model_philic(:,ja))) & + & == optical_model_str) then + ! Requested optical model matches + if (current_score >= 0) then + current_score = current_score + 4 + end if + else + ! Requested optical model does not match + current_score = -1 + end if + else if (current_score >= 0) then + ! No requested optical model + current_score = current_score + 2 + end if + if (current_score > 0 .and. this%is_preferred_philic(ja)) then + current_score = current_score + 1 + end if + if (current_score > score) then + ! Better score than any existing aerosol type + get_index = -ja + score = current_score + is_ambiguous = .false. + else if (current_score > 0 .and. current_score == score) then + is_ambiguous = .true. + end if + end if + end do + else + ! Loop over hydrophobic aerosol types + do ja = 1,size(this%bin_phobic) + current_score = 0 + if (to_string(this%code_phobic(:,ja)) == code_str) then + ! Aerosol code matches + if (present(ibin) .and. this%bin_phobic(ja) > 0) then + if (ibin > 0) then + if (ibin == this%bin_phobic(ja)) then + ! Requested bin number matches + current_score = 4 + else + ! Requested bin number does not match + current_score = -1 + end if + else + ! Bin number is zero: no request + current_score = 2 + end if + else + ! No bin number requested or present + current_score = 2 + end if + if (present(optical_model_str)) then + if (trim(to_string(this%optical_model_phobic(:,ja))) & + & == optical_model_str) then + ! Requested optical model matches + if (current_score >= 0) then + current_score = current_score + 4 + end if + else + ! Requested optical model does not match + current_score = -1 + end if + else if (current_score >= 0) then + ! No requested optical model + current_score = current_score + 2 + end if + if (current_score > 0 .and. this%is_preferred_phobic(ja)) then + current_score = current_score + 1 + end if + if (current_score > score) then + ! Better score than any existing aerosol type + get_index = ja + score = current_score + is_ambiguous = .false. + else if (current_score > 0 .and. current_score == score) then + is_ambiguous = .true. + end if + end if + end do + end if + + if (is_ambiguous) then + write(nulout,'(a,a2,a,l,a)') 'Warning: radiation_aerosol_optics_description:get_index("', & + & code_str, '",', lhydrophilic, & + & ',...) does not unambiguously identify an aerosol optical property index' + end if + + if (lhook) call dr_hook('radiation_aerosol_optics_description:get_index',1,hook_handle) + + end function get_index + + !--------------------------------------------------------------------- + ! Utility function to convert an array of single characters to a + ! character string (yes Fortran's string handling is a bit + ! rubbish). We set NULL characters (ASCII code 0) returned from the + ! NetCDF library to spaces, so that TRIM can remove them. + pure function to_string(arr) result(str) + character, intent(in) :: arr(:) + character(len=size(arr)) :: str + integer :: jc + do jc = 1,size(arr) + if (ichar(arr(jc)) == 0) then + ! Replace NULL character with a space + str(jc:jc) = ' ' + else + str(jc:jc) = arr(jc) + end if + end do + end function to_string + +end module radiation_aerosol_optics_description Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_check.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_check.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_check.F90 (revision 6016) @@ -0,0 +1,212 @@ +! radiation_check.F90 - Checking routines +! +! (C) Copyright 2020- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_check + + use parkind1, only : jprb + + implicit none + public + +contains + + !--------------------------------------------------------------------- + ! Return .true. if 1D allocatable array "var" is out of physical + ! range specified by boundmin and boundmax, and issue a warning. + ! "do_fix" determines whether erroneous values are fixed to lie + ! within the physical range. To check only a subset of the array, + ! specify i1 and i2 for the range. + function out_of_bounds_1d(var, var_name, boundmin, boundmax, do_fix, i1, i2) result (is_bad) + + use radiation_io, only : nulout + + real(jprb), allocatable, intent(inout) :: var(:) + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: boundmin, boundmax + logical, intent(in) :: do_fix + integer, optional, intent(in) :: i1, i2 + + logical :: is_bad + + real(jprb) :: varmin, varmax + + is_bad = .false. + + if (allocated(var)) then + + if (present(i1) .and. present(i2)) then + varmin = minval(var(i1:i2)) + varmax = maxval(var(i1:i2)) + else + varmin = minval(var) + varmax = maxval(var) + end if + + if (varmin < boundmin .or. varmax > boundmax) then + write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & + & '*** Warning: ', var_name, ' range', varmin, ' to', varmax, & + & ' is out of physical range', boundmin, 'to', boundmax + is_bad = .true. + if (do_fix) then + if (present(i1) .and. present(i2)) then + var(i1:i2) = max(boundmin, min(boundmax, var(i1:i2))) + else + var = max(boundmin, min(boundmax, var)) + end if + write(nulout,'(a)') ': corrected' + else + write(nulout,'(1x)') + end if + end if + + end if + + end function out_of_bounds_1d + + + !--------------------------------------------------------------------- + ! Return .true. if 2D allocatable array "var" is out of physical + ! range specified by boundmin and boundmax, and issue a warning. To + ! check only a subset of the array, specify i1 and i2 for the range + ! of the first dimension and j1 and j2 for the range of the second. + function out_of_bounds_2d(var, var_name, boundmin, boundmax, do_fix, & + & i1, i2, j1, j2) result (is_bad) + + use radiation_io, only : nulout + + real(jprb), allocatable, intent(inout) :: var(:,:) + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: boundmin, boundmax + logical, intent(in) :: do_fix + integer, optional, intent(in) :: i1, i2, j1, j2 + + ! Local copies of indices + integer :: ii1, ii2, jj1, jj2 + + logical :: is_bad + + real(jprb) :: varmin, varmax + + is_bad = .false. + + if (allocated(var)) then + + if (present(i1) .and. present(i2)) then + ii1 = i1 + ii2 = i2 + else + ii1 = lbound(var,1) + ii2 = ubound(var,1) + end if + if (present(j1) .and. present(j2)) then + jj1 = j1 + jj2 = j2 + else + jj1 = lbound(var,2) + jj2 = ubound(var,2) + end if + varmin = minval(var(ii1:ii2,jj1:jj2)) + varmax = maxval(var(ii1:ii2,jj1:jj2)) + + if (varmin < boundmin .or. varmax > boundmax) then + write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & + & '*** Warning: ', var_name, ' range', varmin, ' to', varmax,& + & ' is out of physical range', boundmin, 'to', boundmax + is_bad = .true. + if (do_fix) then + var(ii1:ii2,jj1:jj2) = max(boundmin, min(boundmax, var(ii1:ii2,jj1:jj2))) + write(nulout,'(a)') ': corrected' + else + write(nulout,'(1x)') + end if + end if + + end if + + end function out_of_bounds_2d + + + !--------------------------------------------------------------------- + ! Return .true. if 3D allocatable array "var" is out of physical + ! range specified by boundmin and boundmax, and issue a warning. To + ! check only a subset of the array, specify i1 and i2 for the range + ! of the first dimension, j1 and j2 for the second and k1 and k2 for + ! the third. + function out_of_bounds_3d(var, var_name, boundmin, boundmax, do_fix, & + & i1, i2, j1, j2, k1, k2) result (is_bad) + + use radiation_io, only : nulout + + real(jprb), allocatable, intent(inout) :: var(:,:,:) + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: boundmin, boundmax + logical, intent(in) :: do_fix + integer, optional, intent(in) :: i1, i2, j1, j2, k1, k2 + + ! Local copies of indices + integer :: ii1, ii2, jj1, jj2, kk1, kk2 + + logical :: is_bad + + real(jprb) :: varmin, varmax + + is_bad = .false. + + if (allocated(var)) then + + if (present(i1) .and. present(i2)) then + ii1 = i1 + ii2 = i2 + else + ii1 = lbound(var,1) + ii2 = ubound(var,1) + end if + if (present(j1) .and. present(j2)) then + jj1 = j1 + jj2 = j2 + else + jj1 = lbound(var,2) + jj2 = ubound(var,2) + end if + if (present(k1) .and. present(k2)) then + kk1 = k1 + kk2 = k2 + else + kk1 = lbound(var,3) + kk2 = ubound(var,3) + end if + varmin = minval(var(ii1:ii2,jj1:jj2,kk1:kk2)) + varmax = maxval(var(ii1:ii2,jj1:jj2,kk1:kk2)) + + if (varmin < boundmin .or. varmax > boundmax) then + write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & + & '*** Warning: ', var_name, ' range', varmin, ' to', varmax,& + & ' is out of physical range', boundmin, 'to', boundmax + is_bad = .true. + if (do_fix) then + var(ii1:ii2,jj1:jj2,kk1:kk2) = max(boundmin, min(boundmax, & + & var(ii1:ii2,jj1:jj2,kk1:kk2))) + write(nulout,'(a)') ': corrected' + else + write(nulout,'(1x)') + end if + end if + + end if + + end function out_of_bounds_3d + +end module radiation_check Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud.F90 (revision 6016) @@ -0,0 +1,1123 @@ +! This file has been modified for the use in ICON + +! radiation_cloud.F90 - Derived type to store cloud/precip properties +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2019-01-14 R. Hogan Added inv_inhom_effective_size variable +! 2019-01-14 R. Hogan Added out_of_physical_bounds routine +! 2019-06-14 R. Hogan Added capability to store any number of cloud/precip types + +module radiation_cloud + + use parkind1, only : jprb + + implicit none + public + + !--------------------------------------------------------------------- + ! The intention is that all variables describing clouds and + ! radiatively-active precipitation are contained in this derived + ! type, and if cloud variables are to be added in future, they can + ! be added to this type without requiring extra variables to be + ! passed between subroutines elsewhere in the program. + type cloud_type + ! For maximum flexibility, an arbitrary number "ntype" of + ! hydrometeor types can be stored, dimensioned (ncol,nlev,ntype) + integer :: ntype = 0 + real(jprb), allocatable, dimension(:,:,:) :: & + & mixing_ratio, & ! mass mixing ratio (kg/kg) + & effective_radius ! (m) + + ! For backwards compatibility, we also allow for the two + ! traditional cloud types, liquid cloud droplets and ice cloud + ! particles, dimensioned (ncol,nlev) + real(jprb), pointer, dimension(:,:) :: & + & q_liq, q_ice, & ! mass mixing ratio (kg/kg) + & re_liq, re_ice ! effective radius (m) + + ! For the moment, the different types of hydrometeor are assumed + ! to be mixed with each other, so there is just one cloud fraction + ! variable varying from 0 to 1 + real(jprb), allocatable, dimension(:,:) :: fraction + + ! The fractional standard deviation of cloud optical depth in the + ! cloudy part of the gridbox. In the Tripleclouds representation + ! of cloud inhomogeneity, this is implemented by splitting the + ! cloudy part of the gridbox into two equal-area regions, one + ! with the cloud optical depth scaled by 1+fractional_std and the + ! other scaled by 1-fractional_std. This variable is dimensioned + ! (ncol,nlev) + real(jprb), allocatable, dimension(:,:) :: fractional_std + + ! The inverse of the effective horizontal size of the clouds in + ! the gridbox, used to compute the cloud edge length per unit + ! gridbox area for use in representing 3D effects. This variable + ! is dimensioned (ncol,nlev). + real(jprb), allocatable, dimension(:,:) :: inv_cloud_effective_size ! m-1 + + ! Similarly for the in-cloud heterogeneities, used to compute the + ! edge length between the optically thin and thick cloudy regions + ! of the gridbox. + real(jprb), allocatable, dimension(:,:) :: inv_inhom_effective_size ! m-1 + + ! The following variable describes the overlap of cloud boundaries + ! in adjacent layers, with dimensions (ncol,nlev-1): 1 corresponds + ! to maximum overlap and 0 to random overlap. Depending on the + ! ecRad configuration, it may be the "alpha" overlap parameter of + ! Hogan and Illingworth (2000) or the "beta" overlap parameter of + ! Shonk et al. (2010). + real(jprb), allocatable, dimension(:,:) :: overlap_param + + contains + procedure :: allocate => allocate_cloud_arrays + procedure :: deallocate => deallocate_cloud_arrays + procedure :: set_overlap_param_fix + procedure :: set_overlap_param_var + generic :: set_overlap_param => set_overlap_param_fix, set_overlap_param_var + procedure :: set_overlap_param_var2D + procedure :: set_overlap_param_approx + procedure :: create_fractional_std + procedure :: create_inv_cloud_effective_size + procedure :: create_inv_cloud_effective_size_eta + procedure :: param_cloud_effective_separation_eta + procedure :: param_cloud_effective_separation_tanh + procedure :: crop_cloud_fraction + procedure :: out_of_physical_bounds +#ifdef _OPENACC + procedure :: update_host + procedure :: update_device +#endif + + end type cloud_type + +contains + + !--------------------------------------------------------------------- + ! Allocate arrays for describing clouds and precipitation, although + ! in the offline code these are allocated when they are read from + ! the NetCDF file + subroutine allocate_cloud_arrays(this, ncol, nlev, ntype, use_inhom_effective_size) + + use yomhook, only : lhook, dr_hook, jphook + +#ifdef _OPENACC + use openacc, only : acc_attach +#endif + + class(cloud_type), intent(inout), target :: this + integer, intent(in) :: ncol ! Number of columns + integer, intent(in) :: nlev ! Number of levels + ! Number of cloud/precip particle types. If not present then the + ! older cloud behaviour is assumed: two types are present, (1) + ! liquid and (2) ice, and they can be accessed via q_liq, q_ice, + ! re_liq and re_ice. + integer, intent(in), optional :: ntype + logical, intent(in), optional :: use_inhom_effective_size + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:allocate',0,hook_handle) + + if (present(ntype)) then + this%ntype = ntype + else + this%ntype = 2 + end if + !$ACC UPDATE DEVICE(this%ntype) + allocate(this%mixing_ratio(ncol,nlev,this%ntype)) + allocate(this%effective_radius(ncol,nlev,this%ntype)) + !$ACC ENTER DATA CREATE(this%mixing_ratio) ASYNC(1) + !$ACC ENTER DATA CREATE(this%effective_radius) ASYNC(1) + nullify(this%q_liq) + nullify(this%q_ice) + nullify(this%re_liq) + nullify(this%re_ice) + if (.not. present(ntype)) then + ! Older interface in which only liquid and ice are supported + this%q_liq => this%mixing_ratio(:,:,1) + this%q_ice => this%mixing_ratio(:,:,2) + this%re_liq => this%effective_radius(:,:,1) + this%re_ice => this%effective_radius(:,:,2) +#ifdef _OPENACC + CALL acc_attach(this%q_liq) + CALL acc_attach(this%q_ice) + CALL acc_attach(this%re_liq) + CALL acc_attach(this%re_ice) +#endif + end if + + allocate(this%fraction(ncol,nlev)) + allocate(this%overlap_param(ncol,nlev-1)) + allocate(this%fractional_std(ncol,nlev)) + allocate(this%inv_cloud_effective_size(ncol,nlev)) + !$ACC ENTER DATA CREATE(this%fraction) ASYNC(1) + !$ACC ENTER DATA CREATE(this%overlap_param) ASYNC(1) + !$ACC ENTER DATA CREATE(this%fractional_std) ASYNC(1) + !$ACC ENTER DATA CREATE(this%inv_cloud_effective_size) ASYNC(1) + + if (present(use_inhom_effective_size)) then + if (use_inhom_effective_size) then + allocate(this%inv_inhom_effective_size(ncol,nlev)) + !$ACC ENTER DATA CREATE(this%inv_inhom_effective_size) ASYNC(1) + end if + end if + + if (lhook) call dr_hook('radiation_cloud:allocate',1,hook_handle) + + end subroutine allocate_cloud_arrays + + + !--------------------------------------------------------------------- + ! Deallocate arrays + subroutine deallocate_cloud_arrays(this) + + use yomhook, only : lhook, dr_hook, jphook + + class(cloud_type), intent(inout) :: this + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:deallocate',0,hook_handle) + + nullify(this%q_liq) + nullify(this%q_ice) + nullify(this%re_liq) + nullify(this%re_ice) + + !$ACC EXIT DATA DELETE(this%mixing_ratio) ASYNC(1) IF(allocated(this%mixing_ratio)) + !$ACC EXIT DATA DELETE(this%effective_radius) ASYNC(1) IF(allocated(this%effective_radius)) + !$ACC EXIT DATA DELETE(this%fraction) ASYNC(1) IF(allocated(this%fraction)) + !$ACC EXIT DATA DELETE(this%overlap_param) ASYNC(1) IF(allocated(this%overlap_param)) + !$ACC EXIT DATA DELETE(this%fractional_std) ASYNC(1) IF(allocated(this%fractional_std)) + !$ACC EXIT DATA DELETE(this%inv_cloud_effective_size) ASYNC(1) IF(allocated(this%inv_cloud_effective_size)) + !$ACC EXIT DATA DELETE(this%inv_inhom_effective_size) ASYNC(1) IF(allocated(this%inv_inhom_effective_size)) + !$ACC WAIT + if (allocated(this%mixing_ratio)) deallocate(this%mixing_ratio) + if (allocated(this%effective_radius)) deallocate(this%effective_radius) + if (allocated(this%fraction)) deallocate(this%fraction) + if (allocated(this%overlap_param)) deallocate(this%overlap_param) + if (allocated(this%fractional_std)) deallocate(this%fractional_std) + if (allocated(this%inv_cloud_effective_size)) & + & deallocate(this%inv_cloud_effective_size) + if (allocated(this%inv_inhom_effective_size)) & + & deallocate(this%inv_inhom_effective_size) + + if (lhook) call dr_hook('radiation_cloud:deallocate',1,hook_handle) + + end subroutine deallocate_cloud_arrays + + + !--------------------------------------------------------------------- + ! Compute and store the overlap parameter from the provided overlap + ! decorrelation length (in metres). If istartcol and/or iendcol are + ! provided then only columns in this range are computed. If the + ! overlap_param array has not been allocated then it will be + ! allocated to be of the correct size relative to the pressure + ! field. This version assumes a fixed decorrelation_length for all + ! columns. + subroutine set_overlap_param_fix(this, thermodynamics, decorrelation_length, & + & istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_thermodynamics, only : thermodynamics_type + use radiation_constants, only : GasConstantDryAir, AccelDueToGravity + + class(cloud_type), intent(inout) :: this + type(thermodynamics_type), intent(in) :: thermodynamics + real(jprb), intent(in) :: decorrelation_length ! m + integer, optional, intent(in) :: istartcol, iendcol + + ! Ratio of gas constant for dry air to acceleration due to gravity + real(jprb), parameter :: R_over_g = GasConstantDryAir / AccelDueToGravity + + ! Process only columns i1 to i2, which will be istartcol to + ! iendcol if they were provided + integer :: i1, i2 + + integer :: ncol, nlev + + integer :: jcol, jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:set_overlap_param_fix',0,hook_handle) + + ! Pressure at half-levels, pressure_hl, is defined at nlev+1 + ! points + ncol = size(thermodynamics%pressure_hl,dim=1) + nlev = size(thermodynamics%pressure_hl,dim=2)-1 + + if (present(istartcol)) then + i1 = istartcol + else + i1 = 1 + end if + + if (present(iendcol)) then + i2 = iendcol + else + i2 = ncol + end if + + if (.not. allocated(this%overlap_param)) then + ! If pressure is of size (ncol,nlev+1) then overlap_param is of + ! size (ncol,nlev-1), since overlap parameter is only defined here + ! for interfaces between model layers, not for the interface to + ! space or the surface + allocate(this%overlap_param(ncol, nlev-1)) + !$ACC ENTER DATA CREATE(this%overlap_param) ASYNC(1) + end if + + !$ACC DATA PRESENT(this, thermodynamics) + + !$ACC UPDATE HOST(thermodynamics%pressure_hl(i1,1:2)) WAIT(1) + if (thermodynamics%pressure_hl(i1,2) > thermodynamics%pressure_hl(i1,1)) then + ! Pressure is increasing with index (order of layers is + ! top-of-atmosphere to surface). In case pressure_hl(:,1)=0, we + ! don't take the logarithm of the first pressure in each column. + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = i1,i2 + this%overlap_param(jcol,1) = exp(-(R_over_g/decorrelation_length) & + & * thermodynamics%temperature_hl(jcol,2) & + & *log(thermodynamics%pressure_hl(jcol,3) & + & /thermodynamics%pressure_hl(jcol,2))) + end do + + !$ACC LOOP SEQ + do jlev = 2,nlev-1 + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = i1,i2 + this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) & + & * thermodynamics%temperature_hl(jcol,jlev+1) & + & *log(thermodynamics%pressure_hl(jcol,jlev+2) & + & /thermodynamics%pressure_hl(jcol,jlev))) + end do + end do + !$ACC END PARALLEL + + else + ! Pressure is decreasing with index (order of layers is surface + ! to top-of-atmosphere). In case pressure_hl(:,nlev+1)=0, we + ! don't take the logarithm of the last pressure in each column. + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP SEQ + do jlev = 1,nlev-2 + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = i1,i2 + this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) & + & * thermodynamics%temperature_hl(jcol,jlev+1) & + & *log(thermodynamics%pressure_hl(jcol,jlev) & + & /thermodynamics%pressure_hl(jcol,jlev+2))) + end do + end do + + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = i1,i2 + this%overlap_param(jcol,nlev-1) = exp(-(R_over_g/decorrelation_length) & + & * thermodynamics%temperature_hl(jcol,nlev) & + & *log(thermodynamics%pressure_hl(jcol,nlev-1) & + & /thermodynamics%pressure_hl(jcol,nlev))) + end do + !$ACC END PARALLEL + end if + + !$ACC END DATA + + if (lhook) call dr_hook('radiation_cloud:set_overlap_param_fix',1,hook_handle) + + end subroutine set_overlap_param_fix + + + !--------------------------------------------------------------------- + ! Compute and store the overlap parameter from the provided overlap + ! decorrelation length (in metres), which may vary with column. Only + ! columns from istartcol to iendcol are computed. If the + ! overlap_param array has not been allocated then it will be + ! allocated to be of the correct size relative to the pressure + ! field. + subroutine set_overlap_param_var(this, thermodynamics, decorrelation_length, & + & istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_thermodynamics, only : thermodynamics_type + use radiation_constants, only : GasConstantDryAir, AccelDueToGravity +#ifdef _OPENACC + use radiation_io, only : nulerr, radiation_abort +#endif + + class(cloud_type), intent(inout) :: this + type(thermodynamics_type), intent(in) :: thermodynamics + integer, intent(in) :: istartcol, iendcol + real(jprb), intent(in) :: decorrelation_length(istartcol:iendcol) ! m + + ! Ratio of gas constant for dry air to acceleration due to gravity + real(jprb), parameter :: R_over_g = GasConstantDryAir / AccelDueToGravity + + integer :: ncol, nlev + + integer :: jcol, jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:set_overlap_param_var',0,hook_handle) + + ! Pressure at half-levels, pressure_hl, is defined at nlev+1 + ! points + ncol = size(thermodynamics%pressure_hl,dim=1) + nlev = size(thermodynamics%pressure_hl,dim=2)-1 + + if (.not. allocated(this%overlap_param)) then + ! If pressure is of size (ncol,nlev+1) then overlap_param is of + ! size (ncol,nlev-1), since overlap parameter is only defined here + ! for interfaces between model layers, not for the interface to + ! space or the surface + allocate(this%overlap_param(ncol, nlev-1)) + !$ACC ENTER DATA CREATE(this%overlap_param) ASYNC(1) + end if + + !$ACC DATA PRESENT(this, thermodynamics, decorrelation_length) + !$ACC UPDATE HOST(thermodynamics%pressure_hl(istartcol,1:2)) WAIT(1) + if (thermodynamics%pressure_hl(istartcol,2) > thermodynamics%pressure_hl(istartcol,1)) then + ! Pressure is increasing with index (order of layers is + ! top-of-atmosphere to surface). In case pressure_hl(:,1)=0, we + ! don't take the logarithm of the first pressure in each column. + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + this%overlap_param(jcol,1) = exp(-(R_over_g/decorrelation_length(jcol)) & + & * thermodynamics%temperature_hl(jcol,2) & + & *log(thermodynamics%pressure_hl(jcol,3) & + & /thermodynamics%pressure_hl(jcol,2))) + end do + + !$ACC LOOP SEQ + do jlev = 2,nlev-1 + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length(jcol)) & + & * thermodynamics%temperature_hl(jcol,jlev+1) & + & *log(thermodynamics%pressure_hl(jcol,jlev+2) & + & /thermodynamics%pressure_hl(jcol,jlev))) + end do + end do + !$ACC END PARALLEL + + else + ! Pressure is decreasing with index (order of layers is surface + ! to top-of-atmosphere). In case pressure_hl(:,nlev+1)=0, we + ! don't take the logarithm of the last pressure in each column. + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP SEQ + do jlev = 1,nlev-2 + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length(jcol)) & + & * thermodynamics%temperature_hl(jcol,jlev+1) & + & *log(thermodynamics%pressure_hl(jcol,jlev) & + & /thermodynamics%pressure_hl(jcol,jlev+2))) + end do + end do + + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + this%overlap_param(jcol,nlev-1) = exp(-(R_over_g/decorrelation_length(jcol)) & + & * thermodynamics%temperature_hl(jcol,nlev) & + & *log(thermodynamics%pressure_hl(jcol,nlev-1) & + & /thermodynamics%pressure_hl(jcol,nlev))) + end do + !$ACC END PARALLEL + end if + + !$ACC END DATA + + if (lhook) call dr_hook('radiation_cloud:set_overlap_param_var',1,hook_handle) + + end subroutine set_overlap_param_var + +! AI 04 2024 variation de la longueur Ld en fonction de la verticale + subroutine set_overlap_param_var2D(this, thermodynamics, decorrelation_length, & + & klev, istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_thermodynamics, only : thermodynamics_type + use radiation_constants, only : GasConstantDryAir, AccelDueToGravity + + integer, intent(in) :: klev + class(cloud_type), intent(inout) :: this + type(thermodynamics_type), intent(in) :: thermodynamics + integer, intent(in) :: istartcol, iendcol + real(jprb), intent(in) :: decorrelation_length(istartcol:iendcol,klev) ! m + + ! Ratio of gas constant for dry air to acceleration due to gravity + real(jprb), parameter :: R_over_g = GasConstantDryAir / AccelDueToGravity + + integer :: ncol, nlev + + integer :: jcol, jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:set_overlap_param_var',0,hook_handle) + + ! Pressure at half-levels, pressure_hl, is defined at nlev+1 + ! points + ncol = size(thermodynamics%pressure_hl,dim=1) + nlev = size(thermodynamics%pressure_hl,dim=2)-1 + + if (.not. allocated(this%overlap_param)) then + ! If pressure is of size (ncol,nlev+1) then overlap_param is of + ! size (ncol,nlev-1), since overlap parameter is only defined here + ! for interfaces between model layers, not for the interface to + ! space or the surface + allocate(this%overlap_param(ncol, nlev-1)) + end if + + if (thermodynamics%pressure_hl(istartcol,2) > thermodynamics%pressure_hl(istartcol,1)) then + ! Pressure is increasing with index (order of layers is + ! top-of-atmosphere to surface). In case pressure_hl(:,1)=0, we + ! don't take the logarithm of the first pressure in each column. + do jcol = istartcol,iendcol + this%overlap_param(jcol,1) = exp(-(R_over_g/decorrelation_length(jcol,1)) & + & * thermodynamics%temperature_hl(jcol,2) & + & *log(thermodynamics%pressure_hl(jcol,3) & + & /thermodynamics%pressure_hl(jcol,2))) + end do + + do jlev = 2,nlev-1 + do jcol = istartcol,iendcol + this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length(jcol,jlev)) & + & * thermodynamics%temperature_hl(jcol,jlev+1) & + & *log(thermodynamics%pressure_hl(jcol,jlev+2) & + & /thermodynamics%pressure_hl(jcol,jlev))) + end do + end do + + else + ! Pressure is decreasing with index (order of layers is surface + ! to top-of-atmosphere). In case pressure_hl(:,nlev+1)=0, we + ! don't take the logarithm of the last pressure in each column. + do jlev = 1,nlev-2 + do jcol = istartcol,iendcol + this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length(jcol,jlev)) & + & * thermodynamics%temperature_hl(jcol,jlev+1) & + & *log(thermodynamics%pressure_hl(jcol,jlev) & + & /thermodynamics%pressure_hl(jcol,jlev+2))) + end do + end do + + do jcol = istartcol,iendcol + ! AI ATTENTION a verifier decorrelation_length(jcol,nlev-1) ou nlev + this%overlap_param(jcol,nlev-1) = exp(-(R_over_g/decorrelation_length(jcol,nlev-1)) & + & * thermodynamics%temperature_hl(jcol,nlev) & + & *log(thermodynamics%pressure_hl(jcol,nlev-1) & + & /thermodynamics%pressure_hl(jcol,nlev))) + end do + end if + + if (lhook) call dr_hook('radiation_cloud:set_overlap_param_var',1,hook_handle) + + end subroutine set_overlap_param_var2D + + !--------------------------------------------------------------------- + ! Compute and store the overlap parameter from the provided overlap + ! decorrelation length (in metres). If istartcol and/or iendcol are + ! provided then only columns in this range are computed. If the + ! overlap_param array has not been allocated then it will be + ! allocated to be of the correct size relative to the pressure + ! field. This is the APPROXIMATE method as it assumes a fixed + ! atmospheric scale height, which leads to differences particularly + ! in low cloud. + subroutine set_overlap_param_approx(this, thermodynamics, decorrelation_length, & + & istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_thermodynamics, only : thermodynamics_type + + class(cloud_type), intent(inout) :: this + type(thermodynamics_type), intent(in) :: thermodynamics + real(jprb), intent(in) :: decorrelation_length ! m + integer, optional, intent(in) :: istartcol, iendcol + + ! To convert decorrelation length (m) to overlap parameter between + ! layers, we need an estimate for the thickness of the layer. This + ! is found using the pressure difference between the edges of the + ! layer, along with the approximate scale height of the atmosphere + ! (m) given here: + real(jprb), parameter :: scale_height = 8000.0_jprb + + ! Process only columns i1 to i2, which will be istartcol to + ! iendcol if they were provided + integer :: i1, i2 + + integer :: ncol, nlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:set_overlap_param_approx',0,hook_handle) + + ! Pressure at half-levels, pressure_hl, is defined at nlev+1 + ! points + ncol = size(thermodynamics%pressure_hl,dim=1) + nlev = size(thermodynamics%pressure_hl,dim=2)-1 + + if (present(istartcol)) then + i1 = istartcol + else + i1 = 1 + end if + + if (present(iendcol)) then + i2 = iendcol + else + i2 = ncol + end if + + if (.not. allocated(this%overlap_param)) then + ! If pressure is of size (ncol,nlev+1) then overlap_param is of + ! size (ncol,nlev-1), since overlap parameter is only defined here + ! for interfaces between model layers, not for the interface to + ! space or the surface + allocate(this%overlap_param(ncol, nlev-1)) + end if + + if (thermodynamics%pressure_hl(i1,2) > thermodynamics%pressure_hl(i1,1)) then + ! Pressure is increasing with index (order of layers is + ! top-of-atmosphere to surface). In case pressure_hl(:,1)=0, we + ! don't take the logarithm of the first pressure in each + ! column. + this%overlap_param(i1:i2,:) = exp(-(scale_height/decorrelation_length) & + & * ( log(thermodynamics%pressure_hl(i1:i2,3:nlev+1) & + & /thermodynamics%pressure_hl(i1:i2,2:nlev )) ) ) + else + ! Pressure is decreasing with index (order of layers is surface + ! to top-of-atmosphere). In case pressure_hl(:,nlev+1)=0, we + ! don't take the logarithm of the last pressure in each column. + this%overlap_param(i1:i2,:) = exp(-(scale_height/decorrelation_length) & + & * ( log(thermodynamics%pressure_hl(i1:i2,1:nlev-1) & + & /thermodynamics%pressure_hl(i1:i2,2:nlev )) ) ) + end if + + if (lhook) call dr_hook('radiation_cloud:set_overlap_param_approx',1,hook_handle) + + end subroutine set_overlap_param_approx + + + !--------------------------------------------------------------------- + ! Create a matrix of constant fractional standard deviations + ! (dimensionless) + subroutine create_fractional_std(this, ncol, nlev, frac_std) + + use yomhook, only : lhook, dr_hook, jphook + + class(cloud_type), intent(inout) :: this + integer, intent(in) :: ncol, nlev + real(jprb), intent(in) :: frac_std + + integer :: jcol, jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:create_fractional_std',0,hook_handle) + + if (allocated(this%fractional_std)) then + !$ACC EXIT DATA DELETE(this%fractional_std) WAIT(1) + !$ACC WAIT ! ACCWA (nvhpc 22.7, nvhpc 22.5) crashes otherwise + deallocate(this%fractional_std) + end if + + allocate(this%fractional_std(ncol, nlev)) + !$ACC ENTER DATA CREATE(this%fractional_std) ASYNC(1) + + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jlev = 1, nlev + do jcol = 1, ncol + this%fractional_std(jcol, jlev) = frac_std + end do + end do + !$ACC END PARALLEL + + if (lhook) call dr_hook('radiation_cloud:create_fractional_std',1,hook_handle) + + end subroutine create_fractional_std + + + !--------------------------------------------------------------------- + ! Create a matrix of constant inverse cloud effective size (m-1) + subroutine create_inv_cloud_effective_size(this, ncol, nlev, inv_eff_size) + + use yomhook, only : lhook, dr_hook, jphook + + class(cloud_type), intent(inout) :: this + integer, intent(in) :: ncol, nlev + real(jprb), intent(in) :: inv_eff_size + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:create_inv_cloud_effective_size',0,hook_handle) + + if (allocated(this%inv_cloud_effective_size)) then + deallocate(this%inv_cloud_effective_size) + end if + + allocate(this%inv_cloud_effective_size(ncol, nlev)) + + this%inv_cloud_effective_size = inv_eff_size + + if (lhook) call dr_hook('radiation_cloud:create_inv_cloud_effective_size',1,hook_handle) + + end subroutine create_inv_cloud_effective_size + + + !--------------------------------------------------------------------- + ! Create a matrix of inverse cloud effective size (m-1) according to + ! the value of eta (=pressure divided by surface pressure) + subroutine create_inv_cloud_effective_size_eta(this, ncol, nlev, & + & pressure_hl, inv_eff_size_low, inv_eff_size_mid, inv_eff_size_high, & + & eta_low_mid, eta_mid_high, istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + + class(cloud_type), intent(inout) :: this + integer, intent(in) :: ncol, nlev + ! Pressure on half levels (Pa) + real(jprb), intent(in) :: pressure_hl(:,:) + ! Inverse effective size for low, mid and high cloud (m-1) + real(jprb), intent(in) :: inv_eff_size_low + real(jprb), intent(in) :: inv_eff_size_mid + real(jprb), intent(in) :: inv_eff_size_high + ! Eta values at low-mid and mid-high interfaces + real(jprb), intent(in) :: eta_low_mid, eta_mid_high + integer, optional, intent(in) :: istartcol, iendcol + + ! Ratio of layer midpoint pressure to surface pressure + real(jprb) :: eta(nlev) + + ! Indices of column, level and surface half-level + integer :: jcol, isurf + + ! Local values of istartcol, iendcol + integer :: i1, i2 + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:create_inv_cloud_effective_size_eta',0,hook_handle) + + if (allocated(this%inv_cloud_effective_size)) then + deallocate(this%inv_cloud_effective_size) + end if + + allocate(this%inv_cloud_effective_size(ncol, nlev)) + + if (present(istartcol)) then + i1 = istartcol + else + i1 = 1 + end if + + if (present(iendcol)) then + i2 = iendcol + else + i2 = ncol + end if + + ! Locate the surface half-level + if (pressure_hl(1,1) > pressure_hl(1,2)) then + isurf = 1 + else + isurf = nlev+1 + end if + + do jcol = i1,i2 + eta = (pressure_hl(jcol,1:nlev)+pressure_hl(jcol,2:nlev+1)) & + & * (0.5_jprb / pressure_hl(jcol,isurf)) + where (eta > eta_low_mid) + this%inv_cloud_effective_size(jcol,:) = inv_eff_size_low + elsewhere (eta > eta_mid_high) + this%inv_cloud_effective_size(jcol,:) = inv_eff_size_mid + elsewhere + this%inv_cloud_effective_size(jcol,:) = inv_eff_size_high + end where + end do + + if (lhook) call dr_hook('radiation_cloud:create_inv_cloud_effective_size_eta',1,hook_handle) + + end subroutine create_inv_cloud_effective_size_eta + + + !--------------------------------------------------------------------- + ! Create a matrix of inverse cloud and inhomogeneity effective size + ! (m-1) parameterized according to the value of eta (=pressure + ! divided by surface pressure): effective_separation = + ! coeff_a + coeff_b*exp(-(eta**power)). + subroutine param_cloud_effective_separation_eta(this, ncol, nlev, & + & pressure_hl, separation_surf, separation_toa, power, & + & inhom_separation_factor, istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + + class(cloud_type), intent(inout) :: this + integer, intent(in) :: ncol, nlev + ! Pressure on half levels (Pa) + real(jprb), intent(in) :: pressure_hl(:,:) + ! Separation distances at surface and top-of-atmosphere, and power + ! on eta + real(jprb), intent(in) :: separation_surf ! m + real(jprb), intent(in) :: separation_toa ! m + real(jprb), intent(in) :: power + real(jprb), optional, intent(in) :: inhom_separation_factor + integer, optional, intent(in) :: istartcol, iendcol + + ! Ratio of layer midpoint pressure to surface pressure + real(jprb) :: eta(nlev) + + ! Effective cloud separation (m) + real(jprb) :: eff_separation(nlev) + + ! Coefficients used to compute effective separation distance + real(jprb) :: coeff_e, coeff_a, coeff_b, inhom_sep_factor + + ! Indices of column, level and surface half-level + integer :: jcol, isurf + + ! Local values of istartcol, iendcol + integer :: i1, i2 + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:param_cloud_effective_separation_eta',0,hook_handle) + + if (present(inhom_separation_factor)) then + inhom_sep_factor = inhom_separation_factor + else + inhom_sep_factor = 1.0_jprb + end if + + coeff_e = 1.0_jprb - exp(-1.0_jprb) + coeff_b = (separation_toa - separation_surf) / coeff_e + coeff_a = separation_toa - coeff_b + + if (allocated(this%inv_cloud_effective_size)) then + deallocate(this%inv_cloud_effective_size) + end if + if (allocated(this%inv_inhom_effective_size)) then + deallocate(this%inv_inhom_effective_size) + end if + + allocate(this%inv_cloud_effective_size(ncol, nlev)) + allocate(this%inv_inhom_effective_size(ncol, nlev)) + + if (present(istartcol)) then + i1 = istartcol + else + i1 = 1 + end if + + if (present(iendcol)) then + i2 = iendcol + else + i2 = ncol + end if + + ! Locate the surface half-level + if (pressure_hl(1,1) > pressure_hl(1,2)) then + isurf = 1 + else + isurf = nlev+1 + end if + + do jcol = i1,i2 + eta = (pressure_hl(jcol,1:nlev)+pressure_hl(jcol,2:nlev+1)) & + & * (0.5_jprb / pressure_hl(jcol,isurf)) + eff_separation = coeff_a + coeff_b * exp(-eta**power) + this%inv_cloud_effective_size(jcol,:) = 1.0_jprb / (eff_separation & + & * sqrt(max(1.0e-5_jprb,this%fraction(jcol,:)*(1.0_jprb-this%fraction(jcol,:))))) + this%inv_inhom_effective_size(jcol,:) = 1.0_jprb / (eff_separation * inhom_sep_factor & + & * sqrt(max(1.0e-5_jprb,0.5_jprb*this%fraction(jcol,:)*(1.0_jprb-0.5_jprb*this%fraction(jcol,:))))) + end do + + if (lhook) call dr_hook('radiation_cloud:param_cloud_effective_separation_eta',1,hook_handle) + + end subroutine param_cloud_effective_separation_eta + + !AI 20 mai 2025 + !Nouvelle param Lx=f(P) avec Lf(P) tgte hyperb + subroutine param_cloud_effective_separation_tanh(this, ncol, nlev, & + & pressure_hl, & + & lx_surf, lx_toa, gama, & + & inhom_separation_factor, istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + use write_field_phy + implicit none + + class(cloud_type), intent(inout) :: this + integer, intent(in) :: ncol, nlev + ! Pressure on half levels (Pa) : size should be (ncol, nlev+1) + real(jprb), intent(in) :: pressure_hl(:,:) + ! Separation distances at surface and top-of-atmosphere (m) + real(jprb), intent(in) :: lx_surf, lx_toa + ! Facteur de raideur + real(jprb), intent(in) :: gama + ! Optional factor + real(jprb), optional, intent(in) :: inhom_separation_factor + integer, optional, intent(in) :: istartcol, iendcol + + ! Parameters (AI attention a revoir) + real(kind=jprb), parameter :: eps = 1.0e-5_jprb + + ! Locals + real(jprb) :: eff_separation(ncol,nlev) + real(jprb) :: Lmin, Lmax, Pmin, Pmax, p_mean, p0, inhom_sep_factor, alpha + integer :: jcol, k + integer :: i1, i2 + real(jphook) :: hook_handle + real(jprb) :: frac, denom1, denom2 + real(jprb) :: pdiff + + ! Hook entry + if (lhook) call dr_hook('radiation_cloud:param_cloud_effective_separation_eta',0,hook_handle) + + ! inhom separation factor default + if (present(inhom_separation_factor)) then + inhom_sep_factor = inhom_separation_factor + else + inhom_sep_factor = 1.0_jprb + end if + + ! (re)allocation of output arrays + if (allocated(this%inv_cloud_effective_size)) then + deallocate(this%inv_cloud_effective_size) + end if + if (allocated(this%inv_inhom_effective_size)) then + deallocate(this%inv_inhom_effective_size) + end if + + allocate(this%inv_cloud_effective_size(ncol, nlev)) + allocate(this%inv_inhom_effective_size(ncol, nlev)) + + ! columns range + if (present(istartcol)) then + i1 = istartcol + else + i1 = 1 + end if + + if (present(iendcol)) then + i2 = iendcol + else + i2 = ncol + end if + + ! map inputs to local names + Lmin = lx_surf + Lmax = lx_toa + + ! Determine pressure range (expect pressure_hl(:,1) ~ surface, (:,nlev+1) ~ TOA) + ! Use safe guards if pressure_hl dimension is smaller/wrong => runtime will fail earlier + Pmin = minval(pressure_hl(:,nlev+1)) + Pmax = maxval(pressure_hl(:,1)) + + ! compute centre and alpha (guard if Pmax==Pmin) + p0 = 0.5_jprb*(Pmax + Pmin) + pdiff = (Pmax - Pmin) + if (abs(pdiff) < eps) then + ! improbable but guard against division by zero + alpha = gama / eps + write(*,*) 'Warning: Pmax - Pmin trop petit -> alpha forcé' + else + alpha = gama / pdiff + end if + + ! Main loops + do jcol = i1, i2 + do k = 1, nlev + ! pression moyenne de la couche k (half-levels k and k+1 must exist) + p_mean = 0.5_jprb * (pressure_hl(jcol,k) + pressure_hl(jcol,k+1)) + + ! loi hyperbolique bornée entre Lmin et Lmax + eff_separation(jcol,k) = 0.5_jprb*(Lmax + Lmin) - 0.5_jprb*(Lmax - Lmin) * tanh(alpha*(p_mean - p0)) + + ! borne de sécurité (eviter 0 ou négatif) + eff_separation(jcol,k) = max(eps, eff_separation(jcol,k)) + + ! fraction safe clamp + frac = this%fraction(jcol,k) + if (frac < 0.0_jprb) then + frac = 0.0_jprb + else if (frac > 1.0_jprb) then + frac = 1.0_jprb + end if + + ! denominators and protection + denom1 = eff_separation(jcol,k) * sqrt( max(eps, frac*(1.0_jprb - frac)) ) + if (denom1 < eps) denom1 = eps + this%inv_cloud_effective_size(jcol,k) = 1.0_jprb / denom1 + + denom2 = eff_separation(jcol,k) * inhom_sep_factor * sqrt( max(eps, 0.5_jprb*frac*(1.0_jprb - 0.5_jprb*frac)) ) + if (denom2 < eps) denom2 = eps + this%inv_inhom_effective_size(jcol,k) = 1.0_jprb / denom2 + + end do + end do + + ! diagnostics + !CALL writefield_phy('pressure_hl',pressure_hl,nlev+1) + !CALL writefield_phy('eff_lx',eff_separation,nlev) + + if (lhook) call dr_hook('radiation_cloud:param_cloud_effective_separation_eta',1,hook_handle) + + end subroutine param_cloud_effective_separation_tanh + + !--------------------------------------------------------------------- + ! Remove "ghost" clouds: those with a cloud fraction that is too + ! small to treat sensibly (e.g. because it implies that the + ! "in-cloud" water content is too high), or with a cloud water + ! content that is too small. We do this in one place to ensure that + ! all subsequent subroutines can assume that if cloud_fraction > 0.0 + ! then cloud is really present and should be treated. + subroutine crop_cloud_fraction(this, istartcol, iendcol, & + & cloud_fraction_threshold, cloud_mixing_ratio_threshold) + + use yomhook, only : lhook, dr_hook, jphook + + class(cloud_type), intent(inout) :: this + integer, intent(in) :: istartcol, iendcol + + integer :: nlev + integer :: jcol, jlev, jh + + real(jprb) :: cloud_fraction_threshold, cloud_mixing_ratio_threshold + real(jprb) :: sum_mixing_ratio(istartcol:iendcol) + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:crop_cloud_fraction',0,hook_handle) + + nlev = size(this%fraction,2) + + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this) CREATE(sum_mixing_ratio) ASYNC(1) + !$ACC LOOP SEQ + do jlev = 1,nlev + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + sum_mixing_ratio(jcol) = 0.0_jprb + end do + !$ACC LOOP SEQ + do jh = 1, this%ntype + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + sum_mixing_ratio(jcol) = sum_mixing_ratio(jcol) + this%mixing_ratio(jcol,jlev,jh) + end do + end do + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + if (this%fraction(jcol,jlev) < cloud_fraction_threshold & + & .or. sum_mixing_ratio(jcol) < cloud_mixing_ratio_threshold) then + this%fraction(jcol,jlev) = 0.0_jprb + end if + end do + end do + !$ACC END PARALLEL + + if (lhook) call dr_hook('radiation_cloud:crop_cloud_fraction',1,hook_handle) + + end subroutine crop_cloud_fraction + + + !--------------------------------------------------------------------- + ! Return .true. if variables are out of a physically sensible range, + ! optionally only considering columns between istartcol and iendcol + function out_of_physical_bounds(this, istartcol, iendcol, do_fix) result(is_bad) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_check, only : out_of_bounds_2d, out_of_bounds_3d + + class(cloud_type), intent(inout) :: this + integer, optional,intent(in) :: istartcol, iendcol + logical, optional,intent(in) :: do_fix + logical :: is_bad + + logical :: do_fix_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud:out_of_physical_bounds',0,hook_handle) + + if (present(do_fix)) then + do_fix_local = do_fix + else + do_fix_local = .false. + end if + + is_bad = out_of_bounds_3d(this%mixing_ratio, 'cloud%mixing_ratio', 0.0_jprb, 1.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_3d(this%effective_radius, 'cloud%effective_radius', 0.0_jprb, 0.1_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%fraction, 'cloud%fraction', 0.0_jprb, 1.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%fractional_std, 'fractional_std', 0.0_jprb, 10.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%inv_cloud_effective_size, 'inv_cloud_effective_size', & + & 0.0_jprb, 1.0_jprb, do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%inv_inhom_effective_size, 'inv_inhom_effective_size', & + & 0.0_jprb, 1.0_jprb, do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%overlap_param, 'overlap_param', -0.5_jprb, 1.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) + + if (lhook) call dr_hook('radiation_cloud:out_of_physical_bounds',1,hook_handle) + + end function out_of_physical_bounds + +#ifdef _OPENACC + !--------------------------------------------------------------------- + ! updates fields on host + subroutine update_host(this) + + class(cloud_type), intent(inout) :: this + + !$ACC UPDATE HOST(this%q_liq) IF(allocated(this%q_liq)) + !$ACC UPDATE HOST(this%re_liq) IF(allocated(this%re_liq)) + !$ACC UPDATE HOST(this%q_ice) IF(allocated(this%q_ice)) + !$ACC UPDATE HOST(this%re_ice) IF(allocated(this%re_ice)) + !$ACC UPDATE HOST(this%fraction) IF(allocated(this%fraction)) + !$ACC UPDATE HOST(this%overlap_param) IF(allocated(this%overlap_param)) + !$ACC UPDATE HOST(this%fractional_std) IF(allocated(this%fractional_std)) + !$ACC UPDATE HOST(this%inv_cloud_effective_size) IF(allocated(this%inv_cloud_effective_size)) + !$ACC UPDATE HOST(this%inv_inhom_effective_size) IF(allocated(this%inv_inhom_effective_size)) + + end subroutine update_host + + !--------------------------------------------------------------------- + ! updates fields on device + subroutine update_device(this) + + class(cloud_type), intent(inout) :: this + + !$ACC UPDATE DEVICE(this%q_liq) IF(allocated(this%q_liq)) + !$ACC UPDATE DEVICE(this%re_liq) IF(allocated(this%re_liq)) + !$ACC UPDATE DEVICE(this%q_ice) IF(allocated(this%q_ice)) + !$ACC UPDATE DEVICE(this%re_ice) IF(allocated(this%re_ice)) + !$ACC UPDATE DEVICE(this%fraction) IF(allocated(this%fraction)) + !$ACC UPDATE DEVICE(this%overlap_param) IF(allocated(this%overlap_param)) + !$ACC UPDATE DEVICE(this%fractional_std) IF(allocated(this%fractional_std)) + !$ACC UPDATE DEVICE(this%inv_cloud_effective_size) IF(allocated(this%inv_cloud_effective_size)) + !$ACC UPDATE DEVICE(this%inv_inhom_effective_size) IF(allocated(this%inv_inhom_effective_size)) + + end subroutine update_device +#endif + +end module radiation_cloud Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_cover.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_cover.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_cover.F90 (revision 6016) @@ -0,0 +1,576 @@ +! This file has been modified for the use in ICON + +! radiation_cloud_cover.F90 - Compute cumulative cloud cover for McICA +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Generate profiles of the cumulative cloud cover as seen from TOA, +! used in the McICA cloud generator. +! +! Modifications +! 2020-10-07 R. Hogan Ensure iobj1 initialized in case of alpha_obj==0 + +#include "ecrad_config.h" + +module radiation_cloud_cover + + use parkind1, only : jprb + + public + + ! Three overlap schemes. Note that "Exponential" means that + ! clear-sky regions have no special significance for computing the + ! cumulative cloud cover: non-contiguous clouds are exponentially + ! rather than randomly overlapped. This is the situaition in the + ! McRad radiation scheme at ECMWF. + enum, bind(c) + enumerator IOverlapMaximumRandom, IOverlapExponentialRandom, & + & IOverlapExponential + end enum + character(len=*), parameter :: OverlapName(0:2) = (/ 'Max-Ran', & + & 'Exp-Ran', & + & 'Exp-Exp' /) + + ! Maximum cloud fraction distinguishable from 1 + real(jprb), parameter :: MaxCloudFrac = 1.0_jprb-epsilon(1.0_jprb)*10.0_jprb + + +contains + + !--------------------------------------------------------------------- + ! Convert "beta" overlap parameter of Shonk et al. (2010) to "alpha" + ! overlap parameter of Hogan and Illingworth (2000) + elemental function beta2alpha(beta, frac1, frac2) + + implicit none + + ! Beta overlap parameter and the cloud fractions in the upper and + ! lower layers + real(jprb), intent(in) :: beta, frac1, frac2 + + real(jprb) :: beta2alpha + + ! Absolute difference in cloud fraction + real(jprb) :: frac_diff + + !$ACC ROUTINE SEQ + + if (beta < 1.0_jprb) then + frac_diff = abs(frac1-frac2) + beta2alpha = beta & + & + (1.0_jprb-beta)*frac_diff & + & / (frac_diff + 1.0_jprb/beta - 1.0_jprb) + else + beta2alpha = 1.0_jprb + end if + + end function beta2alpha + + + !--------------------------------------------------------------------- + ! Compute total cloud cover according to the specified overlap + ! rule. This can be used to compute the high, mid and low cloud + ! cover by passing in subsets of the cloud fraction array + function cloud_cover(nlev, i_overlap_scheme, frac, overlap_param, & + & is_beta_overlap) + + implicit none + + ! Number of levels and the overlap scheme to be applied + integer, intent(in) :: nlev, i_overlap_scheme + + ! Cloud fraction and the overlap parameter between adjacent pairs + ! of levels + real(jprb), intent(in) :: frac(nlev), overlap_param(nlev-1) + + ! Do we use the "beta" overlap scheme of Shonk et al. (2010)? + ! Default is false. + logical, intent(in), optional :: is_beta_overlap + + ! Return cloud cover + real(jprb) :: cloud_cover + + ! Cumulative cloud cover from TOA to the base of each layer + real(jprb) :: cum_cloud_cover(nlev) + + ! Cloud cover of a pair of layers + real(jprb) :: pair_cloud_cover(nlev-1) + + if (i_overlap_scheme == IOverlapExponentialRandom) then + call cum_cloud_cover_exp_ran(nlev, frac, overlap_param, & + & cum_cloud_cover, pair_cloud_cover, is_beta_overlap) + else if (i_overlap_scheme == IOverlapExponential) then + call cum_cloud_cover_exp_exp(nlev, frac, overlap_param, & + & cum_cloud_cover, pair_cloud_cover, is_beta_overlap) + else + call cum_cloud_cover_max_ran(nlev, frac, cum_cloud_cover, & + & pair_cloud_cover) + end if + + cloud_cover = cum_cloud_cover(nlev) + + end function cloud_cover + + + !--------------------------------------------------------------------- + ! Maximum-random overlap: Geleyn & Hollingsworth formula + subroutine cum_cloud_cover_max_ran(nlev, frac, & + & cum_cloud_cover, pair_cloud_cover) + + use yomhook, only : lhook, dr_hook, jphook + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + + ! Cloud fraction on full levels + real(jprb), intent(in) :: frac(nlev) + + ! Outputs + + ! Cumulative cloud cover from TOA to the base of each layer + real(jprb), intent(out) :: cum_cloud_cover(nlev) + + ! Cloud cover of a pair of layers + real(jprb), intent(out) :: pair_cloud_cover(nlev-1) + + ! Local variables + + ! Cumulative product needed in computation of total_cloud_cover + real(jprb) :: cum_product + + ! Loop index for model level + integer :: jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud_cover:cum_cloud_cover_max_ran',0,hook_handle) + + ! Loop to compute total cloud cover and the cumulative cloud cover + + ! down to the base of each layer + cum_product = 1.0_jprb - frac(1) + cum_cloud_cover(1) = frac(1) + do jlev = 1,nlev-1 + ! Compute the combined cloud cover of layers jlev and jlev+1 + pair_cloud_cover(jlev) = max(frac(jlev),frac(jlev+1)) + + if (frac(jlev) >= MaxCloudFrac) then + ! Cloud cover has reached one + cum_product = 0.0_jprb + else + cum_product = cum_product * (1.0_jprb - pair_cloud_cover(jlev)) & + & / (1.0_jprb - frac(jlev)) + end if + cum_cloud_cover(jlev+1) = 1.0_jprb - cum_product + end do + + if (lhook) call dr_hook('radiation_cloud_cover:cum_cloud_cover_max_ran',1,hook_handle) + + end subroutine cum_cloud_cover_max_ran + + + !--------------------------------------------------------------------- + ! Exponential-random overlap: exponential overlap for contiguous + ! clouds, random overlap for non-contiguous clouds + subroutine cum_cloud_cover_exp_ran(nlev, frac, overlap_param, & + & cum_cloud_cover, pair_cloud_cover, is_beta_overlap) + + use yomhook, only : lhook, dr_hook, jphook + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + + ! Cloud fraction on full levels + real(jprb), intent(in) :: frac(nlev) + + ! Cloud overlap parameter for interfaces between model layers, + ! where 0 indicates random overlap and 1 indicates maximum-random + ! overlap + real(jprb), intent(in) :: overlap_param(nlev-1) + + ! This routine has been coded using the "alpha" overlap parameter + ! of Hogan and Illingworth (2000). If the following logical is + ! present and true then the input is interpretted to be the "beta" + ! overlap parameter of Shonk et al. (2010), and needs to be + ! converted to alpha. + logical, intent(in), optional :: is_beta_overlap + + ! Outputs + + ! Cumulative cloud cover from TOA to the base of each layer + real(jprb), intent(out) :: cum_cloud_cover(nlev) + + ! Cloud cover of a pair of layers + real(jprb), intent(out) :: pair_cloud_cover(nlev-1) + + ! Local variables + + ! Cumulative product needed in computation of total_cloud_cover + real(jprb) :: cum_product + + ! "Alpha" overlap parameter + real(jprb) :: overlap_alpha + logical :: do_overlap_conversion + + ! Loop index for model level + integer :: jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud_cover:cum_cloud_cover_exp_ran',0,hook_handle) + + + if (present(is_beta_overlap)) then + do_overlap_conversion = is_beta_overlap + else + do_overlap_conversion = .false. + end if + + ! Loop to compute total cloud cover and the cumulative cloud cover + + ! down to the base of each layer + cum_product = 1.0_jprb - frac(1) + cum_cloud_cover(1) = frac(1) + do jlev = 1,nlev-1 + ! Convert to "alpha" overlap parameter if necessary + if (do_overlap_conversion) then + overlap_alpha = beta2alpha(overlap_param(jlev), & + & frac(jlev), frac(jlev+1)) + else + overlap_alpha = overlap_param(jlev) + end if + + ! Compute the combined cloud cover of layers jlev and jlev+1 + pair_cloud_cover(jlev) = overlap_alpha*max(frac(jlev),frac(jlev+1)) & + & + (1.0_jprb - overlap_alpha) & + & * (frac(jlev)+frac(jlev+1)-frac(jlev)*frac(jlev+1)) +! Added for DWD (2020) +#ifdef DWD_VECTOR_OPTIMIZATIONS + end do + do jlev = 1,nlev-1 +#endif + if (frac(jlev) >= MaxCloudFrac) then + ! Cloud cover has reached one + cum_product = 0.0_jprb + else + cum_product = cum_product * (1.0_jprb - pair_cloud_cover(jlev)) & + & / (1.0_jprb - frac(jlev)) + end if + cum_cloud_cover(jlev+1) = 1.0_jprb - cum_product + end do + + + if (lhook) call dr_hook('radiation_cloud_cover:cum_cloud_cover_exp_ran',1,hook_handle) + + end subroutine cum_cloud_cover_exp_ran + + + + !--------------------------------------------------------------------- + ! Exponential-exponential overlap: exponential overlap for both + ! contiguous and non-contiguous clouds. This is the result of the + ! simple Raisanen cloud generator, but unfortunately it has no + ! (known) analytic formula for the total cloud cover, or the + ! cumulative cloud cover. In partially cloudy columns, The McICA + ! scheme needs this info in order to devote all the cloudy g-points + ! to columns containing cloud, which reduces McICA noise. The + ! following routine provides an approximate estimate of cumulative + ! cloud cover consistent with the exponential-exponential scheme. + subroutine cum_cloud_cover_exp_exp(nlev, frac, overlap_param, & + & cum_cloud_cover, pair_cloud_cover, is_beta_overlap) + + use yomhook, only : lhook, dr_hook, jphook + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + + ! Cloud fraction on full levels + real(jprb), intent(in) :: frac(nlev) + + ! Cloud overlap parameter for interfaces between model layers, + ! where 0 indicates random overlap and 1 indicates maximum-random + ! overlap + real(jprb), intent(in) :: overlap_param(nlev-1) + + ! This routine has been coded using the "alpha" overlap parameter + ! of Hogan and Illingworth (2000). If the following logical is + ! present and true then the input is interpretted to be the "beta" + ! overlap parameter of Shonk et al. (2010), and needs to be + ! converted to alpha. + logical, intent(in), optional :: is_beta_overlap + + ! Outputs + + ! Cumulative cloud cover from TOA to the base of each layer + real(jprb), intent(out) :: cum_cloud_cover(nlev) + + ! Cloud cover of a pair of layers + real(jprb), intent(out) :: pair_cloud_cover(nlev-1) + + ! Local variables + + ! If this routine is called from the radiation_interface tree then + ! very low cloud fractions have already been set to zero, but if + ! it is called as a cloud cover diagnostic then this can't be + ! guaranteed so a small non-zero numbers is required + real(jprb), parameter :: min_frac = 1.0e-6_jprb + + ! "Alpha" overlap parameter + real(jprb) :: overlap_alpha(nlev-1) + logical :: do_overlap_conversion + + ! Variables describing "concave cloud objects", i.e. contiguous + ! layers where the cloud fraction monotonically increases then + ! monotonically decreases + + ! Number of objects + integer :: nobj + + ! Indices to the location of the top, maximum cloud fraction, and + ! base, of each concave cloud object + integer :: i_top_obj(nlev) + integer :: i_max_obj(nlev) + integer :: i_base_obj(nlev) + ! Poor-man's linked list to allow for deletion of objects: this + ! variable points to the index of the next active object + integer :: i_next_obj(nlev) + + ! Cloud cover of object + real(jprb) :: cc_obj(nlev) + + ! Overlap parameter between objects + real(jprb) :: alpha_obj(nlev) + + ! Do (while) loop index for model level + integer :: jlev + + ! Do loop index for object + integer :: jobj + + ! Maximum correlation between adjacent objects + real(jprb) :: alpha_max + + ! Indices to pair of objects + integer :: iobj1, iobj2 + + ! Combined cloud cover of pair of objects, and scaling to modify + ! cumulative cloud cover of lower layer + real(jprb) :: cc_pair, scaling + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud_cover:cum_cloud_cover_exp_exp',0,hook_handle) + + + if (present(is_beta_overlap)) then + do_overlap_conversion = is_beta_overlap + else + do_overlap_conversion = .false. + end if + + ! Loop down through atmosphere to locate objects and compute their + ! basic properties + jlev = 1 + nobj = 0 + do while (jlev <= nlev) + if (frac(jlev) > min_frac) then + ! Starting a new object: store its top + nobj = nobj + 1 + i_top_obj(nobj) = jlev; + ! Find its maximum cloud fraction + jlev = jlev + 1 + do while (jlev <= nlev) + if (frac(jlev) < frac(jlev-1)) then + exit + end if + jlev = jlev + 1 + end do + i_max_obj(nobj) = jlev - 1 + ! Find its base + do while (jlev <= nlev) + if (frac(jlev) > frac(jlev-1) .or. frac(jlev) <= min_frac) then + exit + end if + jlev = jlev + 1 + end do + ! In the case of cloud fraction profile starting from the top + ! like this: 0.1 0.2 0.1 0.2 0.1, we may want the object grouping + ! to be (0.1 0.2) (0.1 0.2 0.1), not (0.1 0.2 0.1) (0.2 0.1), + ! in which case the following should be uncommented + ! if (jlev < nlev) then + ! if (frac(jlev) > frac(jlev-1)) then + ! jlev = jlev - 1 + ! end if + ! end if + i_base_obj(nobj) = jlev - 1 + ! Index to the next object + i_next_obj(nobj) = nobj+1 + else + jlev = jlev + 1 + end if + end do + + ! Array assignments + cum_cloud_cover = 0.0_jprb + pair_cloud_cover = 0.0_jprb + + if (nobj > 0) then + ! Only do any more work if there is cloud present + + ! To minimize the potential calls to beta2alpha, we do all the + ! computations related to overlap parameter here + if (.not. do_overlap_conversion) then + + ! Compute the combined cloud cover of pairs of layers + do jlev = 1,nlev-1 + pair_cloud_cover(jlev) & + & = overlap_param(jlev)*max(frac(jlev),frac(jlev+1)) & + & + (1.0_jprb - overlap_param(jlev)) & + & * (frac(jlev)+frac(jlev+1)-frac(jlev)*frac(jlev+1)) + end do + ! Estimate the effective overlap parameter "alpha_obj" between + ! adjacent objects as the product of the layerwise overlap + ! parameters between their layers of maximum cloud fraction + do jobj = 1,nobj-1 + alpha_obj(jobj) & + & = product(overlap_param(i_max_obj(jobj):i_max_obj(jobj+1)-1)) + end do + + else + + ! Convert Shonk et al overlap parameter to Hogan and + ! Illingworth definition + overlap_alpha = beta2alpha(overlap_param, & + & frac(1:nlev-1), frac(2:nlev)) + ! Compute the combined cloud cover of pairs of layers + do jlev = 1,nlev-1 + pair_cloud_cover(jlev) & + & = overlap_alpha(jlev)*max(frac(jlev),frac(jlev+1)) & + & + (1.0_jprb - overlap_alpha(jlev)) & + & * (frac(jlev)+frac(jlev+1)-frac(jlev)*frac(jlev+1)) + end do + ! Estimate the effective overlap parameter "alpha_obj" between + ! adjacent objects as the product of the layerwise overlap + ! parameters between their layers of maximum cloud fraction + do jobj = 1,nobj-1 + alpha_obj(jobj) & + & = product(overlap_alpha(i_max_obj(jobj):i_max_obj(jobj+1)-1)) + end do + + end if + + + ! Compute the cumulative cloud cover working down from the top + ! of each object: this will later be converted to the cumulative + ! cloud cover working down from TOA + do jobj = 1,nobj + cum_cloud_cover(i_top_obj(jobj)) = frac(i_top_obj(jobj)) + do jlev = i_top_obj(jobj), i_base_obj(jobj)-1 + if (frac(jlev) >= MaxCloudFrac) then + ! Cloud cover has reached one + cum_cloud_cover(jlev+1) = 1.0_jprb + else + cum_cloud_cover(jlev+1) = 1.0_jprb & + & - (1.0_jprb - cum_cloud_cover(jlev)) & + & * (1.0_jprb - pair_cloud_cover(jlev)) & + & / (1.0_jprb - frac(jlev)) + end if + end do + cc_obj(jobj) = cum_cloud_cover(i_base_obj(jobj)) + end do + + iobj1 = 1 + + ! Sequentially combine objects until there is only one left + ! covering the full vertical extent of clouds in the profile + do while (nobj > 1) + ! Find the most correlated adjacent pair of objects + alpha_max = 0.0_jprb + + ! Need to re-initialize iobj1 here in case alpha_obj(:)==0.0, + ! which would mean that the "if" statement in the following + ! loop would never get triggered + iobj1 = 1 + + jobj = 1 + do while (jobj < nobj) + if (alpha_obj(jobj) > alpha_max) then + alpha_max = alpha_obj(jobj) + iobj1 = jobj + end if + jobj = i_next_obj(jobj) + end do + + ! iobj1 is the index to the first object in the pair, set + ! iobj2 to the second + iobj2 = i_next_obj(iobj1) + + ! Set the cumulative cloud cover in the clear-sky gap between + ! the objects to the value at the base of the upper object + cum_cloud_cover(i_base_obj(iobj1)+1:i_top_obj(iobj2)-1) & + & = cum_cloud_cover(i_base_obj(iobj1)) + + ! Calculate the combined cloud cover of the pair of objects + cc_pair = alpha_obj(iobj1)*max(cc_obj(iobj1), cc_obj(iobj2)) & + & + (1.0_jprb - alpha_obj(iobj1)) & + & * (cc_obj(iobj1) + cc_obj(iobj2) - cc_obj(iobj1)*cc_obj(iobj2)) + scaling = min(max((cc_pair-cc_obj(iobj1)) / max(min_frac, cc_obj(iobj2)), & + & 0.0_jprb), & + & 1.0_jprb) + + ! Scale the combined cloud cover of the lower object to + ! account for its overlap with the upper object + do jlev = i_top_obj(iobj2),i_base_obj(iobj2) + cum_cloud_cover(jlev) = cum_cloud_cover(i_base_obj(iobj1)) & + + cum_cloud_cover(jlev) * scaling + end do + + ! Merge the objects by setting the properties of the upper + ! object to the combined properties of both. Note that + ! i_max_obj is not modified because it is no longer needed. + cc_obj(iobj1) = cc_pair + i_base_obj(iobj1) = i_base_obj(iobj2) + i_next_obj(iobj1) = i_next_obj(iobj2) + alpha_obj(iobj1) = alpha_obj(iobj2) + nobj = nobj - 1 + end do + + ! Finish off the total cloud cover below cloud + cum_cloud_cover(i_base_obj(iobj1)+1:nlev) & + & = cum_cloud_cover(i_base_obj(iobj1)) + + ! Ensure that the combined cloud cover of pairs of layers is + ! consistent with the overhang + do jlev = 1,nlev-1 + pair_cloud_cover(jlev) = max(pair_cloud_cover(jlev), & + & frac(jlev)+cum_cloud_cover(jlev+1)-cum_cloud_cover(jlev)) + end do + + ! Sometimes round-off error can lead to cloud cover just above + ! one, which in turn can lead to direct shortwave fluxes just + ! below zero + cum_cloud_cover = min(cum_cloud_cover, 1.0_jprb) + + end if ! cloud is present in profile + + if (lhook) call dr_hook('radiation_cloud_cover:cum_cloud_cover_exp_exp',1,hook_handle) + + end subroutine cum_cloud_cover_exp_exp + +end module radiation_cloud_cover Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_generator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_generator.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_generator.F90 (revision 6016) @@ -0,0 +1,737 @@ +! radiation_cloud_generator.F90 - Generate water-content or optical-depth scalings for McICA +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Generate clouds for McICA using a method modified from Raisanen et +! al. (2002) +! +! Modifications +! 2018-02-22 R. Hogan Call masked version of PDF sampler for speed +! 2020-03-31 R. Hogan More vectorizable version of Exp-Ran + +module radiation_cloud_generator + + public + +contains + + !--------------------------------------------------------------------- + ! Generate scaling factors for the cloud optical depth to represent + ! cloud overlap, the overlap of internal cloud inhomogeneities and + ! the fractional standard deviation of these inhomogeneities, for + ! use in a Monte Carlo Independent Column Approximation radiation + ! scheme. All returned profiles contain cloud, and the total cloud + ! cover is also returned, so the calling function can then do a + ! weighted average of clear and cloudy skies; this is a way to + ! reduce the Monte Carlo noise in profiles with low cloud cover. + subroutine cloud_generator(ng, nlev, i_overlap_scheme, & + & iseed, frac_threshold, & + & frac, overlap_param, decorrelation_scaling, & + & fractional_std, pdf_sampler, & + & od_scaling, total_cloud_cover, & + & use_beta_overlap, use_vectorizable_generator) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + use random_numbers_mix, only : randomnumberstream, & + initialize_random_numbers, uniform_distribution + use radiation_pdf_sampler, only : pdf_sampler_type + use radiation_cloud_cover, only : cum_cloud_cover_exp_ran, & + & cum_cloud_cover_max_ran, cum_cloud_cover_exp_exp, & + & IOverlapMaximumRandom, IOverlapExponentialRandom, & + & IOverlapExponential + + implicit none + + ! Inputs + integer, intent(in) :: ng ! number of g points + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: i_overlap_scheme + integer, intent(in) :: iseed ! seed for random number generator + + ! Only cloud fractions above this threshold are considered to be + ! clouds + real(jprb), intent(in) :: frac_threshold + + ! Cloud fraction on full levels + real(jprb), intent(in) :: frac(nlev) + + ! Cloud overlap parameter for interfaces between model layers, + ! where 0 indicates random overlap and 1 indicates maximum-random + ! overlap + real(jprb), intent(in) :: overlap_param(nlev-1) + + ! Overlap parameter for internal inhomogeneities + real(jprb), intent(in) :: decorrelation_scaling + + ! Fractional standard deviation at each layer + real(jprb), intent(in) :: fractional_std(nlev) + + ! Object for sampling from a lognormal or gamma distribution + type(pdf_sampler_type), intent(in) :: pdf_sampler + + ! This routine has been coded using the "alpha" overlap parameter + ! of Hogan and Illingworth (2000). If the following logical is + ! present and true then the input is interpretted to be the "beta" + ! overlap parameter of Shonk et al. (2010), and needs to be + ! converted to alpha. + logical, intent(in), optional :: use_beta_overlap + + ! Do we use the more vectorizable cloud generator, at the expense + ! of more random numbers being needed? + logical, intent(in), optional :: use_vectorizable_generator + + ! Outputs + + ! Cloud optical depth scaling factor, with 0 indicating clear sky + real(jprb), intent(out) :: od_scaling(ng,nlev) + + ! Total cloud cover using cloud fraction and overlap parameter + real(jprb), intent(out) :: total_cloud_cover + + ! Local variables + + ! Cumulative cloud cover from TOA to the base of each layer + real(jprb) :: cum_cloud_cover(nlev) + + ! Scaled random number for finding cloud + real(jprb) :: trigger + + ! Uniform deviates between 0 and 1 + real(jprb) :: rand_top(ng) + + ! Overlap parameter of inhomogeneities + real(jprb) :: overlap_param_inhom(nlev-1) + + ! Seed for random number generator and stream for producing random + ! numbers + type(randomnumberstream) :: random_stream + + ! First and last cloudy layers + integer :: ibegin, iend + + integer :: itrigger + + ! Loop index for model level and g-point + integer :: jlev, jg + + ! Cloud cover of a pair of layers, and amount by which cloud at + ! next level increases total cloud cover as seen from above + real(jprb), dimension(nlev-1) :: pair_cloud_cover, overhang + + logical :: use_vec_gen + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud_generator:cloud_generator',0,hook_handle) + + if (i_overlap_scheme == IOverlapExponentialRandom) then + call cum_cloud_cover_exp_ran(nlev, frac, overlap_param, & + & cum_cloud_cover, pair_cloud_cover, use_beta_overlap) + else if (i_overlap_scheme == IOverlapMaximumRandom) then + call cum_cloud_cover_max_ran(nlev, frac, & + & cum_cloud_cover, pair_cloud_cover) + else if (i_overlap_scheme == IOverlapExponential) then + call cum_cloud_cover_exp_exp(nlev, frac, overlap_param, & + & cum_cloud_cover, pair_cloud_cover, use_beta_overlap) + else + write(nulerr,'(a)') '*** Error: cloud overlap scheme not recognised' + call radiation_abort() + end if + + total_cloud_cover = cum_cloud_cover(nlev); + do jlev = 1,nlev-1 + overhang(jlev) = cum_cloud_cover(jlev+1)-cum_cloud_cover(jlev) + end do + + if (total_cloud_cover < frac_threshold) then + ! Treat column as clear sky: calling function therefore will not + ! use od_scaling so we don't need to calculate it + total_cloud_cover = 0.0_jprb + + else + ! Cloud is present: need to calculate od_scaling + + ! Find range of cloudy layers + jlev = 1 + do while (frac(jlev) <= 0.0_jprb) + jlev = jlev + 1 + end do + ibegin = jlev + iend = jlev + do jlev = jlev+1,nlev + if (frac(jlev) > 0.0_jprb) then + iend = jlev + end if + end do + + ! Set overlap parameter of inhomogeneities + overlap_param_inhom = overlap_param + + do jlev = ibegin,iend-1 + if (overlap_param(jlev) > 0.0_jprb) then + overlap_param_inhom(jlev) & + & = overlap_param(jlev)**(1.0_jprb/decorrelation_scaling) + end if + end do + + ! Reset optical depth scaling to clear skies + od_scaling = 0.0_jprb + + if (present(use_vectorizable_generator)) then + use_vec_gen = use_vectorizable_generator + else + use_vec_gen = .false. + end if + + if (.not. use_vec_gen) then + ! Original generator that minimizes the number of random + ! numbers used, but is not vectorizable + + ! Expensive operation: initialize random number generator for + ! this column + call initialize_random_numbers(iseed, random_stream) + + ! Compute ng random numbers to use to locate cloud top + call uniform_distribution(rand_top, random_stream) + + ! Loop over ng columns + do jg = 1,ng + ! Find the cloud top height corresponding to the current + ! random number, and store in itrigger + trigger = rand_top(jg) * total_cloud_cover + jlev = ibegin + do while (trigger > cum_cloud_cover(jlev) .and. jlev < iend) + jlev = jlev + 1 + end do + itrigger = jlev + + if (i_overlap_scheme /= IOverlapExponential) then + call generate_column_exp_ran(ng, nlev, jg, random_stream, pdf_sampler, & + & frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & itrigger, iend, od_scaling) + else + call generate_column_exp_exp(ng, nlev, jg, random_stream, pdf_sampler, & + & frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & itrigger, iend, od_scaling) + end if + + end do + + else + ! Alternative generator (only for Exp-Ran overlap so far) that + ! should be vectorizable but generates more random numbers, + ! some of which are not used + + if (i_overlap_scheme == IOverlapExponential) then + write(nulerr,'(a)') '*** Error: vectorizable cloud generator is not available with Exp-Exp overlap' + call radiation_abort() + end if + + call generate_columns_exp_ran(ng, nlev, iseed, pdf_sampler, & + & total_cloud_cover, frac_threshold, frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & ibegin, iend, od_scaling) + + end if + + end if + + if (lhook) call dr_hook('radiation_cloud_generator:cloud_generator',1,hook_handle) + + end subroutine cloud_generator + + + !--------------------------------------------------------------------- + ! Generate a column of optical depth scalings using + ! exponential-random overlap (which includes maximum-random overlap + ! as a limiting case) + subroutine generate_column_exp_ran(ng, nlev, ig, random_stream, pdf_sampler, & + & frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & itrigger, iend, od_scaling) + + use parkind1, only : jprb + use radiation_pdf_sampler, only : pdf_sampler_type + use random_numbers_mix, only : randomnumberstream, & + initialize_random_numbers, uniform_distribution + + + implicit none + + ! Number of g points / columns, and number of current column + integer, intent(in) :: ng, ig + + ! Number of levels + integer, intent(in) :: nlev + + ! Stream for producing random numbers + type(randomnumberstream), intent(inout) :: random_stream + + ! Object for sampling from a lognormal or gamma distribution + type(pdf_sampler_type), intent(in) :: pdf_sampler + + ! Cloud fraction, cumulative cloud cover and fractional standard + ! deviation in each layer + real(jprb), intent(in), dimension(nlev) :: frac, cum_cloud_cover, fractional_std + + ! Cloud cover of a pair of layers, and amount by which cloud at + ! next level increases total cloud cover as seen from above + real(jprb), intent(in), dimension(nlev-1) :: pair_cloud_cover, overhang + + ! Overlap parameter of inhomogeneities + real(jprb), intent(in), dimension(nlev-1) :: overlap_param_inhom + + ! Top of highest cloudy layer (in this subcolumn) and base of + ! lowest + integer, intent(in) :: itrigger, iend + + ! Optical depth scaling to output + real(jprb), intent(inout), dimension(ng,nlev) :: od_scaling + + ! Height indices + integer :: jlev, jcloud + + ! Number of contiguous cloudy layers for which to compute optical + ! depth scaling + integer :: n_layers_to_scale + + integer :: iy + + ! Is it time to fill the od_scaling variable? + logical :: do_fill_od_scaling + + real(jprb) :: rand_cloud(nlev) + real(jprb) :: rand_inhom1(nlev), rand_inhom2(nlev) + + ! So far our vertically contiguous cloud contains only one layer + n_layers_to_scale = 1 + iy = 0 + + ! Locate the clouds below this layer: first generate some more + ! random numbers + call uniform_distribution(rand_cloud(1:(iend+1-itrigger)),random_stream) + + ! Loop from the layer below the local cloud top down to the + ! bottom-most cloudy layer + do jlev = itrigger+1,iend+1 + do_fill_od_scaling = .false. + if (jlev <= iend) then + iy = iy+1 + if (n_layers_to_scale > 0) then + ! There is a cloud above, in which case the probability + ! of cloud in the layer below is as follows + if (rand_cloud(iy)*frac(jlev-1) & + & < frac(jlev) + frac(jlev-1) - pair_cloud_cover(jlev-1)) then + ! Add another cloudy layer + n_layers_to_scale = n_layers_to_scale + 1 + else + ! Reached the end of a contiguous set of cloudy layers and + ! will compute the optical depth scaling immediately. + do_fill_od_scaling = .true. + end if + else + ! There is clear-sky above, in which case the + ! probability of cloud in the layer below is as follows + if (rand_cloud(iy)*(cum_cloud_cover(jlev-1) - frac(jlev-1)) & + & < pair_cloud_cover(jlev-1) - overhang(jlev-1) - frac(jlev-1)) then + ! A new cloud top + n_layers_to_scale = 1 + end if + end if + else + ! We are at the bottom of the cloudy layers in the model, + ! so in a moment need to populate the od_scaling array + do_fill_od_scaling = .true. + end if + + if (do_fill_od_scaling) then + ! We have a contiguous range of layers for which we + ! compute the od_scaling elements using some random + ! numbers + call uniform_distribution(rand_inhom1(1:n_layers_to_scale),random_stream) + call uniform_distribution(rand_inhom2(1:n_layers_to_scale),random_stream) + + ! Loop through the sequence of cloudy layers + do jcloud = 2,n_layers_to_scale + ! Use second random number, and inhomogeneity overlap + ! parameter, to decide whether the first random number + ! should be repeated (corresponding to maximum overlap) + ! or not (corresponding to random overlap) + if (rand_inhom2(jcloud) & + & < overlap_param_inhom(jlev-n_layers_to_scale+jcloud-2)) then + rand_inhom1(jcloud) = rand_inhom1(jcloud-1) + end if + end do + + ! Sample from a lognormal or gamma distribution to obtain + ! the optical depth scalings + call pdf_sampler%sample(fractional_std(jlev-n_layers_to_scale:jlev-1), & + & rand_inhom1(1:n_layers_to_scale), od_scaling(ig,jlev-n_layers_to_scale:jlev-1)) + + n_layers_to_scale = 0 + end if + + end do + + end subroutine generate_column_exp_ran + + + !--------------------------------------------------------------------- + ! Generate a column of optical depth scalings using + ! exponential-exponential overlap + subroutine generate_column_exp_exp(ng, nlev, ig, random_stream, pdf_sampler, & + & frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & itrigger, iend, od_scaling) + + use parkind1, only : jprb + use radiation_pdf_sampler, only : pdf_sampler_type + use random_numbers_mix, only : randomnumberstream, & + initialize_random_numbers, uniform_distribution + + implicit none + + ! Number of g points / columns, and number of current column + integer, intent(in) :: ng, ig + + ! Number of levels + integer, intent(in) :: nlev + + ! Stream for producing random numbers + type(randomnumberstream), intent(inout) :: random_stream + + ! Object for sampling from a lognormal or gamma distribution + type(pdf_sampler_type), intent(in) :: pdf_sampler + + ! Cloud fraction, cumulative cloud cover and fractional standard + ! deviation in each layer + real(jprb), intent(in), dimension(nlev) :: frac, cum_cloud_cover, fractional_std + + ! Cloud cover of a pair of layers, and amount by which cloud at + ! next level increases total cloud cover as seen from above + real(jprb), intent(in), dimension(nlev-1) :: pair_cloud_cover, overhang + + ! Overlap parameter of inhomogeneities + real(jprb), intent(in), dimension(nlev-1) :: overlap_param_inhom + + ! Top of highest cloudy layer (in this subcolumn) and base of + ! lowest + integer, intent(in) :: itrigger, iend + + ! Optical depth scaling to output + real(jprb), intent(inout), dimension(ng,nlev) :: od_scaling + + ! Height indices + integer :: jlev, jcloud + + integer :: iy + + real(jprb) :: rand_cloud(nlev) + real(jprb) :: rand_inhom1(nlev), rand_inhom2(nlev) + + ! For each column analysed, this vector locates the clouds. It is + ! only actually used for Exp-Exp overlap + logical :: is_cloudy(nlev) + + ! Number of contiguous cloudy layers for which to compute optical + ! depth scaling + integer :: n_layers_to_scale + + iy = 0 + + is_cloudy = .false. + is_cloudy(itrigger) = .true. + + ! Locate the clouds below this layer: first generate some more + ! random numbers + call uniform_distribution(rand_cloud(1:(iend+1-itrigger)),random_stream) + + ! Loop from the layer below the local cloud top down to the + ! bottom-most cloudy layer + do jlev = itrigger+1,iend + iy = iy+1 + if (is_cloudy(jlev-1)) then + ! There is a cloud above, in which case the probability + ! of cloud in the layer below is as follows + if (rand_cloud(iy)*frac(jlev-1) & + & < frac(jlev) + frac(jlev-1) - pair_cloud_cover(jlev-1)) then + ! Add another cloudy layer + is_cloudy(jlev) = .true. + end if + else + ! There is clear-sky above, in which case the + ! probability of cloud in the layer below is as follows + if (rand_cloud(iy)*(cum_cloud_cover(jlev-1) - frac(jlev-1)) & + & < pair_cloud_cover(jlev-1) - overhang(jlev-1) - frac(jlev-1)) then + ! A new cloud top + is_cloudy(jlev) = .true. + end if + end if + end do + + ! We have a contiguous range of layers for which we compute the + ! od_scaling elements using some random numbers + + ! In the Exp-Exp overlap scheme we do all layers at once + n_layers_to_scale = iend+1 - itrigger + + call uniform_distribution(rand_inhom1(1:n_layers_to_scale),random_stream) + call uniform_distribution(rand_inhom2(1:n_layers_to_scale),random_stream) + + ! Loop through the sequence of cloudy layers + do jcloud = 2,n_layers_to_scale + ! Use second random number, and inhomogeneity overlap + ! parameter, to decide whether the first random number + ! should be repeated (corresponding to maximum overlap) + ! or not (corresponding to random overlap) + if (rand_inhom2(jcloud) & + & < overlap_param_inhom(iend-n_layers_to_scale+jcloud-1)) then + rand_inhom1(jcloud) = rand_inhom1(jcloud-1) + end if + end do + + ! Sample from a lognormal or gamma distribution to obtain the + ! optical depth scalings + + ! Masked version assuming values outside the range itrigger:iend + ! are already zero: + call pdf_sampler%masked_sample(n_layers_to_scale, & + & fractional_std(itrigger:iend), & + & rand_inhom1(1:n_layers_to_scale), od_scaling(ig,itrigger:iend), & + & is_cloudy(itrigger:iend)) + + ! ! IFS version: + ! !$omp simd + ! do jlev=itrigger,iend + ! if (.not. is_cloudy(jlev)) then + ! od_scaling(ig,jlev) = 0.0_jprb + ! else + ! call sample_from_pdf_simd(& + ! pdf_sampler,fractional_std(jlev),& + ! rand_inhom1(jlev-itrigger+1), & + ! od_scaling(ig,jlev)) + ! end if + ! end do + + end subroutine generate_column_exp_exp + + + !--------------------------------------------------------------------- + ! Extract the value of a lognormal distribution with fractional + ! standard deviation "fsd" corresponding to the cumulative + ! distribution function value "cdf", and return it in x. Since this + ! is an elemental subroutine, fsd, cdf and x may be arrays. SIMD version. + subroutine sample_from_pdf_simd(this, fsd, cdf, x) + use parkind1, only : jprb + use radiation_pdf_sampler, only : pdf_sampler_type + implicit none +#if defined(__GFORTRAN__) || defined(__PGI) || defined(__NEC__) || defined(__INTEL_LLVM_COMPILER) +#else + !$omp declare simd(sample_from_pdf_simd) uniform(this) & + !$omp linear(ref(fsd)) linear(ref(cdf)) +#endif + type(pdf_sampler_type), intent(in) :: this + + ! Fractional standard deviation (0 to 4) and cumulative + ! distribution function (0 to 1) + real(jprb), intent(in) :: fsd, cdf + + ! Sample from distribution + real(jprb), intent(out) :: x + + ! Index to look-up table + integer :: ifsd, icdf + + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + ! Bilinear interpolation with bounds + wcdf = cdf * (this%ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), this%ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fsd-this%fsd1) * this%inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), this%nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + x = (1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf ,ifsd) & + & + (1.0_jprb-wcdf)* wfsd * this%val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd) & + & + wcdf * wfsd * this%val(icdf+1,ifsd+1) + + end subroutine sample_from_pdf_simd + + + !--------------------------------------------------------------------- + ! Generate columns of optical depth scalings using + ! exponential-random overlap (which includes maximum-random overlap + ! as a limiting case). This version is intended to work better on + ! hardware with long vector lengths. As with all calculations in + ! this file, we zoom into the fraction of the column with cloud at + ! any height, so that all spectral intervals see a cloud somewhere. + ! In the McICA solver, this is combined appropriately with the + ! clear-sky calculation. + subroutine generate_columns_exp_ran(ng, nlev, iseed, pdf_sampler, & + & total_cloud_cover, frac_threshold, frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & ibegin, iend, od_scaling) + + use parkind1, only : jprb + use radiation_pdf_sampler, only : pdf_sampler_type + use radiation_random_numbers, only : rng_type, IRngMinstdVector, IRngNative + + implicit none + + ! Number of g points / columns + integer, intent(in) :: ng + + ! Number of levels + integer, intent(in) :: nlev + + integer, intent(in) :: iseed ! seed for random number generator + + ! Stream for producing random numbers + !type(randomnumberstream) :: random_stream + type(rng_type) :: random_number_generator + + ! Object for sampling from a lognormal or gamma distribution + type(pdf_sampler_type), intent(in) :: pdf_sampler + + ! Total cloud cover using cloud fraction and overlap parameter + real(jprb), intent(in) :: total_cloud_cover + + real(jprb), intent(in) :: frac_threshold + + ! Cloud fraction, cumulative cloud cover and fractional standard + ! deviation in each layer + real(jprb), intent(in), dimension(nlev) :: frac, cum_cloud_cover, fractional_std + + ! Cloud cover of a pair of layers, and amount by which cloud at + ! next level increases total cloud cover as seen from above + real(jprb), intent(in), dimension(nlev-1) :: pair_cloud_cover, overhang + + ! Overlap parameter of inhomogeneities + real(jprb), intent(in), dimension(nlev-1) :: overlap_param_inhom + + ! Top of highest cloudy layer and base of lowest + integer, intent(inout) :: ibegin, iend + + ! Optical depth scaling to output + real(jprb), intent(inout), dimension(ng,nlev) :: od_scaling + + ! Loop indices + integer :: jlev, jg + + real(jprb) :: rand_cloud(ng,ibegin:iend) + real(jprb) :: rand_inhom(ng,ibegin-1:iend), rand_inhom2(ng,ibegin:iend) + + ! Is the cloud fraction above the minimum threshold at each level + logical :: is_any_cloud(ibegin:iend) + + ! Scaled random number for finding cloud + real(jprb) :: trigger(ng) + + logical :: is_cloud(ng) ! Is there cloud at this level and spectral interval? + logical :: prev_cloud(ng) ! Was there cloud at level above? + logical :: first_cloud(ng) ! At level of first cloud counting down from top? + logical :: found_cloud(ng) ! Cloud found in this column counting down from top? + + is_any_cloud = (frac(ibegin:iend) >= frac_threshold) + + ! Initialize random number generator for this column, and state + ! that random numbers will be requested in blocks of length the + ! number of spectral intervals ng. + call random_number_generator%initialize(IRngMinstdVector, iseed=iseed, & + & nmaxstreams=ng) + + ! Random numbers to use to locate cloud top + call random_number_generator%uniform_distribution(trigger) + + ! Random numbers to work out whether to transition vertically from + ! clear to cloudy, cloudy to clear, clear to clear or cloudy to + ! cloudy + call random_number_generator%uniform_distribution(rand_cloud, is_any_cloud) + + ! Random numbers to generate sub-grid cloud structure + call random_number_generator%uniform_distribution(rand_inhom) + call random_number_generator%uniform_distribution(rand_inhom2, is_any_cloud) + + trigger = trigger * total_cloud_cover + + ! Initialize logicals for clear-sky above first cloudy layer + found_cloud = .false. + is_cloud = .false. + first_cloud = .false. + + ! Loop down through layers starting at the first cloudy layer + do jlev = ibegin,iend + + if (is_any_cloud(jlev)) then + +! Added for DWD (2020) +!NEC$ shortloop + do jg = 1,ng + ! The intention is that all these operations are vectorizable, + ! since all are vector operations on vectors of length ng... + + ! Copy the cloud mask between levels + prev_cloud(jg) = is_cloud(jg) + + ! For each spectral interval, has the first cloud appeared at this level? + first_cloud(jg) = (trigger(jg) <= cum_cloud_cover(jlev) .and. .not. found_cloud(jg)) + + ! ...if so, add to found_cloud + found_cloud(jg) = found_cloud(jg) .or. first_cloud(jg) + + ! There is cloud at this level either if a first cloud has + ! appeared, or using separate probability calculations + ! depending on whether there is a cloud above (given by + ! prev_cloud) + is_cloud(jg) = first_cloud(jg) & + & .or. found_cloud(jg) .and. merge(rand_cloud(jg,jlev)*frac(jlev-1) & + & < frac(jlev)+frac(jlev-1)-pair_cloud_cover(jlev-1), & + & rand_cloud(jg,jlev)*(cum_cloud_cover(jlev-1) - frac(jlev-1)) & + & < pair_cloud_cover(jlev-1) - overhang(jlev-1) - frac(jlev-1), & + & prev_cloud(jg)) + ! The random number determining cloud structure decorrelates + ! with the one above it according to the overlap parameter, + ! but always decorrelates if there is clear-sky above. If + ! there is clear-sky in the present level, the random number + ! is set to zero to ensure that the optical depth scaling is + ! also zero. + rand_inhom(jg,jlev) = merge(merge(rand_inhom(jg,jlev-1), rand_inhom(jg,jlev), & + & rand_inhom2(jg,jlev) < overlap_param_inhom(jlev-1) & + & .and. prev_cloud(jg)), & + & 0.0_jprb, is_cloud(jg)) + end do + else + ! No cloud at this level + is_cloud = .false. + end if + end do + + ! Sample from a lognormal or gamma distribution to obtain the + ! optical depth scalings, calling the faster masked version and + ! assuming values outside the range ibegin:iend are already zero + call pdf_sampler%masked_block_sample(iend-ibegin+1, ng, & + & fractional_std(ibegin:iend), & + & rand_inhom(:,ibegin:iend), od_scaling(:,ibegin:iend), & + & is_any_cloud) + + end subroutine generate_columns_exp_ran + +end module radiation_cloud_generator Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_generator_acc.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_generator_acc.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_generator_acc.F90 (revision 6016) @@ -0,0 +1,265 @@ +! This file has been modified for the use in ICON + +! radiation_cloud_generator_acc.F90 - Generate water-content or optical-depth scalings for McICA +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Generate clouds for McICA using a method modified from Raisanen et +! al. (2002) +! This is a copy of the original cloud_generator, that is better suited for OpenACC +! +! Modifications +! 2018-02-22 R. Hogan Call masked version of PDF sampler for speed +! 2020-03-31 R. Hogan More vectorizable version of Exp-Ran +! 2022-11-07 D. Hupp adaptation for ACC + +module radiation_cloud_generator_acc + + public + +contains + + !--------------------------------------------------------------------- + ! Generate scaling factors for the cloud optical depth to represent + ! cloud overlap, the overlap of internal cloud inhomogeneities and + ! the fractional standard deviation of these inhomogeneities, for + ! use in a Monte Carlo Independent Column Approximation radiation + ! scheme. All returned profiles contain cloud, and the total cloud + ! cover is also returned, so the calling function can then do a + ! weighted average of clear and cloudy skies; this is a way to + ! reduce the Monte Carlo noise in profiles with low cloud cover. + subroutine cloud_generator_acc(ng, nlev, & + & iseed, frac_threshold, & + & frac, overlap_param, decorrelation_scaling, & + & fractional_std, & + & sample_ncdf, sample_nfsd, sample_fsd1, & + & sample_inv_fsd_interval, sample_val, & + & od_scaling, total_cloud_cover, & + & ibegin, iend, & + & cum_cloud_cover, & + & pair_cloud_cover) + + use parkind1, only : jprb + use radiation_random_numbers, only : initialize_acc, uniform_distribution_acc, IMinstdA0, IMinstdA, IMinstdM + + implicit none + + ! Inputs + integer, intent(in) :: ng ! number of g points + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: iseed ! seed for random number generator + + ! Only cloud fractions above this threshold are considered to be + ! clouds + real(jprb), intent(in) :: frac_threshold + + ! Cloud fraction on full levels + real(jprb), intent(in) :: frac(nlev) + + ! Cloud overlap parameter for interfaces between model layers, + ! where 0 indicates random overlap and 1 indicates maximum-random + ! overlap + real(jprb), intent(in) :: overlap_param(nlev-1) + + ! Overlap parameter for internal inhomogeneities + real(jprb), intent(in) :: decorrelation_scaling + + ! Fractional standard deviation at each layer + real(jprb), intent(in) :: fractional_std(nlev) + + ! Object for sampling from a lognormal or gamma distribution + integer, intent(in) :: sample_ncdf, sample_nfsd + real(jprb), intent(in) :: sample_fsd1, sample_inv_fsd_interval + real(jprb), intent(in), dimension(:,:) :: sample_val + + ! Outputs + + ! Cloud optical depth scaling factor, with 0 indicating clear sky + real(jprb), intent(out) :: od_scaling(ng,nlev) + + ! Total cloud cover using cloud fraction and overlap parameter + real(jprb), intent(in) :: total_cloud_cover + + ! Local variables + + ! Cumulative cloud cover from TOA to the base of each layer + real(jprb), intent(in) :: cum_cloud_cover(nlev) + + ! First and last cloudy layers + integer, intent(in) :: ibegin, iend + + ! Scaled random number for finding cloud + real(jprb) :: trigger + + ! Uniform deviates between 0 and 1 + real(jprb) :: rand_top + + ! Overlap parameter of inhomogeneities + real(jprb) :: overlap_param_inhom + + real(jprb) :: rand_cloud, rand_inhom1, rand_inhom2 + + integer :: itrigger + + ! Loop index for model level and g-point + integer :: jlev, jg + + ! Cloud cover of a pair of layers, and amount by which cloud at + ! next level increases total cloud cover as seen from above + real(jprb), intent(inout), dimension(nlev-1) :: pair_cloud_cover + real(jprb) :: overhang + + integer :: jcloud + ! Number of contiguous cloudy layers for which to compute optical + ! depth scaling + integer :: n_layers_to_scale + + ! Is it time to fill the od_scaling variable? + logical :: do_fill_od_scaling + + ! variables from manual inlining of sample_vec_from_pdf + ! Index to look-up table + integer :: ifsd, icdf + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + ! local variable for the acc rng + real(kind=jprb) :: istate + + !$ACC ROUTINE WORKER + + if (total_cloud_cover >= frac_threshold) then + ! Loop over ng columns (this loop should be paralized as soon as acc RNG is available) + !$ACC LOOP WORKER VECTOR PRIVATE(istate, rand_top, trigger, itrigger, n_layers_to_scale) + do jg = 1,ng + + !$ACC LOOP SEQ + do jlev = 1,nlev + od_scaling(jg,jlev) = 0.0_jprb + end do + + ! begin manuel inline of istate = initialize_acc(iseed, jg) + istate = REAL(ABS(iseed),jprb) + ! Use a modified (and vectorized) C++ minstd_rand0 algorithm to populate the state + istate = nint(mod( istate*jg*(1._jprb-0.05_jprb*jg+0.005_jprb*jg**2)*IMinstdA0, IMinstdM)) + + ! One warmup of the C++ minstd_rand algorithm + istate = mod(IMinstdA * istate, IMinstdM) + ! end manuel inline of istate = initialize_acc(iseed, jg) + rand_top = uniform_distribution_acc(istate) + + ! Find the cloud top height corresponding to the current + ! random number, and store in itrigger + trigger = rand_top * total_cloud_cover + itrigger = iend + !$ACC LOOP SEQ + do jlev = ibegin,iend + if (trigger <= cum_cloud_cover(jlev)) then + itrigger = min(jlev, itrigger) + end if + end do + + ! manual inline: call generate_column_exp_ran >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! So far our vertically contiguous cloud contains only one layer + n_layers_to_scale = 1 + + ! Locate the clouds below this layer: first generate some more + ! random numbers + ! Loop from the layer below the local cloud top down to the + ! bottom-most cloudy layer + !$ACC LOOP SEQ PRIVATE(do_fill_od_scaling, rand_cloud, rand_inhom1, overhang) + do jlev = itrigger+1,iend+1 + do_fill_od_scaling = .false. + if (jlev <= iend) then + rand_cloud = uniform_distribution_acc(istate) + if (n_layers_to_scale > 0) then + ! There is a cloud above, in which case the probability + ! of cloud in the layer below is as follows + if (rand_cloud*frac(jlev-1) & + & < frac(jlev) + frac(jlev-1) - pair_cloud_cover(jlev-1)) then + ! Add another cloudy layer + n_layers_to_scale = n_layers_to_scale + 1 + else + ! Reached the end of a contiguous set of cloudy layers and + ! will compute the optical depth scaling immediately. + do_fill_od_scaling = .true. + end if + else + overhang = cum_cloud_cover(jlev)-cum_cloud_cover(jlev-1) + ! There is clear-sky above, in which case the + ! probability of cloud in the layer below is as follows + if (rand_cloud*(cum_cloud_cover(jlev-1) - frac(jlev-1)) & + & < pair_cloud_cover(jlev-1) - overhang - frac(jlev-1)) then + ! A new cloud top + n_layers_to_scale = 1 + end if + end if + else + ! We are at the bottom of the cloudy layers in the model, + ! so in a moment need to populate the od_scaling array + do_fill_od_scaling = .true. + end if ! (jlev <= iend) + + if (do_fill_od_scaling) then + + rand_inhom1 = uniform_distribution_acc(istate) + ! Loop through the sequence of cloudy layers + !$ACC LOOP SEQ PRIVATE(rand_inhom2, overlap_param_inhom, wcdf, icdf, & + !$ACC wfsd, ifsd) + do jcloud = max(2,jlev-n_layers_to_scale),jlev-1 + + rand_inhom2 = uniform_distribution_acc(istate) + + ! Set overlap parameter of inhomogeneities + overlap_param_inhom = overlap_param(jcloud-1) + if ( ibegin<=jcloud-1 .and. jcloud-1< iend .and. & + & overlap_param(jcloud-1) > 0.0_jprb) then + overlap_param_inhom = & + & overlap_param(jcloud-1)**(1.0_jprb/decorrelation_scaling) + end if + + ! Use second random number, and inhomogeneity overlap + ! parameter, to decide whether the first random number + ! should be repeated (corresponding to maximum overlap) + ! or not (corresponding to random overlap) + if ( jcloud > jlev-n_layers_to_scale .and. & + & rand_inhom2 >= overlap_param_inhom) then + rand_inhom1 = uniform_distribution_acc(istate) + end if + ! manual inline >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Bilinear interpolation with bounds + wcdf = rand_inhom1 * (sample_ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), sample_ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fractional_std(jcloud)-sample_fsd1) * sample_inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), sample_nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + od_scaling(jg,jcloud) = (1.0_jprb-wcdf)*(1.0_jprb-wfsd) * sample_val(icdf ,ifsd) & + & + (1.0_jprb-wcdf)* wfsd * sample_val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * sample_val(icdf+1,ifsd) & + & + wcdf * wfsd * sample_val(icdf+1,ifsd+1) + ! manual inline <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + end do + + n_layers_to_scale = 0 + + end if ! (do_fill_od_scaling) + end do ! jlev = itrigger+1,iend+1 + end do ! jg = 1,ng + end if ! (total_cloud_cover < frac_threshold) + + end subroutine cloud_generator_acc + +end module radiation_cloud_generator_acc Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_optics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_optics.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_optics.F90 (revision 6016) @@ -0,0 +1,545 @@ +! This file has been modified for the use in ICON + +! radiation_cloud_optics.F90 - Computing cloud optical properties +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-07-22 R. Hogan Added Yi et al. ice optics model + +module radiation_cloud_optics + + implicit none + + public + +contains + + ! Provides elemental function "delta_eddington_scat_od" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Load cloud scattering data; this subroutine delegates to one + ! in radiation_cloud_optics_data.F90, but checks the size of + ! what is returned + subroutine setup_cloud_optics(config) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type, IIceModelFu, IIceModelBaran, & + & IIceModelBaran2016, IIceModelBaran2017, & + & IIceModelYi, & + & ILiquidModelSOCRATES, ILiquidModelSlingo + use radiation_ice_optics_fu, only : NIceOpticsCoeffsFuSW, & + & NIceOpticsCoeffsFuLW + use radiation_ice_optics_baran, only : NIceOpticsCoeffsBaran, & + & NIceOpticsCoeffsBaran2016 + use radiation_ice_optics_baran2017, only : NIceOpticsCoeffsBaran2017, & + & NIceOpticsGeneralCoeffsBaran2017 + use radiation_ice_optics_yi, only : NIceOpticsCoeffsYiSW, & + & NIceOpticsCoeffsYiLW + use radiation_liquid_optics_socrates, only : NLiqOpticsCoeffsSOCRATES + use radiation_liquid_optics_slingo, only : NLiqOpticsCoeffsSlingoSW, & + & NLiqOpticsCoeffsLindnerLiLW + + type(config_type), intent(inout) :: config + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud_optics:setup_cloud_optics',0,hook_handle) + + call config%cloud_optics%setup(trim(config%liq_optics_file_name), & + & trim(config%ice_optics_file_name), iverbose=config%iverbosesetup) + + ! Check liquid coefficients + if (size(config%cloud_optics%liq_coeff_lw, 1) /= config%n_bands_lw) then + write(nulerr,'(a,i0,a,i0,a)') & + & '*** Error: number of longwave bands for droplets (', & + & size(config%cloud_optics%liq_coeff_lw, 1), & + & ') does not match number for gases (', config%n_bands_lw, ')' + call radiation_abort() + end if + if (size(config%cloud_optics%liq_coeff_sw, 1) /= config%n_bands_sw) then + write(nulerr,'(a,i0,a,i0,a)') & + & '*** Error: number of shortwave bands for droplets (', & + & size(config%cloud_optics%liq_coeff_sw, 1), & + & ') does not match number for gases (', config%n_bands_sw, ')' + call radiation_abort() + end if + + if (config%i_liq_model == ILiquidModelSOCRATES) then + if (size(config%cloud_optics%liq_coeff_lw, 2) /= NLiqOpticsCoeffsSOCRATES) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of liquid cloud optical coefficients (', & + & size(config%cloud_optics%liq_coeff_lw, 2), & + & ') does not match number expected (', NLiqOpticsCoeffsSOCRATES,')' + call radiation_abort() + end if + else if (config%i_liq_model == ILiquidModelSlingo) then + if (size(config%cloud_optics%liq_coeff_sw, 2) /= NLiqOpticsCoeffsSlingoSW) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of shortwave liquid cloud optical coefficients (', & + & size(config%cloud_optics%liq_coeff_sw, 2), & + & ') does not match number expected (', NLiqOpticsCoeffsSlingoSW,')' + call radiation_abort() + end if + if (size(config%cloud_optics%liq_coeff_lw, 2) /= NLiqOpticsCoeffsLindnerLiLW) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of longwave liquid cloud optical coefficients (', & + & size(config%cloud_optics%liq_coeff_lw, 2), & + & ') does not match number expected (', NLiqOpticsCoeffsLindnerLiLw,')' + call radiation_abort() + end if + end if + + ! Check ice coefficients + if (size(config%cloud_optics%ice_coeff_lw, 1) /= config%n_bands_lw) then + write(nulerr,'(a,i0,a,i0,a)') & + & '*** Error: number of longwave bands for ice particles (', & + & size(config%cloud_optics%ice_coeff_lw, 1), & + & ') does not match number for gases (', config%n_bands_lw, ')' + call radiation_abort() + end if + if (size(config%cloud_optics%ice_coeff_sw, 1) /= config%n_bands_sw) then + write(nulerr,'(a,i0,a,i0,a)') & + & '*** Error: number of shortwave bands for ice particles (', & + & size(config%cloud_optics%ice_coeff_sw, 1), & + & ') does not match number for gases (', config%n_bands_sw, ')' + call radiation_abort() + end if + + if (config%i_ice_model == IIceModelFu) then + if (size(config%cloud_optics%ice_coeff_lw, 2) & + & /= NIceOpticsCoeffsFuLW) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of LW ice-particle optical coefficients (', & + & size(config%cloud_optics%ice_coeff_lw, 2), & + & ') does not match number expected (', NIceOpticsCoeffsFuLW,')' + call radiation_abort() + end if + if (size(config%cloud_optics%ice_coeff_sw, 2) & + & /= NIceOpticsCoeffsFuSW) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of SW ice-particle optical coefficients (', & + & size(config%cloud_optics%ice_coeff_sw, 2), & + & ') does not match number expected (', NIceOpticsCoeffsFuSW,')' + call radiation_abort() + end if + else if (config%i_ice_model == IIceModelBaran & + & .and. size(config%cloud_optics%ice_coeff_lw, 2) & + & /= NIceOpticsCoeffsBaran) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of ice-particle optical coefficients (', & + & size(config%cloud_optics%ice_coeff_lw, 2), & + & ') does not match number expected (', NIceOpticsCoeffsBaran,')' + call radiation_abort() + else if (config%i_ice_model == IIceModelBaran2016 & + & .and. size(config%cloud_optics%ice_coeff_lw, 2) & + & /= NIceOpticsCoeffsBaran2016) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of ice-particle optical coefficients (', & + & size(config%cloud_optics%ice_coeff_lw, 2), & + & ') does not match number expected (', NIceOpticsCoeffsBaran2016,')' + call radiation_abort() + else if (config%i_ice_model == IIceModelBaran2017) then + if (size(config%cloud_optics%ice_coeff_lw, 2) & + & /= NIceOpticsCoeffsBaran2017) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of ice-particle optical coefficients (', & + & size(config%cloud_optics%ice_coeff_lw, 2), & + & ') does not match number expected (', NIceOpticsCoeffsBaran2017,')' + call radiation_abort() + else if (.not. allocated(config%cloud_optics%ice_coeff_gen)) then + write(nulerr,'(a)') & + & '*** Error: coeff_gen needed for Baran-2017 ice optics parameterization' + call radiation_abort() + else if (size(config%cloud_optics%ice_coeff_gen) & + & /= NIceOpticsGeneralCoeffsBaran2017) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of general ice-particle optical coefficients (', & + & size(config%cloud_optics%ice_coeff_gen), & + & ') does not match number expected (', NIceOpticsGeneralCoeffsBaran2017,')' + call radiation_abort() + end if + else if (config%i_ice_model == IIceModelYi) then + if (size(config%cloud_optics%ice_coeff_lw, 2) & + & /= NIceOpticsCoeffsYiLW) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of LW ice-particle optical coefficients (', & + & size(config%cloud_optics%ice_coeff_lw, 2), & + & ') does not match number expected (', NIceOpticsCoeffsYiLW,')' + call radiation_abort() + end if + if (size(config%cloud_optics%ice_coeff_sw, 2) & + & /= NIceOpticsCoeffsYiSW) then + write(nulerr,'(a,i0,a,i0,a,i0,a)') & + & '*** Error: number of SW ice-particle optical coefficients (', & + & size(config%cloud_optics%ice_coeff_sw, 2), & + & ') does not match number expected (', NIceOpticsCoeffsYiSW,')' + call radiation_abort() + end if + end if + + if (lhook) call dr_hook('radiation_cloud_optics:setup_cloud_optics',1,hook_handle) + + end subroutine setup_cloud_optics + + + !--------------------------------------------------------------------- + ! Compute cloud optical properties + subroutine cloud_optics(nlev,istartcol,iendcol, & + & config, thermodynamics, cloud, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulout, nulerr, radiation_abort + use radiation_config, only : config_type, IIceModelFu, IIceModelBaran, & + & IIceModelBaran2016, IIceModelBaran2017, & + & IIceModelYi, & + & ILiquidModelSOCRATES, ILiquidModelSlingo + use radiation_thermodynamics, only : thermodynamics_type + use radiation_cloud, only : cloud_type + use radiation_constants, only : AccelDueToGravity + use radiation_ice_optics_fu, only : calc_ice_optics_fu_sw, & + & calc_ice_optics_fu_lw + use radiation_ice_optics_baran, only : calc_ice_optics_baran, & + & calc_ice_optics_baran2016 + use radiation_ice_optics_baran2017, only : calc_ice_optics_baran2017 + use radiation_ice_optics_yi, only : calc_ice_optics_yi_sw, & + & calc_ice_optics_yi_lw + use radiation_liquid_optics_socrates, only:calc_liq_optics_socrates + use radiation_liquid_optics_slingo, only:calc_liq_optics_slingo, & + & calc_liq_optics_lindner_li + + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in), target :: config + type(thermodynamics_type),intent(in) :: thermodynamics + type(cloud_type), intent(in) :: cloud + + ! Layer optical depth, single scattering albedo and g factor of + ! clouds in each longwave band, where the latter two + ! variables are only defined if cloud longwave scattering is + ! enabled (otherwise both are treated as zero). + real(jprb), dimension(config%n_bands_lw,nlev,istartcol:iendcol), intent(out) :: & + & od_lw_cloud + real(jprb), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol), & + & intent(out) :: ssa_lw_cloud, g_lw_cloud + + ! Layer optical depth, single scattering albedo and g factor of + ! clouds in each shortwave band + real(jprb), dimension(config%n_bands_sw,nlev,istartcol:iendcol), intent(out) :: & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud + + ! Longwave and shortwave optical depth, scattering optical depth + ! and asymmetry factor, for liquid and ice in all bands but a + ! single cloud layer + real(jprb), dimension(config%n_bands_lw) :: & + & od_lw_liq, scat_od_lw_liq, g_lw_liq, & + & od_lw_ice, scat_od_lw_ice, g_lw_ice + real(jprb), dimension(config%n_bands_sw) :: & + & od_sw_liq, scat_od_sw_liq, g_sw_liq, & + & od_sw_ice, scat_od_sw_ice, g_sw_ice + + ! In-cloud water path of cloud liquid or ice (i.e. liquid or ice + ! gridbox-mean water path divided by cloud fraction); kg m-2 + real(jprb) :: lwp_in_cloud, iwp_in_cloud + + ! Full-level temperature (K) + real(jprb) :: temperature + + ! Factor to convert gridbox-mean mixing ratio to in-cloud water + ! path + real(jprb) :: factor + + integer :: jcol, jlev, jb + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud_optics:cloud_optics',0,hook_handle) + + if (config%iverbose >= 2) then + write(nulout,'(a)') 'Computing cloud absorption/scattering properties' + end if + + associate(ho => config%cloud_optics) + + !$ACC DATA PRESENT (config, thermodynamics, thermodynamics%pressure_hl, & + !$ACC cloud, cloud%fraction, cloud%q_liq, cloud%q_ice, & + !$ACC cloud%re_liq, cloud%re_ice) & + !$ACC PRESENT(od_lw_cloud, g_lw_cloud, ssa_lw_cloud, od_sw_cloud, g_sw_cloud, ssa_sw_cloud) + + ! Array-wise assignment + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG COLLAPSE(2) + do jcol=istartcol, iendcol + do jlev=1, nlev + !$ACC LOOP VECTOR + do jb=1, config%n_bands_sw + od_sw_cloud(jb,jlev,jcol) = 0.0_jprb + ssa_sw_cloud(jb,jlev,jcol) = 0.0_jprb + g_sw_cloud(jb,jlev,jcol) = 0.0_jprb + end do + !$ACC LOOP VECTOR + do jb=1, config%n_bands_lw + od_lw_cloud(jb,jlev,jcol) = 0.0_jprb + end do + !$ACC LOOP VECTOR + do jb=1, config%n_bands_lw_if_scattering + ssa_lw_cloud(jb,jlev,jcol) = 0.0_jprb + g_lw_cloud(jb,jlev,jcol) = 0.0_jprb + end do + end do + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP SEQ + do jlev = 1,nlev + !$ACC LOOP GANG VECTOR & + !$ACC PRIVATE(od_lw_liq, scat_od_lw_liq, g_lw_liq, od_lw_ice, scat_od_lw_ice, g_lw_ice) & + !$ACC PRIVATE(od_sw_liq, scat_od_sw_liq, g_sw_liq, od_sw_ice, scat_od_sw_ice, g_sw_ice) + do jcol = istartcol,iendcol + ! Only do anything if cloud is present (assume that + ! cloud%crop_cloud_fraction has already been called) + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + + ! Compute in-cloud liquid and ice water path + if (config%is_homogeneous) then + ! Homogeneous solvers assume cloud fills the box + ! horizontally, so we don't divide by cloud fraction + factor = ( thermodynamics%pressure_hl(jcol,jlev+1) & + & -thermodynamics%pressure_hl(jcol,jlev ) ) & + & / AccelDueToGravity + else + factor = ( thermodynamics%pressure_hl(jcol,jlev+1) & + & -thermodynamics%pressure_hl(jcol,jlev ) ) & + & / (AccelDueToGravity * cloud%fraction(jcol,jlev)) + end if + lwp_in_cloud = factor * cloud%q_liq(jcol,jlev) + iwp_in_cloud = factor * cloud%q_ice(jcol,jlev) + + ! Only compute liquid properties if liquid cloud is + ! present + if (lwp_in_cloud > 0.0_jprb) then +#ifndef _OPENACC + if (config%i_liq_model == ILiquidModelSOCRATES) then +#endif + ! Compute longwave properties + call calc_liq_optics_socrates(config%n_bands_lw, & + & config%cloud_optics%liq_coeff_lw, & + & lwp_in_cloud, cloud%re_liq(jcol,jlev), & + & od_lw_liq, scat_od_lw_liq, g_lw_liq) + ! Compute shortwave properties + call calc_liq_optics_socrates(config%n_bands_sw, & + & config%cloud_optics%liq_coeff_sw, & + & lwp_in_cloud, cloud%re_liq(jcol,jlev), & + & od_sw_liq, scat_od_sw_liq, g_sw_liq) +#ifndef _OPENACC + else if (config%i_liq_model == ILiquidModelSlingo) then + ! Compute longwave properties + call calc_liq_optics_lindner_li(config%n_bands_lw, & + & config%cloud_optics%liq_coeff_lw, & + & lwp_in_cloud, cloud%re_liq(jcol,jlev), & + & od_lw_liq, scat_od_lw_liq, g_lw_liq) + ! Compute shortwave properties + call calc_liq_optics_slingo(config%n_bands_sw, & + & config%cloud_optics%liq_coeff_sw, & + & lwp_in_cloud, cloud%re_liq(jcol,jlev), & + & od_sw_liq, scat_od_sw_liq, g_sw_liq) + else + write(nulerr,*) '*** Error: Unknown liquid model with code', & + & config%i_liq_model + call radiation_abort() + end if +#endif + + ! Delta-Eddington scaling in the shortwave only + if (.not. config%do_sw_delta_scaling_with_gases) then + call delta_eddington_scat_od(od_sw_liq, scat_od_sw_liq, g_sw_liq) + end if + ! Originally delta-Eddington has been off in ecRad for + ! liquid clouds in the longwave, but it should be on + !call delta_eddington_scat_od(od_lw_liq, scat_od_lw_liq, g_lw_liq) + + else + ! Liquid not present: set properties to zero + od_lw_liq = 0.0_jprb + scat_od_lw_liq = 0.0_jprb + g_lw_liq = 0.0_jprb + + od_sw_liq = 0.0_jprb + scat_od_sw_liq = 0.0_jprb + g_sw_liq = 0.0_jprb + end if ! Liquid present + + ! Only compute ice properties if ice cloud is present + if (iwp_in_cloud > 0.0_jprb) then +#ifndef _OPENACC + if (config%i_ice_model == IIceModelBaran) then + ! Compute longwave properties + call calc_ice_optics_baran(config%n_bands_lw, & + & config%cloud_optics%ice_coeff_lw, & + & iwp_in_cloud, cloud%q_ice(jcol,jlev), & + & od_lw_ice, scat_od_lw_ice, g_lw_ice) + ! Compute shortwave properties + call calc_ice_optics_baran(config%n_bands_sw, & + & config%cloud_optics%ice_coeff_sw, & + & iwp_in_cloud, cloud%q_ice(jcol,jlev), & + & od_sw_ice, scat_od_sw_ice, g_sw_ice) + else if (config%i_ice_model == IIceModelBaran2016) then + temperature = 0.5_jprb * (thermodynamics%temperature_hl(jcol,jlev) & + & +thermodynamics%temperature_hl(jcol,jlev+1)) + ! Compute longwave properties + call calc_ice_optics_baran2016(config%n_bands_lw, & + & config%cloud_optics%ice_coeff_lw, & + & iwp_in_cloud, cloud%q_ice(jcol,jlev), & + & temperature, & + & od_lw_ice, scat_od_lw_ice, g_lw_ice) + ! Compute shortwave properties + call calc_ice_optics_baran2016(config%n_bands_sw, & + & config%cloud_optics%ice_coeff_sw, & + & iwp_in_cloud, cloud%q_ice(jcol,jlev), & + & temperature, & + & od_sw_ice, scat_od_sw_ice, g_sw_ice) + else if (config%i_ice_model == IIceModelBaran2017) then + temperature = 0.5_jprb * (thermodynamics%temperature_hl(jcol,jlev) & + & +thermodynamics%temperature_hl(jcol,jlev+1)) + ! Compute longwave properties + call calc_ice_optics_baran2017(config%n_bands_lw, & + & config%cloud_optics%ice_coeff_gen, & + & config%cloud_optics%ice_coeff_lw, & + & iwp_in_cloud, cloud%q_ice(jcol,jlev), & + & temperature, & + & od_lw_ice, scat_od_lw_ice, g_lw_ice) + ! Compute shortwave properties + call calc_ice_optics_baran2017(config%n_bands_sw, & + & config%cloud_optics%ice_coeff_gen, & + & config%cloud_optics%ice_coeff_sw, & + & iwp_in_cloud, cloud%q_ice(jcol,jlev), & + & temperature, & + & od_sw_ice, scat_od_sw_ice, g_sw_ice) + else if (config%i_ice_model == IIceModelFu) then +#endif + ! Compute longwave properties + call calc_ice_optics_fu_lw(config%n_bands_lw, & + & config%cloud_optics%ice_coeff_lw, & + & iwp_in_cloud, cloud%re_ice(jcol,jlev), & + & od_lw_ice, scat_od_lw_ice, g_lw_ice) + if (config%do_fu_lw_ice_optics_bug) then + ! Reproduce bug in old IFS scheme + scat_od_lw_ice = od_lw_ice - scat_od_lw_ice + end if + ! Compute shortwave properties + call calc_ice_optics_fu_sw(config%n_bands_sw, & + & config%cloud_optics%ice_coeff_sw, & + & iwp_in_cloud, cloud%re_ice(jcol,jlev), & + & od_sw_ice, scat_od_sw_ice, g_sw_ice) +#ifndef _OPENACC + else if (config%i_ice_model == IIceModelYi) then + ! Compute longwave properties + call calc_ice_optics_yi_lw(config%n_bands_lw, & + & config%cloud_optics%ice_coeff_lw, & + & iwp_in_cloud, cloud%re_ice(jcol,jlev), & + & od_lw_ice, scat_od_lw_ice, g_lw_ice) + ! Compute shortwave properties + call calc_ice_optics_yi_sw(config%n_bands_sw, & + & config%cloud_optics%ice_coeff_sw, & + & iwp_in_cloud, cloud%re_ice(jcol,jlev), & + & od_sw_ice, scat_od_sw_ice, g_sw_ice) + else + write(nulerr,*) '*** Error: Unknown ice model with code', & + & config%i_ice_model + call radiation_abort() + end if +#endif + + ! Delta-Eddington scaling in both longwave and shortwave + ! (assume that particles are larger than wavelength even + ! in longwave) + if (.not. config%do_sw_delta_scaling_with_gases) then + call delta_eddington_scat_od(od_sw_ice, scat_od_sw_ice, g_sw_ice) + end if + call delta_eddington_scat_od(od_lw_ice, scat_od_lw_ice, g_lw_ice) + + else + ! Ice not present: set properties to zero + od_lw_ice = 0.0_jprb + scat_od_lw_ice = 0.0_jprb + g_lw_ice = 0.0_jprb + + od_sw_ice = 0.0_jprb + scat_od_sw_ice = 0.0_jprb + g_sw_ice = 0.0_jprb + end if ! Ice present + + ! Combine liquid and ice + if (config%do_lw_cloud_scattering) then +! Added for DWD (2020) +!NEC$ shortloop + !$ACC LOOP SEQ + do jb = 1, config%n_bands_lw + od_lw_cloud(jb,jlev,jcol) = od_lw_liq(jb) + od_lw_ice(jb) + if (scat_od_lw_liq(jb)+scat_od_lw_ice(jb) > 0.0_jprb) then + g_lw_cloud(jb,jlev,jcol) = (g_lw_liq(jb) * scat_od_lw_liq(jb) & + & + g_lw_ice(jb) * scat_od_lw_ice(jb)) & + & / (scat_od_lw_liq(jb)+scat_od_lw_ice(jb)) + else + g_lw_cloud(jb,jlev,jcol) = 0.0_jprb + end if + ssa_lw_cloud(jb,jlev,jcol) = (scat_od_lw_liq(jb) + scat_od_lw_ice(jb)) & + & / (od_lw_liq(jb) + od_lw_ice(jb)) + end do + else + ! If longwave scattering is to be neglected then the + ! best approximation is to set the optical depth equal + ! to the absorption optical depth +! Added for DWD (2020) +!NEC$ shortloop + !$ACC LOOP SEQ + do jb = 1, config%n_bands_lw + od_lw_cloud(jb,jlev,jcol) = od_lw_liq(jb) - scat_od_lw_liq(jb) & + & + od_lw_ice(jb) - scat_od_lw_ice(jb) + end do + end if +! Added for DWD (2020) +!NEC$ shortloop + !$ACC LOOP SEQ + do jb = 1, config%n_bands_sw + od_sw_cloud(jb,jlev,jcol) = od_sw_liq(jb) + od_sw_ice(jb) + g_sw_cloud(jb,jlev,jcol) = (g_sw_liq(jb) * scat_od_sw_liq(jb) & + & + g_sw_ice(jb) * scat_od_sw_ice(jb)) & + & / (scat_od_sw_liq(jb) + scat_od_sw_ice(jb)) + ssa_sw_cloud(jb,jlev,jcol) & + & = (scat_od_sw_liq(jb) + scat_od_sw_ice(jb)) / (od_sw_liq(jb) + od_sw_ice(jb)) + end do + end if ! Cloud present + end do ! Loop over column + end do ! Loop over level + + !$ACC END PARALLEL + !$ACC WAIT + !$ACC END DATA ! PRESENT + + end associate + + if (lhook) call dr_hook('radiation_cloud_optics:cloud_optics',1,hook_handle) + + end subroutine cloud_optics + +end module radiation_cloud_optics Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_optics_data.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_optics_data.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloud_optics_data.F90 (revision 6016) @@ -0,0 +1,113 @@ +! radiation_cloud_optics_data.F90 - Type to store cloud optical properties +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +#include "ecrad_config.h" + +module radiation_cloud_optics_data + + use parkind1, only : jprb + + implicit none + public + + !--------------------------------------------------------------------- + ! This type holds the configuration information to compute + ! cloud optical properties + type cloud_optics_type + ! Band-specific coefficients are provided separately in the + ! shortwave and longwave, and are dimensioned (nband,ncoeff), + ! where ncoeff depends on the nature of the parameterization + real(jprb), allocatable, dimension(:,:) :: & + & liq_coeff_lw, liq_coeff_sw, & + & ice_coeff_lw, ice_coeff_sw + ! General coefficients are vectors of length ncoeffgen, which + ! depends on the nature of the parameterization; note that most + ! parameterizations use only band-specific coefficients + real(jprb), allocatable, dimension(:) :: & + & liq_coeff_gen, ice_coeff_gen + + contains + procedure :: setup => setup_cloud_optics + + end type cloud_optics_type + +contains + + !--------------------------------------------------------------------- + ! Setup cloud optics coefficients by reading them from a file + subroutine setup_cloud_optics(this, liq_file_name, ice_file_name, iverbose) + + use yomhook, only : lhook, dr_hook, jphook +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + + class(cloud_optics_type), intent(inout) :: this + character(len=*), intent(in) :: liq_file_name, ice_file_name + integer, intent(in), optional :: iverbose + + ! The NetCDF file containing the coefficients + type(netcdf_file) :: file + integer :: iverb + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloud_optics_data:setup',0,hook_handle) + + if (present(iverbose)) then + iverb = iverbose + else + iverb = 2 + end if + + ! Open the droplet scattering file and configure the way it is + ! read + call file%open(trim(liq_file_name), iverbose=iverb) + call file%transpose_matrices() + + ! Read the band-specific coefficients + call file%get('coeff_lw',this%liq_coeff_lw) + call file%get('coeff_sw',this%liq_coeff_sw) + + ! Read the general coefficients + if (file%exists('coeff_gen')) then + call file%get('coeff_gen',this%liq_coeff_gen) + end if + + ! Close droplet scattering file + call file%close() + + ! Open the ice scattering file and configure the way it is read + call file%open(trim(ice_file_name), iverbose=iverb) + call file%transpose_matrices() + + ! Read the band-specific coefficients + call file%get('coeff_lw',this%ice_coeff_lw) + call file%get('coeff_sw',this%ice_coeff_sw) + + ! Read the general coefficients + if (file%exists('coeff_gen')) then + call file%get('coeff_gen',this%ice_coeff_gen) + end if + + ! Close ice scattering file + call file%close() + + if (lhook) call dr_hook('radiation_cloud_optics_data:setup',1,hook_handle) + + end subroutine setup_cloud_optics + +end module radiation_cloud_optics_data Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloudless_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloudless_lw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloudless_lw.F90 (revision 6016) @@ -0,0 +1,179 @@ +! radiation_cloudless_lw.F90 - Longwave homogeneous cloudless solver +! +! (C) Copyright 2019- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_cloudless_lw + +public :: solver_cloudless_lw + +contains + + !--------------------------------------------------------------------- + ! Longwave homogeneous solver containing no clouds + subroutine solver_cloudless_lw(nlev,istartcol,iendcol, & + & config, od, ssa, g, planck_hl, emission, albedo, flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config, only : config_type + use radiation_flux, only : flux_type, indexed_sum_profile + use radiation_two_stream, only : calc_two_stream_gammas_lw, & + & calc_reflectance_transmittance_lw, & + & calc_no_scattering_transmittance_lw + use radiation_adding_ica_lw, only : adding_ica_lw, calc_fluxes_no_scattering_lw + use radiation_lw_derivatives, only : calc_lw_derivatives_ica + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, nlev, istartcol:iendcol) :: & + & od + real(jprb), intent(in), dimension(config%n_g_lw_if_scattering, nlev, istartcol:iendcol) :: & + & ssa, g + + ! Planck function at each half-level and the surface + real(jprb), intent(in), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: & + & planck_hl + + ! Emission (Planck*emissivity) and albedo (1-emissivity) at the + ! surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, istartcol:iendcol) & + & :: emission, albedo + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! Diffuse reflectance and transmittance for each layer in clear + ! and all skies + real(jprb), dimension(config%n_g_lw, nlev) :: reflectance, transmittance + + ! Emission by a layer into the upwelling or downwelling diffuse + ! streams, in clear and all skies + real(jprb), dimension(config%n_g_lw, nlev) :: source_up, source_dn + + ! Fluxes per g point + real(jprb), dimension(config%n_g_lw, nlev+1) :: flux_up, flux_dn + + ! Combined optical depth, single scattering albedo and asymmetry + ! factor + real(jprb), dimension(config%n_g_lw) :: ssa_total, g_total + + ! Two-stream coefficients + real(jprb), dimension(config%n_g_lw) :: gamma1, gamma2 + + ! Number of g points + integer :: ng + + ! Loop indices for level and column + integer :: jlev, jcol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloudless_lw:solver_cloudless_lw',0,hook_handle) + + ng = config%n_g_lw + + ! Loop through columns + do jcol = istartcol,iendcol + + ! Compute the reflectance and transmittance of all layers, + ! neglecting clouds + do jlev = 1,nlev + if (config%do_lw_aerosol_scattering) then + ! Scattering case: first compute clear-sky reflectance, + ! transmittance etc at each model level + ssa_total = ssa(:,jlev,jcol) + g_total = g(:,jlev,jcol) + call calc_two_stream_gammas_lw(ng, ssa_total, g_total, & + & gamma1, gamma2) + call calc_reflectance_transmittance_lw(ng, & + & od(:,jlev,jcol), gamma1, gamma2, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & + & reflectance(:,jlev), transmittance(:,jlev), & + & source_up(:,jlev), source_dn(:,jlev)) + else + ! Non-scattering case: use simpler functions for + ! transmission and emission + call calc_no_scattering_transmittance_lw(ng, od(:,jlev,jcol), & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & transmittance(:,jlev), source_up(:,jlev), source_dn(:,jlev)) + ! Ensure that clear-sky reflectance is zero + reflectance(:,jlev) = 0.0_jprb + end if + end do + + if (config%do_lw_aerosol_scattering) then + ! Then use adding method to compute fluxes + call adding_ica_lw(ng, nlev, & + & reflectance, transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up, flux_dn) + else + ! Simpler down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up, flux_dn) + + end if + + ! Sum over g-points to compute broadband fluxes + flux%lw_up(jcol,:) = sum(flux_up,1) + flux%lw_dn(jcol,:) = sum(flux_dn,1) + ! Store surface spectral downwelling fluxes + flux%lw_dn_surf_g(:,jcol) = flux_dn(:,nlev+1) + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum_profile(flux_up, config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,:)) + call indexed_sum_profile(flux_dn, config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_band(:,jcol,:)) + end if + + if (config%do_clear) then + ! Clear-sky calculations are equal to all-sky for this solver: + ! copy fluxes over + flux%lw_up_clear(jcol,:) = flux%lw_up(jcol,:) + flux%lw_dn_clear(jcol,:) = flux%lw_dn(jcol,:) + flux%lw_dn_surf_clear_g(:,jcol) = flux%lw_dn_surf_g(:,jcol) + if (config%do_save_spectral_flux) then + flux%lw_up_clear_band(:,jcol,:) = flux%lw_up_band(:,jcol,:) + flux%lw_dn_clear_band(:,jcol,:) = flux%lw_dn_band(:,jcol,:) + end if + end if + + ! Compute the longwave derivatives needed by Hogan and Bozzo + ! (2015) approximate radiation update scheme + if (config%do_lw_derivatives) then + call calc_lw_derivatives_ica(ng, nlev, jcol, transmittance, flux_up(:,nlev+1), & + & flux%lw_derivatives) + end if + + end do + + if (lhook) call dr_hook('radiation_cloudless_lw:solver_cloudless_lw',1,hook_handle) + + end subroutine solver_cloudless_lw + +end module radiation_cloudless_lw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloudless_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloudless_sw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_cloudless_sw.F90 (revision 6016) @@ -0,0 +1,254 @@ +! This file has been modified for the use in ICON + +! radiation_cloudless_sw.F90 - Shortwave homogeneous cloudless solver +! +! (C) Copyright 2019- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_cloudless_sw + +public :: solver_cloudless_sw + +contains + + ! Provides elemental function "delta_eddington" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Shortwave homogeneous solver containing no clouds + subroutine solver_cloudless_sw(nlev,istartcol,iendcol, & + & config, single_level, & + & od, ssa, g, albedo_direct, albedo_diffuse, incoming_sw, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_flux, only : flux_type, indexed_sum_profile, & + & add_indexed_sum_profile + use radiation_two_stream, only : calc_two_stream_gammas_sw, & + & calc_reflectance_transmittance_sw + use radiation_constants, only : Pi, GasConstantDryAir, & + & AccelDueToGravity + use radiation_adding_ica_sw, only : adding_ica_sw + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each shortwave g-point + real(jprb), intent(in), dimension(config%n_g_sw, nlev, istartcol:iendcol) :: & + & od, ssa, g + + ! Direct and diffuse surface albedos, and the incoming shortwave + ! flux into a plane perpendicular to the incoming radiation at + ! top-of-atmosphere in each of the shortwave g points + real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) :: & + & albedo_direct, albedo_diffuse, incoming_sw + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! Cosine of solar zenith angle + real(jprb) :: cos_sza + + ! Diffuse reflectance and transmittance for each layer + real(jprb), dimension(config%n_g_sw, nlev) :: reflectance, transmittance + + ! Fraction of direct beam scattered by a layer into the upwelling + ! or downwelling diffuse streams + real(jprb), dimension(config%n_g_sw, nlev) :: ref_dir, trans_dir_diff + + ! Transmittance for the direct beam in clear and all skies + real(jprb), dimension(config%n_g_sw, nlev) :: trans_dir_dir + + ! Fluxes per g point + real(jprb), dimension(config%n_g_sw, nlev+1) :: flux_up, flux_dn_diffuse, flux_dn_direct + + ! Combined optical depth, single scattering albedo and asymmetry + ! factor + real(jprb), dimension(config%n_g_sw) :: od_total, ssa_total, g_total + + ! Two-stream coefficients + real(jprb), dimension(config%n_g_sw) :: gamma1, gamma2, gamma3 + + ! Temporary working array + real(jprb), dimension(config%n_g_sw,nlev+1) :: tmp_work_albedo, tmp_work_source + real(jprb), dimension(config%n_g_sw,nlev) :: tmp_work_inv_denominator + + ! Number of g points + integer :: ng + + ! Loop indices for level and column + integer :: jlev, jcol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_cloudless_sw:solver_cloudless_sw',0,hook_handle) + + ng = config%n_g_sw + + ! Loop through columns + do jcol = istartcol,iendcol + ! Only perform calculation if sun above the horizon + if (single_level%cos_sza(jcol) > 0.0_jprb) then + + cos_sza = single_level%cos_sza(jcol) + + ! The following is the same as the clear-sky part of + ! solver_homogeneous_sw + if (.not. config%do_sw_delta_scaling_with_gases) then + ! Delta-Eddington scaling has already been performed to the + ! aerosol part of od, ssa and g + do jlev = 1,nlev + call calc_two_stream_gammas_sw(ng, cos_sza, & + & ssa(:,jlev,jcol), g(:,jlev,jcol), & + & gamma1, gamma2, gamma3) + call calc_reflectance_transmittance_sw(ng, & + & cos_sza, & + & od(:,jlev,jcol), ssa(:,jlev,jcol), & + & gamma1, gamma2, gamma3, & + & reflectance(:,jlev), transmittance(:,jlev), & + & ref_dir(:,jlev), trans_dir_diff(:,jlev), & + & trans_dir_dir(:,jlev) ) + end do + else + ! Apply delta-Eddington scaling to the aerosol-gas mixture + do jlev = 1,nlev + od_total = od(:,jlev,jcol) + ssa_total = ssa(:,jlev,jcol) + g_total = g(:,jlev,jcol) + call delta_eddington(od_total, ssa_total, g_total) + call calc_two_stream_gammas_sw(ng, & + & cos_sza, ssa_total, g_total, & + & gamma1, gamma2, gamma3) + call calc_reflectance_transmittance_sw(ng, & + & cos_sza, od_total, ssa_total, & + & gamma1, gamma2, gamma3, & + & reflectance(:,jlev), transmittance(:,jlev), & + & ref_dir(:,jlev), trans_dir_diff(:,jlev), & + & trans_dir_dir(:,jlev) ) + end do + end if + + ! Use adding method to compute fluxes + call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), & + & albedo_diffuse(:,jcol), albedo_direct(:,jcol), & + & cos_sza, reflectance, transmittance, ref_dir, trans_dir_diff, & + & trans_dir_dir, flux_up, flux_dn_diffuse, flux_dn_direct, & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + + ! Sum over g-points to compute and save clear-sky broadband + ! fluxes + flux%sw_up(jcol,:) = sum(flux_up,1) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = sum(flux_dn_direct,1) + flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) & + & + flux%sw_dn_direct(jcol,:) + else + flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) + sum(flux_dn_direct,1) + end if + ! Store spectral downwelling fluxes at surface + flux%sw_dn_diffuse_surf_g(:,jcol) = flux_dn_diffuse(:,nlev+1) + flux%sw_dn_direct_surf_g(:,jcol) = flux_dn_direct(:,nlev+1) + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum_profile(flux_up, config%i_spec_from_reordered_g_sw, & + & flux%sw_up_band(:,jcol,:)) + call indexed_sum_profile(flux_dn_direct, config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,:)) + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,:) & + & = flux%sw_dn_band(:,jcol,:) + end if + call add_indexed_sum_profile(flux_dn_diffuse, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,:)) + end if + + if (config%do_clear) then + ! Clear-sky calculations are equal to all-sky for this + ! solver: copy fluxes over + flux%sw_up_clear(jcol,:) = flux%sw_up(jcol,:) + flux%sw_dn_clear(jcol,:) = flux%sw_dn(jcol,:) + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,:) = flux%sw_dn_direct(jcol,:) + end if + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = flux%sw_dn_diffuse_surf_g(:,jcol) + flux%sw_dn_direct_surf_clear_g(:,jcol) = flux%sw_dn_direct_surf_g(:,jcol) + + if (config%do_save_spectral_flux) then + flux%sw_up_clear_band(:,jcol,:) = flux%sw_up_band(:,jcol,:) + flux%sw_dn_clear_band(:,jcol,:) = flux%sw_dn_band(:,jcol,:) + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,:) = flux%sw_dn_direct_band(:,jcol,:) + end if + end if + + end if ! do_clear + + else + ! Set fluxes to zero if sun is below the horizon + flux%sw_up(jcol,:) = 0.0_jprb + flux%sw_dn(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = 0.0_jprb + end if + flux%sw_dn_diffuse_surf_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_g(:,jcol) = 0.0_jprb + + if (config%do_clear) then + flux%sw_up_clear(jcol,:) = 0.0_jprb + flux%sw_dn_clear(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,:) = 0.0_jprb + end if + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_clear_g(:,jcol) = 0.0_jprb + end if + + if (config%do_save_spectral_flux) then + flux%sw_dn_band(:,jcol,:) = 0.0_jprb + flux%sw_up_band(:,jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,:) = 0.0_jprb + end if + if (config%do_clear) then + flux%sw_dn_clear_band(:,jcol,:) = 0.0_jprb + flux%sw_up_clear_band(:,jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,:) = 0.0_jprb + end if + end if + end if + + end if ! sun above horizon + end do + + if (lhook) call dr_hook('radiation_cloudless_sw:solver_cloudless_sw',1,hook_handle) + + end subroutine solver_cloudless_sw + +end module radiation_cloudless_sw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_config.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_config.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_config.F90 (revision 6016) @@ -0,0 +1,2145 @@ +! This file has been modified for the use in ICON + +! radiation_config.F90 - Derived type to configure the radiation scheme +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-07-22 R. Hogan Added Yi et al. ice optics model +! 2017-10-23 R. Hogan Renamed single-character variables +! 2018-03-15 R. Hogan Added logicals controlling surface spectral treatment +! 2018-08-29 R. Hogan Added monochromatic single-scattering albedo / asymmetry factor +! 2018-09-03 R. Hogan Added min_cloud_effective_size +! 2018-09-04 R. Hogan Added encroachment_scaling +! 2018-09-13 R. Hogan Added IEncroachmentFractal +! 2019-01-02 R. Hogan Added Cloudless solvers +! 2019-01-14 R. Hogan Added out_of_bounds_[1,2,3]d for checker routines +! 2019-01-18 R. Hogan Added albedo weighting +! 2019-02-03 R. Hogan Added ability to fix out-of-physical-bounds inputs +! 2019-02-10 R. Hogan Renamed "encroachment" to "entrapment" +! 2020-05-18 R. Hogan Moved out_of_bounds_* to radiation_check.F90 +! 2021-07-04 R. Hogan Numerous changes for ecCKD and general cloud/aerosol optics +! +! Note: The aim is for ecRad in the IFS to be as similar as possible +! to the offline version, so if you make any changes to this or any +! files in this directory, please inform Robin Hogan. +! + +#include "ecrad_config.h" + +module radiation_config + + use parkind1, only : jprb + + use radiation_cloud_optics_data, only : cloud_optics_type + use radiation_general_cloud_optics_data, only : general_cloud_optics_type + use radiation_aerosol_optics_data, only : aerosol_optics_type + use radiation_pdf_sampler, only : pdf_sampler_type + use radiation_cloud_cover, only : OverlapName, & + & IOverlapMaximumRandom, IOverlapExponentialRandom, IOverlapExponential + use radiation_ecckd, only : ckd_model_type + + implicit none + public + + ! Configuration codes: use C-style enumerators to avoid having to + ! remember the numbers + + ! Solvers: can be specified for longwave and shortwave + ! independently, except for "Homogeneous", which must be the same + ! for both + enum, bind(c) + enumerator ISolverCloudless, ISolverHomogeneous, ISolverMcICA, & + & ISolverSpartacus, ISolverTripleclouds, ISolverMcICAACC + end enum + character(len=*), parameter :: SolverName(0:5) = (/ 'Cloudless ', & + & 'Homogeneous ', & + & 'McICA ', & + & 'SPARTACUS ', & + & 'Tripleclouds', & + & 'McICA ACC ' /) + + ! SPARTACUS shortwave solver can treat the reflection of radiation + ! back up into different regions in various ways + enum, bind(c) + enumerator & + & IEntrapmentZero, & ! No entrapment, as Tripleclouds + & IEntrapmentEdgeOnly, & ! Only radiation passed through cloud edge is horizontally homogenized + & IEntrapmentExplicit, & ! Estimate horiz migration dist, account for fractal clouds + & IEntrapmentExplicitNonFractal, & ! As above but ignore fractal nature of clouds + & IEntrapmentMaximum ! Complete horizontal homogenization within regions (old SPARTACUS assumption) + end enum + + ! Names available in the radiation namelist for variable + ! sw_entrapment_name + character(len=*), parameter :: EntrapmentName(0:4) = [ 'Zero ', & + & 'Edge-only ', & + & 'Explicit ', & + & 'Non-fractal', & + & 'Maximum ' ] + ! For backwards compatibility, the radiation namelist also supports + ! the equivalent variable sw_encroachment_name with the following + ! names + character(len=*), parameter :: EncroachmentName(0:4) = [ 'Zero ', & + & 'Minimum ', & + & 'Fractal ', & + & 'Computed', & + & 'Maximum ' ] + + ! Two-stream models + ! This is not configurable at run-time + + ! Gas models + enum, bind(c) + enumerator IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD + end enum + character(len=*), parameter :: GasModelName(0:2) = (/ 'Monochromatic', & + & 'RRTMG-IFS ', & + & 'ECCKD '/) + + ! Liquid cloud optics models for use with RRTMG gas optics + enum, bind(c) + enumerator ILiquidModelMonochromatic, & + & ILiquidModelSOCRATES, ILiquidModelSlingo + end enum + character(len=*), parameter :: LiquidModelName(0:2) = (/ 'Monochromatic', & + & 'SOCRATES ', & + & 'Slingo ' /) + + ! Ice optics models for use with RRTMG gas optics. Note that of the + ! "Baran" parameterizations, only Baran2016 is published (Baran, + ! J. Climate, 2016) - the others are experimental and not + ! recommended. + enum, bind(c) + enumerator IIceModelMonochromatic, IIceModelFu, & + & IIceModelBaran, IIceModelBaran2016, IIceModelBaran2017, & + & IIceModelYi + end enum + character(len=*), parameter :: IceModelName(0:5) = (/ 'Monochromatic ', & + & 'Fu-IFS ', & + & 'Baran-EXPERIMENTAL ', & + & 'Baran2016 ', & + & 'Baran2017-EXPERIMENTAL', & + & 'Yi ' /) + + ! Cloud PDF distribution shapes + enum, bind(c) + enumerator IPdfShapeLognormal, IPdfShapeGamma + end enum + character(len=*), parameter :: PdfShapeName(0:1) = (/ 'Lognormal', & + & 'Gamma ' /) + + ! Maximum number of different aerosol types that can be provided + integer, parameter :: NMaxAerosolTypes = 256 + + ! Maximum number of different cloud types that can be provided + integer, parameter :: NMaxCloudTypes = 12 + + ! Maximum number of shortwave albedo and longwave emissivity + ! intervals + integer, parameter :: NMaxAlbedoIntervals = 256 + + ! Length of string buffer for printing config information + integer, parameter :: NPrintStringLen = 60 + + !--------------------------------------------------------------------- + ! Derived type containing all the configuration information needed + ! to run the radiation scheme. The intention is that this is fixed + ! for a given model run. The parameters are to list first those + ! quantities that can be set directly by the user, for example using a + ! namelist, and second those quantities that are computed afterwards + ! from the user-supplied numbers, especially the details of the gas + ! optics model. + type config_type + ! USER-CONFIGURABLE PARAMETERS + + ! Scale the solar spectrum per band (or g-point if + ! do_cloud_aerosol_per_sw_g_point=true) via vector + ! single_level%spectral_solar_scaling + logical :: use_spectral_solar_scaling = .false. + + ! Modify the solar spectrum per g-point to account for the current + ! phase of the solar cycle, via scalar + ! single_level%spectral_solar_cycle_multiplier + logical :: use_spectral_solar_cycle = .false. + + ! Directory in which gas, cloud and aerosol data files are to be + ! found + character(len=511) :: directory_name = '.' + + ! If this is true then support arbitrary hydrometeor types (not + ! just ice and liquid) and arbitrary spectral discretization (not + ! just RRTMG). It is required that this is true if the ecCKD gas + ! optics model is selected. General cloud optics has only been + ! available from ecRad version 1.5. + logical :: use_general_cloud_optics = .true. + + ! If this is true then support aerosol properties at an arbitrary + ! spectral discretization (not just RRTMG). It is required that + ! this is true if the ecCKD gas optics model is selected. + logical :: use_general_aerosol_optics = .true. + + ! Cloud is deemed to be present in a layer if cloud fraction + ! exceeds this value + real(jprb) :: cloud_fraction_threshold = 1.0e-6_jprb + ! ...and total cloud water mixing ratio exceeds this value + real(jprb) :: cloud_mixing_ratio_threshold = 1.0e-9_jprb + + ! Overlap scheme + integer :: i_overlap_scheme = IOverlapExponentialRandom + + ! Use the Shonk et al. (2010) "beta" overlap parameter, rather + ! than the "alpha" overlap parameter of Hogan and Illingworth + ! (2000)? + logical :: use_beta_overlap = .false. + + ! Use a more vectorizable McICA cloud generator, at the expense of + ! more random numbers being generated? This is the default on NEC + ! SX. +#ifdef DWD_VECTOR_OPTIMIZATIONS + logical :: use_vectorizable_generator = .true. +#else + logical :: use_vectorizable_generator = .false. +#endif + + ! Shape of sub-grid cloud water PDF + integer :: i_cloud_pdf_shape = IPdfShapeGamma + + ! The ratio of the overlap decorrelation length for cloud + ! inhomogeneities to the overlap decorrelation length for cloud + ! boundaries. Observations suggest this has a value of 0.5 + ! (e.g. from the decorrelation lengths of Hogan and Illingworth + ! 2003 and Hogan and Illingworth 2000). + real(jprb) :: cloud_inhom_decorr_scaling = 0.5_jprb + + ! Factor controlling how much of the cloud edge length interfaces + ! directly between the clear-sky region (region a) and the + ! optically thick cloudy region (region c). If Lxy is the length + ! of the interfaces between regions x and y, and Lab and Lbc have + ! been computed already, then + ! Lac=clear_to_thick_fraction*min(Lab,Lbc). + real(jprb) :: clear_to_thick_fraction = 0.0_jprb + + ! Factor allowing lateral transport when the sun is close to + ! overhead; consider atand(overhead_sun_factor) to be the number + ! of degrees that the sun angle is perturbed from zenith for the + ! purposes of computing lateral transport. A value of up to 0.1 + ! seems to be necessary to account for the fact that some forward + ! scattered radiation is treated as unscattered by delta-Eddington + ! scaling; therefore it ought to have the chance to escape. + real(jprb) :: overhead_sun_factor = 0.0_jprb + + ! Minimum gas optical depth in a single layer at any wavelength, + ! for stability + real(jprb) :: min_gas_od_lw = 1.0e-15_jprb + real(jprb) :: min_gas_od_sw = 0.0_jprb + + ! Maximum gas optical depth in a layer before that g-point will + ! not be considered for 3D treatment: a limit is required to avoid + ! expensive computation of matrix exponentials on matrices with + ! large elements + real(jprb) :: max_gas_od_3d = 8.0_jprb + + ! Maximum total optical depth of a cloudy region for stability: + ! optical depth will be capped at this value in the SPARTACUS + ! solvers + real(jprb) :: max_cloud_od = 16.0_jprb + + ! How much longwave scattering is included? + logical :: do_lw_cloud_scattering = .true. + logical :: do_lw_aerosol_scattering = .true. + + ! Number of regions used to describe clouds and clear skies. A + ! value of 2 means one clear and one cloudy region, so clouds are + ! horizontally homogeneous, while a value of 3 means two cloudy + ! regions with different optical depth, thereby representing + ! inhomogeneity via the Shonk & Hogan (2008) "Tripleclouds" + ! method. + integer :: nregions = 3 + + ! Code specifying the solver to be used: use the enumerations + ! defined above + integer :: i_solver_sw = ISolverMcICA + integer :: i_solver_lw = ISolverMcICA + + ! Do shortwave delta-Eddington scaling on the cloud-aerosol-gas + ! mixture (as in the original IFS scheme), rather than the more + ! correct approach of separately scaling the cloud and aerosol + ! scattering properties before merging with gases. Note that + ! .true. is not compatible with the SPARTACUS solver. + logical :: do_sw_delta_scaling_with_gases = .false. + + ! Codes describing the gas model + integer :: i_gas_model_sw = IGasModelIFSRRTMG + integer :: i_gas_model_lw = IGasModelIFSRRTMG + + ! Optics if i_gas_model==IGasModelMonochromatic. + ! The wavelength to use for the Planck function in metres. If this + ! is positive then the output longwave fluxes will be in units of + ! W m-2 um-1. If this is zero or negative (the default) then + ! sigma*T^4 will be used and the output longwave fluxes will be in + ! W m-2. + real(jprb) :: mono_lw_wavelength = -1.0_jprb + ! Total zenith optical depth of the atmosphere in the longwave and + ! shortwave, distributed vertically according to the pressure. + ! Default is zero. + real(jprb) :: mono_lw_total_od = 0.0_jprb + real(jprb) :: mono_sw_total_od = 0.0_jprb + ! Single-scattering albedo and asymmetry factor: values typical + ! for liquid clouds with effective radius of 10 microns, at (SW) + ! 0.55 micron wavelength and (LW) 10.7 microns wavelength + real(jprb) :: mono_sw_single_scattering_albedo = 0.999999_jprb + real(jprb) :: mono_sw_asymmetry_factor = 0.86_jprb + real(jprb) :: mono_lw_single_scattering_albedo = 0.538_jprb + real(jprb) :: mono_lw_asymmetry_factor = 0.925_jprb + + ! Codes describing particle scattering models + integer :: i_liq_model = ILiquidModelSOCRATES + integer :: i_ice_model = IIceModelBaran + + ! The mapping from albedo/emissivity intervals to SW/LW bands can + ! either be done by finding the interval containing the central + ! wavenumber of the band (nearest neighbour), or by a weighting + ! according to the spectral overlap of each interval with each + ! band + logical :: do_nearest_spectral_sw_albedo = .false. + logical :: do_nearest_spectral_lw_emiss = .false. + + ! User-defined monotonically increasing wavelength bounds (m) + ! between input surface albedo/emissivity intervals. Implicitly + ! the first interval starts at zero and the last ends at + ! infinity. These must be set with define_sw_albedo_intervals and + ! define_lw_emiss_intervals. + real(jprb) :: sw_albedo_wavelength_bound(NMaxAlbedoIntervals-1) = -1.0_jprb + real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1) = -1.0_jprb + + ! The index to the surface albedo/emissivity intervals for each of + ! the wavelength bounds specified in sw_albedo_wavelength_bound + ! and lw_emiss_wavelength_bound + integer :: i_sw_albedo_index(NMaxAlbedoIntervals) = 0 + integer :: i_lw_emiss_index (NMaxAlbedoIntervals) = 0 + + ! Do we compute longwave and/or shortwave radiation? + logical :: do_lw = .true. + logical :: do_sw = .true. + + ! Do we compute clear-sky fluxes and/or solar direct fluxes? + logical :: do_clear = .true. + logical :: do_sw_direct = .true. + + ! Do we include 3D effects? + logical :: do_3d_effects = .true. + + character(len=511) :: cloud_type_name(NMaxCloudTypes) = ["","","","","","","","","","","",""] +! & +! & = ["mie_droplet ", & +! & "baum-general-habit-mixture_ice"] + + ! Spectral averaging method to use with generalized cloud optics; + ! see Edwards & Slingo (1996) for definition. Experimentation + ! with ecRad suggests that "thick" averaging is more accurate for + ! both liquid and ice clouds. + logical :: use_thick_cloud_spectral_averaging(NMaxCloudTypes) & + & = [.true.,.true.,.true.,.true.,.true.,.true., & + & .true.,.true.,.true.,.true.,.true.,.true.] + + ! To what extent do we include "entrapment" effects in the + ! SPARTACUS solver? This essentially means that in a situation + ! like this + ! + ! 000111 + ! 222222 + ! + ! Radiation downwelling from region 1 may be reflected back into + ! region 0 due to some degree of homogenization of the radiation + ! in region 2. Hogan and Shonk (2013) referred to this as + ! "anomalous horizontal transport" for a 1D model, although for 3D + ! calculations it is desirable to include at least some of it. The + ! options are described by the IEntrapment* parameters above. + integer :: i_3d_sw_entrapment = IEntrapmentExplicit + + ! In the longwave, the equivalent process it either "on" (like + ! maximum entrapment) or "off" (like zero entrapment): + logical :: do_3d_lw_multilayer_effects = .false. + + ! Do we account for the effective emissivity of the side of + ! clouds? + logical :: do_lw_side_emissivity = .true. + + ! The 3D transfer rate "X" is such that if transport out of a + ! region was the only process occurring then by the base of a + ! layer only exp(-X) of the original flux would remain in that + ! region. The transfer rate computed geometrically can be very + ! high for the clear-sky regions in layers with high cloud + ! fraction. For stability reasons it is necessary to provide a + ! maximum possible 3D transfer rate. + real(jprb) :: max_3d_transfer_rate = 10.0_jprb + + ! It has also sometimes been found necessary to set a minimum + ! cloud effective size for stability (metres) + real(jprb) :: min_cloud_effective_size = 100.0_jprb + + ! Given a horizontal migration distance, there is still + ! uncertainty about how much entrapment occurs associated with how + ! one assumes cloud boundaries line up in adjacent layers. This + ! factor can be varied between 0.0 (the boundaries line up to the + ! greatest extent possible given the overlap parameter) and 1.0 + ! (the boundaries line up to the minimum extent possible). In the + ! Hogan et al. entrapment paper it is referred to as the overhang + ! factor zeta, and a value of 0 matches the Monte Carlo + ! calculations best. + real(jprb) :: overhang_factor = 0.0_jprb + + ! By default, the Meador & Weaver (1980) expressions are used + ! instead of the matrix exponential whenever 3D effects can be + ! neglected (e.g. cloud-free layers or clouds with infinitely + ! large effective cloud size), but setting the following to true + ! uses the matrix exponential everywhere, enabling the two + ! methods to be compared. Note that Meador & Weaver will still be + ! used for very optically thick g points where the matrix + ! exponential can produce incorrect results. + logical :: use_expm_everywhere = .false. + + ! Aerosol descriptors: aerosol_type_mapping must be of length + ! n_aerosol_types, and contains 0 if that type is to be ignored, + ! positive numbers to map on to the indices of hydrophobic + ! aerosols in the aerosol optics configuration file, and negative + ! numbers to map on to (the negative of) the indices of + ! hydrophilic aerosols in the configuration file. + logical :: use_aerosols = .false. + integer :: n_aerosol_types = 0 + integer :: i_aerosol_type_map(NMaxAerosolTypes) + + ! Save the gas and cloud optical properties for each g point in + ! "radiative_properties.nc"? + logical :: do_save_radiative_properties = .false. + + ! Save the flux profiles in each band? + logical :: do_save_spectral_flux = .false. + + ! Save the surface downwelling shortwave fluxes in each band? + logical :: do_surface_sw_spectral_flux = .true. + + ! Save the TOA fluxes in each band? + logical :: do_toa_spectral_flux = .false. + + ! Compute the longwave derivatives needed to apply the approximate + ! radiation updates of Hogan and Bozzo (2015) + logical :: do_lw_derivatives = .false. + + ! Save the flux profiles in each g-point (overrides + ! do_save_spectral_flux if TRUE)? + logical :: do_save_gpoint_flux = .false. + + ! In the IFS environment, setting up RRTM has already been done + ! so not needed to do it again + logical :: do_setup_ifsrrtm = .true. + + ! In the IFS environment the old scheme has a bug in the Fu + ! longwave ice optics whereby the single scattering albedo is one + ! minus what it should be. Unfortunately fixing it makes + ! forecasts worse. Setting the following to true reproduces the + ! bug. + logical :: do_fu_lw_ice_optics_bug = .false. + + ! Control verbosity: 0=none (no output to standard output; write + ! to standard error only if an error occurs), 1=warning, 2=info, + ! 3=progress, 4=detailed, 5=debug. Separate settings for the + ! setup of the scheme and the execution of it. + integer :: iverbosesetup = 2 + integer :: iverbose = 1 + + ! Are we doing radiative transfer in complex surface canopies + ! (streets/vegetation), in which case tailored downward fluxes are + ! needed at the top of the canopy? + logical :: do_canopy_fluxes_sw = .false. + logical :: do_canopy_fluxes_lw = .false. + ! If so, do we use the full spectrum as in the atmosphere, or just + ! the reduced spectrum in which the shortwave albedo and longwave + ! emissivity are provided? + logical :: use_canopy_full_spectrum_sw = .false. + logical :: use_canopy_full_spectrum_lw = .false. + ! Do we treat gas radiative transfer in streets/vegetation? + logical :: do_canopy_gases_sw = .false. + logical :: do_canopy_gases_lw = .false. + + ! Optics file names for overriding the ones generated from the + ! other options. If these remain empty then the generated names + ! will be used (see the "consolidate_config" routine below). If + ! the user assigns one of these and it starts with a '/' character + ! then that will be used instead. If the user assigns one and it + ! doesn't start with a '/' character then it will be prepended by + ! the contents of directory_name. + character(len=511) :: ice_optics_override_file_name = '' + character(len=511) :: liq_optics_override_file_name = '' + character(len=511) :: aerosol_optics_override_file_name = '' + character(len=511) :: gas_optics_sw_override_file_name = '' + character(len=511) :: gas_optics_lw_override_file_name = '' + + ! Optionally override the default file describing variations in + ! the spectral solar irradiance associated with the solar cycle + character(len=511) :: ssi_override_file_name = '' + + ! Do we use the solar spectral irradiance file to update the solar + ! irradiance in each g point? Only possible if + ! use_spectral_solar_cycle==true. + logical :: use_updated_solar_spectrum = .false. + + ! Optionally override the look-up table file for the cloud-water + ! PDF used by the McICA solver + character(len=511) :: cloud_pdf_override_file_name = '' + + ! Do we compute cloud, aerosol and surface optical properties per + ! g point? Not available with RRTMG gas optics model. + logical :: do_cloud_aerosol_per_sw_g_point = .true. + logical :: do_cloud_aerosol_per_lw_g_point = .true. + + ! Do we weight the mapping from surface emissivity/albedo to + ! g-point/band weighting by a reference Planck function (more + ! accurate) or weighting each wavenumber equally (less accurate + ! but consistent with IFS Cycle 48r1 and earlier)? + logical :: do_weighted_surface_mapping = .true. + + ! COMPUTED PARAMETERS + + ! Users of this library should not edit these parameters directly; + ! they are set by the "consolidate" routine + + ! Has "consolidate" been called? + logical :: is_consolidated = .false. + + ! Fraction of each g point in each wavenumber interval, + ! dimensioned (n_wav_frac_[l|s]w, n_g_[l|s]w) + real(jprb), allocatable, dimension(:,:) :: g_frac_sw, g_frac_lw + + ! If the nearest surface albedo/emissivity interval is to be used + ! for each SW/LW band then the following arrays will be allocated + ! to the length of the number of bands and contain the index to + ! the relevant interval + integer, allocatable, dimension(:) :: i_albedo_from_band_sw + integer, allocatable, dimension(:) :: i_emiss_from_band_lw + + ! ...alternatively, this matrix dimensioned + ! (n_albedo_intervals,n_bands_sw) providing the weights needed for + ! computing the albedo in each ecRad band from the albedo in each + ! native albedo band - see radiation_single_level.F90 + real(jprb), allocatable, dimension(:,:) :: sw_albedo_weights + ! ...and similarly in the longwave, dimensioned + ! (n_emiss_intervals,n_bands_lw) + real(jprb), allocatable, dimension(:,:) :: lw_emiss_weights + + ! Arrays of length the number of g-points that convert from + ! g-point to the band index + integer, allocatable, dimension(:) :: i_band_from_g_lw + integer, allocatable, dimension(:) :: i_band_from_g_sw + + ! We allow for the possibility for g-points to be ordered in terms + ! of likely absorption (weakest to strongest) across the shortwave + ! or longwave spectrum, in order that in SPARTACUS we select only + ! the first n g-points that will not have too large an absorption, + ! and therefore matrix exponentials that are both finite and not + ! too expensive to compute. The following two arrays map the + ! reordered g-points to the original ones. + integer, allocatable, dimension(:) :: i_g_from_reordered_g_lw + integer, allocatable, dimension(:) :: i_g_from_reordered_g_sw + + ! The following map the reordered g-points to the bands + integer, allocatable, dimension(:) :: i_band_from_reordered_g_lw + integer, allocatable, dimension(:) :: i_band_from_reordered_g_sw + + ! The following map the reordered g-points to the spectral + ! information being saved: if do_save_gpoint_flux==TRUE then this + ! will map on to the original g points, but if only + ! do_save_spectral_flux==TRUE then this will map on to the bands + integer, pointer, dimension(:) :: i_spec_from_reordered_g_lw + integer, pointer, dimension(:) :: i_spec_from_reordered_g_sw + + ! Number of spectral intervals used for the canopy radiative + ! transfer calculation; they are either equal to + ! n_albedo_intervals/n_emiss_intervals or n_g_sw/n_g_lw + integer :: n_canopy_bands_sw = 1 + integer :: n_canopy_bands_lw = 1 + + ! Data structures containing gas optics description in the case of + ! ecCKD + type(ckd_model_type) :: gas_optics_sw, gas_optics_lw + + ! Data structure containing cloud scattering data + type(cloud_optics_type) :: cloud_optics + + ! Number of general cloud types, default liquid and ice + integer :: n_cloud_types = 2 + + ! List of data structures (one per cloud type) containing cloud + ! scattering data + type(general_cloud_optics_type), allocatable :: cloud_optics_sw(:) + type(general_cloud_optics_type), allocatable :: cloud_optics_lw(:) + + ! Data structure containing aerosol scattering data + type(aerosol_optics_type) :: aerosol_optics + + ! Object for sampling from a gamma or lognormal distribution + type(pdf_sampler_type) :: pdf_sampler + + ! Optics file names + character(len=511) :: ice_optics_file_name, & + & liq_optics_file_name, & + & aerosol_optics_file_name, & + & gas_optics_sw_file_name, & + & gas_optics_lw_file_name + + ! Solar spectral irradiance file name + character(len=511) :: ssi_file_name + + ! McICA PDF look-up table file name + character(len=511) :: cloud_pdf_file_name + + ! Number of gpoints and bands in the shortwave and longwave - set + ! to zero as will be set properly later + integer :: n_g_sw = 0, n_g_lw = 0 + integer :: n_bands_sw = 0, n_bands_lw = 0 + + ! Number of spectral points to save (equal either to the number of + ! g points or the number of bands + integer :: n_spec_sw = 0, n_spec_lw = 0 + + ! Number of wavenumber intervals used to describe the mapping from + ! g-points to wavenumber space + integer :: n_wav_frac_sw = 0, n_wav_frac_lw = 0 + + ! Dimensions to store variables that are only needed if longwave + ! scattering is included. "n_g_lw_if_scattering" is equal to + ! "n_g_lw" if aerosols are allowed to scatter in the longwave, + ! and zero otherwise. "n_bands_lw_if_scattering" is equal to + ! "n_bands_lw" if clouds are allowed to scatter in the longwave, + ! and zero otherwise. + integer :: n_g_lw_if_scattering = 0, n_bands_lw_if_scattering = 0 + + ! Treat clouds as horizontally homogeneous within the gribox + logical :: is_homogeneous = .false. + + ! If the solvers are both "Cloudless" then we don't need to do any + ! cloud processing + logical :: do_clouds = .true. + + contains + procedure :: read => read_config_from_namelist + procedure :: consolidate => consolidate_config + procedure :: set => set_config + procedure :: print => print_config + procedure :: get_sw_weights + procedure :: get_sw_mapping + procedure :: define_sw_albedo_intervals + procedure :: define_lw_emiss_intervals + procedure :: set_aerosol_wavelength_mono + procedure :: consolidate_sw_albedo_intervals + procedure :: consolidate_lw_emiss_intervals + + end type config_type + +! procedure, private :: print_logical, print_real, print_int + +contains + + + !--------------------------------------------------------------------- + ! This subroutine reads configuration data from a namelist file, and + ! anything that is not in the namelists will be set to default + ! values. If optional output argument "is_success" is present, then + ! on error (e.g. missing file) it will be set to .false.; if this + ! argument is missing then on error the program will be aborted. You + ! may either specify the file_name or the unit of an open file to + ! read, but not both. + subroutine read_config_from_namelist(this, file_name, unit, is_success) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulout, nulerr, nulrad, radiation_abort + + class(config_type), intent(inout) :: this + character(*), intent(in), optional :: file_name + integer, intent(in), optional :: unit + logical, intent(out), optional :: is_success + + integer :: iosopen, iosread ! Status after calling open and read + + ! The following variables are read from the namelists and map + ! directly onto members of the config_type derived type + + ! To be read from the radiation_config namelist + logical :: do_sw, do_lw, do_clear, do_sw_direct + logical :: do_3d_effects, use_expm_everywhere, use_aerosols + logical :: use_general_cloud_optics, use_general_aerosol_optics + logical :: do_lw_side_emissivity + logical :: do_3d_lw_multilayer_effects, do_fu_lw_ice_optics_bug + logical :: do_lw_aerosol_scattering, do_lw_cloud_scattering + logical :: do_save_radiative_properties, do_save_spectral_flux + logical :: do_save_gpoint_flux, do_surface_sw_spectral_flux, do_toa_spectral_flux + logical :: use_beta_overlap, do_lw_derivatives, use_vectorizable_generator + logical :: do_sw_delta_scaling_with_gases + logical :: do_canopy_fluxes_sw, do_canopy_fluxes_lw + logical :: use_canopy_full_spectrum_sw, use_canopy_full_spectrum_lw + logical :: do_canopy_gases_sw, do_canopy_gases_lw + logical :: do_cloud_aerosol_per_sw_g_point, do_cloud_aerosol_per_lw_g_point + logical :: do_weighted_surface_mapping + logical :: use_spectral_solar_scaling, use_spectral_solar_cycle, use_updated_solar_spectrum + integer :: n_regions, iverbose, iverbosesetup, n_aerosol_types + real(jprb):: mono_lw_wavelength, mono_lw_total_od, mono_sw_total_od + real(jprb):: mono_lw_single_scattering_albedo, mono_sw_single_scattering_albedo + real(jprb):: mono_lw_asymmetry_factor, mono_sw_asymmetry_factor + real(jprb):: cloud_inhom_decorr_scaling, cloud_fraction_threshold + real(jprb):: clear_to_thick_fraction, max_gas_od_3d, max_cloud_od + real(jprb):: cloud_mixing_ratio_threshold, overhead_sun_factor + real(jprb):: max_3d_transfer_rate, min_cloud_effective_size + real(jprb):: overhang_factor, encroachment_scaling + character(511) :: directory_name, aerosol_optics_override_file_name + character(511) :: liq_optics_override_file_name, ice_optics_override_file_name + character(511) :: cloud_pdf_override_file_name + character(511) :: gas_optics_sw_override_file_name, gas_optics_lw_override_file_name + character(511) :: ssi_override_file_name + character(63) :: liquid_model_name, ice_model_name, gas_model_name + character(63) :: sw_gas_model_name, lw_gas_model_name + character(63) :: sw_solver_name, lw_solver_name, overlap_scheme_name + character(63) :: sw_entrapment_name, sw_encroachment_name, cloud_pdf_shape_name + character(len=511) :: cloud_type_name(NMaxCloudTypes) = ["","","","","","","","","","","",""] + logical :: use_thick_cloud_spectral_averaging(NMaxCloudTypes) & + & = [.false.,.false.,.false.,.false.,.false.,.false., & + & .false.,.false.,.false.,.false.,.false.,.false.] + integer :: i_aerosol_type_map(NMaxAerosolTypes) ! More than 256 is an error + + logical :: do_nearest_spectral_sw_albedo + logical :: do_nearest_spectral_lw_emiss + real(jprb) :: sw_albedo_wavelength_bound(NMaxAlbedoIntervals-1) + real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1) + integer :: i_sw_albedo_index(NMaxAlbedoIntervals) + integer :: i_lw_emiss_index (NMaxAlbedoIntervals) + integer :: i_gas_model + + integer :: iunit ! Unit number of namelist file + + namelist /radiation/ do_sw, do_lw, do_sw_direct, & + & do_3d_effects, do_lw_side_emissivity, do_clear, & + & do_save_radiative_properties, sw_entrapment_name, sw_encroachment_name, & + & do_3d_lw_multilayer_effects, do_fu_lw_ice_optics_bug, & + & do_save_spectral_flux, do_save_gpoint_flux, & + & do_surface_sw_spectral_flux, do_lw_derivatives, do_toa_spectral_flux, & + & do_lw_aerosol_scattering, do_lw_cloud_scattering, & + & n_regions, directory_name, gas_model_name, sw_gas_model_name, lw_gas_model_name, & + & ice_optics_override_file_name, liq_optics_override_file_name, & + & aerosol_optics_override_file_name, cloud_pdf_override_file_name, & + & gas_optics_sw_override_file_name, gas_optics_lw_override_file_name, & + & ssi_override_file_name, & + & liquid_model_name, ice_model_name, max_3d_transfer_rate, & + & min_cloud_effective_size, overhang_factor, encroachment_scaling, & + & use_canopy_full_spectrum_sw, use_canopy_full_spectrum_lw, & + & do_canopy_fluxes_sw, do_canopy_fluxes_lw, & + & do_canopy_gases_sw, do_canopy_gases_lw, & + & use_general_cloud_optics, use_general_aerosol_optics, & + & do_sw_delta_scaling_with_gases, overlap_scheme_name, & + & sw_solver_name, lw_solver_name, use_beta_overlap, use_vectorizable_generator, & + & use_expm_everywhere, iverbose, iverbosesetup, & + & cloud_inhom_decorr_scaling, cloud_fraction_threshold, & + & clear_to_thick_fraction, max_gas_od_3d, max_cloud_od, & + & cloud_mixing_ratio_threshold, overhead_sun_factor, & + & n_aerosol_types, i_aerosol_type_map, use_aerosols, & + & mono_lw_wavelength, mono_lw_total_od, mono_sw_total_od, & + & mono_lw_single_scattering_albedo, mono_sw_single_scattering_albedo, & + & mono_lw_asymmetry_factor, mono_sw_asymmetry_factor, & + & cloud_pdf_shape_name, cloud_type_name, use_thick_cloud_spectral_averaging, & + & do_nearest_spectral_sw_albedo, do_nearest_spectral_lw_emiss, & + & sw_albedo_wavelength_bound, lw_emiss_wavelength_bound, & + & i_sw_albedo_index, i_lw_emiss_index, & + & do_cloud_aerosol_per_lw_g_point, & + & do_cloud_aerosol_per_sw_g_point, do_weighted_surface_mapping, & + & use_spectral_solar_scaling, use_spectral_solar_cycle, use_updated_solar_spectrum + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_config:read',0,hook_handle) + + ! Copy default values from the original structure + do_sw = this%do_sw + do_lw = this%do_lw + do_sw_direct = this%do_sw_direct + do_3d_effects = this%do_3d_effects + do_3d_lw_multilayer_effects = this%do_3d_lw_multilayer_effects + do_lw_side_emissivity = this%do_lw_side_emissivity + do_clear = this%do_clear + do_lw_aerosol_scattering = this%do_lw_aerosol_scattering + do_lw_cloud_scattering = this%do_lw_cloud_scattering + do_sw_delta_scaling_with_gases = this%do_sw_delta_scaling_with_gases + do_fu_lw_ice_optics_bug = this%do_fu_lw_ice_optics_bug + do_canopy_fluxes_sw = this%do_canopy_fluxes_sw + do_canopy_fluxes_lw = this%do_canopy_fluxes_lw + use_canopy_full_spectrum_sw = this%use_canopy_full_spectrum_sw + use_canopy_full_spectrum_lw = this%use_canopy_full_spectrum_lw + do_canopy_gases_sw = this%do_canopy_gases_sw + do_canopy_gases_lw = this%do_canopy_gases_lw + n_regions = this%nregions + directory_name = this%directory_name + cloud_pdf_override_file_name = this%cloud_pdf_override_file_name + liq_optics_override_file_name = this%liq_optics_override_file_name + ice_optics_override_file_name = this%ice_optics_override_file_name + aerosol_optics_override_file_name = this%aerosol_optics_override_file_name + gas_optics_sw_override_file_name = this%gas_optics_sw_override_file_name + gas_optics_lw_override_file_name = this%gas_optics_lw_override_file_name + ssi_override_file_name = this%ssi_override_file_name + use_expm_everywhere = this%use_expm_everywhere + use_aerosols = this%use_aerosols + do_save_radiative_properties = this%do_save_radiative_properties + do_save_spectral_flux = this%do_save_spectral_flux + do_save_gpoint_flux = this%do_save_gpoint_flux + do_lw_derivatives = this%do_lw_derivatives + do_surface_sw_spectral_flux = this%do_surface_sw_spectral_flux + do_toa_spectral_flux = this%do_toa_spectral_flux + iverbose = this%iverbose + iverbosesetup = this%iverbosesetup + use_general_cloud_optics = this%use_general_cloud_optics + use_general_aerosol_optics = this%use_general_aerosol_optics + cloud_fraction_threshold = this%cloud_fraction_threshold + cloud_mixing_ratio_threshold = this%cloud_mixing_ratio_threshold + use_beta_overlap = this%use_beta_overlap + use_vectorizable_generator = this%use_vectorizable_generator + cloud_inhom_decorr_scaling = this%cloud_inhom_decorr_scaling + clear_to_thick_fraction = this%clear_to_thick_fraction + overhead_sun_factor = this%overhead_sun_factor + max_gas_od_3d = this%max_gas_od_3d + max_cloud_od = this%max_cloud_od + max_3d_transfer_rate = this%max_3d_transfer_rate + min_cloud_effective_size = this%min_cloud_effective_size + cloud_type_name = this%cloud_type_name + use_thick_cloud_spectral_averaging = this%use_thick_cloud_spectral_averaging + + overhang_factor = this%overhang_factor + encroachment_scaling = -1.0_jprb + gas_model_name = '' !DefaultGasModelName + sw_gas_model_name = '' !DefaultGasModelName + lw_gas_model_name = '' !DefaultGasModelName + liquid_model_name = '' !DefaultLiquidModelName + ice_model_name = '' !DefaultIceModelName + sw_solver_name = '' !DefaultSwSolverName + lw_solver_name = '' !DefaultLwSolverName + sw_entrapment_name = '' + sw_encroachment_name = '' + overlap_scheme_name = '' + cloud_pdf_shape_name = '' + n_aerosol_types = this%n_aerosol_types + mono_lw_wavelength = this%mono_lw_wavelength + mono_lw_total_od = this%mono_lw_total_od + mono_sw_total_od = this%mono_sw_total_od + mono_lw_single_scattering_albedo = this%mono_lw_single_scattering_albedo + mono_sw_single_scattering_albedo = this%mono_sw_single_scattering_albedo + mono_lw_asymmetry_factor = this%mono_lw_asymmetry_factor + mono_sw_asymmetry_factor = this%mono_sw_asymmetry_factor + i_aerosol_type_map = this%i_aerosol_type_map + do_nearest_spectral_sw_albedo = this%do_nearest_spectral_sw_albedo + do_nearest_spectral_lw_emiss = this%do_nearest_spectral_lw_emiss + sw_albedo_wavelength_bound = this%sw_albedo_wavelength_bound + lw_emiss_wavelength_bound = this%lw_emiss_wavelength_bound + i_sw_albedo_index = this%i_sw_albedo_index + i_lw_emiss_index = this%i_lw_emiss_index + do_cloud_aerosol_per_lw_g_point = this%do_cloud_aerosol_per_lw_g_point + do_cloud_aerosol_per_sw_g_point = this%do_cloud_aerosol_per_sw_g_point + do_weighted_surface_mapping = this%do_weighted_surface_mapping + use_spectral_solar_scaling = this%use_spectral_solar_scaling + use_spectral_solar_cycle = this%use_spectral_solar_cycle + use_updated_solar_spectrum = this%use_updated_solar_spectrum + + if (present(file_name) .and. present(unit)) then + write(nulerr,'(a)') '*** Error: cannot specify both file_name and unit in call to config_type%read' + call radiation_abort('Radiation configuration error') + else if (.not. present(file_name) .and. .not. present(unit)) then + write(nulerr,'(a)') '*** Error: neither file_name nor unit specified in call to config_type%read' + call radiation_abort('Radiation configuration error') + end if + + if (present(file_name)) then + ! Open the namelist file + iunit = nulrad + open(unit=iunit, iostat=iosopen, file=trim(file_name)) + else + ! Assume that iunit represents and open file + iosopen = 0 + iunit = unit + end if + + if (iosopen /= 0) then + ! An error occurred opening the file + if (present(is_success)) then + is_success = .false. + ! We now continue the subroutine so that the default values + ! are placed in the config structure + else + write(nulerr,'(a,a,a)') '*** Error: namelist file "', & + & trim(file_name), '" not found' + call radiation_abort('Radiation configuration error') + end if + else + + ! This version exits correctly, but provides less information + ! about how the namelist was incorrect + read(unit=iunit, iostat=iosread, nml=radiation) + + ! Depending on compiler this version provides more information + ! about the error in the namelist + !read(unit=iunit, nml=radiation) + + if (iosread /= 0) then + ! An error occurred reading the file + if (present(is_success)) then + is_success = .false. + ! We now continue the subroutine so that the default values + ! are placed in the config structure + else if (present(file_name)) then + write(nulerr,'(a,a,a)') '*** Error reading namelist "radiation" from file "', & + & trim(file_name), '"' + close(unit=iunit) + call radiation_abort('Radiation configuration error') + else + write(nulerr,'(a,i0)') '*** Error reading namelist "radiation" from unit ', & + & iunit + call radiation_abort('Radiation configuration error') + end if + end if + + if (present(file_name)) then + close(unit=iunit) + end if + end if + + ! Copy namelist data into configuration object + + ! Start with verbosity levels, which should be within limits + if (iverbose < 0) then + iverbose = 0 + end if + this%iverbose = iverbose + + if (iverbosesetup < 0) then + iverbosesetup = 0 + end if + this%iverbosesetup = iverbosesetup + + this%do_lw = do_lw + this%do_sw = do_sw + this%do_clear = do_clear + this%do_sw_direct = do_sw_direct + this%do_3d_effects = do_3d_effects + this%do_3d_lw_multilayer_effects = do_3d_lw_multilayer_effects + this%do_lw_side_emissivity = do_lw_side_emissivity + this%use_expm_everywhere = use_expm_everywhere + this%use_aerosols = use_aerosols + this%do_lw_cloud_scattering = do_lw_cloud_scattering + this%do_lw_aerosol_scattering = do_lw_aerosol_scattering + this%nregions = n_regions + this%do_surface_sw_spectral_flux = do_surface_sw_spectral_flux + this%do_toa_spectral_flux = do_toa_spectral_flux + this%do_sw_delta_scaling_with_gases = do_sw_delta_scaling_with_gases + this%do_fu_lw_ice_optics_bug = do_fu_lw_ice_optics_bug + this%do_canopy_fluxes_sw = do_canopy_fluxes_sw + this%do_canopy_fluxes_lw = do_canopy_fluxes_lw + this%use_canopy_full_spectrum_sw = use_canopy_full_spectrum_sw + this%use_canopy_full_spectrum_lw = use_canopy_full_spectrum_lw + this%do_canopy_gases_sw = do_canopy_gases_sw + this%do_canopy_gases_lw = do_canopy_gases_lw + this%mono_lw_wavelength = mono_lw_wavelength + this%mono_lw_total_od = mono_lw_total_od + this%mono_sw_total_od = mono_sw_total_od + this%mono_lw_single_scattering_albedo = mono_lw_single_scattering_albedo + this%mono_sw_single_scattering_albedo = mono_sw_single_scattering_albedo + this%mono_lw_asymmetry_factor = mono_lw_asymmetry_factor + this%mono_sw_asymmetry_factor = mono_sw_asymmetry_factor + this%use_beta_overlap = use_beta_overlap + this%use_vectorizable_generator = use_vectorizable_generator + this%cloud_inhom_decorr_scaling = cloud_inhom_decorr_scaling + this%clear_to_thick_fraction = clear_to_thick_fraction + this%overhead_sun_factor = overhead_sun_factor + this%max_gas_od_3d = max_gas_od_3d + this%max_cloud_od = max_cloud_od + this%max_3d_transfer_rate = max_3d_transfer_rate + this%min_cloud_effective_size = max(1.0e-6_jprb, min_cloud_effective_size) + this%cloud_type_name = cloud_type_name + this%use_thick_cloud_spectral_averaging = use_thick_cloud_spectral_averaging + if (encroachment_scaling >= 0.0_jprb) then + this%overhang_factor = encroachment_scaling + if (iverbose >= 1) then + write(nulout, '(a)') 'Warning: radiation namelist parameter "encroachment_scaling" is deprecated: use "overhang_factor"' + end if + else + this%overhang_factor = overhang_factor + end if + this%directory_name = directory_name + this%cloud_pdf_override_file_name = cloud_pdf_override_file_name + this%liq_optics_override_file_name = liq_optics_override_file_name + this%ice_optics_override_file_name = ice_optics_override_file_name + this%aerosol_optics_override_file_name = aerosol_optics_override_file_name + this%gas_optics_sw_override_file_name = gas_optics_sw_override_file_name + this%gas_optics_lw_override_file_name = gas_optics_lw_override_file_name + this%ssi_override_file_name = ssi_override_file_name + this%use_general_cloud_optics = use_general_cloud_optics + this%use_general_aerosol_optics = use_general_aerosol_optics + this%cloud_fraction_threshold = cloud_fraction_threshold + this%cloud_mixing_ratio_threshold = cloud_mixing_ratio_threshold + this%n_aerosol_types = n_aerosol_types + this%do_save_radiative_properties = do_save_radiative_properties + this%do_lw_derivatives = do_lw_derivatives + this%do_save_spectral_flux = do_save_spectral_flux + this%do_save_gpoint_flux = do_save_gpoint_flux + this%do_nearest_spectral_sw_albedo = do_nearest_spectral_sw_albedo + this%do_nearest_spectral_lw_emiss = do_nearest_spectral_lw_emiss + this%sw_albedo_wavelength_bound = sw_albedo_wavelength_bound + this%lw_emiss_wavelength_bound = lw_emiss_wavelength_bound + this%i_sw_albedo_index = i_sw_albedo_index + this%i_lw_emiss_index = i_lw_emiss_index + this%do_cloud_aerosol_per_lw_g_point = do_cloud_aerosol_per_lw_g_point + this%do_cloud_aerosol_per_sw_g_point = do_cloud_aerosol_per_sw_g_point + this%do_weighted_surface_mapping = do_weighted_surface_mapping + this%use_spectral_solar_scaling = use_spectral_solar_scaling + this%use_spectral_solar_cycle = use_spectral_solar_cycle + this%use_updated_solar_spectrum = use_updated_solar_spectrum + + if (do_save_gpoint_flux) then + ! Saving the fluxes every g-point overrides saving as averaged + ! in a band, but this%do_save_spectral_flux needs to be TRUE as + ! it is tested inside the solver routines to decide whether to + ! save anything + this%do_save_spectral_flux = .true. + end if + + ! Determine liquid optics model + call get_enum_code(liquid_model_name, LiquidModelName, & + & 'liquid_model_name', this%i_liq_model) + + ! Determine ice optics model + call get_enum_code(ice_model_name, IceModelName, & + & 'ice_model_name', this%i_ice_model) + + ! Determine gas optics model(s) - firstly try the generic gas_model_name + i_gas_model = -1 + call get_enum_code(gas_model_name, GasModelName, & + & 'gas_model_name', i_gas_model) + if (i_gas_model > -1) then + this%i_gas_model_sw = i_gas_model + this%i_gas_model_lw = i_gas_model + end if + ! ...then the band-specific values + call get_enum_code(sw_gas_model_name, GasModelName, & + & 'sw_gas_model_name', this%i_gas_model_sw) + call get_enum_code(lw_gas_model_name, GasModelName, & + & 'lw_gas_model_name', this%i_gas_model_lw) + + ! Determine solvers + call get_enum_code(sw_solver_name, SolverName, & + & 'sw_solver_name', this%i_solver_sw) + call get_enum_code(lw_solver_name, SolverName, & + & 'lw_solver_name', this%i_solver_lw) + + if (len_trim(sw_encroachment_name) > 1) then + call get_enum_code(sw_encroachment_name, EncroachmentName, & + & 'sw_encroachment_name', this%i_3d_sw_entrapment) + write(nulout, '(a)') 'Warning: radiation namelist string "sw_encroachment_name" is deprecated: use "sw_entrapment_name"' + else + call get_enum_code(sw_entrapment_name, EntrapmentName, & + & 'sw_entrapment_name', this%i_3d_sw_entrapment) + end if + + ! Determine overlap scheme + call get_enum_code(overlap_scheme_name, OverlapName, & + & 'overlap_scheme_name', this%i_overlap_scheme) + + ! Determine cloud PDF shape + call get_enum_code(cloud_pdf_shape_name, PdfShapeName, & + & 'cloud_pdf_shape_name', this%i_cloud_pdf_shape) + + this%i_aerosol_type_map = 0 + if (this%use_aerosols) then + this%i_aerosol_type_map(1:n_aerosol_types) & + & = i_aerosol_type_map(1:n_aerosol_types) + end if + + ! Will clouds be used at all? + if ((this%do_sw .and. this%i_solver_sw /= ISolverCloudless) & + & .or. (this%do_lw .and. this%i_solver_lw /= ISolverCloudless)) then + this%do_clouds = .true. + else + this%do_clouds = .false. + end if + + if (this%use_general_cloud_optics .or. this%use_general_aerosol_optics) then + if (this%do_sw .and. this%do_cloud_aerosol_per_sw_g_point & + & .and. this%i_gas_model_sw == IGasModelIFSRRTMG) then + write(nulout,'(a)') 'Warning: RRTMG SW only supports cloud/aerosol/surface optical properties per band, not per g-point' + this%do_cloud_aerosol_per_sw_g_point = .false. + end if + if (this%do_lw .and. this%do_cloud_aerosol_per_lw_g_point & + & .and. this%i_gas_model_lw == IGasModelIFSRRTMG) then + write(nulout,'(a)') 'Warning: RRTMG LW only supports cloud/aerosol/surface optical properties per band, not per g-point' + this%do_cloud_aerosol_per_lw_g_point = .false. + end if + end if + + + ! Normal subroutine exit + if (present(is_success)) then + is_success = .true. + end if + + if (lhook) call dr_hook('radiation_config:read',1,hook_handle) + + end subroutine read_config_from_namelist + + + !--------------------------------------------------------------------- + ! This routine is called by radiation_interface:setup_radiation and + ! it converts the user specified options into some more specific + ! data such as data file names + subroutine consolidate_config(this) + + use parkind1, only : jprd + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulout, nulerr, radiation_abort + + class(config_type), intent(inout) :: this + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_config:consolidate',0,hook_handle) + + ! Check consistency of models + if (this%do_canopy_fluxes_sw .and. .not. this%do_surface_sw_spectral_flux) then + if (this%iverbosesetup >= 1) then + write(nulout,'(a)') 'Warning: turning on do_surface_sw_spectral_flux as required by do_canopy_fluxes_sw' + end if + this%do_surface_sw_spectral_flux = .true. + end if + + ! Will clouds be used at all? + if ((this%do_sw .and. this%i_solver_sw /= ISolverCloudless) & + & .or. (this%do_lw .and. this%i_solver_lw /= ISolverCloudless)) then + this%do_clouds = .true. + else + this%do_clouds = .false. + end if + + ! SPARTACUS only works with Exp-Ran overlap scheme + if (( this%i_solver_sw == ISolverSPARTACUS & + & .or. this%i_solver_lw == ISolverSPARTACUS & + & .or. this%i_solver_sw == ISolverTripleclouds & + & .or. this%i_solver_lw == ISolverTripleclouds) & + & .and. this%i_overlap_scheme /= IOverlapExponentialRandom) then + write(nulerr,'(a)') '*** Error: SPARTACUS/Tripleclouds solvers can only do Exponential-Random overlap' + call radiation_abort('Radiation configuration error') + end if + + if (jprb < jprd .and. this%iverbosesetup >= 1 & + & .and. (this%i_solver_sw == ISolverSPARTACUS & + & .or. this%i_solver_lw == ISolverSPARTACUS)) then + write(nulout,'(a)') 'Warning: the SPARTACUS solver may be unstable in single precision' + end if + + ! If ecCKD gas optics model is being used set relevant file names + if (this%i_gas_model_sw == IGasModelECCKD .or. this%i_gas_model_lw == IGasModelECCKD) then + + ! This gas optics model usually used with general cloud and + ! aerosol optics settings + if (.not. this%use_general_cloud_optics) then + write(nulout,'(a)') 'Warning: ecCKD gas optics model usually used with general cloud optics' + end if + if (.not. this%use_general_aerosol_optics) then + write(nulout,'(a)') 'Warning: ecCKD gas optics model usually used with general aerosol optics' + end if + + end if + + if (this%i_gas_model_sw == IGasModelECCKD) then + + if (len_trim(this%gas_optics_sw_override_file_name) > 0) then + if (this%gas_optics_sw_override_file_name(1:1) == '/') then + this%gas_optics_sw_file_name = trim(this%gas_optics_sw_override_file_name) + else + this%gas_optics_sw_file_name = trim(this%directory_name) & + & // '/' // trim(this%gas_optics_sw_override_file_name) + end if + else + ! In the IFS, the gas optics files should be specified in + ! ifs/module/radiation_setup.F90, not here + this%gas_optics_sw_file_name = trim(this%directory_name) & + & // "/ecckd-1.4_sw_climate_rgb-32b_ckd-definition.nc" + end if + + end if + + if (this%i_gas_model_lw == IGasModelECCKD) then + + if (len_trim(this%gas_optics_lw_override_file_name) > 0) then + if (this%gas_optics_lw_override_file_name(1:1) == '/') then + this%gas_optics_lw_file_name = trim(this%gas_optics_lw_override_file_name) + else + this%gas_optics_lw_file_name = trim(this%directory_name) & + & // '/' // trim(this%gas_optics_lw_override_file_name) + end if + else + ! In the IFS, the gas optics files should be specified in + ! ifs/module/radiation_setup.F90, not here + this%gas_optics_lw_file_name = trim(this%directory_name) & + & // "/ecckd-1.0_lw_climate_fsck-32b_ckd-definition.nc" + end if + + end if + + if (this%use_spectral_solar_cycle) then + if (this%i_gas_model_sw /= IGasModelECCKD) then + write(nulerr,'(a)') '*** Error: solar cycle only available with ecCKD gas optics model' + call radiation_abort('Radiation configuration error') + else + ! Add directory name to solar spectral irradiance file, if + ! provided and does not start with '/' + if (len_trim(this%ssi_override_file_name) > 0) then + if (this%ssi_override_file_name(1:1) /= '/') then + this%ssi_file_name = trim(this%directory_name) & + & // '/' // trim(this%ssi_override_file_name) + else + this%ssi_file_name = trim(this%ssi_override_file_name) + end if + else + this%ssi_file_name = 'ssi_nrl2.nc' + end if + end if + end if + + ! Set aerosol optics file name + if (len_trim(this%aerosol_optics_override_file_name) > 0) then + if (this%aerosol_optics_override_file_name(1:1) == '/') then + this%aerosol_optics_file_name = trim(this%aerosol_optics_override_file_name) + else + this%aerosol_optics_file_name = trim(this%directory_name) & + & // '/' // trim(this%aerosol_optics_override_file_name) + end if + else + ! In the IFS, the aerosol optics file should be specified in + ! ifs/module/radiation_setup.F90, not here + if (this%use_general_aerosol_optics) then + this%aerosol_optics_file_name & + & = trim(this%directory_name) // "/aerosol_ifs_49R1_20230119.nc" + else + this%aerosol_optics_file_name & + & = trim(this%directory_name) // "/aerosol_ifs_rrtm_46R1_with_NI_AM.nc" + end if + end if + + ! Set liquid optics file name + if (len_trim(this%liq_optics_override_file_name) > 0) then + if (this%liq_optics_override_file_name(1:1) == '/') then + this%liq_optics_file_name = trim(this%liq_optics_override_file_name) + else + this%liq_optics_file_name = trim(this%directory_name) & + & // '/' // trim(this%liq_optics_override_file_name) + end if + else if (this%i_liq_model == ILiquidModelSOCRATES) then + this%liq_optics_file_name & + & = trim(this%directory_name) // "/socrates_droplet_scattering_rrtm.nc" + else if (this%i_liq_model == ILiquidModelSlingo) then + this%liq_optics_file_name & + & = trim(this%directory_name) // "/slingo_droplet_scattering_rrtm.nc" + end if + + ! Set ice optics file name + if (len_trim(this%ice_optics_override_file_name) > 0) then + if (this%ice_optics_override_file_name(1:1) == '/') then + this%ice_optics_file_name = trim(this%ice_optics_override_file_name) + else + this%ice_optics_file_name = trim(this%directory_name) & + & // '/' // trim(this%ice_optics_override_file_name) + end if + else if (this%i_ice_model == IIceModelFu) then + this%ice_optics_file_name & + & = trim(this%directory_name) // "/fu_ice_scattering_rrtm.nc" + else if (this%i_ice_model == IIceModelBaran) then + this%ice_optics_file_name & + & = trim(this%directory_name) // "/baran_ice_scattering_rrtm.nc" + else if (this%i_ice_model == IIceModelBaran2016) then + this%ice_optics_file_name & + & = trim(this%directory_name) // "/baran2016_ice_scattering_rrtm.nc" + else if (this%i_ice_model == IIceModelBaran2017) then + this%ice_optics_file_name & + & = trim(this%directory_name) // "/baran2017_ice_scattering_rrtm.nc" + else if (this%i_ice_model == IIceModelYi) then + this%ice_optics_file_name & + & = trim(this%directory_name) // "/yi_ice_scattering_rrtm.nc" + end if + + ! Set cloud-water PDF look-up table file name + if (len_trim(this%cloud_pdf_override_file_name) > 0) then + if (this%cloud_pdf_override_file_name(1:1) == '/') then + this%cloud_pdf_file_name = trim(this%cloud_pdf_override_file_name) + else + this%cloud_pdf_file_name = trim(this%directory_name) & + & // '/' // trim(this%cloud_pdf_override_file_name) + end if + elseif (this%i_cloud_pdf_shape == IPdfShapeLognormal) then + this%cloud_pdf_file_name = trim(this%directory_name) // "/mcica_lognormal.nc" + else + this%cloud_pdf_file_name = trim(this%directory_name) // "/mcica_gamma.nc" + end if + + ! Aerosol data + if (this%n_aerosol_types < 0 & + & .or. this%n_aerosol_types > NMaxAerosolTypes) then + write(nulerr,'(a,i0)') '*** Error: number of aerosol types must be between 0 and ', & + & NMaxAerosolTypes + call radiation_abort('Radiation configuration error') + end if + + if (this%use_aerosols .and. this%n_aerosol_types == 0) then + if (this%iverbosesetup >= 2) then + write(nulout, '(a)') 'Aerosols on but n_aerosol_types=0: optical properties to be computed outside ecRad' + end if + end if + + if (this%i_gas_model_sw == IGasModelMonochromatic .or. this%i_gas_model_lw == IGasModelMonochromatic) then + + if (this%i_gas_model_sw /= this%i_gas_model_lw) then + write(nulerr,'(a,i0)') '*** Error: Monochromatic gas optics model must be used in shortwave and longwave' + call radiation_abort('Radiation configuration error') + end if + + ! In the monochromatic case we need to override the liquid, ice + ! and aerosol models to ensure compatibility + this%i_liq_model = ILiquidModelMonochromatic + this%i_ice_model = IIceModelMonochromatic + this%use_aerosols = .false. + + end if + + ! McICA solver currently can't store full profiles of spectral fluxes + if (this%i_solver_sw == ISolverMcICA .or. this%i_solver_sw == ISolverMcICAACC) then + if (this%iverbosesetup >= 1) then + write(nulout, '(a)') 'Warning: McICA solver cannot store full profiles of spectral fluxes' + end if + this%do_save_spectral_flux = .false. + end if + + if (this%i_solver_sw == ISolverSPARTACUS .and. this%do_sw_delta_scaling_with_gases) then + write(nulerr,'(a)') '*** Error: SW delta-Eddington scaling with gases not possible with SPARTACUS solver' + call radiation_abort('Radiation configuration error') + end if + + if ((this%do_lw .and. this%do_sw) .and. & + & ( ( this%i_solver_sw == ISolverHomogeneous & + & .and. this%i_solver_lw /= ISolverHomogeneous) & + & .or. ( this%i_solver_sw /= ISolverHomogeneous & + & .and. this%i_solver_lw == ISolverHomogeneous) & + & ) ) then + write(nulerr,'(a)') '*** Error: if one solver is "Homogeneous" then the other must be' + call radiation_abort('Radiation configuration error') + end if + + ! Set is_homogeneous if the active solvers are homogeneous, since + ! this affects how "in-cloud" water contents are computed + if ( (this%do_sw .and. this%i_solver_sw == ISolverHomogeneous) & + & .or. (this%do_lw .and. this%i_solver_lw == ISolverHomogeneous)) then + this%is_homogeneous = .true. + end if + + this%is_consolidated = .true. + + if (lhook) call dr_hook('radiation_config:consolidate',1,hook_handle) + + end subroutine consolidate_config + + + !--------------------------------------------------------------------- + ! This subroutine sets members of the configuration object via + ! optional arguments, and any member not specified is left + ! untouched. Therefore, this should be called after taking data from + ! the namelist. + subroutine set_config(config, directory_name, & + & do_lw, do_sw, & + & do_lw_aerosol_scattering, do_lw_cloud_scattering, & + & do_sw_direct) + + class(config_type), intent(inout):: config + character(len=*), intent(in), optional :: directory_name + logical, intent(in), optional :: do_lw, do_sw + logical, intent(in), optional :: do_lw_aerosol_scattering + logical, intent(in), optional :: do_lw_cloud_scattering + logical, intent(in), optional :: do_sw_direct + + if (present(do_lw)) then + config%do_lw = do_lw + end if + + if(present(do_sw)) then + config%do_sw = do_sw + end if + + if (present(do_sw_direct)) then + config%do_sw_direct = do_sw_direct + end if + + if (present(directory_name)) then + config%directory_name = trim(directory_name) + end if + + if (present(do_lw_aerosol_scattering)) then + config%do_lw_aerosol_scattering = .true. + end if + + if (present(do_lw_cloud_scattering)) then + config%do_lw_cloud_scattering = .true. + end if + + end subroutine set_config + + + !--------------------------------------------------------------------- + ! Print configuration information to standard output + subroutine print_config(this, iverbose) + + use radiation_io, only : nulout + + class(config_type), intent(in) :: this + + integer, optional, intent(in) :: iverbose + integer :: i_local_verbose + + if (present(iverbose)) then + i_local_verbose = iverbose + else + i_local_verbose = this%iverbose + end if + + if (i_local_verbose >= 2) then + !--------------------------------------------------------------------- + write(nulout, '(a)') 'General settings:' + write(nulout, '(a,a,a)') ' Data files expected in "', & + & trim(this%directory_name), '"' + call print_logical(' Clear-sky calculations are', 'do_clear', this%do_clear) + call print_logical(' Saving intermediate radiative properties', & + & 'do_save_radiative_properties', this%do_save_radiative_properties) + call print_logical(' Saving spectral flux profiles', & + & 'do_save_spectral_flux', this%do_save_spectral_flux) + call print_enum(' Shortwave gas model is', GasModelName, 'i_gas_model_sw', & + & this%i_gas_model_sw) + call print_enum(' Longwave gas model is', GasModelName, 'i_gas_model_lw', & + & this%i_gas_model_lw) + call print_logical(' Aerosols are', 'use_aerosols', this%use_aerosols) + if (this%use_aerosols) then + call print_logical(' General aerosol optics', & + & 'use_general_aerosol_optics', this%use_general_aerosol_optics) + end if + if (this%do_clouds) then + write(nulout,'(a)') ' Clouds are ON' + else + write(nulout,'(a)') ' Clouds are OFF' + end if + if (this%do_sw) then + call print_logical(' Do cloud/aerosol/surface SW properties per g-point', & + & 'do_cloud_aerosol_per_sw_g_point', this%do_cloud_aerosol_per_sw_g_point) + end if + if (this%do_lw) then + call print_logical(' Do cloud/aerosol/surface LW properties per g-point', & + & 'do_cloud_aerosol_per_lw_g_point', this%do_cloud_aerosol_per_lw_g_point) + end if + if (this%do_sw) then + call print_logical(' Represent solar cycle in spectral irradiance', & + & 'use_spectral_solar_cycle', this%use_spectral_solar_cycle) + call print_logical(' Scale spectral solar irradiance', & + & 'use_spectral_solar_scaling', this%use_spectral_solar_scaling) + end if + + !--------------------------------------------------------------------- + write(nulout, '(a)') 'Surface and top-of-atmosphere settings:' + call print_logical(' Saving top-of-atmosphere spectral fluxes', & + & 'do_toa_spectral_flux', this%do_toa_spectral_flux) + if (this%do_sw) then + call print_logical(' Saving surface shortwave spectral fluxes', & + & 'do_surface_sw_spectral_flux', this%do_surface_sw_spectral_flux) + call print_logical(' Saving surface shortwave fluxes in abledo bands', & + & 'do_canopy_fluxes_sw', this%do_canopy_fluxes_sw) + end if + if (this%do_lw) then + call print_logical(' Saving surface longwave fluxes in emissivity bands', & + & 'do_canopy_fluxes_lw', this%do_canopy_fluxes_lw) + call print_logical(' Longwave derivative calculation is', & + & 'do_lw_derivatives',this%do_lw_derivatives) + end if + if (this%do_sw) then + call print_logical(' Nearest-neighbour spectral albedo mapping', & + & 'do_nearest_spectral_sw_albedo', this%do_nearest_spectral_sw_albedo) + end if + if (this%do_lw) then + call print_logical(' Nearest-neighbour spectral emissivity mapping', & + & 'do_nearest_spectral_lw_emiss', this%do_nearest_spectral_lw_emiss) + end if + call print_logical(' Planck-weighted surface albedo/emiss mapping', & + & 'do_weighted_surface_mapping', this%do_weighted_surface_mapping) + + !--------------------------------------------------------------------- + if (this%do_clouds) then + write(nulout, '(a)') 'Cloud settings:' + call print_real(' Cloud fraction threshold', & + & 'cloud_fraction_threshold', this%cloud_fraction_threshold) + call print_real(' Cloud mixing-ratio threshold', & + & 'cloud_mixing_ratio_threshold', this%cloud_mixing_ratio_threshold) + call print_logical(' General cloud optics', & + & 'use_general_cloud_optics', this%use_general_cloud_optics) + if (.not. this%use_general_cloud_optics) then + call print_enum(' Liquid optics scheme is', LiquidModelName, & + & 'i_liq_model',this%i_liq_model) + call print_enum(' Ice optics scheme is', IceModelName, & + & 'i_ice_model',this%i_ice_model) + if (this%i_ice_model == IIceModelFu) then + call print_logical(' Longwave ice optics bug in Fu scheme is', & + & 'do_fu_lw_ice_optics_bug',this%do_fu_lw_ice_optics_bug) + end if + end if + call print_enum(' Cloud overlap scheme is', OverlapName, & + & 'i_overlap_scheme',this%i_overlap_scheme) + call print_logical(' Use "beta" overlap parameter is', & + & 'use_beta_overlap', this%use_beta_overlap) + call print_enum(' Cloud PDF shape is', PdfShapeName, & + & 'i_cloud_pdf_shape',this%i_cloud_pdf_shape) + call print_real(' Cloud inhom decorrelation scaling', & + & 'cloud_inhom_decorr_scaling', this%cloud_inhom_decorr_scaling) + end if + + !--------------------------------------------------------------------- + write(nulout, '(a)') 'Solver settings:' + if (this%do_sw) then + call print_enum(' Shortwave solver is', SolverName, & + & 'i_solver_sw', this%i_solver_sw) + + if (this%i_gas_model_sw == IGasModelMonochromatic) then + call print_real(' Shortwave atmospheric optical depth', & + & 'mono_sw_total_od', this%mono_sw_total_od) + call print_real(' Shortwave particulate single-scattering albedo', & + & 'mono_sw_single_scattering_albedo', & + & this%mono_sw_single_scattering_albedo) + call print_real(' Shortwave particulate asymmetry factor', & + & 'mono_sw_asymmetry_factor', & + & this%mono_sw_asymmetry_factor) + end if + call print_logical(' Shortwave delta scaling after merge with gases', & + & 'do_sw_delta_scaling_with_gases', & + & this%do_sw_delta_scaling_with_gases) + else + call print_logical(' Shortwave calculations are','do_sw',this%do_sw) + end if + + if (this%do_lw) then + call print_enum(' Longwave solver is', SolverName, 'i_solver_lw', & + & this%i_solver_lw) + + if (this%i_gas_model_lw == IGasModelMonochromatic) then + if (this%mono_lw_wavelength > 0.0_jprb) then + call print_real(' Longwave effective wavelength (m)', & + & 'mono_lw_wavelength', this%mono_lw_wavelength) + else + write(nulout,'(a)') ' Longwave fluxes are broadband (mono_lw_wavelength<=0)' + end if + call print_real(' Longwave atmospheric optical depth', & + & 'mono_lw_total_od', this%mono_lw_total_od) + call print_real(' Longwave particulate single-scattering albedo', & + & 'mono_lw_single_scattering_albedo', & + & this%mono_lw_single_scattering_albedo) + call print_real(' Longwave particulate asymmetry factor', & + & 'mono_lw_asymmetry_factor', & + & this%mono_lw_asymmetry_factor) + end if + call print_logical(' Longwave cloud scattering is', & + & 'do_lw_cloud_scattering',this%do_lw_cloud_scattering) + call print_logical(' Longwave aerosol scattering is', & + & 'do_lw_aerosol_scattering',this%do_lw_aerosol_scattering) + else + call print_logical(' Longwave calculations are','do_lw', this%do_lw) + end if + + if (this%i_solver_sw == ISolverSpartacus & + & .or. this%i_solver_lw == ISolverSpartacus) then + write(nulout, '(a)') ' SPARTACUS options:' + call print_integer(' Number of regions', 'n_regions', this%nregions) + call print_real(' Max cloud optical depth per layer', & + & 'max_cloud_od', this%max_cloud_od) + call print_enum(' Shortwave entrapment is', EntrapmentName, & + & 'i_3d_sw_entrapment', this%i_3d_sw_entrapment) + call print_logical(' Multilayer longwave horizontal transport is', & + 'do_3d_lw_multilayer_effects', this%do_3d_lw_multilayer_effects) + call print_logical(' Use matrix exponential everywhere is', & + & 'use_expm_everywhere', this%use_expm_everywhere) + call print_logical(' 3D effects are', 'do_3d_effects', & + & this%do_3d_effects) + + if (this%do_3d_effects) then + call print_logical(' Longwave side emissivity parameterization is', & + & 'do_lw_side_emissivity', this%do_lw_side_emissivity) + call print_real(' Clear-to-thick edge fraction is', & + & 'clear_to_thick_fraction', this%clear_to_thick_fraction) + call print_real(' Overhead sun factor is', & + & 'overhead_sun_factor', this%overhead_sun_factor) + call print_real(' Max gas optical depth for 3D effects', & + & 'max_gas_od_3d', this%max_gas_od_3d) + call print_real(' Max 3D transfer rate', & + & 'max_3d_transfer_rate', this%max_3d_transfer_rate) + call print_real(' Min cloud effective size (m)', & + & 'min_cloud_effective_size', this%min_cloud_effective_size) + call print_real(' Overhang factor', & + & 'overhang_factor', this%overhang_factor) + end if + + else if (this%i_solver_sw == ISolverMcICA & + & .or. this%i_solver_lw == ISolverMcICA & + & .or. this%i_solver_sw == ISolverMcICAACC & + & .or. this%i_solver_lw == ISolverMcICAACC ) then + call print_logical(' Use vectorizable McICA cloud generator', & + & 'use_vectorizable_generator', this%use_vectorizable_generator) + end if + + end if + + end subroutine print_config + + + !--------------------------------------------------------------------- + ! In order to estimate UV and photosynthetically active radiation, + ! we need weighted sum of fluxes considering wavelength range + ! required. This routine returns information for how to correctly + ! weight output spectral fluxes for a range of input wavelengths. + ! Note that this is approximate; internally it may be assumed that + ! the energy is uniformly distributed in wavenumber space, for + ! example. If the character string "weighting_name" is present, and + ! iverbose>=2, then information on the weighting will be provided on + ! nulout. + subroutine get_sw_weights(this, wavelength1, wavelength2, & + & nweights, iband, weight, weighting_name) + + use parkind1, only : jprb + use radiation_io, only : nulout, nulerr, radiation_abort + use radiation_spectral_definition, only : SolarReferenceTemperature + + class(config_type), intent(in) :: this + ! Range of wavelengths to get weights for (m) + real(jprb), intent(in) :: wavelength1, wavelength2 + ! Output number of weights needed + integer, intent(out) :: nweights + ! Only write to the first nweights of these arrays: they contain + ! the indices to the non-zero bands, and the weight in each of + ! those bands + integer, intent(out) :: iband(:) + real(jprb), intent(out) :: weight(:) + character(len=*), optional, intent(in) :: weighting_name + + real(jprb), allocatable :: mapping(:,:) + + ! Internally we deal with wavenumber + real(jprb) :: wavenumber1, wavenumber2 ! cm-1 + + real(jprb) :: wavenumber1_band, wavenumber2_band ! cm-1 + + integer :: jband ! Loop index for spectral band + + if (this%n_bands_sw <= 0) then + write(nulerr,'(a)') '*** Error: get_sw_weights called before number of shortwave bands set' + call radiation_abort('Radiation configuration error') + end if + + ! Convert wavelength range (m) to wavenumber (cm-1) + wavenumber1 = 0.01_jprb / wavelength2 + wavenumber2 = 0.01_jprb / wavelength1 + + call this%gas_optics_sw%spectral_def%calc_mapping_from_bands( & + & [wavelength1, wavelength2], [1, 2, 3], mapping, & + & use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point), use_fluxes=.true.) + + ! "mapping" now contains a 3*nband matrix, where mapping(2,:) + ! contains the weights of interest. We now find the non-zero weights + nweights = 0 + do jband = 1,size(mapping,2) + if (mapping(2,jband) > 0.0_jprb) then + nweights = nweights+1 + iband(nweights) = jband; + weight(nweights) = mapping(2,jband) + end if + end do + + if (nweights == 0) then + write(nulerr,'(a,e8.4,a,e8.4,a)') '*** Error: wavelength range ', & + & wavelength1, ' to ', wavelength2, ' m is outside shortwave band' + call radiation_abort('Radiation configuration error') + else if (this%iverbosesetup >= 2 .and. present(weighting_name)) then + write(nulout,'(a,a,a,f6.0,a,f6.0,a)') 'Spectral weights for ', & + & weighting_name, ' (', wavenumber1, ' to ', & + & wavenumber2, ' cm-1):' + if (this%do_cloud_aerosol_per_sw_g_point) then + do jband = 1, nweights + write(nulout, '(a,i0,a,f8.4)') ' Shortwave g point ', iband(jband), ': ', weight(jband) + end do + else + do jband = 1, nweights + wavenumber1_band = this%gas_optics_sw%spectral_def%wavenumber1_band(iband(jband)) + wavenumber2_band = this%gas_optics_sw%spectral_def%wavenumber2_band(iband(jband)) + write(nulout, '(a,i0,a,f6.0,a,f6.0,a,f8.4)') ' Shortwave band ', & + & iband(jband), ' (', wavenumber1_band, ' to ', & + & wavenumber2_band, ' cm-1): ', weight(jband) + end do + end if + end if + + end subroutine get_sw_weights + + + !--------------------------------------------------------------------- + ! As get_sw_weights but suitable for a larger number of spectral + ! diagnostics at once: a set of monotonically increasing wavelength + ! bounds are provided (m), and a mapping matrix is allocated and + ! returned such that y=matmul(mapping,x), where x is a set of + ! band-wise fluxes after calling ecRad, e.g. flux%sw_dn_surf_band, + ! and y is the resulting fluxes in each of the wavenumber + ! intervals. If the character string "weighting_name" is present, + ! and iverbose>=2, then information on the weighting will be + ! provided on nulout. + subroutine get_sw_mapping(this, wavelength_bound, mapping, weighting_name) + + use parkind1, only : jprb + use radiation_io, only : nulout, nulerr, radiation_abort + use radiation_spectral_definition, only : SolarReferenceTemperature + + class(config_type), intent(in) :: this + ! Range of wavelengths to get weights for (m) + real(jprb), intent(in) :: wavelength_bound(:) + real(jprb), intent(out), allocatable :: mapping(:,:) + character(len=*), optional, intent(in) :: weighting_name + + real(jprb), allocatable :: mapping_local(:,:) + integer, allocatable :: diag_ind(:) + + integer :: ninterval + + integer :: jint ! Loop for interval + + if (this%n_bands_sw <= 0) then + write(nulerr,'(a)') '*** Error: get_sw_mapping called before number of shortwave bands set' + call radiation_abort('Radiation configuration error') + end if + + ninterval = size(wavelength_bound)-1 + allocate(diag_ind(ninterval+2)) + diag_ind = 0 + do jint = 1,ninterval+2 + diag_ind(jint) = jint + end do + + call this%gas_optics_sw%spectral_def%calc_mapping_from_bands( & + & wavelength_bound, diag_ind, mapping_local, & + & use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point), use_fluxes=.false.) + + ! "mapping" now contains a (ninterval+2)*nband matrix, where the + ! first and last rows correspond to wavelengths smaller than the + ! first and larger than the last, which we discard + mapping = mapping_local(2:ninterval+1,:) + + if (this%iverbosesetup >= 2 .and. present(weighting_name)) then + write(nulout,'(a,a)') 'Spectral mapping generated for ', & + & weighting_name + if (this%do_cloud_aerosol_per_sw_g_point) then + write(nulout,'(a,i0,a,i0,a,f9.3,a,f9.3,a)') ' from ', size(mapping,2), ' g-points to ', & + & size(mapping,1), ' wavelength intervals between ', & + & wavelength_bound(1)*1.0e6_jprb, ' um and ', wavelength_bound(ninterval+1)*1.0e6_jprb, ' um' + else + write(nulout,'(a,i0,a,i0,a,f9.3,a,f9.3,a)') ' from ', size(mapping,2), ' bands to ', & + & size(mapping,1), ' wavelength intervals between ', & + & wavelength_bound(1)*1.0e6_jprb, ' um and ', wavelength_bound(ninterval+1)*1.0e6_jprb, ' um' + end if + end if + + end subroutine get_sw_mapping + + + !--------------------------------------------------------------------- + ! The input shortwave surface albedo coming in is likely to be in + ! different spectral intervals to the gas model in the radiation + ! scheme. We assume that the input albedo is defined within + ! "ninterval" spectral intervals covering the wavelength range 0 to + ! infinity, but allow for the possibility that two intervals may be + ! indexed back to the same albedo band. + subroutine define_sw_albedo_intervals(this, ninterval, wavelength_bound, & + & i_intervals, do_nearest) + + use radiation_io, only : nulerr, radiation_abort + use radiation_spectral_definition, only : SolarReferenceTemperature + + class(config_type), intent(inout) :: this + ! Number of spectral intervals in which albedo is defined + integer, intent(in) :: ninterval + ! Monotonically increasing wavelength bounds between intervals, + ! not including the outer bounds (which are assumed to be zero and + ! infinity) + real(jprb), intent(in) :: wavelength_bound(ninterval-1) + ! The albedo indices corresponding to each interval + integer, intent(in) :: i_intervals(ninterval) + logical, optional, intent(in) :: do_nearest + + if (ninterval > NMaxAlbedoIntervals) then + write(nulerr,'(a,i0,a,i0)') '*** Error: ', ninterval, & + & ' albedo intervals exceeds maximum of ', NMaxAlbedoIntervals + call radiation_abort('Radiation configuration error') + end if + + if (present(do_nearest)) then + this%do_nearest_spectral_sw_albedo = do_nearest + else + this%do_nearest_spectral_sw_albedo = .false. + end if + if (ninterval > 1) then + this%sw_albedo_wavelength_bound(1:ninterval-1) = wavelength_bound(1:ninterval-1) + end if + this%sw_albedo_wavelength_bound(ninterval:) = -1.0_jprb + this%i_sw_albedo_index(1:ninterval) = i_intervals(1:ninterval) + this%i_sw_albedo_index(ninterval+1:) = 0 + + ! If this routine is called before setup_radiation then the + ! spectral intervals are not yet known + ! consolidate_sw_albedo_intervals is called later. Otherwise it + ! is called immediately and overwrites any existing mapping. + if (this%is_consolidated) then + call this%consolidate_sw_albedo_intervals + end if + + end subroutine define_sw_albedo_intervals + + + !--------------------------------------------------------------------- + ! As define_sw_albedo_intervals but for longwave emissivity + subroutine define_lw_emiss_intervals(this, ninterval, wavelength_bound, & + & i_intervals, do_nearest) + + use radiation_io, only : nulerr, radiation_abort + use radiation_spectral_definition, only : TerrestrialReferenceTemperature + + class(config_type), intent(inout) :: this + ! Number of spectral intervals in which emissivity is defined + integer, intent(in) :: ninterval + ! Monotonically increasing wavelength bounds between intervals, + ! not including the outer bounds (which are assumed to be zero and + ! infinity) + real(jprb), intent(in) :: wavelength_bound(ninterval-1) + ! The emissivity indices corresponding to each interval + integer, intent(in) :: i_intervals(ninterval) + logical, optional, intent(in) :: do_nearest + + if (ninterval > NMaxAlbedoIntervals) then + write(nulerr,'(a,i0,a,i0)') '*** Error: ', ninterval, & + & ' emissivity intervals exceeds maximum of ', NMaxAlbedoIntervals + call radiation_abort('Radiation configuration error') + end if + + if (present(do_nearest)) then + this%do_nearest_spectral_lw_emiss = do_nearest + else + this%do_nearest_spectral_lw_emiss = .false. + end if + if (ninterval > 1) then + this%lw_emiss_wavelength_bound(1:ninterval-1) = wavelength_bound(1:ninterval-1) + end if + this%lw_emiss_wavelength_bound(ninterval:) = -1.0_jprb + this%i_lw_emiss_index(1:ninterval) = i_intervals(1:ninterval) + this%i_lw_emiss_index(ninterval+1:) = 0 + + if (this%is_consolidated) then + call this%consolidate_lw_emiss_intervals + end if + + end subroutine define_lw_emiss_intervals + + + !--------------------------------------------------------------------- + ! Set the wavelengths (m) at which monochromatic aerosol properties + ! are required. This routine must be called before consolidation of + ! settings. + subroutine set_aerosol_wavelength_mono(this, wavelength_mono) + + use radiation_io, only : nulerr, radiation_abort + + class(config_type), intent(inout) :: this + real(jprb), intent(in) :: wavelength_mono(:) + + if (this%is_consolidated) then + write(nulerr,'(a)') '*** Errror: set_aerosol_wavelength_mono must be called before setup_radiation' + call radiation_abort('Radiation configuration error') + end if + + if (allocated(this%aerosol_optics%wavelength_mono)) then + deallocate(this%aerosol_optics%wavelength_mono) + end if + allocate(this%aerosol_optics%wavelength_mono(size(wavelength_mono))) + this%aerosol_optics%wavelength_mono = wavelength_mono + + end subroutine set_aerosol_wavelength_mono + + + !--------------------------------------------------------------------- + ! Consolidate the surface shortwave albedo intervals with the + ! band/g-point intervals + subroutine consolidate_sw_albedo_intervals(this) + + use radiation_io, only : nulout + use radiation_spectral_definition, only : SolarReferenceTemperature + + class(config_type), intent(inout) :: this + + integer :: ninterval, jint, jband + + ! Count the number of albedo/emissivity intervals + ninterval = 0 + do jint = 1,NMaxAlbedoIntervals + if (this%i_sw_albedo_index(jint) > 0) then + ninterval = jint + else + exit + end if + end do + + if (ninterval < 1) then + ! The user has not specified shortwave albedo bands - assume + ! only one + ninterval = 1 + this%i_sw_albedo_index(1) = 1 + this%i_sw_albedo_index(2:) = 0 + if (this%use_canopy_full_spectrum_sw) then + this%n_canopy_bands_sw = this%n_g_sw + else + this%n_canopy_bands_sw = 1 + end if + else + if (this%use_canopy_full_spectrum_sw) then + this%n_canopy_bands_sw = this%n_g_sw + else + this%n_canopy_bands_sw = maxval(this%i_sw_albedo_index(1:ninterval)) + end if + end if + + if (this%do_weighted_surface_mapping) then + call this%gas_optics_sw%spectral_def%calc_mapping_from_bands( & + & this%sw_albedo_wavelength_bound(1:ninterval-1), this%i_sw_albedo_index(1:ninterval), & + & this%sw_albedo_weights, use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point)) + else + ! Weight each wavenumber equally as in IFS Cycles 48 and earlier + call this%gas_optics_sw%spectral_def%calc_mapping_from_bands( & + & this%sw_albedo_wavelength_bound(1:ninterval-1), this%i_sw_albedo_index(1:ninterval), & + & this%sw_albedo_weights, use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point)) + end if + + ! Legacy method uses input band with largest weight + if (this%do_nearest_spectral_sw_albedo) then + allocate(this%i_albedo_from_band_sw(this%n_bands_sw)) + this%i_albedo_from_band_sw = maxloc(this%sw_albedo_weights, dim=1) + end if + + if (this%iverbosesetup >= 2) then + write(nulout, '(a)') 'Surface shortwave albedo' + if (.not. this%do_nearest_spectral_sw_albedo) then + call this%gas_optics_sw%spectral_def%print_mapping_from_bands(this%sw_albedo_weights, & + & use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point)) + else if (ninterval <= 1) then + write(nulout, '(a)') 'All shortwave bands will use the same albedo' + else + write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', size(this%i_albedo_from_band_sw), & + & ' shortwave intervals to albedo intervals:' + do jband = 1,size(this%i_albedo_from_band_sw) + write(nulout,'(a,i0)',advance='no') ' ', this%i_albedo_from_band_sw(jband) + end do + write(nulout, '()') + end if + end if + + end subroutine consolidate_sw_albedo_intervals + + + !--------------------------------------------------------------------- + ! Consolidate the surface longwave emissivity intervals with the + ! band/g-point intervals + subroutine consolidate_lw_emiss_intervals(this) + + use radiation_io, only : nulout + use radiation_spectral_definition, only : TerrestrialReferenceTemperature + + class(config_type), intent(inout) :: this + + integer :: ninterval, jint, jband + + ! Count the number of albedo/emissivity intervals + ninterval = 0 + do jint = 1,NMaxAlbedoIntervals + if (this%i_lw_emiss_index(jint) > 0) then + ninterval = jint + else + exit + end if + end do + + if (ninterval < 1) then + ! The user has not specified longwave emissivity bands - assume + ! only one + ninterval = 1 + this%i_lw_emiss_index(1) = 1 + this%i_lw_emiss_index(2:) = 0 + if (this%use_canopy_full_spectrum_sw) then + this%n_canopy_bands_lw = this%n_g_lw + else + this%n_canopy_bands_lw = 1 + end if + else + if (this%use_canopy_full_spectrum_lw) then + this%n_canopy_bands_lw = this%n_g_lw + else + this%n_canopy_bands_lw = maxval(this%i_lw_emiss_index(1:ninterval)) + end if + end if + + if (this%do_weighted_surface_mapping) then + call this%gas_optics_lw%spectral_def%calc_mapping_from_bands( & + & this%lw_emiss_wavelength_bound(1:ninterval-1), this%i_lw_emiss_index(1:ninterval), & + & this%lw_emiss_weights, use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point)) + else + ! Weight each wavenumber equally as in IFS Cycles 48 and earlier + call this%gas_optics_lw%spectral_def%calc_mapping_from_bands( & + & this%lw_emiss_wavelength_bound(1:ninterval-1), this%i_lw_emiss_index(1:ninterval), & + & this%lw_emiss_weights, use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point)) + end if + + ! Legacy method uses input band with largest weight + if (this%do_nearest_spectral_lw_emiss) then + allocate(this%i_emiss_from_band_lw(this%n_bands_lw)) + this%i_emiss_from_band_lw = maxloc(this%lw_emiss_weights, dim=1) + end if + + if (this%iverbosesetup >= 2) then + write(nulout, '(a)') 'Surface longwave emissivity' + if (.not. this%do_nearest_spectral_lw_emiss) then + call this%gas_optics_lw%spectral_def%print_mapping_from_bands(this%lw_emiss_weights, & + & use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point)) + else if (ninterval <= 1) then + write(nulout, '(a)') 'All longwave bands will use the same emissivty' + else + write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', size(this%i_emiss_from_band_lw), & + & ' longwave intervals to emissivity intervals:' + do jband = 1,size(this%i_emiss_from_band_lw) + write(nulout,'(a,i0)',advance='no') ' ', this%i_emiss_from_band_lw(jband) + end do + write(nulout, '()') + end if + end if + + end subroutine consolidate_lw_emiss_intervals + + + !--------------------------------------------------------------------- + ! Return the 0-based index for str in enum_str, or abort if it is + ! not found + subroutine get_enum_code(str, enum_str, var_name, icode) + + use radiation_io, only : nulerr, radiation_abort + + character(len=*), intent(in) :: str + character(len=*), intent(in) :: enum_str(0:) + character(len=*), intent(in) :: var_name + integer, intent(out) :: icode + + integer :: jc + logical :: is_not_found + + ! If string is empty then we don't modify icode but assume it has + ! a sensible default value + if (len_trim(str) > 1) then + is_not_found = .true. + + do jc = 0,size(enum_str)-1 + if (trim(str) == trim(enum_str(jc))) then + icode = jc + is_not_found = .false. + exit + end if + end do + if (is_not_found) then + write(nulerr,'(a,a,a,a,a)',advance='no') '*** Error: ', trim(var_name), & + & ' must be one of: "', enum_str(0), '"' + do jc = 1,size(enum_str)-1 + write(nulerr,'(a,a,a)',advance='no') ', "', trim(enum_str(jc)), '"' + end do + write(nulerr,'(a)') '' + call radiation_abort('Radiation configuration error') + end if + end if + + end subroutine get_enum_code + + + !--------------------------------------------------------------------- + ! Print one line of information: logical + subroutine print_logical(message_str, name, val) + use radiation_io, only : nulout + character(len=*), intent(in) :: message_str + character(len=*), intent(in) :: name + logical, intent(in) :: val + character(4) :: on_or_off + character(NPrintStringLen) :: str + if (val) then + on_or_off = ' ON ' + else + on_or_off = ' OFF' + end if + write(str, '(a,a4)') message_str, on_or_off + write(nulout,'(a,a,a,a,l1,a)') str, ' (', name, '=', val,')' + end subroutine print_logical + + + !--------------------------------------------------------------------- + ! Print one line of information: integer + subroutine print_integer(message_str, name, val) + use radiation_io, only : nulout + character(len=*), intent(in) :: message_str + character(len=*), intent(in) :: name + integer, intent(in) :: val + character(NPrintStringLen) :: str + write(str, '(a,a,i0)') message_str, ' = ', val + write(nulout,'(a,a,a,a)') str, ' (', name, ')' + end subroutine print_integer + + + !--------------------------------------------------------------------- + ! Print one line of information: real + subroutine print_real(message_str, name, val) + use parkind1, only : jprb + use radiation_io, only : nulout + character(len=*), intent(in) :: message_str + character(len=*), intent(in) :: name + real(jprb), intent(in) :: val + character(NPrintStringLen) :: str + write(str, '(a,a,g8.3)') message_str, ' = ', val + write(nulout,'(a,a,a,a)') str, ' (', name, ')' + end subroutine print_real + + + !--------------------------------------------------------------------- + ! Print one line of information: enum + subroutine print_enum(message_str, enum_str, name, val) + use radiation_io, only : nulout + character(len=*), intent(in) :: message_str + character(len=*), intent(in) :: enum_str(0:) + character(len=*), intent(in) :: name + integer, intent(in) :: val + character(NPrintStringLen) :: str + write(str, '(a,a,a,a)') message_str, ' "', trim(enum_str(val)), '"' + write(nulout,'(a,a,a,a,i0,a)') str, ' (', name, '=', val,')' + end subroutine print_enum + +end module radiation_config Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_constants.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_constants.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_constants.F90 (revision 6016) @@ -0,0 +1,35 @@ +! radiation_constants.F90 - Constants used in radiation calculations +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_constants + + use parkind1, only : jprb +! use yomcst, only : RPI, RSIGMA, RG, RD, RMV, RMO3, RHPLA + + implicit none + public + + ! Rename some constants from their cryptic IFS names + real(jprb), parameter :: Pi = 3.14159265358979323846_jprb + real(jprb), parameter :: AccelDueToGravity = 9.80665_jprb! m s-2 + real(jprb), parameter :: StefanBoltzmann = 5.67037321e-8_jprb ! W m-2 K-4 + real(jprb), parameter :: DensityLiquidWater = 1000.0_jprb ! kg m-3 + real(jprb), parameter :: DensitySolidIce = 916.7_jprb ! kg m-3 + real(jprb), parameter :: GasConstantDryAir = 287.058_jprb! J kg-1 K-1 + real(jprb), parameter :: PlanckConstant = 6.6260695729e-34_jprb ! J s + real(jprb), parameter :: BoltzmannConstant = 1.380648813e-23_jprb ! J K-1 + real(jprb), parameter :: SpeedOfLight = 299792458.0_jprb ! m s-1 + +end module radiation_constants Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_delta_eddington.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_delta_eddington.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_delta_eddington.h (revision 6016) @@ -0,0 +1,146 @@ +! radiation_delta_eddington.h - Delta-Eddington scaling -*- f90 -*- +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! This file is intended to be included inside a module to ensure that +! these simple functions may be inlined + +!--------------------------------------------------------------------- +! Perform in-place delta-Eddington scaling of the phase function +elemental subroutine delta_eddington(od, ssa, g) + + use parkind1, only : jprb + + ! Total optical depth, single scattering albedo and asymmetry + ! factor + real(jprb), intent(inout) :: od, ssa, g + + ! Fraction of the phase function deemed to be in the forward lobe + ! and therefore treated as if it is not scattered at all + real(jprb) :: f + + f = g*g + od = od * (1.0_jprb - ssa*f) + ssa = ssa * (1.0_jprb - f) / (1.0_jprb - ssa*f) + g = g / (1.0_jprb + g) + +end subroutine delta_eddington + + +!--------------------------------------------------------------------- +! Perform in-place delta-Eddington scaling of the phase function, but +! using extensive variables (i.e. the scattering optical depth, +! scat_od, rather than the single-scattering albedo, and the +! scattering-optical-depth-multiplied-by-asymmetry-factor, scat_od_g, +! rather than the asymmetry factor. +elemental subroutine delta_eddington_extensive(od, scat_od, scat_od_g) + + !$ACC ROUTINE SEQ + + use parkind1, only : jprb + + ! Total optical depth, scattering optical depth and asymmetry factor + ! multiplied by the scattering optical depth + real(jprb), intent(inout) :: od, scat_od, scat_od_g + + ! Fraction of the phase function deemed to be in the forward lobe + ! and therefore treated as if it is not scattered at all + real(jprb) :: f, g + + if (scat_od > 0.0_jprb) then + g = scat_od_g / scat_od + else + g = 0.0 + end if + + f = g*g + od = od - scat_od * f + scat_od = scat_od * (1.0_jprb - f) + scat_od_g = scat_od * g / (1.0_jprb + g) + +end subroutine delta_eddington_extensive + + +!--------------------------------------------------------------------- +! Array version of delta_eddington_extensive, more likely to vectorize + subroutine delta_eddington_extensive_vec(ng, od, scat_od, scat_od_g) + + use parkind1, only : jprb + + ! Total optical depth, scattering optical depth and asymmetry factor + ! multiplied by the scattering optical depth + integer, intent(in) :: ng + real(jprb), dimension(ng), intent(inout) :: od, scat_od, scat_od_g + + ! Fraction of the phase function deemed to be in the forward lobe + ! and therefore treated as if it is not scattered at all + real(jprb) :: f, g + integer :: j + + do j = 1,ng + g = scat_od_g(j) / max(scat_od(j), 1.0e-24) + f = g*g + od(j) = od(j) - scat_od(j) * f + scat_od(j) = scat_od(j) * (1.0_jprb - f) + scat_od_g(j) = scat_od(j) * g / (1.0_jprb + g) + end do + +end subroutine delta_eddington_extensive_vec + + +!--------------------------------------------------------------------- +! Perform in-place delta-Eddington scaling of the phase function, +! using the scattering optical depth rather than the single scattering +! albedo +elemental subroutine delta_eddington_scat_od(od, scat_od, g) + + use parkind1, only : jprb + + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(inout) :: od, scat_od, g + + ! Fraction of the phase function deemed to be in the forward lobe + ! and therefore treated as if it is not scattered at all + real(jprb) :: f + + !$ACC ROUTINE SEQ + + f = g*g + od = od - scat_od * f + scat_od = scat_od * (1.0_jprb - f) + g = g / (1.0_jprb + g) + +end subroutine delta_eddington_scat_od + + +!--------------------------------------------------------------------- +! Revert delta-Eddington-scaled quantities in-place, back to their +! original state +elemental subroutine revert_delta_eddington(od, ssa, g) + + use parkind1, only : jprb + + ! Total optical depth, single scattering albedo and asymmetry + ! factor + real(jprb), intent(inout) :: od, ssa, g + + ! Fraction of the phase function deemed to be in the forward lobe + ! and therefore treated as if it is not scattered at all + real(jprb) :: f + + g = g / (1.0_jprb - g) + f = g*g + ssa = ssa / (1.0_jprb - f + f*ssa); + od = od / (1.0_jprb - ssa*f) + +end subroutine revert_delta_eddington Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd.F90 (revision 6016) @@ -0,0 +1,967 @@ +! radiation_ecckd.F90 - ecCKD generalized gas optics model +! +! (C) Copyright 2020- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +#include "ecrad_config.h" + +module radiation_ecckd + + use parkind1, only : jprb + use radiation_gas_constants + use radiation_ecckd_gas + use radiation_spectral_definition, only : spectral_definition_type + + implicit none + + public + + !--------------------------------------------------------------------- + ! This derived type contains all the data needed to describe a + ! correlated k-distribution gas optics model created using the ecCKD + ! tool + type ckd_model_type + + ! Gas information + + ! Number of gases + integer :: ngas = 0 + ! Array of individual-gas data objects + type(ckd_gas_type), allocatable :: single_gas(:) + ! Mapping from the "gas codes" in the radiation_gas_constants + ! module to an index to the single_gas array, where zero means gas + ! not present (or part of a composite gas) + integer :: i_gas_mapping(0:NMaxGases) + + ! Coordinates of main look-up table for absorption coeffts + + ! Number of pressure and temperature points + integer :: npress = 0 + integer :: ntemp = 0 + ! Natural logarithm of first (lowest) pressure (Pa) and increment + real(jprb) :: log_pressure1, d_log_pressure + ! First temperature profile (K), dimensioned (npress) + real(jprb), allocatable :: temperature1(:) + ! Temperature increment (K) + real(jprb) :: d_temperature + + ! Look-up table for Planck function + + ! Number of entries + integer :: nplanck = 0 + ! Temperature of first element of look-up table and increment (K) + real(jprb), allocatable :: temperature1_planck + real(jprb), allocatable :: d_temperature_planck + ! Planck function (black body flux into a horizontal plane) in W + ! m-2, dimensioned (ng,nplanck) + real(jprb), allocatable :: planck_function(:,:) + + ! Normalized solar irradiance in each g point, dimensioned (ng) + real(jprb), allocatable :: norm_solar_irradiance(:) + + ! Normalized amplitude of variations in the solar irradiance + ! through the solar cycle in each g point, dimensioned (ng). + ! Since the user always provides the solar irradiance SI + ! integrated across the spectrum, this variable must sum to zero: + ! this ensures that the solar irradiance in each g-point is + ! SSI=SI*(norm_solar_irradiance + + ! A*norm_amplitude_solar_irradiance) for any A, where A denotes + ! the amplitude of deviations from the mean solar spectrum, + ! typically between -1.0 and 1.0 and provided by + ! single_level%solar_spectral_multiplier. + real(jprb), allocatable :: norm_amplitude_solar_irradiance(:) + + ! Rayleigh molar scattering coefficient in m2 mol-1 in each g + ! point + real(jprb), allocatable :: rayleigh_molar_scat(:) + + ! ! Spectral mapping of g points + + ! ! Number of wavenumber intervals + ! integer :: nwav = 0 + + ! Number of k terms / g points + integer :: ng = 0 + + ! Spectral definition describing bands and g points + type(spectral_definition_type) :: spectral_def + + ! Shortwave: true, longwave: false + logical :: is_sw + + contains + + procedure :: read => read_ckd_model + procedure :: read_spectral_solar_cycle +! Vectorized version of the optical depth look-up performs better on +! NEC, but slower on x86 +#ifdef DWD_VECTOR_OPTIMIZATIONS + procedure :: calc_optical_depth => calc_optical_depth_ckd_model_vec +#else + procedure :: calc_optical_depth => calc_optical_depth_ckd_model +#endif + procedure :: print => print_ckd_model + procedure :: calc_planck_function + procedure :: calc_incoming_sw +! procedure :: deallocate => deallocate_ckd_model + + end type ckd_model_type + + +contains + + !--------------------------------------------------------------------- + ! Read a complete ecCKD gas optics model from a NetCDF file + ! "filename" + subroutine read_ckd_model(this, filename, iverbose) + +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + !use radiation_io, only : nulerr, radiation_abort + use yomhook, only : lhook, dr_hook, jphook + + class(ckd_model_type), intent(inout) :: this + character(len=*), intent(in) :: filename + integer, optional, intent(in) :: iverbose + + type(netcdf_file) :: file + + real(jprb), allocatable :: pressure_lut(:) + real(jprb), allocatable :: temperature_full(:,:) + real(jprb), allocatable :: temperature_planck(:) + + character(len=512) :: constituent_id + + integer :: iverbose_local + + ! Loop counters + integer :: jgas, jjgas + + integer :: istart, inext, nchar, i_gas_code + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd:read_ckd_model',0,hook_handle) + + if (present(iverbose)) then + iverbose_local = iverbose + else + iverbose_local = 3 + end if + + call file%open(trim(filename), iverbose=iverbose_local) + + ! Read temperature and pressure coordinate variables + call file%get('pressure', pressure_lut) + this%log_pressure1 = log(pressure_lut(1)) + this%npress = size(pressure_lut) + this%d_log_pressure = log(pressure_lut(2)) - this%log_pressure1 + call file%get('temperature', temperature_full) + allocate(this%temperature1(this%npress)); + this%temperature1 = temperature_full(:,1) + this%d_temperature = temperature_full(1,2)-temperature_full(1,1) + this%ntemp = size(temperature_full,2) + deallocate(temperature_full) + + ! Read Planck function, or solar irradiance and Rayleigh + ! scattering coefficient + if (file%exists('solar_irradiance')) then + this%is_sw = .true. + call file%get('solar_irradiance', this%norm_solar_irradiance) + this%norm_solar_irradiance = this%norm_solar_irradiance & + & / sum(this%norm_solar_irradiance) + call file%get('rayleigh_molar_scattering_coeff', & + & this%rayleigh_molar_scat) + else + this%is_sw = .false. + call file%get('temperature_planck', temperature_planck) + this%nplanck = size(temperature_planck) + this%temperature1_planck = temperature_planck(1) + this%d_temperature_planck = temperature_planck(2) - temperature_planck(1) + deallocate(temperature_planck) + call file%get('planck_function', this%planck_function) + end if + + ! Read the spectral definition information into a separate + ! derived type + call this%spectral_def%read(file); + this%ng = this%spectral_def%ng + + ! Read gases + call file%get('n_gases', this%ngas) + allocate(this%single_gas(this%ngas)) + call file%get_global_attribute('constituent_id', constituent_id) + nchar = len(trim(constituent_id)) + istart = 1 + this%i_gas_mapping = 0 + do jgas = 1, this%ngas + if (jgas < this%ngas) then + inext = istart + scan(constituent_id(istart:nchar), ' ') + else + inext = nchar+2 + end if + ! Find gas code + i_gas_code = 0 + do jjgas = 1, NMaxGases + if (constituent_id(istart:inext-2) == trim(GasLowerCaseName(jjgas))) then + i_gas_code = jjgas + exit + end if + end do + ! if (i_gas_code == 0) then + ! write(nulerr,'(a,a,a)') '*** Error: Gas "', constituent_id(istart:inext-2), & + ! & '" not understood' + ! call radiation_abort('Radiation configuration error') + ! end if + this%i_gas_mapping(i_gas_code) = jgas; + call this%single_gas(jgas)%read(file, constituent_id(istart:inext-2), i_gas_code) + istart = inext + end do + + call file%close() + + if (lhook) call dr_hook('radiation_ecckd:read_ckd_model',1,hook_handle) + + end subroutine read_ckd_model + + !--------------------------------------------------------------------- + ! Print a description of the correlated k-distribution model to the + ! "nulout" unit + subroutine print_ckd_model(this) + + use radiation_io, only : nulout + use radiation_gas_constants + + class(ckd_model_type), intent(in) :: this + + integer :: jgas + + if (this%is_sw) then + write(nulout,'(a)',advance='no') 'ecCKD shortwave gas optics model: ' + else + write(nulout,'(a)',advance='no') 'ecCKD longwave gas optics model: ' + end if + + write(nulout,'(i0,a,i0,a,i0,a,i0,a)') & + & nint(this%spectral_def%wavenumber1(1)), '-', & + & nint(this%spectral_def%wavenumber2(size(this%spectral_def%wavenumber2))), & + & ' cm-1, ', this%ng, ' g-points in ', this%spectral_def%nband, ' bands' + write(nulout,'(a,i0,a,i0,a,i0,a)') ' Look-up table sizes: ', this%npress, ' pressures, ', & + & this%ntemp, ' temperatures, ', this%nplanck, ' planck-function entries' + write(nulout, '(a)') ' Gases:' + do jgas = 1,this%ngas + if (this%single_gas(jgas)%i_gas_code > 0) then + write(nulout, '(a,a,a)', advance='no') ' ', & + & trim(GasName(this%single_gas(jgas)%i_gas_code)), ': ' + else + write(nulout, '(a)', advance='no') ' Composite of well-mixed background gases: ' + end if + select case (this%single_gas(jgas)%i_conc_dependence) + case (IConcDependenceNone) + write(nulout, '(a)') 'no concentration dependence' + case (IConcDependenceLinear) + write(nulout, '(a)') 'linear concentration dependence' + case (IConcDependenceRelativeLinear) + write(nulout, '(a,e14.6)') 'linear concentration dependence relative to a mole fraction of ', & + & this%single_gas(jgas)%reference_mole_frac + case (IConcDependenceLUT) + write(nulout, '(a,i0,a,e14.6,a,e13.6)') 'look-up table with ', this%single_gas(jgas)%n_mole_frac, & + & ' log-spaced mole fractions in range ', exp(this%single_gas(jgas)%log_mole_frac1), & + & ' to ', exp(this%single_gas(jgas)%log_mole_frac1 & + & + this%single_gas(jgas)%n_mole_frac*this%single_gas(jgas)%d_log_mole_frac) + end select + end do + + end subroutine print_ckd_model + + + !--------------------------------------------------------------------- + ! Read the amplitude of the spectral variations associated with the + ! solar cycle and map to g-points + subroutine read_spectral_solar_cycle(this, filename, iverbose, use_updated_solar_spectrum) + +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + use radiation_io, only : nulout, nulerr, radiation_abort + use yomhook, only : lhook, dr_hook, jphook + + ! Reference total solar irradiance (W m-2) + real(jprb), parameter :: ReferenceTSI = 1361.0_jprb + + class(ckd_model_type), intent(inout) :: this + character(len=*), intent(in) :: filename + integer, optional, intent(in) :: iverbose + ! Do we update the mean solar spectral irradiance for each g-point + ! based on the contents of the file? + logical, optional, intent(in) :: use_updated_solar_spectrum + + type(netcdf_file) :: file + + ! Solar spectral irradiance, its amplitude and wavenumber + ! coordinate variable, read from NetCDF file + real(jprb), allocatable :: wavenumber(:) ! cm-1 + real(jprb), allocatable :: ssi(:) ! W m-2 cm + real(jprb), allocatable :: ssi_amplitude(:) ! W m-2 cm + + ! As above but on the wavenumber grid delimited by + ! this%wavenumber1 and this%wavenumber2 + real(jprb), allocatable :: ssi_grid(:) + real(jprb), allocatable :: ssi_amplitude_grid(:) + real(jprb), allocatable :: wavenumber_grid(:) + + ! Old normalized solar irradiance in case it gets changed and we + ! need to report the amplitude of the change + real(jprb), allocatable :: old_norm_solar_irradiance(:) + + real(jprb) :: dwav_grid + + ! Number of input wavenumbers, and number on ecCKD model's grid + integer :: nwav, nwav_grid + ! Corresponding loop indices + integer :: jwav, jwav_grid, jg + + integer :: iband + + integer :: iverbose_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd:read_spectral_solar_cycle',0,hook_handle) + + if (present(iverbose)) then + iverbose_local = iverbose + else + iverbose_local = 3 + end if + + call file%open(trim(filename), iverbose=iverbose_local) + + call file%get('wavenumber', wavenumber) + call file%get('mean_solar_spectral_irradiance', ssi) + call file%get('ssi_solar_cycle_amplitude', ssi_amplitude) + + call file%close() + + nwav = size(wavenumber) + + nwav_grid = size(this%spectral_def%wavenumber1) + allocate(ssi_grid(nwav_grid)) + allocate(ssi_amplitude_grid(nwav_grid)) + allocate(wavenumber_grid(nwav_grid)) + wavenumber_grid = 0.5_jprb * (this%spectral_def%wavenumber1+this%spectral_def%wavenumber2) + dwav_grid = this%spectral_def%wavenumber2(1)-this%spectral_def%wavenumber1(1) + + ssi_grid = 0.0_jprb + ssi_amplitude_grid = 0.0_jprb + + ! Interpolate input SSI to regular wavenumber grid + do jwav_grid = 1,nwav_grid + do jwav = 1,nwav-1 + if (wavenumber(jwav) < wavenumber_grid(jwav_grid) & + & .and. wavenumber(jwav+1) >= wavenumber_grid(jwav_grid)) then + ! Linear interpolation - this is not perfect + ssi_grid(jwav_grid) = (ssi(jwav)*(wavenumber(jwav+1)-wavenumber_grid(jwav_grid)) & + & +ssi(jwav+1)*(wavenumber_grid(jwav_grid)-wavenumber(jwav))) & + & * dwav_grid / (wavenumber(jwav+1)-wavenumber(jwav)) + ssi_amplitude_grid(jwav_grid) = (ssi_amplitude(jwav)*(wavenumber(jwav+1)-wavenumber_grid(jwav_grid)) & + & +ssi_amplitude(jwav+1)*(wavenumber_grid(jwav_grid)-wavenumber(jwav))) & + & * dwav_grid / (wavenumber(jwav+1)-wavenumber(jwav)) + exit + end if + end do + end do + + ! Optionally update the solar irradiances in each g-point, and the + ! spectral solar irradiance on the wavenumber grid corresponding + ! to gpoint_fraction + allocate(old_norm_solar_irradiance(nwav_grid)) + old_norm_solar_irradiance = this%norm_solar_irradiance + if (present(use_updated_solar_spectrum)) then + if (use_updated_solar_spectrum) then + if (.not. allocated(this%spectral_def%solar_spectral_irradiance)) then + write(nulerr,'(a)') 'Cannot use_updated_solar_spectrum unless gas optics model is from ecCKD >= 1.4' + call radiation_abort() + end if + this%norm_solar_irradiance = old_norm_solar_irradiance & + & * matmul(ssi_grid,this%spectral_def%gpoint_fraction) & + & / matmul(this%spectral_def%solar_spectral_irradiance,this%spectral_def%gpoint_fraction) + this%norm_solar_irradiance = this%norm_solar_irradiance / sum(this%norm_solar_irradiance) + this%spectral_def%solar_spectral_irradiance = ssi_grid + end if + end if + + ! Map on to g-points + this%norm_amplitude_solar_irradiance & + & = this%norm_solar_irradiance & + & * matmul(ssi_amplitude_grid, this%spectral_def%gpoint_fraction) & + & / matmul(ssi_grid,this%spectral_def%gpoint_fraction) + + ! Remove the mean from the solar-cycle fluctuations, since the + ! user will scale with total solar irradiance + this%norm_amplitude_solar_irradiance & + & = (this%norm_solar_irradiance+this%norm_amplitude_solar_irradiance) & + & / sum(this%norm_solar_irradiance+this%norm_amplitude_solar_irradiance) & + & - this%norm_solar_irradiance + + ! Print the spectral solar irradiance per g point, and solar cycle amplitude + if (iverbose_local >= 2) then + write(nulout,'(a,f6.1,a)') 'G-point, solar irradiance for nominal TSI = ', & + & ReferenceTSI, ' W m-2, solar cycle amplitude (at solar maximum), update to original solar irradiance' + iband = 0 + do jg = 1,this%ng + if (this%spectral_def%i_band_number(jg) > iband) then + iband = this%spectral_def%i_band_number(jg) + write(nulout, '(i2,f10.4,f7.3,a,f8.4,a,i2,a,f7.1,a,f7.1,a)') & + & jg, ReferenceTSI*this%norm_solar_irradiance(jg), & + & 100.0_jprb * this%norm_amplitude_solar_irradiance(jg) & + & / this%norm_solar_irradiance(jg), '% ', & + & 100.0_jprb * (this%norm_solar_irradiance(jg) & + & / old_norm_solar_irradiance(jg) - 1.0_jprb), '% Band ', iband, ': ', & + & this%spectral_def%wavenumber1_band(iband), '-', & + & this%spectral_def%wavenumber2_band(iband), ' cm-1' + else + write(nulout, '(i2,f10.4,f7.3,a,f8.4,a)') jg, ReferenceTSI*this%norm_solar_irradiance(jg), & + & 100.0_jprb * this%norm_amplitude_solar_irradiance(jg) & + & / this%norm_solar_irradiance(jg), '% ', & + & 100.0_jprb * (this%norm_solar_irradiance(jg) & + & / old_norm_solar_irradiance(jg) - 1.0_jprb), '%' + end if + end do + end if + + if (lhook) call dr_hook('radiation_ecckd:read_spectral_solar_cycle',1,hook_handle) + + end subroutine read_spectral_solar_cycle + + + !--------------------------------------------------------------------- + ! Compute layerwise optical depth for each g point for ncol columns + ! at nlev layers + subroutine calc_optical_depth_ckd_model(this, ncol, nlev, istartcol, iendcol, nmaxgas, & + & pressure_hl, temperature_fl, mole_fraction_fl, & + & optical_depth_fl, rayleigh_od_fl, opt_concentration_scaling) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_constants, only : AccelDueToGravity + + ! Input variables + + class(ckd_model_type), intent(in), target :: this + ! Number of columns, levels and input gases + integer, intent(in) :: ncol, nlev, nmaxgas, istartcol, iendcol + ! Pressure at half levels (Pa), dimensioned (ncol,nlev+1) + real(jprb), intent(in) :: pressure_hl(ncol,nlev+1) + ! Temperature at full levels (K), dimensioned (ncol,nlev) + real(jprb), intent(in) :: temperature_fl(istartcol:iendcol,nlev) + ! Gas mole fractions at full levels (mol mol-1), dimensioned (ncol,nlev,nmaxgas) + real(jprb), intent(in) :: mole_fraction_fl(ncol,nlev,nmaxgas) + ! Optional concentration scaling of each gas + real(jprb), optional, intent(in) :: opt_concentration_scaling(nmaxgas) + + ! Output variables + + ! Layer absorption optical depth for each g point + real(jprb), intent(out) :: optical_depth_fl(this%ng,nlev,istartcol:iendcol) + ! In the shortwave only, the Rayleigh scattering optical depth + real(jprb), optional, intent(out) :: rayleigh_od_fl(this%ng,nlev,istartcol:iendcol) + + ! Local variables + + real(jprb), pointer :: molar_abs(:,:,:), molar_abs_conc(:,:,:,:) + + ! Natural logarithm of pressure at full levels + real(jprb) :: log_pressure_fl(nlev) + + ! Optical depth of single gas at one point in space versus + ! spectral interval + !real(jprb) :: od_single_gas(this%ng) + + real(jprb) :: multiplier(nlev), simple_multiplier(nlev), global_multiplier, temperature1 + real(jprb) :: scaling + real(jprb) :: concentration_scaling(nmaxgas) + + ! Indices and weights in temperature, pressure and concentration interpolation + real(jprb) :: pindex1, tindex1, cindex1 + real(jprb) :: pw1(nlev), pw2(nlev), tw1(nlev), tw2(nlev), cw1(nlev), cw2(nlev) + integer :: ip1(nlev), it1(nlev), ic1(nlev) + + ! Natural logarithm of mole fraction at one point + real(jprb) :: log_conc + + ! Minimum mole fraction in look-up-table + real(jprb) :: mole_frac1 + + integer :: jcol, jlev, jgas, igascode + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd:calc_optical_depth',0,hook_handle) + + global_multiplier = 1.0_jprb / (AccelDueToGravity * 0.001_jprb * AirMolarMass) + concentration_scaling = 1.0_jprb + if (present(opt_concentration_scaling)) concentration_scaling = opt_concentration_scaling + + do jcol = istartcol,iendcol + + log_pressure_fl = log(0.5_jprb * (pressure_hl(jcol,1:nlev)+pressure_hl(jcol,2:nlev+1))) + + do jlev = 1,nlev + ! Find interpolation points in pressure + pindex1 = (log_pressure_fl(jlev)-this%log_pressure1) & + & / this%d_log_pressure + pindex1 = 1.0_jprb + max(0.0_jprb, min(pindex1, this%npress-1.0001_jprb)) + ip1(jlev) = int(pindex1) + pw2(jlev) = pindex1 - ip1(jlev) + pw1(jlev) = 1.0_jprb - pw2(jlev) + + ! Find interpolation points in temperature + temperature1 = pw1(jlev)*this%temperature1(ip1(jlev)) & + & + pw2(jlev)*this%temperature1(ip1(jlev)+1) + tindex1 = (temperature_fl(jcol,jlev) - temperature1) & + & / this%d_temperature + tindex1 = 1.0_jprb + max(0.0_jprb, min(tindex1, this%ntemp-1.0001_jprb)) + it1(jlev) = int(tindex1) + tw2(jlev) = tindex1 - it1(jlev) + tw1(jlev) = 1.0_jprb - tw2(jlev) + + ! Concentration multiplier + simple_multiplier(jlev) = global_multiplier & + & * (pressure_hl(jcol,jlev+1) - pressure_hl(jcol,jlev)) + end do + + optical_depth_fl(:,:,jcol) = 0.0_jprb + + do jgas = 1,this%ngas + + associate (single_gas => this%single_gas(jgas)) + igascode = this%single_gas(jgas)%i_gas_code + + select case (single_gas%i_conc_dependence) + + case (IConcDependenceLinear) + molar_abs => this%single_gas(jgas)%molar_abs + multiplier = simple_multiplier * mole_fraction_fl(jcol,:,igascode) + + multiplier = multiplier * concentration_scaling(igascode) + + do jlev = 1,nlev + optical_depth_fl(:,jlev,jcol) = optical_depth_fl(:,jlev,jcol) & + & + (multiplier(jlev)*tw1(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev))) & + & + (multiplier(jlev)*tw2(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)+1) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev)+1)) + end do + + case (IConcDependenceRelativeLinear) + molar_abs => this%single_gas(jgas)%molar_abs + + multiplier = simple_multiplier & + & * (mole_fraction_fl(jcol,:,igascode)*concentration_scaling(igascode) & + & - single_gas%reference_mole_frac) + + do jlev = 1,nlev + optical_depth_fl(:,jlev,jcol) = optical_depth_fl(:,jlev,jcol) & + & + (multiplier(jlev)*tw1(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev))) & + & + (multiplier(jlev)*tw2(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)+1) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev)+1)) + end do + + case (IConcDependenceNone) + ! Composite gases + molar_abs => this%single_gas(jgas)%molar_abs + do jlev = 1,nlev + optical_depth_fl(:,jlev,jcol) = optical_depth_fl(:,jlev,jcol) & + & + (simple_multiplier(jlev)*tw1(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev))) & + & + (simple_multiplier(jlev)*tw2(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)+1) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev)+1)) + end do + + case (IConcDependenceLUT) + + scaling = concentration_scaling(igascode) + + ! Logarithmic interpolation in concentration space + molar_abs_conc => this%single_gas(jgas)%molar_abs_conc + mole_frac1 = exp(single_gas%log_mole_frac1) + do jlev = 1,nlev + ! Take care of mole_fraction == 0 + log_conc = log(max(mole_fraction_fl(jcol,jlev,igascode)*scaling, mole_frac1)) + cindex1 = (log_conc - single_gas%log_mole_frac1) / single_gas%d_log_mole_frac + cindex1 = 1.0_jprb + max(0.0_jprb, min(cindex1, single_gas%n_mole_frac-1.0001_jprb)) + ic1(jlev) = int(cindex1) + cw2(jlev) = cindex1 - ic1(jlev) + cw1(jlev) = 1.0_jprb - cw2(jlev) + end do + ! od_single_gas = cw1 * (tw1 * (pw1 * molar_abs_conc(:,ip1,it1,ic1) & + ! & +pw2 * molar_abs_conc(:,ip1+1,it1,ic1)) & + ! & +tw2 * (pw1 * molar_abs_conc(:,ip1,it1+1,ic1) & + ! & +pw2 * molar_abs_conc(:,ip1+1,it1+1,ic1))) & + ! & +cw2 * (tw1 * (pw1 * molar_abs_conc(:,ip1,it1,ic1+1) & + ! & +pw2 * molar_abs_conc(:,ip1+1,it1,ic1+1)) & + ! & +tw2 * (pw1 * molar_abs_conc(:,ip1,it1+1,ic1+1) & + ! & +pw2 * molar_abs_conc(:,ip1+1,it1+1,ic1+1))) + do jlev = 1,nlev + optical_depth_fl(:,jlev,jcol) = optical_depth_fl(:,jlev,jcol) & + & + (simple_multiplier(jlev) * mole_fraction_fl(jcol,jlev,igascode) * scaling) * ( & + & (cw1(jlev) * tw1(jlev) * pw1(jlev)) * molar_abs_conc(:,ip1(jlev),it1(jlev),ic1(jlev)) & + & +(cw1(jlev) * tw1(jlev) * pw2(jlev)) * molar_abs_conc(:,ip1(jlev)+1,it1(jlev),ic1(jlev)) & + & +(cw1(jlev) * tw2(jlev) * pw1(jlev)) * molar_abs_conc(:,ip1(jlev),it1(jlev)+1,ic1(jlev)) & + & +(cw1(jlev) * tw2(jlev) * pw2(jlev)) * molar_abs_conc(:,ip1(jlev)+1,it1(jlev)+1,ic1(jlev)) & + & +(cw2(jlev) * tw1(jlev) * pw1(jlev)) * molar_abs_conc(:,ip1(jlev),it1(jlev),ic1(jlev)+1) & + & +(cw2(jlev) * tw1(jlev) * pw2(jlev)) * molar_abs_conc(:,ip1(jlev)+1,it1(jlev),ic1(jlev)+1) & + & +(cw2(jlev) * tw2(jlev) * pw1(jlev)) * molar_abs_conc(:,ip1(jlev),it1(jlev)+1,ic1(jlev)+1) & + & +(cw2(jlev) * tw2(jlev) * pw2(jlev)) * molar_abs_conc(:,ip1(jlev)+1,it1(jlev)+1,ic1(jlev)+1)) + end do + end select + + end associate + + end do + + ! Ensure the optical depth is not negative + optical_depth_fl(:,:,jcol) = max(0.0_jprb, optical_depth_fl(:,:,jcol)) + + ! Rayleigh scattering + if (this%is_sw .and. present(rayleigh_od_fl)) then + do jlev = 1,nlev + rayleigh_od_fl(:,jlev,jcol) = global_multiplier & + & * (pressure_hl(jcol,jlev+1) - pressure_hl(jcol,jlev)) * this%rayleigh_molar_scat + end do + end if + + end do + + if (lhook) call dr_hook('radiation_ecckd:calc_optical_depth',1,hook_handle) + + end subroutine calc_optical_depth_ckd_model + + + !--------------------------------------------------------------------- + ! Vectorized variant of above routine + subroutine calc_optical_depth_ckd_model_vec(this, ncol, nlev, istartcol, iendcol, nmaxgas, & + & pressure_hl, temperature_fl, mole_fraction_fl, & + & optical_depth_fl, rayleigh_od_fl, opt_concentration_scaling) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_constants, only : AccelDueToGravity + + ! Input variables + + class(ckd_model_type), intent(in), target :: this + ! Number of columns, levels and input gases + integer, intent(in) :: ncol, nlev, nmaxgas, istartcol, iendcol + ! Pressure at half levels (Pa), dimensioned (ncol,nlev+1) + real(jprb), intent(in) :: pressure_hl(ncol,nlev+1) + ! Temperature at full levels (K), dimensioned (ncol,nlev) + real(jprb), intent(in) :: temperature_fl(istartcol:iendcol,nlev) + ! Gas mole fractions at full levels (mol mol-1), dimensioned (ncol,nlev,nmaxgas) + real(jprb), intent(in) :: mole_fraction_fl(ncol,nlev,nmaxgas) + ! Optional concentration scaling of each gas + real(jprb), optional, intent(in) :: opt_concentration_scaling(nmaxgas) + + ! Output variables + + ! Layer absorption optical depth for each g point + real(jprb), intent(out) :: optical_depth_fl(this%ng,nlev,istartcol:iendcol) + ! In the shortwave only, the Rayleigh scattering optical depth + real(jprb), optional, intent(out) :: rayleigh_od_fl(this%ng,nlev,istartcol:iendcol) + + ! Local variables + + real(jprb), pointer :: molar_abs(:,:,:), molar_abs_conc(:,:,:,:) + + ! Natural logarithm of pressure at full levels + real(jprb) :: log_pressure_fl + + ! Optical depth of single gas at one point in space versus + ! spectral interval + !real(jprb) :: od_single_gas(this%ng) + + real(jprb) :: multiplier, simple_multiplier(ncol,nlev), global_multiplier, temperature1 + real(jprb) :: scaling + real(jprb) :: concentration_scaling(nmaxgas) + + ! Indices and weights in temperature, pressure and concentration interpolation + real(jprb) :: pindex1, tindex1, cindex1 + real(jprb) :: pw1(ncol,nlev), pw2(ncol,nlev), tw1(ncol,nlev), tw2(ncol,nlev), cw1(ncol,nlev), cw2(ncol,nlev) + integer :: ip1(ncol,nlev), it1(ncol,nlev), ic1(ncol,nlev) + + ! Natural logarithm of mole fraction at one point + real(jprb) :: log_conc + + ! Minimum mole fraction in look-up-table + real(jprb) :: mole_frac1 + + ! Layer absorption optical depth for each g point (memory layout adjusted to vectorization) + real(jprb) :: od_fl(ncol,this%ng,nlev) + + integer :: jcol, jlev, jgas, igascode, jg + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd:calc_optical_depth_vec',0,hook_handle) + + global_multiplier = 1.0_jprb / (AccelDueToGravity * 0.001_jprb * AirMolarMass) + concentration_scaling = 1._jprb + if (present(opt_concentration_scaling)) concentration_scaling = opt_concentration_scaling + + od_fl(:,:,:) = 0.0_jprb + + do jlev = 1,nlev + do jcol = istartcol,iendcol + + log_pressure_fl = log(0.5_jprb * (pressure_hl(jcol,jlev)+pressure_hl(jcol,jlev+1))) + + ! Find interpolation points in pressure + pindex1 = (log_pressure_fl-this%log_pressure1) & + & / this%d_log_pressure + pindex1 = 1.0_jprb + max(0.0_jprb, min(pindex1, this%npress-1.0001_jprb)) + ip1(jcol,jlev) = int(pindex1) + pw2(jcol,jlev) = pindex1 - ip1(jcol,jlev) + pw1(jcol,jlev) = 1.0_jprb - pw2(jcol,jlev) + + ! Find interpolation points in temperature + temperature1 = pw1(jcol,jlev)*this%temperature1(ip1(jcol,jlev)) & + & + pw2(jcol,jlev)*this%temperature1(ip1(jcol,jlev)+1) + tindex1 = (temperature_fl(jcol,jlev) - temperature1) & + & / this%d_temperature + tindex1 = 1.0_jprb + max(0.0_jprb, min(tindex1, this%ntemp-1.0001_jprb)) + it1(jcol,jlev) = int(tindex1) + tw2(jcol,jlev) = tindex1 - it1(jcol,jlev) + tw1(jcol,jlev) = 1.0_jprb - tw2(jcol,jlev) + + ! Concentration multiplier + simple_multiplier(jcol,jlev) = global_multiplier & + & * (pressure_hl(jcol,jlev+1) - pressure_hl(jcol,jlev)) + end do + end do + + do jgas = 1,this%ngas + + associate (single_gas => this%single_gas(jgas)) + igascode = this%single_gas(jgas)%i_gas_code + + select case (single_gas%i_conc_dependence) + + case (IConcDependenceLinear) + molar_abs => this%single_gas(jgas)%molar_abs + + do jlev = 1,nlev + do jg = 1, this%ng + do jcol = istartcol,iendcol + multiplier = simple_multiplier(jcol,jlev) * mole_fraction_fl(jcol,jlev,igascode) & + & * concentration_scaling(igascode) + + od_fl(jcol,jg,jlev) = od_fl(jcol,jg,jlev) & + & + (multiplier*tw1(jcol,jlev)) * (pw1(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev),it1(jcol,jlev)) & + & +pw2(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev)+1,it1(jcol,jlev))) & + & + (multiplier*tw2(jcol,jlev)) * (pw1(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev),it1(jcol,jlev)+1) & + & +pw2(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev)+1,it1(jcol,jlev)+1)) + end do + end do + end do + + case (IConcDependenceRelativeLinear) + molar_abs => this%single_gas(jgas)%molar_abs + + do jlev = 1,nlev + do jg = 1, this%ng + do jcol = istartcol,iendcol + multiplier = simple_multiplier(jcol,jlev) * (mole_fraction_fl(jcol,jlev,igascode) & + & * concentration_scaling(igascode) & + & - single_gas%reference_mole_frac) + + od_fl(jcol,jg,jlev) = od_fl(jcol,jg,jlev) & + & + (multiplier*tw1(jcol,jlev)) * (pw1(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev),it1(jcol,jlev)) & + & +pw2(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev)+1,it1(jcol,jlev))) & + & + (multiplier*tw2(jcol,jlev)) * (pw1(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev),it1(jcol,jlev)+1) & + & +pw2(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev)+1,it1(jcol,jlev)+1)) + end do + end do + end do + + case (IConcDependenceNone) + ! Composite gases + molar_abs => this%single_gas(jgas)%molar_abs + + do jlev = 1,nlev + do jg = 1, this%ng + do jcol = istartcol,iendcol + od_fl(jcol,jg,jlev) = od_fl(jcol,jg,jlev) & + & + (simple_multiplier(jcol,jlev)*tw1(jcol,jlev)) * & + & (pw1(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev),it1(jcol,jlev)) & + & +pw2(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev)+1,it1(jcol,jlev))) & + & + (simple_multiplier(jcol,jlev)*tw2(jcol,jlev)) * & + & (pw1(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev),it1(jcol,jlev)+1) & + & +pw2(jcol,jlev) * molar_abs(jg,ip1(jcol,jlev)+1,it1(jcol,jlev)+1)) + end do + end do + end do + + case (IConcDependenceLUT) + scaling = concentration_scaling(igascode) + ! Logarithmic interpolation in concentration space + molar_abs_conc => this%single_gas(jgas)%molar_abs_conc + mole_frac1 = exp(single_gas%log_mole_frac1) + + do jlev = 1,nlev + do jcol = istartcol,iendcol + ! Take care of mole_fraction == 0 + log_conc = log(max(mole_fraction_fl(jcol,jlev,igascode)*scaling, mole_frac1)) + cindex1 = (log_conc - single_gas%log_mole_frac1) / single_gas%d_log_mole_frac + cindex1 = 1.0_jprb + max(0.0_jprb, min(cindex1, single_gas%n_mole_frac-1.0001_jprb)) + ic1(jcol,jlev) = int(cindex1) + cw2(jcol,jlev) = cindex1 - ic1(jcol,jlev) + cw1(jcol,jlev) = 1.0_jprb - cw2(jcol,jlev) + end do + end do + + do jlev = 1,nlev + do jg = 1, this%ng +!NEC$ select_vector + do jcol = istartcol,iendcol + + od_fl(jcol,jg,jlev) = od_fl(jcol,jg,jlev) & + & + (simple_multiplier(jcol,jlev) * mole_fraction_fl(jcol,jlev,igascode) *scaling) * ( & + & (cw1(jcol,jlev) * tw1(jcol,jlev) * pw1(jcol,jlev)) * & + & molar_abs_conc(jg,ip1(jcol,jlev),it1(jcol,jlev),ic1(jcol,jlev)) & + & +(cw1(jcol,jlev) * tw1(jcol,jlev) * pw2(jcol,jlev)) * & + & molar_abs_conc(jg,ip1(jcol,jlev)+1,it1(jcol,jlev),ic1(jcol,jlev)) & + & +(cw1(jcol,jlev) * tw2(jcol,jlev) * pw1(jcol,jlev)) * & + & molar_abs_conc(jg,ip1(jcol,jlev),it1(jcol,jlev)+1,ic1(jcol,jlev)) & + & +(cw1(jcol,jlev) * tw2(jcol,jlev) * pw2(jcol,jlev)) * & + & molar_abs_conc(jg,ip1(jcol,jlev)+1,it1(jcol,jlev)+1,ic1(jcol,jlev)) & + & +(cw2(jcol,jlev) * tw1(jcol,jlev) * pw1(jcol,jlev)) * & + & molar_abs_conc(jg,ip1(jcol,jlev),it1(jcol,jlev),ic1(jcol,jlev)+1) & + & +(cw2(jcol,jlev) * tw1(jcol,jlev) * pw2(jcol,jlev)) * & + & molar_abs_conc(jg,ip1(jcol,jlev)+1,it1(jcol,jlev),ic1(jcol,jlev)+1) & + & +(cw2(jcol,jlev) * tw2(jcol,jlev) * pw1(jcol,jlev)) * & + & molar_abs_conc(jg,ip1(jcol,jlev),it1(jcol,jlev)+1,ic1(jcol,jlev)+1) & + & +(cw2(jcol,jlev) * tw2(jcol,jlev) * pw2(jcol,jlev)) * & + & molar_abs_conc(jg,ip1(jcol,jlev)+1,it1(jcol,jlev)+1,ic1(jcol,jlev)+1)) + end do + end do + end do + end select + + end associate + + ! Ensure the optical depth is not negative + do jcol = istartcol,iendcol + do jlev = 1,nlev + do jg = 1, this%ng + optical_depth_fl(jg,jlev,jcol) = max(0.0_jprb, od_fl(jcol,jg,jlev)) + end do + end do + end do + + ! Rayleigh scattering + if (this%is_sw .and. present(rayleigh_od_fl)) then + do jcol = istartcol,iendcol + do jlev = 1,nlev + do jg = 1, this%ng + rayleigh_od_fl(jg,jlev,jcol) = global_multiplier & + & * (pressure_hl(jcol,jlev+1) - pressure_hl(jcol,jlev)) * this%rayleigh_molar_scat(jg) + end do + end do + end do + end if + + end do + + if (lhook) call dr_hook('radiation_ecckd:calc_optical_depth_vec',1,hook_handle) + + end subroutine calc_optical_depth_ckd_model_vec + + + !--------------------------------------------------------------------- + ! Calculate the Planck function integrated across each of the g + ! points of this correlated k-distribution model, for a given + ! temperature, where Planck function is defined as the flux emitted + ! by a black body (rather than radiance) + subroutine calc_planck_function(this, nt, temperature, planck) + + class(ckd_model_type), intent(in) :: this + integer, intent(in) :: nt + real(jprb), intent(in) :: temperature(:) ! K + real(jprb), intent(out) :: planck(this%ng,nt) ! W m-2 + + real(jprb) :: tindex1, tw1, tw2 + integer :: it1, jt + + do jt = 1,nt + tindex1 = (temperature(jt) - this%temperature1_planck) & + & * (1.0_jprb / this%d_temperature_planck) + if (tindex1 >= 0) then + ! Normal interpolation, and extrapolation for high temperatures + tindex1 = 1.0_jprb + tindex1 + it1 = min(int(tindex1), this%nplanck-1) + tw2 = tindex1 - it1 + tw1 = 1.0_jprb - tw2 + planck(:,jt) = tw1 * this%planck_function(:,it1) & + & + tw2 * this%planck_function(:,it1+1) + else + ! Interpolate linearly to zero + planck(:,jt) = this%planck_function(:,1) & + & * (temperature(jt)/this%temperature1_planck) + end if + end do + + end subroutine calc_planck_function + + + !--------------------------------------------------------------------- + ! Return the spectral solar irradiance integrated over each g point + ! of a solar correlated k-distribution model, given the + ! total_solar_irradiance + subroutine calc_incoming_sw(this, total_solar_irradiance, & + & spectral_solar_irradiance, & + & solar_spectral_multiplier) + + use radiation_io, only : nulerr, radiation_abort + + class(ckd_model_type), intent(in) :: this + real(jprb), intent(in) :: total_solar_irradiance ! W m-2 + real(jprb), intent(inout) :: spectral_solar_irradiance(:,:) ! W m-2 + real(jprb), optional, intent(in) :: solar_spectral_multiplier + + if (.not. present(solar_spectral_multiplier)) then + spectral_solar_irradiance & + & = spread(total_solar_irradiance * this%norm_solar_irradiance, & + & 2, size(spectral_solar_irradiance,2)) + else if (allocated(this%norm_amplitude_solar_irradiance)) then + spectral_solar_irradiance & + & = spread(total_solar_irradiance * (this%norm_solar_irradiance & + & + solar_spectral_multiplier*this%norm_amplitude_solar_irradiance), & + & 2, size(spectral_solar_irradiance,2)) + else if (solar_spectral_multiplier == 0.0_jprb) then + spectral_solar_irradiance & + & = spread(total_solar_irradiance * this%norm_solar_irradiance, & + & 2, size(spectral_solar_irradiance,2)) + else + write(nulerr, '(a)') '*** Error in calc_incoming_sw: no information present on solar cycle' + call radiation_abort() + end if + + end subroutine calc_incoming_sw + +end module radiation_ecckd Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd_gas.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd_gas.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd_gas.F90 (revision 6016) @@ -0,0 +1,124 @@ +! radiation_ecckd_gas.F90 - type representing a single ecCKD gas +! +! (C) Copyright 2020- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +#include "ecrad_config.h" + +module radiation_ecckd_gas + + use parkind1, only : jprb + use radiation_gas_constants + + implicit none + + public + + ! Concentration dependence of individual gases + enum, bind(c) + enumerator :: IConcDependenceNone = 0, & + & IConcDependenceLinear, & + & IConcDependenceLUT, & + & IConcDependenceRelativeLinear + end enum + + !--------------------------------------------------------------------- + ! This derived type describes a correlated k-distribution + ! representation of an individual gas (including composite gases) + type ckd_gas_type + + ! Code identifying the gas, from the codes in the + ! radiation_gas_constants module + integer :: i_gas_code = -1 + + ! One of the IConcDependence* enumerators + integer :: i_conc_dependence + + ! Molar absorption coefficient in m2 mol-1. If + ! i_conc_dependence==IConcDependenceNone then it is the absorption + ! cross section per mole of dry air. If + ! conc_dependence==IConcDependenceLinear|IConcDependenceRelativeLinear, + ! it is the absorption cross section per mole of the gas in + ! question. It is dimensioned (g_point,pressure,temperature). + real(jprb), allocatable :: molar_abs(:,:,:) + + ! If i_conc_dependence==IConcDependenceLUT then we have an + ! additional dimension for concentration. It is dimensioned + ! (g_point,pressure,temperature,conc) + real(jprb), allocatable :: molar_abs_conc(:,:,:,:) + + ! If i_conc_dependence==IConcDependenceRelativeLinear then the + ! following reference concentration is subtracted from the actual + ! concentration before the result is multiplied by the mass + ! absorption coefficient + real(jprb) :: reference_mole_frac = 0.0_jprb + + ! Mole fraction coordinate variable if + ! i_conc_dependence==IConcDependenceLUT + real(jprb) :: log_mole_frac1 = 0.0_jprb, d_log_mole_frac = 1.0_jprb + integer :: n_mole_frac = 0 + + contains + + procedure :: read => read_ckd_gas +! procedure :: deallocate => deallocate_ckd_gas + + end type ckd_gas_type + +contains + + !--------------------------------------------------------------------- + ! Read information about the representation of a single gas from a + ! NetCDF file, identifying it with code i_gas_code + subroutine read_ckd_gas(this, file, gas_name, i_gas_code) + +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + + class(ckd_gas_type), intent(inout) :: this + type(netcdf_file), intent(inout) :: file + character(len=*), intent(in) :: gas_name + integer, intent(in) :: i_gas_code + + ! Local storage for mole fraction coordinate variable + real(jprb), allocatable :: mole_fraction(:) + + this%i_gas_code = i_gas_code + + call file%get(gas_name // "_conc_dependence_code", this%i_conc_dependence) + if (this%i_conc_dependence == IConcDependenceLut) then + call file%get(gas_name // "_molar_absorption_coeff", & + & this%molar_abs_conc) + call file%get(gas_name // "_mole_fraction", mole_fraction) + this%log_mole_frac1 = log(mole_fraction(1)) + this%n_mole_frac = size(mole_fraction) + this%d_log_mole_frac = (log(mole_fraction(size(mole_fraction))) & + & - this%log_mole_frac1) / (this%n_mole_frac-1) + deallocate(mole_fraction) + else + call file%get(gas_name // "_molar_absorption_coeff", & + & this%molar_abs) + end if + + if (this%i_conc_dependence == IConcDependenceRelativeLinear) then + call file%get(gas_name // "_reference_mole_fraction", & + & this%reference_mole_frac) + end if + + end subroutine read_ckd_gas + +end module radiation_ecckd_gas Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd_interface.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ecckd_interface.F90 (revision 6016) @@ -0,0 +1,343 @@ +! radiation_ecckd_interface.F90 - Interface to ecCKD gas optics model +! +! (C) Copyright 2020- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_ecckd_interface + + implicit none + + public :: setup_gas_optics, set_gas_units, gas_optics !, planck_function + +contains + + !--------------------------------------------------------------------- + ! Setup the ecCKD generalized gas optics model + subroutine setup_gas_optics(config) + + use parkind1, only : jprb + use radiation_config + use yomhook, only : lhook, dr_hook, jphook + + type(config_type), intent(inout), target :: config + + integer :: jj + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd_interface:setup_gas_optics',0,hook_handle) + + if (config%do_sw .and. config%i_gas_model_sw == IGasModelECCKD) then + + ! Read shortwave ecCKD gas optics NetCDF file + call config%gas_optics_sw%read(trim(config%gas_optics_sw_file_name), & + & config%iverbosesetup) + + ! Copy over relevant properties + config%n_g_sw = config%gas_optics_sw%ng + + if (config%do_cloud_aerosol_per_sw_g_point) then + ! Bands and g points are the same + config%n_bands_sw = config%n_g_sw + else + ! Bands are groups of g points and span a continuous region of + ! wavenumber space + config%n_bands_sw = config%gas_optics_sw%spectral_def%nband + end if + + allocate(config%i_band_from_g_sw (config%n_g_sw)) + allocate(config%i_band_from_reordered_g_sw(config%n_g_sw)) + allocate(config%i_g_from_reordered_g_sw (config%n_g_sw)) + + if (config%do_cloud_aerosol_per_sw_g_point) then + config%i_band_from_g_sw = [ (jj, jj = 1,config%n_g_sw) ] + config%i_band_from_reordered_g_sw = [ (jj, jj = 1,config%n_g_sw) ] + else + config%i_band_from_g_sw & + & = config%gas_optics_sw%spectral_def%i_band_number + config%i_band_from_reordered_g_sw & + & = config%gas_optics_sw%spectral_def%i_band_number + end if + config%i_g_from_reordered_g_sw = [ (jj, jj = 1,config%n_g_sw) ] + + if (config%iverbosesetup >= 2) then + call config%gas_optics_sw%print() + end if + + ! Override solar spectral irradiance, if filename provided + if (config%use_spectral_solar_cycle) then + call config%gas_optics_sw%read_spectral_solar_cycle(config%ssi_file_name, & + & config%iverbosesetup, config%use_updated_solar_spectrum) + end if + + end if + + if (config%do_lw .and. config%i_gas_model_lw == IGasModelECCKD) then + + ! Read longwave ecCKD gas optics NetCDF file + call config%gas_optics_lw%read(trim(config%gas_optics_lw_file_name), & + & config%iverbosesetup) + + ! Copy over relevant properties + config%n_g_lw = config%gas_optics_lw%ng + + if (config%do_cloud_aerosol_per_lw_g_point) then + ! Bands and g points are the same + config%n_bands_lw = config%n_g_lw + else + ! Bands are groups of g points and span a continuous region of + ! wavenumber space + config%n_bands_lw = config%gas_optics_lw%spectral_def%nband + end if + + allocate(config%i_band_from_g_lw (config%n_g_lw)) + allocate(config%i_band_from_reordered_g_lw(config%n_g_lw)) + allocate(config%i_g_from_reordered_g_lw (config%n_g_lw)) + + if (config%do_cloud_aerosol_per_lw_g_point) then + config%i_band_from_g_lw = [ (jj, jj = 1,config%n_g_lw) ] + config%i_band_from_reordered_g_lw = [ (jj, jj = 1,config%n_g_lw) ] + else + config%i_band_from_g_lw & + & = config%gas_optics_lw%spectral_def%i_band_number + config%i_band_from_reordered_g_lw & + & = config%gas_optics_lw%spectral_def%i_band_number + end if + config%i_g_from_reordered_g_lw = [ (jj, jj = 1,config%n_g_lw) ] + + if (config%iverbosesetup >= 2) then + call config%gas_optics_lw%print() + end if + + end if + + ! The i_spec_* variables are used solely for storing spectral + ! data, and this can either be by band or by g-point + if (config%do_save_spectral_flux) then + if (config%do_save_gpoint_flux) then + config%n_spec_sw = config%n_g_sw + config%n_spec_lw = config%n_g_lw + config%i_spec_from_reordered_g_sw => config%i_g_from_reordered_g_sw + config%i_spec_from_reordered_g_lw => config%i_g_from_reordered_g_lw + else + config%n_spec_sw = config%n_bands_sw + config%n_spec_lw = config%n_bands_lw + config%i_spec_from_reordered_g_sw => config%i_band_from_reordered_g_sw + config%i_spec_from_reordered_g_lw => config%i_band_from_reordered_g_lw + end if + else + config%n_spec_sw = 0 + config%n_spec_lw = 0 + nullify(config%i_spec_from_reordered_g_sw) + nullify(config%i_spec_from_reordered_g_lw) + end if + + if (lhook) call dr_hook('radiation_ecckd_interface:setup_gas_optics',1,hook_handle) + + end subroutine setup_gas_optics + + + !--------------------------------------------------------------------- + ! Scale gas mixing ratios according to required units + subroutine set_gas_units(gas) + + use radiation_gas, only : gas_type, IVolumeMixingRatio + use yomhook, only : lhook, dr_hook, jphook + + type(gas_type), intent(inout) :: gas + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd_interface:set_gas_units',0,hook_handle) + + call gas%set_units(IVolumeMixingRatio) + + if (lhook) call dr_hook('radiation_ecckd_interface:set_gas_units',1,hook_handle) + + end subroutine set_gas_units + + + !--------------------------------------------------------------------- + ! Compute gas optical depths, shortwave scattering, Planck function + ! and incoming shortwave radiation at top-of-atmosphere + subroutine gas_optics(ncol,nlev,istartcol,iendcol, & + & config, single_level, thermodynamics, gas, & + & od_lw, od_sw, ssa_sw, lw_albedo, planck_hl, lw_emission, & + & incoming_sw) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config, only : config_type, IGasModelECCKD + use radiation_thermodynamics, only : thermodynamics_type + use radiation_single_level, only : single_level_type + use radiation_gas_constants, only : NMaxGases + use radiation_gas + + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: istartcol, iendcol ! range of cols to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type),intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + + ! Longwave albedo of the surface + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), & + & intent(in), optional :: lw_albedo + + ! Gaseous layer optical depth in longwave and shortwave, and + ! shortwave single scattering albedo (i.e. fraction of extinction + ! due to Rayleigh scattering) at each g-point + real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol), intent(out) :: & + & od_lw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(out) :: & + & od_sw, ssa_sw + + ! The Planck function (emitted flux from a black body) at half + ! levels at each longwave g-point + real(jprb), dimension(config%n_g_lw,nlev+1,istartcol:iendcol), & + & intent(out), optional :: planck_hl + ! Planck function for the surface (W m-2) + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), & + & intent(out), optional :: lw_emission + + ! The incoming shortwave flux into a plane perpendicular to the + ! incoming radiation at top-of-atmosphere in each of the shortwave + ! g-points + real(jprb), dimension(config%n_g_sw,istartcol:iendcol), & + & intent(out), optional :: incoming_sw + + ! Temperature at full levels (K) + real(jprb) :: temperature_fl(istartcol:iendcol,nlev) + + real(jprb) :: concentration_scaling(NMaxGases) + + logical :: is_volume_mixing_ratio + + integer :: jcol, jlev, jg + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd_interface:gas_optics',0,hook_handle) + + !temperature_fl(istartcol:iendcol,:) & + ! & = 0.5_jprb * (thermodynamics%temperature_hl(istartcol:iendcol,1:nlev) & + ! & +thermodynamics%temperature_hl(istartcol:iendcol,2:nlev+1)) + + temperature_fl(istartcol:iendcol,:) & + & = (thermodynamics%temperature_hl(istartcol:iendcol,1:nlev) & + & *thermodynamics%pressure_hl(istartcol:iendcol,1:nlev) & + & +thermodynamics%temperature_hl(istartcol:iendcol,2:nlev+1) & + & *thermodynamics%pressure_hl(istartcol:iendcol,2:nlev+1)) & + & / (thermodynamics%pressure_hl(istartcol:iendcol,1:nlev) & + & +thermodynamics%pressure_hl(istartcol:iendcol,2:nlev+1)) + + ! Check that the gas concentrations are stored in volume mixing + ! ratio with no scaling; if not, return a vector of scalings + call gas%assert_units(IVolumeMixingRatio, scale_factor=1.0_jprb, & + & istatus=is_volume_mixing_ratio) + if (.not. is_volume_mixing_ratio) then + call gas%get_scaling(IVolumeMixingRatio, concentration_scaling) + else + concentration_scaling = 1.0_jprb + end if + + if (config%do_sw .and. config%i_gas_model_sw == IGasModelECCKD) then + + if (is_volume_mixing_ratio) then + call config%gas_optics_sw%calc_optical_depth(ncol,nlev,istartcol,iendcol, & + & NMaxGases, thermodynamics%pressure_hl, & + & temperature_fl, gas%mixing_ratio, & + & od_sw, rayleigh_od_fl=ssa_sw) + else + call config%gas_optics_sw%calc_optical_depth(ncol,nlev,istartcol,iendcol, & + & NMaxGases, thermodynamics%pressure_hl, & + & temperature_fl, gas%mixing_ratio, & + & od_sw, rayleigh_od_fl=ssa_sw, opt_concentration_scaling=concentration_scaling) + end if + + ! At this point od_sw = absorption optical depth and ssa_sw = + ! rayleigh optical depth: convert to total optical depth and + ! single-scattering albedo + do jcol = istartcol,iendcol + do jlev = 1, nlev + do jg = 1, config%n_g_sw + od_sw(jg,jlev,jcol) = od_sw(jg,jlev,jcol) + ssa_sw(jg,jlev,jcol) + ssa_sw(jg,jlev,jcol) = ssa_sw(jg,jlev,jcol) / od_sw(jg,jlev,jcol) + end do + end do + end do + + if (present(incoming_sw)) then + if (single_level%spectral_solar_cycle_multiplier == 0.0_jprb) then + call config%gas_optics_sw%calc_incoming_sw(single_level%solar_irradiance, & + & incoming_sw) + else + call config%gas_optics_sw%calc_incoming_sw(single_level%solar_irradiance, & + & incoming_sw, single_level%spectral_solar_cycle_multiplier) + end if + end if + + end if + + if (config%do_lw .and. config%i_gas_model_lw == IGasModelECCKD) then + + if (is_volume_mixing_ratio) then + call config%gas_optics_lw%calc_optical_depth(ncol,nlev,istartcol,iendcol, & + & NMaxGases, thermodynamics%pressure_hl, & + & temperature_fl, gas%mixing_ratio, & + & od_lw) + else + call config%gas_optics_lw%calc_optical_depth(ncol,nlev,istartcol,iendcol, & + & NMaxGases, thermodynamics%pressure_hl, & + & temperature_fl, gas%mixing_ratio, & + & od_lw, opt_concentration_scaling=concentration_scaling) + end if + + ! Calculate the Planck function for each g point + do jcol = istartcol,iendcol + call config%gas_optics_lw%calc_planck_function(nlev+1, & + & thermodynamics%temperature_hl(jcol,:), planck_hl(:,:,jcol)) + end do + call config%gas_optics_lw%calc_planck_function(iendcol+1-istartcol, & + & single_level%skin_temperature(istartcol:iendcol), & + & lw_emission(:,:)) +!NEC$ forced_collapse + lw_emission = lw_emission * (1.0_jprb - lw_albedo) + + end if + + if (lhook) call dr_hook('radiation_ecckd_interface:gas_optics',1,hook_handle) + + end subroutine gas_optics + + ! !--------------------------------------------------------------------- + ! ! Externally facing function for computing the Planck function + ! ! without reference to any gas profile; typically this would be used + ! ! for computing the emission by a surface. + ! subroutine planck_function(config, temperature, planck_surf) + + ! use parkind1, only : jprb + ! use radiation_config, only : config_type + + ! type(config_type), intent(in) :: config + ! real(jprb), intent(in) :: temperature + + ! ! Planck function of the surface (W m-2) + ! real(jprb), dimension(config%n_g_lw), intent(out) :: planck_surf + + ! end subroutine planck_function + +end module radiation_ecckd_interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_flux.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_flux.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_flux.F90 (revision 6016) @@ -0,0 +1,1092 @@ +! This file has been modified for the use in ICON + +! radiation_flux.F90 - Derived type to store the output fluxes +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-09-08 R. Hogan Store g-point fluxes +! 2017-10-23 R. Hogan Renamed single-character variables +! 2019-01-08 R. Hogan Added "indexed_sum_profile" +! 2019-01-14 R. Hogan out_of_physical_bounds calls routine in radiation_config +! 2021-01-20 R. Hogan Added heating_rate_out_of_physical_bounds function +! 2022-12-07 R. Hogan Added top-of-atmosphere spectral output + +#include "ecrad_config.h" + +module radiation_flux + + use parkind1, only : jprb + + implicit none + public + + !--------------------------------------------------------------------- + ! This derived type contains the output from the radiation + ! calculation. Currently this is solely flux profiles, but in + ! future surface fluxes in each band may be stored in order that the + ! calling program can compute surface-radiation such as + ! photosynthetically active radiation and UV index. + type flux_type + ! All the following are broad-band fluxes in W m-2 with + ! dimensions (ncol,nlev+1). Note that only those fluxes that are + ! requested will be used, so clear-sky and direct-beam arrays may + ! not be allocated + real(jprb), allocatable, dimension(:,:) :: & + & lw_up, lw_dn, & ! Upwelling and downwelling longwave + & sw_up, sw_dn, & ! Upwelling and downwelling shortwave + & sw_dn_direct, & ! Direct-beam shortwave into a horizontal plane + & lw_up_clear, lw_dn_clear, & ! Clear-sky quantities... + & sw_up_clear, sw_dn_clear, & + & sw_dn_direct_clear + ! As above but fluxes in each spectral band in W m-2 with + ! dimensions (nband,ncol,nlev+1). These are only allocated if + ! config%do_save_spectral_flux==.true. + real(jprb), allocatable, dimension(:,:,:) :: & + & lw_up_band, lw_dn_band, & ! Upwelling and downwelling longwave + & sw_up_band, sw_dn_band, & ! Upwelling and downwelling shortwave + & sw_dn_direct_band, & ! Direct-beam shortwave + & lw_up_clear_band, lw_dn_clear_band, & ! Clear-sky quantities... + & sw_up_clear_band, sw_dn_clear_band, & + & sw_dn_direct_clear_band + ! Surface downwelling quantities at each g point, dimensioned + ! (ng,ncol), that are always saved by the solver, except for the + ! clear-sky ones that are only produced if + ! config%do_clear==.true. + real(jprb), allocatable, dimension(:,:) :: & + & lw_dn_surf_g, lw_dn_surf_clear_g, & + & sw_dn_diffuse_surf_g, sw_dn_direct_surf_g, & + & sw_dn_diffuse_surf_clear_g, sw_dn_direct_surf_clear_g + ! Top-of-atmosphere quantities at each g point, dimensioned + ! (ng,ncol), that are always saved by the solver, except for the + ! clear-sky ones that are only produced if + ! config%do_clear==.true. + real(jprb), allocatable, dimension(:,:) :: & + & lw_up_toa_g, lw_up_toa_clear_g, & + & sw_dn_toa_g, sw_up_toa_g, sw_up_toa_clear_g + ! Shortwave downwelling spectral fluxes in W m-2 at the surface, + ! from which quantities such as photosynthetically active and UV + ! radiation can be computed. Only allocated if + ! config%do_surface_sw_spectral_flux==.true. Note that the + ! clear-sky quantities are only computed if + ! config%do_clear==.true., but direct fluxes are computed whether + ! or not do_direct==.true.. The dimensions are (nband,ncol). + real(jprb), allocatable, dimension(:,:) :: & + & sw_dn_surf_band, sw_dn_direct_surf_band, & + & sw_dn_surf_clear_band, sw_dn_direct_surf_clear_band + ! Top-of-atmosphere spectral fluxes in W m-2. Only allocated if + ! config%do_toa_spectral_flux=.true.. Note that the clear-sky + ! quantities are only computed if config%do_clear==.true.. The + ! dimensions are (nband,ncol). + real(jprb), allocatable, dimension(:,:) :: & + & lw_up_toa_band, lw_up_toa_clear_band, & + & sw_dn_toa_band, sw_up_toa_band, sw_up_toa_clear_band + ! Surface downwelling fluxes in W m-2 at the spectral resolution + ! needed by any subsequent canopy radiative transfer. If + ! config%use_canopy_full_spectrum_[sw|lw] then these will be at + ! g-point resolution; otherwise they will be at + ! config%n_albedo_bands and config%n_emiss_bands resolution. + real(jprb), allocatable, dimension(:,:) :: & + & lw_dn_surf_canopy, & + & sw_dn_diffuse_surf_canopy, sw_dn_direct_surf_canopy + + ! Diagnosed cloud cover from the short- and long-wave solvers + real(jprb), allocatable, dimension(:) :: & + & cloud_cover_lw, cloud_cover_sw + ! Longwave derivatives needed by Hogan and Bozzo (2015) method + ! for approximate longwave updates in between the full radiation + ! calls: rate of change of upwelling broad-band flux with respect + ! to surface value, dimensioned (ncol,nlev+1) + real(jprb), allocatable, dimension(:,:) :: & + & lw_derivatives + + contains + procedure :: allocate => allocate_flux_type + procedure :: deallocate => deallocate_flux_type + procedure :: calc_surface_spectral + procedure :: calc_toa_spectral + procedure :: out_of_physical_bounds + procedure :: heating_rate_out_of_physical_bounds +#ifdef _OPENACC + procedure :: update_host + procedure :: update_device +#endif + end type flux_type + +! Added for DWD (2020) +#ifdef DWD_VECTOR_OPTIMIZATIONS + logical, parameter :: use_indexed_sum_vec = .true. +#else + logical, parameter :: use_indexed_sum_vec = .false. +#endif + +contains + + !--------------------------------------------------------------------- + ! Allocate arrays for flux profiles, using config to define which + ! fluxes are needed. The arrays are dimensioned for columns between + ! istartcol, iendcol and levels from 1 to nlev+1 + subroutine allocate_flux_type(this, config, istartcol, iendcol, nlev) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type + + integer, intent(in) :: istartcol, iendcol, nlev + class(flux_type), intent(inout) :: this + type(config_type), intent(in) :: config + + integer :: jcol + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_flux:allocate',0,hook_handle) + + ! Allocate longwave arrays + if (config%do_lw) then + allocate(this%lw_up(istartcol:iendcol,nlev+1)) + allocate(this%lw_dn(istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%lw_up, this%lw_dn) ASYNC(1) + if (config%do_clear) then + allocate(this%lw_up_clear(istartcol:iendcol,nlev+1)) + allocate(this%lw_dn_clear(istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%lw_up_clear, this%lw_dn_clear) ASYNC(1) + end if + + if (config%do_save_spectral_flux) then + if (config%n_spec_lw == 0) then + write(nulerr,'(a)') '*** Error: number of LW spectral points to save not yet defined ' & + & // 'so cannot allocate spectral flux arrays' + call radiation_abort() + end if + + allocate(this%lw_up_band(config%n_spec_lw,istartcol:iendcol,nlev+1)) + allocate(this%lw_dn_band(config%n_spec_lw,istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%lw_up_band, this%lw_dn_band) ASYNC(1) + if (config%do_clear) then + allocate(this%lw_up_clear_band(config%n_spec_lw, & + & istartcol:iendcol,nlev+1)) + allocate(this%lw_dn_clear_band(config%n_spec_lw, & + & istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%lw_up_clear_band, this%lw_dn_clear_band) & + !$ACC ASYNC(1) + end if + end if + + if (config%do_lw_derivatives) then + allocate(this%lw_derivatives(istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%lw_derivatives) ASYNC(1) + end if + + if (config%do_toa_spectral_flux) then + if (config%n_bands_lw == 0) then + write(nulerr,'(a)') '*** Error: number of LW bands not yet defined ' & + & // 'so cannot allocate TOA spectral flux arrays' + call radiation_abort() + end if + allocate(this%lw_up_toa_band(config%n_bands_lw, istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%lw_up_toa_band) ASYNC(1) + if (config%do_clear) then + allocate(this%lw_up_toa_clear_band(config%n_bands_lw, istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%lw_up_toa_clear_band) ASYNC(1) + end if + end if + + ! Allocate g-point downwelling fluxes at surface, and TOA fluxes + allocate(this%lw_dn_surf_g(config%n_g_lw,istartcol:iendcol)) + allocate(this%lw_up_toa_g (config%n_g_lw,istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%lw_dn_surf_g, this%lw_up_toa_g) ASYNC(1) + if (config%do_clear) then + allocate(this%lw_dn_surf_clear_g(config%n_g_lw,istartcol:iendcol)) + allocate(this%lw_up_toa_clear_g (config%n_g_lw,istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%lw_dn_surf_clear_g, this%lw_up_toa_clear_g) ASYNC(1) + end if + + if (config%do_canopy_fluxes_lw) then + ! Downward fluxes at top of canopy at the spectral resolution + ! used in the canopy radiative transfer scheme + allocate(this%lw_dn_surf_canopy(config%n_canopy_bands_lw,istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%lw_dn_surf_canopy) ASYNC(1) + end if + end if + + ! Allocate shortwave arrays + if (config%do_sw) then + allocate(this%sw_up(istartcol:iendcol,nlev+1)) + allocate(this%sw_dn(istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%sw_up, this%sw_dn) ASYNC(1) + if (config%do_sw_direct) then + allocate(this%sw_dn_direct(istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%sw_dn_direct) ASYNC(1) + end if + if (config%do_clear) then + allocate(this%sw_up_clear(istartcol:iendcol,nlev+1)) + allocate(this%sw_dn_clear(istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%sw_up_clear, this%sw_dn_clear) ASYNC(1) + if (config%do_sw_direct) then + allocate(this%sw_dn_direct_clear(istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%sw_dn_direct_clear) ASYNC(1) + end if + end if + + if (config%do_save_spectral_flux) then + if (config%n_spec_sw == 0) then + write(nulerr,'(a)') '*** Error: number of SW spectral points to save not yet defined ' & + & // 'so cannot allocate spectral flux arrays' + call radiation_abort() + end if + + allocate(this%sw_up_band(config%n_spec_sw,istartcol:iendcol,nlev+1)) + allocate(this%sw_dn_band(config%n_spec_sw,istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%sw_up_band, this%sw_dn_band) ASYNC(1) + + if (config%do_sw_direct) then + allocate(this%sw_dn_direct_band(config%n_spec_sw, & + & istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%sw_dn_direct_band) ASYNC(1) + end if + if (config%do_clear) then + allocate(this%sw_up_clear_band(config%n_spec_sw, & + & istartcol:iendcol,nlev+1)) + allocate(this%sw_dn_clear_band(config%n_spec_sw, & + & istartcol:iendcol,nlev+1)) + !$ACC ENTER DATA CREATE(this%sw_up_clear_band, this%sw_dn_clear_band) & + !$ACC ASYNC(1) + if (config%do_sw_direct) then + allocate(this%sw_dn_direct_clear_band(config%n_spec_sw, & + & istartcol:iendcol, nlev+1)) + !$ACC ENTER DATA CREATE(this%sw_dn_direct_clear_band) ASYNC(1) + end if + end if + end if + + if (config%do_surface_sw_spectral_flux) then + if (config%n_bands_sw == 0) then + write(nulerr,'(a)') '*** Error: number of SW bands not yet defined ' & + & // 'so cannot allocate TOA spectral flux arrays' + call radiation_abort() + end if + allocate(this%sw_dn_surf_band(config%n_bands_sw,istartcol:iendcol)) + allocate(this%sw_dn_direct_surf_band(config%n_bands_sw,istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%sw_dn_surf_band, this%sw_dn_direct_surf_band) & + !$ACC ASYNC(1) + if (config%do_clear) then + allocate(this%sw_dn_surf_clear_band(config%n_bands_sw, & + & istartcol:iendcol)) + allocate(this%sw_dn_direct_surf_clear_band(config%n_bands_sw, & + & istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%sw_dn_surf_clear_band, & + !$ACC this%sw_dn_direct_surf_clear_band) ASYNC(1) + end if + end if + + if (config%do_toa_spectral_flux) then + if (config%n_bands_sw == 0) then + write(nulerr,'(a)') '*** Error: number of SW bands not yet defined ' & + & // 'so cannot allocate surface spectral flux arrays' + call radiation_abort() + end if + allocate(this%sw_dn_toa_band(config%n_bands_sw, istartcol:iendcol)) + allocate(this%sw_up_toa_band(config%n_bands_sw, istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%sw_dn_toa_band, this%sw_up_toa_band) ASYNC(1) + if (config%do_clear) then + allocate(this%sw_up_toa_clear_band(config%n_bands_sw, istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%sw_up_toa_clear_band) ASYNC(1) + end if + end if + + ! Allocate g-point downwelling fluxes at surface, and TOA fluxes + allocate(this%sw_dn_diffuse_surf_g(config%n_g_sw,istartcol:iendcol)) + allocate(this%sw_dn_direct_surf_g (config%n_g_sw,istartcol:iendcol)) + allocate(this%sw_dn_toa_g (config%n_g_sw,istartcol:iendcol)) + allocate(this%sw_up_toa_g (config%n_g_sw,istartcol:iendcol)) + !$ACC ENTER DATA & + !$ACC CREATE(this%sw_dn_diffuse_surf_g,this%sw_dn_direct_surf_g) & + !$ACC CREATE(this%sw_dn_toa_g,this%sw_up_toa_g) & + !$ACC ASYNC(1) + if (config%do_clear) then + allocate(this%sw_dn_diffuse_surf_clear_g(config%n_g_sw,istartcol:iendcol)) + allocate(this%sw_dn_direct_surf_clear_g (config%n_g_sw,istartcol:iendcol)) + allocate(this%sw_up_toa_clear_g (config%n_g_sw,istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%sw_dn_diffuse_surf_clear_g, & + !$ACC this%sw_dn_direct_surf_clear_g, this%sw_up_toa_clear_g) ASYNC(1) + end if + + if (config%do_canopy_fluxes_sw) then + ! Downward fluxes at top of canopy at the spectral resolution + ! used in the canopy radiative transfer scheme + allocate(this%sw_dn_diffuse_surf_canopy(config%n_canopy_bands_sw,istartcol:iendcol)) + allocate(this%sw_dn_direct_surf_canopy (config%n_canopy_bands_sw,istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%sw_dn_diffuse_surf_canopy, & + !$ACC this%sw_dn_direct_surf_canopy) ASYNC(1) + end if + end if + + ! Allocate cloud cover arrays + allocate(this%cloud_cover_lw(istartcol:iendcol)) + allocate(this%cloud_cover_sw(istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%cloud_cover_lw, this%cloud_cover_sw) ASYNC(1) + + !$ACC WAIT ! ACCWA (nvhpc 22.7) crashes otherwise + + ! Some solvers may not write to cloud cover, so we initialize to + ! an unphysical value + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this) ASYNC(1) + !$ACC LOOP GANG VECTOR + do jcol = istartcol,iendcol + this%cloud_cover_lw(jcol) = -1.0_jprb + this%cloud_cover_sw(jcol) = -1.0_jprb + end do + !$ACC END PARALLEL + + if (lhook) call dr_hook('radiation_flux:allocate',1,hook_handle) + + end subroutine allocate_flux_type + + + !--------------------------------------------------------------------- + ! Deallocate flux arrays + subroutine deallocate_flux_type(this) + + use yomhook, only : lhook, dr_hook, jphook + + class(flux_type), intent(inout) :: this + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_flux:deallocate',0,hook_handle) + + if (allocated(this%lw_up)) then + !$ACC EXIT DATA DELETE(this%lw_up) ASYNC(1) + !$ACC EXIT DATA DELETE(this%lw_dn) ASYNC(1) IF(allocated(this%lw_dn)) + !$ACC EXIT DATA DELETE(this%lw_up_clear) ASYNC(1) IF(allocated(this%lw_up_clear)) + !$ACC EXIT DATA DELETE(this%lw_dn_clear) ASYNC(1) IF(allocated(this%lw_dn_clear)) + !$ACC WAIT + deallocate(this%lw_up) + if (allocated(this%lw_dn)) deallocate(this%lw_dn) + if (allocated(this%lw_up_clear)) deallocate(this%lw_up_clear) + if (allocated(this%lw_dn_clear)) deallocate(this%lw_dn_clear) + end if + + if (allocated(this%sw_up)) then + !$ACC EXIT DATA DELETE(this%sw_up) ASYNC(1) + !$ACC EXIT DATA DELETE(this%sw_dn) ASYNC(1) IF(allocated(this%sw_dn)) + !$ACC EXIT DATA DELETE(this%sw_up_clear) ASYNC(1) IF(allocated(this%sw_up_clear)) + !$ACC EXIT DATA DELETE(this%sw_dn_clear) ASYNC(1) IF(allocated(this%sw_dn_clear)) + !$ACC EXIT DATA DELETE(this%sw_dn_direct) ASYNC(1) IF(allocated(this%sw_dn_direct)) + !$ACC EXIT DATA DELETE(this%sw_dn_direct_clear) ASYNC(1) IF(allocated(this%sw_dn_direct_clear)) + !$ACC WAIT + deallocate(this%sw_up) + if (allocated(this%sw_dn)) deallocate(this%sw_dn) + if (allocated(this%sw_up_clear)) deallocate(this%sw_up_clear) + if (allocated(this%sw_dn_clear)) deallocate(this%sw_dn_clear) + if (allocated(this%sw_dn_direct)) deallocate(this%sw_dn_direct) + if (allocated(this%sw_dn_direct_clear)) & + & deallocate(this%sw_dn_direct_clear) + end if + + if (allocated(this%lw_up_band)) then + !$ACC EXIT DATA DELETE(this%lw_up_band) ASYNC(1) + !$ACC EXIT DATA DELETE(this%lw_dn_band) ASYNC(1) IF(allocated(this%lw_dn_band)) + !$ACC EXIT DATA DELETE(this%lw_up_clear_band) ASYNC(1) IF(allocated(this%lw_up_clear_band)) + !$ACC EXIT DATA DELETE(this%lw_dn_clear_band) ASYNC(1) IF(allocated(this%lw_dn_clear_band)) + !$ACC WAIT + deallocate(this%lw_up_band) + if (allocated(this%lw_dn_band)) deallocate(this%lw_dn_band) + if (allocated(this%lw_up_clear_band)) deallocate(this%lw_up_clear_band) + if (allocated(this%lw_dn_clear_band)) deallocate(this%lw_dn_clear_band) + end if + + if (allocated(this%sw_up_band)) then + !$ACC EXIT DATA DELETE(this%sw_up_band) ASYNC(1) + !$ACC EXIT DATA DELETE(this%sw_dn_band) ASYNC(1) IF(allocated(this%sw_dn_band)) + !$ACC EXIT DATA DELETE(this%sw_up_clear_band) ASYNC(1) IF(allocated(this%sw_up_clear_band)) + !$ACC EXIT DATA DELETE(this%sw_dn_clear_band) ASYNC(1) IF(allocated(this%sw_dn_clear_band)) + !$ACC EXIT DATA DELETE(this%sw_dn_direct_band) ASYNC(1) IF(allocated(this%sw_dn_direct_band)) + !$ACC EXIT DATA DELETE(this%sw_dn_direct_clear_band) ASYNC(1) & + !$ACC IF(allocated(this%sw_dn_direct_clear_band)) + !$ACC WAIT + deallocate(this%sw_up_band) + if (allocated(this%sw_dn_band)) deallocate(this%sw_dn_band) + if (allocated(this%sw_up_clear_band)) deallocate(this%sw_up_clear_band) + if (allocated(this%sw_dn_clear_band)) deallocate(this%sw_dn_clear_band) + if (allocated(this%sw_dn_direct_band)) deallocate(this%sw_dn_direct_band) + if (allocated(this%sw_dn_direct_clear_band)) & + & deallocate(this%sw_dn_direct_clear_band) + end if + + if (allocated(this%sw_dn_surf_band)) then + !$ACC EXIT DATA DELETE(this%sw_dn_surf_band) ASYNC(1) + !$ACC EXIT DATA DELETE(this%sw_dn_direct_surf_band) ASYNC(1) IF(allocated(this%sw_dn_direct_surf_band)) + !$ACC WAIT + deallocate(this%sw_dn_surf_band) + deallocate(this%sw_dn_direct_surf_band) + end if + if (allocated(this%sw_dn_surf_clear_band)) then + !$ACC EXIT DATA DELETE(this%sw_dn_surf_clear_band) ASYNC(1) + !$ACC EXIT DATA DELETE(this%sw_dn_direct_surf_clear_band) ASYNC(1) & + !$ACC IF(allocated(this%sw_dn_direct_surf_clear_band)) + !$ACC WAIT + deallocate(this%sw_dn_surf_clear_band) + deallocate(this%sw_dn_direct_surf_clear_band) + end if + + !$ACC EXIT DATA DELETE(this%lw_dn_surf_canopy) ASYNC(1) IF(allocated(this%lw_dn_surf_canopy)) + !$ACC EXIT DATA DELETE(this%sw_dn_diffuse_surf_canopy) ASYNC(1) & + !$ACC IF(allocated(this%sw_dn_diffuse_surf_canopy)) + !$ACC EXIT DATA DELETE(this%sw_dn_direct_surf_canopy) ASYNC(1) & + !$ACC IF(allocated(this%sw_dn_direct_surf_canopy)) + !$ACC WAIT + if (allocated(this%lw_dn_surf_canopy)) deallocate(this%lw_dn_surf_canopy) + if (allocated(this%sw_dn_diffuse_surf_canopy)) deallocate(this%sw_dn_diffuse_surf_canopy) + if (allocated(this%sw_dn_direct_surf_canopy)) deallocate(this%sw_dn_direct_surf_canopy) + + if (allocated(this%cloud_cover_sw)) then + !$ACC EXIT DATA DELETE(this%cloud_cover_sw) WAIT(1) + deallocate(this%cloud_cover_sw) + end if + if (allocated(this%cloud_cover_lw)) then + !$ACC EXIT DATA DELETE(this%cloud_cover_lw) WAIT(1) + deallocate(this%cloud_cover_lw) + end if + + if (allocated(this%lw_derivatives)) then + !$ACC EXIT DATA DELETE(this%lw_derivatives) WAIT(1) + deallocate(this%lw_derivatives) + end if + + !$ACC EXIT DATA DELETE(this%lw_dn_surf_g) ASYNC(1) IF(allocated(this%lw_dn_surf_g)) + !$ACC EXIT DATA DELETE(this%lw_dn_surf_clear_g) ASYNC(1) IF(allocated(this%lw_dn_surf_clear_g)) + !$ACC EXIT DATA DELETE(this%sw_dn_diffuse_surf_g) ASYNC(1) IF(allocated(this%sw_dn_diffuse_surf_g)) + !$ACC EXIT DATA DELETE(this%sw_dn_direct_surf_g) ASYNC(1) IF(allocated(this%sw_dn_direct_surf_g)) + !$ACC EXIT DATA DELETE(this%sw_dn_diffuse_surf_clear_g) ASYNC(1) & + !$ACC IF(allocated(this%sw_dn_diffuse_surf_clear_g)) + !$ACC EXIT DATA DELETE(this%sw_dn_direct_surf_clear_g) ASYNC(1) & + !$ACC IF(allocated(this%sw_dn_direct_surf_clear_g)) + !$ACC WAIT + if (allocated(this%lw_dn_surf_g)) deallocate(this%lw_dn_surf_g) + if (allocated(this%lw_dn_surf_clear_g)) deallocate(this%lw_dn_surf_clear_g) + if (allocated(this%sw_dn_diffuse_surf_g)) deallocate(this%sw_dn_diffuse_surf_g) + if (allocated(this%sw_dn_direct_surf_g)) deallocate(this%sw_dn_direct_surf_g) + if (allocated(this%sw_dn_diffuse_surf_clear_g)) deallocate(this%sw_dn_diffuse_surf_clear_g) + if (allocated(this%sw_dn_direct_surf_clear_g)) deallocate(this%sw_dn_direct_surf_clear_g) + + !$ACC EXIT DATA DELETE(this%lw_up_toa_g) ASYNC(1) IF(allocated(this%lw_up_toa_g)) + !$ACC EXIT DATA DELETE(this%sw_up_toa_g) ASYNC(1) IF(allocated(this%sw_up_toa_g)) + !$ACC EXIT DATA DELETE(this%sw_dn_toa_g) ASYNC(1) IF(allocated(this%sw_dn_toa_g)) + !$ACC EXIT DATA DELETE(this%lw_up_toa_clear_g) ASYNC(1) IF(allocated(this%lw_up_toa_clear_g)) + !$ACC EXIT DATA DELETE(this%sw_up_toa_clear_g) ASYNC(1) IF(allocated(this%sw_up_toa_clear_g)) + !$ACC WAIT + if (allocated(this%lw_up_toa_g)) deallocate(this%lw_up_toa_g) + if (allocated(this%sw_up_toa_g)) deallocate(this%sw_up_toa_g) + if (allocated(this%sw_dn_toa_g)) deallocate(this%sw_dn_toa_g) + if (allocated(this%lw_up_toa_clear_g)) deallocate(this%lw_up_toa_clear_g) + if (allocated(this%sw_up_toa_clear_g)) deallocate(this%sw_up_toa_clear_g) + + if (lhook) call dr_hook('radiation_flux:deallocate',1,hook_handle) + + end subroutine deallocate_flux_type + + + !--------------------------------------------------------------------- + ! Calculate surface downwelling fluxes in each band using the + ! downwelling surface fluxes at each g point + subroutine calc_surface_spectral(this, config, istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook +#ifdef _OPENACC + use radiation_io, only : nulerr, radiation_abort +#endif + use radiation_config, only : config_type + + class(flux_type), intent(inout) :: this + type(config_type), intent(in) :: config + integer, intent(in) :: istartcol, iendcol + + integer :: jcol, jband, jalbedoband, nalbedoband + + ! Longwave surface downwelling in each band needed to compute + ! canopy fluxes + real(jprb) :: lw_dn_surf_band(config%n_bands_lw,istartcol:iendcol) + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_flux:calc_surface_spectral',0,hook_handle) + +#ifdef _OPENACC + if (use_indexed_sum_vec) then + write(nulerr,'(a)') '*** Error: radiation_flux:calc_surface_spectral use_indexed_sum_vec==.true. not ported to GPU' + call radiation_abort() + endif +#endif + + !$ACC DATA PRESENT(config, this) + + if (config%do_sw .and. config%do_surface_sw_spectral_flux) then + + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%sw_dn_direct_surf_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_direct_surf_band, istartcol, iendcol) + call indexed_sum_vec(this%sw_dn_diffuse_surf_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_surf_band, istartcol, iendcol) + do jcol = istartcol,iendcol + this%sw_dn_surf_band(:,jcol) & + & = this%sw_dn_surf_band(:,jcol) & + & + this%sw_dn_direct_surf_band(:,jcol) + end do + else + !$ACC PARALLEL DEFAULT(NONE) NUM_GANGS(iendcol-istartcol+1) NUM_WORKERS(1) & + !$ACC VECTOR_LENGTH(32*((config%n_g_sw-1)/32+1)) ASYNC(1) + !$ACC LOOP GANG + do jcol = istartcol,iendcol + call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_direct_surf_band(:,jcol)) + call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_surf_band(:,jcol)) + this%sw_dn_surf_band(:,jcol) & + & = this%sw_dn_surf_band(:,jcol) & + & + this%sw_dn_direct_surf_band(:,jcol) + end do + !$ACC END PARALLEL + end if + + if (config%do_clear) then + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%sw_dn_direct_surf_clear_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_direct_surf_clear_band, istartcol, iendcol) + call indexed_sum_vec(this%sw_dn_diffuse_surf_clear_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_surf_clear_band, istartcol, iendcol) + do jcol = istartcol,iendcol + this%sw_dn_surf_clear_band(:,jcol) & + & = this%sw_dn_surf_clear_band(:,jcol) & + & + this%sw_dn_direct_surf_clear_band(:,jcol) + end do + else + !$ACC PARALLEL DEFAULT(NONE) NUM_GANGS(iendcol-istartcol+1) NUM_WORKERS(1) & + !$ACC VECTOR_LENGTH(32*(config%n_g_sw-1)/32+1) ASYNC(1) + !$ACC LOOP GANG + do jcol = istartcol,iendcol + call indexed_sum(this%sw_dn_direct_surf_clear_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_direct_surf_clear_band(:,jcol)) + call indexed_sum(this%sw_dn_diffuse_surf_clear_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_surf_clear_band(:,jcol)) + this%sw_dn_surf_clear_band(:,jcol) & + & = this%sw_dn_surf_clear_band(:,jcol) & + & + this%sw_dn_direct_surf_clear_band(:,jcol) + end do + !$ACC END PARALLEL + end if + end if + + end if ! do_surface_sw_spectral_flux + + ! Fluxes in bands required for canopy radiative transfer + if (config%do_sw .and. config%do_canopy_fluxes_sw) then + if (config%use_canopy_full_spectrum_sw) then + this%sw_dn_diffuse_surf_canopy(:,istartcol:iendcol) = this%sw_dn_diffuse_surf_g(:,istartcol:iendcol) + this%sw_dn_direct_surf_canopy (:,istartcol:iendcol) = this%sw_dn_direct_surf_g (:,istartcol:iendcol) + else if (config%do_nearest_spectral_sw_albedo) then + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%sw_dn_direct_surf_g, & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & + & this%sw_dn_direct_surf_canopy, istartcol, iendcol) + call indexed_sum_vec(this%sw_dn_diffuse_surf_g, & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & + & this%sw_dn_diffuse_surf_canopy, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & + & this%sw_dn_direct_surf_canopy(:,jcol)) + call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & + & this%sw_dn_diffuse_surf_canopy(:,jcol)) + end do + end if + else + ! More accurate calculations using weights, but requires + ! this%sw_dn_[direct_]surf_band to be defined, i.e. + ! config%do_surface_sw_spectral_flux == .true. + nalbedoband = size(config%sw_albedo_weights,1) + this%sw_dn_diffuse_surf_canopy(:,istartcol:iendcol) = 0.0_jprb + this%sw_dn_direct_surf_canopy (:,istartcol:iendcol) = 0.0_jprb + do jband = 1,config%n_bands_sw + do jalbedoband = 1,nalbedoband + if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then + ! Initially, "diffuse" is actually "total" + this%sw_dn_diffuse_surf_canopy(jalbedoband,istartcol:iendcol) & + & = this%sw_dn_diffuse_surf_canopy(jalbedoband,istartcol:iendcol) & + & + config%sw_albedo_weights(jalbedoband,jband) & + & * this%sw_dn_surf_band(jband,istartcol:iendcol) + this%sw_dn_direct_surf_canopy(jalbedoband,istartcol:iendcol) & + & = this%sw_dn_direct_surf_canopy(jalbedoband,istartcol:iendcol) & + & + config%sw_albedo_weights(jalbedoband,jband) & + & * this%sw_dn_direct_surf_band(jband,istartcol:iendcol) + end if + end do + end do + ! Subtract the direct from total to get diffuse + this%sw_dn_diffuse_surf_canopy(:,istartcol:iendcol) & + & = this%sw_dn_diffuse_surf_canopy(:,istartcol:iendcol) & + & - this%sw_dn_direct_surf_canopy(:,istartcol:iendcol) + end if + + end if ! do_canopy_fluxes_sw + + if (config%do_lw .and. config%do_canopy_fluxes_lw) then + if (config%use_canopy_full_spectrum_lw) then + this%lw_dn_surf_canopy(:,istartcol:iendcol) = this%lw_dn_surf_g(:,istartcol:iendcol) + else if (config%do_nearest_spectral_lw_emiss) then + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%lw_dn_surf_g, & + & config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw), & + & this%lw_dn_surf_canopy, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%lw_dn_surf_g(:,jcol), & + & config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw), & + & this%lw_dn_surf_canopy(:,jcol)) + end do + end if + else + ! Compute fluxes in each longwave emissivity interval using + ! weights; first sum over g points to get the values in bands + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%lw_dn_surf_g, & + & config%i_band_from_reordered_g_lw, & + & lw_dn_surf_band, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%lw_dn_surf_g(:,jcol), & + & config%i_band_from_reordered_g_lw, & + & lw_dn_surf_band(:,jcol)) + end do + end if + nalbedoband = size(config%lw_emiss_weights,1) + this%lw_dn_surf_canopy(:,istartcol:iendcol) = 0.0_jprb + do jband = 1,config%n_bands_lw + do jalbedoband = 1,nalbedoband + if (config%lw_emiss_weights(jalbedoband,jband) /= 0.0_jprb) then + this%lw_dn_surf_canopy(jalbedoband,istartcol:iendcol) & + & = this%lw_dn_surf_canopy(jalbedoband,istartcol:iendcol) & + & + config%lw_emiss_weights(jalbedoband,jband) & + & * lw_dn_surf_band(jband,istartcol:iendcol) + end if + end do + end do + end if + end if + + !$ACC END DATA + + if (lhook) call dr_hook('radiation_flux:calc_surface_spectral',1,hook_handle) + + end subroutine calc_surface_spectral + + + !--------------------------------------------------------------------- + ! Calculate top-of-atmosphere fluxes in each band using the fluxes + ! at each g point + subroutine calc_toa_spectral(this, config, istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_config, only : config_type +#ifdef _OPENACC + use radiation_io, only : nulerr, radiation_abort +#endif + + + class(flux_type), intent(inout) :: this + type(config_type), intent(in) :: config + integer, intent(in) :: istartcol, iendcol + + integer :: jcol, jband + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_flux:calc_toa_spectral',0,hook_handle) + +#ifdef _OPENACC + if (config%do_toa_spectral_flux) then + write(nulerr,'(a)') '*** Error: radiation_flux:calc_toa_spectral not ported to GPU.' + call radiation_abort() + end if +#endif + + if (config%do_sw .and. config%do_toa_spectral_flux) then + + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%sw_dn_toa_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_toa_band, istartcol, iendcol) + call indexed_sum_vec(this%sw_up_toa_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_up_toa_band, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%sw_dn_toa_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_toa_band(:,jcol)) + call indexed_sum(this%sw_up_toa_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_up_toa_band(:,jcol)) + end do + end if + + if (config%do_clear) then + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%sw_up_toa_clear_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_up_toa_clear_band, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%sw_up_toa_clear_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_up_toa_clear_band(:,jcol)) + end do + end if + end if + end if + + if (config%do_lw .and. config%do_toa_spectral_flux) then + + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%lw_up_toa_g, & + & config%i_band_from_reordered_g_lw, & + & this%lw_up_toa_band, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%lw_up_toa_g(:,jcol), & + & config%i_band_from_reordered_g_lw, & + & this%lw_up_toa_band(:,jcol)) + end do + end if + + if (config%do_clear) then + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%lw_up_toa_clear_g, & + & config%i_band_from_reordered_g_lw, & + & this%lw_up_toa_clear_band, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%lw_up_toa_clear_g(:,jcol), & + & config%i_band_from_reordered_g_lw, & + & this%lw_up_toa_clear_band(:,jcol)) + end do + end if + end if + end if + + if (lhook) call dr_hook('radiation_flux:calc_toa_spectral',1,hook_handle) + + end subroutine calc_toa_spectral + + + !--------------------------------------------------------------------- + ! Return .true. if the most important flux variables are out of a + ! physically sensible range, optionally only considering columns + ! between istartcol and iendcol + function out_of_physical_bounds(this, istartcol, iendcol) result(is_bad) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_check, only : out_of_bounds_2d + + class(flux_type), intent(inout) :: this + integer, optional,intent(in) :: istartcol, iendcol + logical :: is_bad + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_flux:out_of_physical_bounds',0,hook_handle) + + is_bad = out_of_bounds_2d(this%lw_up, 'lw_up', 10.0_jprb, 900.0_jprb, .false., i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%lw_dn, 'lw_dn', 0.0_jprb, 800.0_jprb, .false., i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%sw_up, 'sw_up', 0.0_jprb, 1500.0_jprb, .false., i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%sw_dn, 'sw_dn', 0.0_jprb, 1500.0_jprb, .false., i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%sw_dn_direct, 'sw_dn_direct', 0.0_jprb, 1500.0_jprb, .false., i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%lw_derivatives, 'lw_derivatives', 0.0_jprb, 1.0_jprb, .false., i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%sw_dn_surf_band, 'sw_dn_surf_band', 0.0_jprb, 1500.0_jprb, & + & .false., j1=istartcol, j2=iendcol) & + & .or. out_of_bounds_2d(this%sw_dn_surf_clear_band, 'sw_dn_surf_clear_band', 0.0_jprb, 1500.0_jprb, & + & .false., j1=istartcol, j2=iendcol) + + if (lhook) call dr_hook('radiation_flux:out_of_physical_bounds',1,hook_handle) + + end function out_of_physical_bounds + + !--------------------------------------------------------------------- + ! Return .true. if the heating rates are out of a physically + ! sensible range, optionally only considering columns between + ! istartcol and iendcol. This function allocates and deallocates + ! memory due to the requirements for inputs of out_of_bounds_2d. + function heating_rate_out_of_physical_bounds(this, nlev, istartcol, iendcol, pressure_hl) result(is_bad) + + use radiation_check, only : out_of_bounds_2d + use radiation_constants, only : AccelDueToGravity + + ! "Cp" (J kg-1 K-1) + real(jprb), parameter :: SpecificHeatDryAir = 1004.0 + + class(flux_type), intent(inout) :: this + integer, intent(in) :: istartcol, iendcol, nlev + logical :: is_bad + + real(jprb), intent(in) :: pressure_hl(:,:) + + real(jprb), allocatable :: hr_K_day(:,:) + + real(jprb) :: scaling(istartcol:iendcol,nlev) + + allocate(hr_K_day(istartcol:iendcol,nlev)) + + scaling = -(24.0_jprb * 3600.0_jprb * AccelDueToGravity / SpecificHeatDryAir) & + & / (pressure_hl(istartcol:iendcol,2:nlev+1) - pressure_hl(istartcol:iendcol,1:nlev)) + ! Shortwave + hr_K_day = scaling * (this%sw_dn(istartcol:iendcol,2:nlev+1) - this%sw_up(istartcol:iendcol,2:nlev+1) & + & -this%sw_dn(istartcol:iendcol,1:nlev) + this%sw_up(istartcol:iendcol,1:nlev)) + is_bad = out_of_bounds_2d(hr_K_day, 'sw_heating_rate_K_day', 0.0_jprb, 200.0_jprb, & + & .false., i1=istartcol, i2=iendcol) + + ! Longwave + hr_K_day = scaling * (this%lw_dn(istartcol:iendcol,2:nlev+1) - this%lw_up(istartcol:iendcol,2:nlev+1) & + & -this%lw_dn(istartcol:iendcol,1:nlev) + this%lw_up(istartcol:iendcol,1:nlev)) + is_bad = is_bad .or. out_of_bounds_2d(hr_K_day, 'lw_heating_rate_K_day', -250.0_jprb, 150.0_jprb, & + & .false., i1=istartcol, i2=iendcol) + + deallocate(hr_K_day) + + end function heating_rate_out_of_physical_bounds + + + !--------------------------------------------------------------------- + ! Sum elements of "source" into "dest" according to index "ind". + ! "source" and "ind" should have the same size and bounds, and no + ! element of "ind" should refer outside the bounds of "dest". This + ! version increments existing contents of "dest". + pure subroutine add_indexed_sum(source, ind, dest) + + real(jprb), intent(in) :: source(:) + integer, intent(in) :: ind(:) + real(jprb), intent(inout) :: dest(:) + + integer :: ig, jg, istart, iend + + istart = lbound(source,1) + iend = ubound(source,1) + + do jg = istart, iend + ig = ind(jg) + dest(ig) = dest(ig) + source(jg) + end do + + end subroutine add_indexed_sum + + + !--------------------------------------------------------------------- + ! As "add_indexed_sum" but this version overwrites existing contents + ! of "dest" + pure subroutine indexed_sum(source, ind, dest) + + real(jprb), intent(in) :: source(:) + integer, intent(in) :: ind(:) + real(jprb), intent(out) :: dest(:) + + integer :: ig, jg, istart, iend + + !$ACC ROUTINE VECTOR + + dest = 0.0 + + istart = lbound(source,1) + iend = ubound(source,1) + + !$ACC LOOP VECTOR + do jg = istart, iend + ig = ind(jg) + !$ACC ATOMIC UPDATE + dest(ig) = dest(ig) + source(jg) + !$ACC END ATOMIC + end do + + end subroutine indexed_sum + + !--------------------------------------------------------------------- + ! Vectorized version of "add_indexed_sum" + subroutine indexed_sum_vec(source, ind, dest, ist, iend) + + real(jprb), intent(in) :: source(:,:) + integer, intent(in) :: ind(:) + real(jprb), intent(out) :: dest(:,:) + integer, intent(in) :: ist, iend + + integer :: ig, jg, jc + + dest = 0.0 + + do jg = lbound(source,1), ubound(source,1) + ig = ind(jg) + do jc = ist, iend + dest(ig,jc) = dest(ig,jc) + source(jg,jc) + end do + end do + + end subroutine indexed_sum_vec + + !--------------------------------------------------------------------- + ! As "add_indexed_sum" but a whole vertical profiles + pure subroutine add_indexed_sum_profile(source, ind, dest) + + real(jprb), intent(in) :: source(:,:) + integer, intent(in) :: ind(:) + real(jprb), intent(out) :: dest(:,:) + + integer :: ig, jg, istart, iend, jlev, nlev + + istart = lbound(source,1) + iend = ubound(source,1) + nlev = size(source,2) + + do jlev = 1,nlev + do jg = istart, iend + ig = ind(jg) + dest(ig,jlev) = dest(ig,jlev) + source(jg,jlev) + end do + end do + + end subroutine add_indexed_sum_profile + + + !--------------------------------------------------------------------- + ! As "indexed_sum" but a whole vertical profiles + pure subroutine indexed_sum_profile(source, ind, dest) + + real(jprb), intent(in) :: source(:,:) + integer, intent(in) :: ind(:) + real(jprb), intent(out) :: dest(:,:) + + integer :: ig, jg, istart, iend, jlev, nlev + + dest = 0.0 + + istart = lbound(source,1) + iend = ubound(source,1) + nlev = size(source,2) + + do jlev = 1,nlev + do jg = istart, iend + ig = ind(jg) + dest(ig,jlev) = dest(ig,jlev) + source(jg,jlev) + end do + end do + + end subroutine indexed_sum_profile + +#ifdef _OPENACC + !--------------------------------------------------------------------- + ! updates fields on host + subroutine update_host(this) + + class(flux_type), intent(inout) :: this + + !$ACC UPDATE HOST(this%lw_up) IF(allocated(this%lw_up)) + !$ACC UPDATE HOST(this%lw_dn) IF(allocated(this%lw_dn)) + !$ACC UPDATE HOST(this%lw_up_clear) IF(allocated(this%lw_up_clear)) + !$ACC UPDATE HOST(this%lw_dn_clear) IF(allocated(this%lw_dn_clear)) + !$ACC UPDATE HOST(this%sw_up) IF(allocated(this%sw_up)) + !$ACC UPDATE HOST(this%sw_dn) IF(allocated(this%sw_dn)) + !$ACC UPDATE HOST(this%sw_up_clear) IF(allocated(this%sw_up_clear)) + !$ACC UPDATE HOST(this%sw_dn_clear) IF(allocated(this%sw_dn_clear)) + !$ACC UPDATE HOST(this%sw_dn_direct) IF(allocated(this%sw_dn_direct)) + !$ACC UPDATE HOST(this%sw_dn_direct_clear) IF(allocated(this%sw_dn_direct_clear)) + !$ACC UPDATE HOST(this%lw_up_band) IF(allocated(this%lw_up_band)) + !$ACC UPDATE HOST(this%lw_dn_band) IF(allocated(this%lw_dn_band)) + !$ACC UPDATE HOST(this%lw_up_clear_band) IF(allocated(this%lw_up_clear_band)) + !$ACC UPDATE HOST(this%lw_dn_clear_band) IF(allocated(this%lw_dn_clear_band)) + !$ACC UPDATE HOST(this%sw_up_band) IF(allocated(this%sw_up_band)) + !$ACC UPDATE HOST(this%sw_dn_band) IF(allocated(this%sw_dn_band)) + !$ACC UPDATE HOST(this%sw_up_clear_band) IF(allocated(this%sw_up_clear_band)) + !$ACC UPDATE HOST(this%sw_dn_clear_band) IF(allocated(this%sw_dn_clear_band)) + !$ACC UPDATE HOST(this%sw_dn_direct_band) IF(allocated(this%sw_dn_direct_band)) + !$ACC UPDATE HOST(this%sw_dn_direct_clear_band) IF(allocated(this%sw_dn_direct_clear_band)) + !$ACC UPDATE HOST(this%sw_dn_surf_band) IF(allocated(this%sw_dn_surf_band)) + !$ACC UPDATE HOST(this%sw_dn_direct_surf_band) IF(allocated(this%sw_dn_direct_surf_band)) + !$ACC UPDATE HOST(this%sw_dn_surf_clear_band) IF(allocated(this%sw_dn_surf_clear_band)) + !$ACC UPDATE HOST(this%sw_dn_direct_surf_clear_band) IF(allocated(this%sw_dn_direct_surf_clear_band)) + !$ACC UPDATE HOST(this%lw_dn_surf_canopy) IF(allocated(this%lw_dn_surf_canopy)) + !$ACC UPDATE HOST(this%sw_dn_diffuse_surf_canopy) IF(allocated(this%sw_dn_diffuse_surf_canopy)) + !$ACC UPDATE HOST(this%sw_dn_direct_surf_canopy) IF(allocated(this%sw_dn_direct_surf_canopy)) + !$ACC UPDATE HOST(this%cloud_cover_sw) IF(allocated(this%cloud_cover_sw)) + !$ACC UPDATE HOST(this%cloud_cover_lw) IF(allocated(this%cloud_cover_lw)) + !$ACC UPDATE HOST(this%lw_derivatives) IF(allocated(this%lw_derivatives)) + !$ACC UPDATE HOST(this%lw_dn_surf_g) IF(allocated(this%lw_dn_surf_g)) + !$ACC UPDATE HOST(this%lw_dn_surf_clear_g) IF(allocated(this%lw_dn_surf_clear_g)) + !$ACC UPDATE HOST(this%sw_dn_diffuse_surf_g) IF(allocated(this%sw_dn_diffuse_surf_g)) + !$ACC UPDATE HOST(this%sw_dn_direct_surf_g) IF(allocated(this%sw_dn_direct_surf_g)) + !$ACC UPDATE HOST(this%sw_dn_diffuse_surf_clear_g) IF(allocated(this%sw_dn_diffuse_surf_clear_g)) + !$ACC UPDATE HOST(this%sw_dn_direct_surf_clear_g) IF(allocated(this%sw_dn_direct_surf_clear_g)) + + end subroutine update_host + + !--------------------------------------------------------------------- + ! updates fields on device + subroutine update_device(this) + + class(flux_type), intent(inout) :: this + + !$ACC UPDATE DEVICE(this%lw_up) IF(allocated(this%lw_up)) + !$ACC UPDATE DEVICE(this%lw_dn) IF(allocated(this%lw_dn)) + !$ACC UPDATE DEVICE(this%lw_up_clear) IF(allocated(this%lw_up_clear)) + !$ACC UPDATE DEVICE(this%lw_dn_clear) IF(allocated(this%lw_dn_clear)) + !$ACC UPDATE DEVICE(this%sw_up) IF(allocated(this%sw_up)) + !$ACC UPDATE DEVICE(this%sw_dn) IF(allocated(this%sw_dn)) + !$ACC UPDATE DEVICE(this%sw_up_clear) IF(allocated(this%sw_up_clear)) + !$ACC UPDATE DEVICE(this%sw_dn_clear) IF(allocated(this%sw_dn_clear)) + !$ACC UPDATE DEVICE(this%sw_dn_direct) IF(allocated(this%sw_dn_direct)) + !$ACC UPDATE DEVICE(this%sw_dn_direct_clear) IF(allocated(this%sw_dn_direct_clear)) + !$ACC UPDATE DEVICE(this%lw_up_band) IF(allocated(this%lw_up_band)) + !$ACC UPDATE DEVICE(this%lw_dn_band) IF(allocated(this%lw_dn_band)) + !$ACC UPDATE DEVICE(this%lw_up_clear_band) IF(allocated(this%lw_up_clear_band)) + !$ACC UPDATE DEVICE(this%lw_dn_clear_band) IF(allocated(this%lw_dn_clear_band)) + !$ACC UPDATE DEVICE(this%sw_up_band) IF(allocated(this%sw_up_band)) + !$ACC UPDATE DEVICE(this%sw_dn_band) IF(allocated(this%sw_dn_band)) + !$ACC UPDATE DEVICE(this%sw_up_clear_band) IF(allocated(this%sw_up_clear_band)) + !$ACC UPDATE DEVICE(this%sw_dn_clear_band) IF(allocated(this%sw_dn_clear_band)) + !$ACC UPDATE DEVICE(this%sw_dn_direct_band) IF(allocated(this%sw_dn_direct_band)) + !$ACC UPDATE DEVICE(this%sw_dn_direct_clear_band) IF(allocated(this%sw_dn_direct_clear_band)) + !$ACC UPDATE DEVICE(this%sw_dn_surf_band) IF(allocated(this%sw_dn_surf_band)) + !$ACC UPDATE DEVICE(this%sw_dn_direct_surf_band) IF(allocated(this%sw_dn_direct_surf_band)) + !$ACC UPDATE DEVICE(this%sw_dn_surf_clear_band) IF(allocated(this%sw_dn_surf_clear_band)) + !$ACC UPDATE DEVICE(this%sw_dn_direct_surf_clear_band) IF(allocated(this%sw_dn_direct_surf_clear_band)) + !$ACC UPDATE DEVICE(this%lw_dn_surf_canopy) IF(allocated(this%lw_dn_surf_canopy)) + !$ACC UPDATE DEVICE(this%sw_dn_diffuse_surf_canopy) IF(allocated(this%sw_dn_diffuse_surf_canopy)) + !$ACC UPDATE DEVICE(this%sw_dn_direct_surf_canopy) IF(allocated(this%sw_dn_direct_surf_canopy)) + !$ACC UPDATE DEVICE(this%cloud_cover_sw) IF(allocated(this%cloud_cover_sw)) + !$ACC UPDATE DEVICE(this%cloud_cover_lw) IF(allocated(this%cloud_cover_lw)) + !$ACC UPDATE DEVICE(this%lw_derivatives) IF(allocated(this%lw_derivatives)) + !$ACC UPDATE DEVICE(this%lw_dn_surf_g) IF(allocated(this%lw_dn_surf_g)) + !$ACC UPDATE DEVICE(this%lw_dn_surf_clear_g) IF(allocated(this%lw_dn_surf_clear_g)) + !$ACC UPDATE DEVICE(this%sw_dn_diffuse_surf_g) IF(allocated(this%sw_dn_diffuse_surf_g)) + !$ACC UPDATE DEVICE(this%sw_dn_direct_surf_g) IF(allocated(this%sw_dn_direct_surf_g)) + !$ACC UPDATE DEVICE(this%sw_dn_diffuse_surf_clear_g) IF(allocated(this%sw_dn_diffuse_surf_clear_g)) + !$ACC UPDATE DEVICE(this%sw_dn_direct_surf_clear_g) IF(allocated(this%sw_dn_direct_surf_clear_g)) + + end subroutine update_device +#endif + +end module radiation_flux Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_gas.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_gas.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_gas.F90 (revision 6016) @@ -0,0 +1,692 @@ +! This file has been modified for the use in ICON + +! radiation_gas.F90 - Derived type to store the gas mixing ratios +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2019-01-14 R. Hogan Added out_of_physical_bounds routine + +module radiation_gas + + use parkind1, only : jprb + use radiation_gas_constants + + implicit none + public + + ! Available units + enum, bind(c) + enumerator IMassMixingRatio, IVolumeMixingRatio + end enum + + !--------------------------------------------------------------------- + ! This derived type describes the gaseous composition of the + ! atmosphere; gases may be stored as part of a 3D array (if their + ! variation with height/column is to be represented) or one 1D array + ! (if they are to be assumed globally well-mixed). + type gas_type + ! Units of each stored gas (or 0 if not present) + integer :: iunits(NMaxGases) = 0 + + ! Scaling factor that should be applied to each stored gas to get + ! a dimensionless result, e.g. if iunits=IVolumeMixingRatio then + ! 1.0e-6 is used to indicate the units are actually PPMV: need to + ! multiply by 1e-6 to get mol/mol. + real(jprb) :: scale_factor(NMaxGases) = 1.0_jprb + + ! Mixing ratios of variable gases, dimensioned (ncol, nlev, + ! NMaxGases) + real(jprb), allocatable, dimension(:,:,:) :: mixing_ratio + + ! Flag to indicate whether a gas is present + logical :: is_present(NMaxGases) = .false. + + ! Flag to indicate whether a gas is well mixed + logical :: is_well_mixed(NMaxGases) = .false. + + integer :: ntype = 0 ! Number of gas types described + + integer :: ncol = 0 ! Number of columns in mixing_ratio + integer :: nlev = 0 ! Number of levels in mixing_ratio + + ! A list of length ntype of gases whose volume mixing ratios have + ! been provided + integer :: icode(NMaxGases) = 0 + + contains + procedure :: allocate => allocate_gas + procedure :: deallocate => deallocate_gas + procedure :: put => put_gas + procedure :: put_well_mixed => put_well_mixed_gas + procedure :: scale => scale_gas + procedure :: set_units => set_units_gas + procedure :: assert_units => assert_units_gas + procedure :: get => get_gas + procedure :: get_scaling + procedure :: reverse => reverse_gas + procedure :: out_of_physical_bounds +#ifdef _OPENACC + procedure :: update_host + procedure :: update_device +#endif + + end type gas_type + +contains + + + !--------------------------------------------------------------------- + ! Allocate a derived type for holding gas mixing ratios given the + ! number of columns and levels + subroutine allocate_gas(this, ncol, nlev) + + use yomhook, only : lhook, dr_hook, jphook + + class(gas_type), intent(inout) :: this + integer, intent(in) :: ncol, nlev + + integer :: jcol, jlev, jgas + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_gas:allocate',0,hook_handle) + + call this%deallocate() + + allocate(this%mixing_ratio(ncol, nlev, NMaxGases)) + !$ACC ENTER DATA CREATE(this%mixing_ratio) ASYNC(1) + + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + do jgas = 1,NMaxGases + do jlev = 1, nlev + do jcol = 1,ncol + this%mixing_ratio(jcol,jlev,jgas) = 0.0_jprb + end do + end do + end do + !$ACC END PARALLEL + + this%ncol = ncol + this%nlev = nlev + !$ACC UPDATE DEVICE(this%ncol, this%nlev) ASYNC(1) + + if (lhook) call dr_hook('radiation_gas:allocate',1,hook_handle) + + end subroutine allocate_gas + + + !--------------------------------------------------------------------- + ! Deallocate memory and reset arrays + subroutine deallocate_gas(this) + + use yomhook, only : lhook, dr_hook, jphook + + class(gas_type), intent(inout) :: this + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_gas:deallocate',0,hook_handle) + + if (allocated(this%mixing_ratio)) then + !$ACC EXIT DATA DELETE(this%mixing_ratio) WAIT(1) + deallocate(this%mixing_ratio) + end if + + this%iunits = 0 + this%scale_factor = 0.0_jprb + this%is_present = .false. + this%is_well_mixed = .false. + this%ntype = 0 + this%ncol = 0 + this%nlev = 0 + this%icode = 0 + + if (lhook) call dr_hook('radiation_gas:deallocate',1,hook_handle) + + end subroutine deallocate_gas + + + !--------------------------------------------------------------------- + ! Put gas mixing ratio corresponding to gas ID "igas" with units + ! "iunits" + subroutine put_gas(this, igas, iunits, mixing_ratio, scale_factor, & + istartcol) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + + class(gas_type), intent(inout) :: this + integer, intent(in) :: igas + integer, intent(in) :: iunits + real(jprb), intent(in) :: mixing_ratio(:,:) + real(jprb), optional, intent(in) :: scale_factor + integer, optional, intent(in) :: istartcol + + integer :: i1, i2, jc, jk + + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_gas:put',0,hook_handle) + + ! Check inputs + if (igas <= IGasNotPresent .or. iunits > NMaxGases) then + write(nulerr,'(a,i0,a,i0,a,i0)') '*** Error: provided gas ID (', & + & igas, ') must be in the range ', IGasNotPresent+1, ' to ', & + & NMaxGases + call radiation_abort() + end if + if (iunits < IMassMixingRatio .or. iunits > IVolumeMixingRatio) then + write(nulerr,'(a,i0,a,i0,a,i0)') '*** Error: provided gas units (', & + & iunits, ') must be in the range ', IMassMixingRatio, ' to ', & + & IVolumeMixingRatio + call radiation_abort() + end if + + if (.not. allocated(this%mixing_ratio)) then + write(nulerr,'(a,i0,a,i0,a,i0)') '*** Error: attempt to put data to unallocated radiation_gas object' + call radiation_abort() + end if + + if (present(istartcol)) then + i1 = istartcol + else + i1 = 1 + end if + + i2 = i1 + size(mixing_ratio,1) - 1 + + if (i1 < 1 .or. i2 < 1 .or. i1 > this%ncol .or. i2 > this%ncol) then + write(nulerr,'(a,i0,a,i0,a,i0)') '*** Error: attempt to put columns indexed ', & + & i1, ' to ', i2, ' to array indexed 1 to ', this%ncol + call radiation_abort() + end if + + if (size(mixing_ratio,2) /= this%nlev) then + write(nulerr,'(a,i0,a)') & + & '*** Error: gas mixing ratio expected to have ', this%nlev, & + & ' levels' + call radiation_abort() + end if + + if (.not. this%is_present(igas)) then + ! Gas not present until now + this%ntype = this%ntype + 1 + this%icode(this%ntype) = igas + !$ACC UPDATE DEVICE(this%icode(this%ntype:this%ntype)) ASYNC(1) + end if + this%is_present(igas) = .true. + this%iunits(igas) = iunits + this%is_well_mixed(igas) = .false. + + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this, mixing_ratio) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jk = 1,this%nlev + do jc = i1,i2 + this%mixing_ratio(jc,jk,igas) = mixing_ratio(jc-i1+1,jk) + end do + end do + !$ACC END PARALLEL + if (present(scale_factor)) then + this%scale_factor(igas) = scale_factor + else + this%scale_factor(igas) = 1.0_jprb + end if + + if (lhook) call dr_hook('radiation_gas:put',1,hook_handle) + + end subroutine put_gas + + + !--------------------------------------------------------------------- + ! Put well-mixed gas mixing ratio corresponding to gas ID "igas" + ! with units "iunits" + subroutine put_well_mixed_gas(this, igas, iunits, mixing_ratio, & + scale_factor, istartcol, iendcol) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + + class(gas_type), intent(inout) :: this + integer, intent(in) :: igas + integer, intent(in) :: iunits + real(jprb), intent(in) :: mixing_ratio + real(jprb), optional, intent(in) :: scale_factor + integer, optional, intent(in) :: istartcol, iendcol + + real(jphook) :: hook_handle + + integer :: i1, i2, jc, jk + + if (lhook) call dr_hook('radiation_gas:put_well_mixed',0,hook_handle) + + ! Check inputs + if (igas <= IGasNotPresent .or. igas > NMaxGases) then + write(nulerr,'(a,i0,a,i0,a,i0)') '*** Error: provided gas ID (', & + & igas, ') must be in the range ', IGasNotPresent+1, ' to ', & + & NMaxGases + call radiation_abort() + end if + if (iunits < IMassMixingRatio .or. iunits > IVolumeMixingRatio) then + write(nulerr,'(a,i0,a,i0,a,i0)') '*** Error: provided gas units (', & + & iunits, ') must be in the range ', IMassMixingRatio, ' to ', & + & IVolumeMixingRatio + call radiation_abort() + end if + + if (.not. allocated(this%mixing_ratio)) then + write(nulerr,'(a)') '*** Error: attempt to put well-mixed gas data to unallocated radiation_gas object' + call radiation_abort() + end if + + if (present(istartcol)) then + i1 = istartcol + else + i1 = 1 + end if + + if (present(iendcol)) then + i2 = iendcol + else + i2 = this%ncol + end if + + if (i1 < 1 .or. i2 < 1 .or. i1 > this%ncol .or. i2 > this%ncol) then + write(nulerr,'(a,i0,a,i0,a,i0)') '*** Error: attempt to put columns indexed ', & + & i1, ' to ', i2, ' to array indexed 1 to ', this%ncol + call radiation_abort() + end if + + if (.not. this%is_present(igas)) then + ! Gas not present until now + this%ntype = this%ntype + 1 + this%icode(this%ntype) = igas + !$ACC UPDATE DEVICE(this%icode(this%ntype:this%ntype)) ASYNC(1) + + end if + ! Map uses a negative value to indicate a well-mixed value + this%is_present(igas) = .true. + this%iunits(igas) = iunits + this%is_well_mixed(igas) = .true. + + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jk = 1,this%nlev + do jc = i1,i2 + this%mixing_ratio(jc,jk,igas) = mixing_ratio + end do + end do + !$ACC END PARALLEL + if (present(scale_factor)) then + this%scale_factor(igas) = scale_factor + else + this%scale_factor(igas) = 1.0_jprb + end if + + if (lhook) call dr_hook('radiation_gas:put_well_mixed',1,hook_handle) + + end subroutine put_well_mixed_gas + + + !--------------------------------------------------------------------- + ! Scale gas concentrations, e.g. igas=ICO2 and set scale_factor=2 to + ! double CO2. Note that this does not perform the scaling + ! immediately, but changes the scale factor for the specified gas, + ! ready to be used in set_units_gas. + subroutine scale_gas(this, igas, scale_factor, lverbose) + + use radiation_io, only : nulout + + class(gas_type), intent(inout) :: this + integer, intent(in) :: igas + real(jprb), intent(in) :: scale_factor + logical, optional, intent(in) :: lverbose + + if (scale_factor /= 1.0_jprb) then + this%scale_factor(igas) = this%scale_factor(igas) * scale_factor + if (present(lverbose)) then + if (lverbose) then + write(nulout,'(a,a,a,f0.3)') ' Scaling ', trim(GasName(igas)), & + & ' concentration by ', scale_factor + end if + end if + end if + + end subroutine scale_gas + + + !--------------------------------------------------------------------- + ! Scale the gas concentrations so that they have the units "iunits" + ! and are therefore ready to be used by the gas optics model within + ! ecRad with no further scaling. The existing scale_factor for each + ! gas is applied. If "igas" is present then apply only to gas with + ! ID "igas", otherwise to all gases. Optional argument scale_factor + ! specifies scaling that any subsequent access would need to apply + ! to get a dimensionless result (consistent with definition of + ! gas_type). So say that your gas optics model requires gas + ! concentrations in PPMV, specify iunits=IVolumeMixingRatio and + ! scale_factor=1.0e-6. If the gas concentrations were currently + ! dimensionless volume mixing ratios, then the values would be + ! internally divided by 1.0e-6. + recursive subroutine set_units_gas(this, iunits, igas, scale_factor) + class(gas_type), intent(inout) :: this + integer, intent(in) :: iunits + integer, optional, intent(in) :: igas + real(jprb), optional, intent(in) :: scale_factor + + integer :: jg, jcol, jlev + + ! Scaling factor to convert from old to new + real(jprb) :: sf + + ! New scaling factor to store inside the gas object + real(jprb) :: new_sf + + if (present(scale_factor)) then + ! "sf" is the scaling to be applied now to the numbers (and may + ! be modified below), "new_sf" is the value to be stored along + ! with the numbers, informing subsequent routines how much you + ! would need to multiply the numbers by to get a dimensionless + ! result. + sf = 1.0_jprb / scale_factor + new_sf = scale_factor + else + sf = 1.0_jprb + new_sf = 1.0_jprb + end if + + if (present(igas)) then + if (this%is_present(igas)) then + if (iunits == IMassMixingRatio & + & .and. this%iunits(igas) == IVolumeMixingRatio) then + sf = sf * GasMolarMass(igas) / AirMolarMass + else if (iunits == IVolumeMixingRatio & + & .and. this%iunits(igas) == IMassMixingRatio) then + sf = sf * AirMolarMass / GasMolarMass(igas) + end if + sf = sf * this%scale_factor(igas) + + if (sf /= 1.0_jprb) then + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this, this%mixing_ratio, igas) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jlev = 1,this%nlev + do jcol = 1,this%ncol + this%mixing_ratio(jcol,jlev,igas) = this%mixing_ratio(jcol,jlev,igas) * sf + enddo + enddo + !$ACC END PARALLEL + end if + ! Store the new units and scale factor for this gas inside the + ! gas object + this%iunits(igas) = iunits + this%scale_factor(igas) = new_sf + end if + else + do jg = 1,this%ntype + call this%set_units(iunits, igas=this%icode(jg), scale_factor=new_sf) + end do + end if + + end subroutine set_units_gas + + + !--------------------------------------------------------------------- + ! Return a vector indicating the scaling that one would need to + ! apply to each gas in order to obtain the dimension units in + ! "iunits" (which can be IVolumeMixingRatio or IMassMixingRatio) + subroutine get_scaling(this, iunits, scaling) + class(gas_type), intent(in) :: this + integer, intent(in) :: iunits + real(jprb), intent(out) :: scaling(NMaxGases) + integer :: jg + + scaling = this%scale_factor + do jg = 1,NMaxGases + if (iunits == IMassMixingRatio .and. this%iunits(jg) == IVolumeMixingRatio) then + scaling(jg) = scaling(jg) * GasMolarMass(jg) / AirMolarMass + else if (iunits == IVolumeMixingRatio .and. this%iunits(jg) == IMassMixingRatio) then + scaling(jg) = scaling(jg) * AirMolarMass / GasMolarMass(jg) + end if + end do + + end subroutine get_scaling + + + !--------------------------------------------------------------------- + ! Assert that gas mixing ratio units are "iunits", applying to gas + ! with ID "igas" if present, otherwise to all gases. Otherwise the + ! program will exit, except if the optional argument "istatus" is + ! provided in which case it will return true if the units are + ! correct and false if they are not. Optional argument scale factor + ! specifies any subsequent multiplication to apply; for PPMV one + ! would use iunits=IVolumeMixingRatio and scale_factor=1.0e6. + recursive subroutine assert_units_gas(this, iunits, igas, scale_factor, istatus) + + use radiation_io, only : nulerr, radiation_abort + + class(gas_type), intent(in) :: this + integer, intent(in) :: iunits + integer, optional, intent(in) :: igas + real(jprb), optional, intent(in) :: scale_factor + logical, optional, intent(out) :: istatus + + integer :: jg + + real(jprb) :: sf + + if (present(scale_factor)) then + sf = scale_factor + else + sf = 1.0_jprb + end if + + if (present(istatus)) then + istatus = .true. + end if + + if (present(igas)) then + if (this%is_present(igas)) then + if (iunits /= this%iunits(igas)) then + if (present(istatus)) then + istatus = .false. + else + write(nulerr,'(a,a,a)') '*** Error: ', trim(GasName(igas)), & + & ' is not in the required units' + call radiation_abort() + end if + else if (sf /= this%scale_factor(igas)) then + if (present(istatus)) then + istatus = .false. + else + write(nulerr,'(a,a,a,e12.4,a,e12.4)') '*** Error: ', GasName(igas), & + & ' scaling of ', this%scale_factor(igas), & + & ' does not match required ', sf + call radiation_abort() + end if + end if + end if + else + do jg = 1,this%ntype + call this%assert_units(iunits, igas=this%icode(jg), scale_factor=sf, istatus=istatus) + end do + end if + + end subroutine assert_units_gas + + + !--------------------------------------------------------------------- + ! Get gas mixing ratio corresponding to gas ID "igas" with units + ! "iunits" and return as a 2D array of dimensions (ncol,nlev). The + ! array will contain zeros if the gas is not stored. + subroutine get_gas(this, igas, iunits, mixing_ratio, scale_factor, & + & istartcol) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + + class(gas_type), intent(in) :: this + integer, intent(in) :: igas + integer, intent(in) :: iunits + real(jprb), intent(out) :: mixing_ratio(:,:) + real(jprb), optional, intent(in) :: scale_factor + integer, optional, intent(in) :: istartcol + + real(jprb) :: sf + integer :: i1, i2 + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_gas:get',0,hook_handle) + +#ifdef _OPENACC + write(nulerr,'(a)') '*** Error: radiation_gas:get not ported to GPU' + call radiation_abort() +#endif + + if (present(scale_factor)) then + sf = scale_factor + else + sf = 1.0_jprb + end if + + if (present(istartcol)) then + i1 = istartcol + else + i1 = 1 + end if + + i2 = i1 + size(mixing_ratio,1) - 1 + + if (i1 < 1 .or. i2 < 1 .or. i1 > this%ncol .or. i2 > this%ncol) then + write(nulerr,'(a,i0,a,i0,a,i0)') '*** Error: attempt to get columns indexed ', & + & i1, ' to ', i2, ' from array indexed 1 to ', this%ncol + call radiation_abort() + end if + + if (size(mixing_ratio,2) /= this%nlev) then + write(nulerr,'(a,i0,a)') & + & '*** Error: gas destination array expected to have ', this%nlev, & + & ' levels' + call radiation_abort() + end if + + if (.not. this%is_present(igas)) then + mixing_ratio = 0.0_jprb + else + if (iunits == IMassMixingRatio & + & .and. this%iunits(igas) == IVolumeMixingRatio) then + sf = sf * GasMolarMass(igas) / AirMolarMass + else if (iunits == IVolumeMixingRatio & + & .and. this%iunits(igas) == IMassMixingRatio) then + sf = sf * AirMolarMass / GasMolarMass(igas) + end if + sf = sf * this%scale_factor(igas) + + if (sf /= 1.0_jprb) then + mixing_ratio = this%mixing_ratio(i1:i2,:,igas) * sf + else + mixing_ratio = this%mixing_ratio(i1:i2,:,igas) + end if + end if + + if (lhook) call dr_hook('radiation_gas:get',1,hook_handle) + + end subroutine get_gas + + + !--------------------------------------------------------------------- + ! Copy data to "gas_rev", reversing the height ordering of the gas + ! data + subroutine reverse_gas(this, istartcol, iendcol, gas_rev) + + class(gas_type), intent(in) :: this + integer, intent(in) :: istartcol, iendcol + type(gas_type), intent(out) :: gas_rev + + gas_rev%iunits = this%iunits + gas_rev%scale_factor = this%scale_factor + gas_rev%is_present = this%is_present + gas_rev%is_well_mixed = this%is_well_mixed + gas_rev%ntype = this%ntype + gas_rev%ncol = this%ncol + gas_rev%nlev = this%nlev + gas_rev%icode = this%icode + + if (allocated(gas_rev%mixing_ratio)) deallocate(gas_rev%mixing_ratio) + + if (allocated(this%mixing_ratio)) then + allocate(gas_rev%mixing_ratio(istartcol:iendcol,this%nlev,NMaxGases)) + gas_rev%mixing_ratio(istartcol:iendcol,:,:) & + & = this%mixing_ratio(istartcol:iendcol,this%nlev:1:-1,:) + end if + + end subroutine reverse_gas + + !--------------------------------------------------------------------- + ! Return .true. if variables are out of a physically sensible range, + ! optionally only considering columns between istartcol and iendcol + function out_of_physical_bounds(this, istartcol, iendcol, do_fix) result(is_bad) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_check, only : out_of_bounds_3d + + class(gas_type), intent(inout) :: this + integer, optional,intent(in) :: istartcol, iendcol + logical, optional,intent(in) :: do_fix + logical :: is_bad + + logical :: do_fix_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_gas:out_of_physical_bounds',0,hook_handle) + + if (present(do_fix)) then + do_fix_local = do_fix + else + do_fix_local = .false. + end if + + is_bad = out_of_bounds_3d(this%mixing_ratio, 'gas%mixing_ratio', & + & 0.0_jprb, 1.0_jprb, do_fix_local, i1=istartcol, i2=iendcol) + + if (lhook) call dr_hook('radiation_gas:out_of_physical_bounds',1,hook_handle) + + end function out_of_physical_bounds + +#ifdef _OPENACC + !--------------------------------------------------------------------- + ! updates fields on host + subroutine update_host(this) + + class(gas_type), intent(inout) :: this + + !$ACC UPDATE HOST(this%mixing_ratio) & + !$ACC IF(allocated(this%mixing_ratio)) + + end subroutine update_host + + !--------------------------------------------------------------------- + ! updates fields on device + subroutine update_device(this) + + class(gas_type), intent(inout) :: this + + !$ACC UPDATE DEVICE(this%mixing_ratio) & + !$ACC IF(allocated(this%mixing_ratio)) + + end subroutine update_device +#endif + +end module radiation_gas Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_gas_constants.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_gas_constants.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_gas_constants.F90 (revision 6016) @@ -0,0 +1,70 @@ +! This file has been modified for the use in ICON + +! radiation_gas_constants.F90 - Molar mases and ID codes of the various gases +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_gas_constants + + use parkind1, only : jprb + + implicit none + + public + + ! Gas codes; these indices match those of RRTM-LW up to 7 + integer, parameter :: IGasNotPresent = 0 + integer, parameter :: IH2O = 1 + integer, parameter :: ICO2 = 2 + integer, parameter :: IO3 = 3 + integer, parameter :: IN2O = 4 + integer, parameter :: ICO = 5 + integer, parameter :: ICH4 = 6 + integer, parameter :: IO2 = 7 + integer, parameter :: ICFC11 = 8 + integer, parameter :: ICFC12 = 9 + integer, parameter :: IHCFC22= 10 + integer, parameter :: ICCl4 = 11 + integer, parameter :: INO2 = 12 + integer, parameter :: NMaxGases = 12 + !$ACC DECLARE COPYIN(NMaxGases) + + ! Molar masses (g mol-1) of dry air and the various gases above + real(jprb), parameter :: AirMolarMass = 28.970_jprb + real(jprb), parameter, dimension(0:NMaxGases) :: GasMolarMass = (/ & + & 0.0_jprb, & ! Gas not present + & 18.0152833_jprb, & ! H2O + & 44.011_jprb, & ! CO2 + & 47.9982_jprb, & ! O3 + & 44.013_jprb, & ! N2O + & 28.0101_jprb, & ! CO + & 16.043_jprb, & ! CH4 + & 31.9988_jprb, & ! O2 + & 137.3686_jprb, & ! CFC11 + & 120.914_jprb, & ! CFC12 + & 86.469_jprb, & ! HCFC22 + & 153.823_jprb, & ! CCl4 + & 46.0055_jprb /) ! NO2 + + ! The corresponding names of the gases in upper and lower case, used + ! for reading variables from the input file + character*6, dimension(NMaxGases), parameter :: GasName & + & = (/'H2O ','CO2 ','O3 ','N2O ','CO ','CH4 ', & + & 'O2 ','CFC11 ','CFC12 ','HCFC22','CCl4 ','NO2 '/) + character*6, dimension(NMaxGases), parameter :: GasLowerCaseName & + & = (/'h2o ','co2 ','o3 ','n2o ','co ','ch4 ', & + & 'o2 ','cfc11 ','cfc12 ','hcfc22','ccl4 ','no2 '/) + +end module radiation_gas_constants Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_general_cloud_optics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_general_cloud_optics.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_general_cloud_optics.F90 (revision 6016) @@ -0,0 +1,330 @@ +! radiation_general_cloud_optics.F90 - Computing generalized cloud optical properties +! +! (C) Copyright 2020- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_general_cloud_optics + + implicit none + + public + +contains + + ! Provides elemental function "delta_eddington_scat_od" +#include "radiation_delta_eddington.h" + + + !--------------------------------------------------------------------- + ! Load cloud scattering data; this subroutine delegates to one + ! in radiation_general_cloud_optics_data.F90 + subroutine setup_general_cloud_optics(config) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulout + use radiation_config, only : config_type, NMaxCloudTypes + use radiation_spectral_definition, only : SolarReferenceTemperature, & + & TerrestrialReferenceTemperature + + type(config_type), intent(inout) :: config + + character(len=511) :: file_name + + integer :: jtype ! loop index + integer :: strlen + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics:setup_general_cloud_optics',0,hook_handle) + + ! Count number of cloud types + config%n_cloud_types = 0 + do jtype = 1,NMaxCloudTypes + if (len_trim(config%cloud_type_name(jtype)) > 0) then + config%n_cloud_types = jtype + else + exit + end if + end do + + ! If cloud_type_name has not been provided then assume liquid,ice + ! noting that the default spectral averaging (defined in + ! radiation_config.F90) is "thick" + if (config%n_cloud_types == 0) then + config%cloud_type_name(1) = "mie_droplet" + config%cloud_type_name(2) = "baum-general-habit-mixture_ice" + ! Optionally override spectral averaging method + !config%use_thick_cloud_spectral_averaging(1) = .false. + !config%use_thick_cloud_spectral_averaging(2) = .false. + config%n_cloud_types = 2 + end if + + ! Allocate structures + if (config%do_sw) then + allocate(config%cloud_optics_sw(config%n_cloud_types)) + end if + + if (config%do_lw) then + allocate(config%cloud_optics_lw(config%n_cloud_types)) + end if + + ! Load cloud optics data + do jtype = 1,config%n_cloud_types + if (config%cloud_type_name(jtype)(1:1) == '/') then + file_name = trim(config%cloud_type_name(jtype)) + else + strlen = len_trim(config%cloud_type_name(jtype)) + if (config%cloud_type_name(jtype)(strlen-2:strlen) == ".nc") then + file_name = trim(config%directory_name) & + & // '/' // trim(config%cloud_type_name(jtype)) + else + file_name = trim(config%directory_name) & + & // '/' // trim(config%cloud_type_name(jtype)) & + & // '_scattering.nc' + end if + end if + + if (config%do_sw) then + if (config%iverbosesetup >= 2) then + write(nulout,'(a,i0,a)') 'Shortwave cloud type ', jtype, ':' + end if + call config%cloud_optics_sw(jtype)%setup(file_name, & + & config%gas_optics_sw%spectral_def, & + & use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point), & + & use_thick_averaging=config%use_thick_cloud_spectral_averaging(jtype), & + & weighting_temperature=SolarReferenceTemperature, & + & iverbose=config%iverbosesetup) + config%cloud_optics_sw(jtype)%type_name = trim(config%cloud_type_name(jtype)) + end if + + if (config%do_lw) then + if (config%iverbosesetup >= 2) then + write(nulout,'(a,i0,a)') 'Longwave cloud type ', jtype, ':' + end if + call config%cloud_optics_lw(jtype)%setup(file_name, & + & config%gas_optics_lw%spectral_def, & + & use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point), & + & use_thick_averaging=config%use_thick_cloud_spectral_averaging(jtype), & + & weighting_temperature=TerrestrialReferenceTemperature, & + & iverbose=config%iverbosesetup) + config%cloud_optics_lw(jtype)%type_name = trim(config%cloud_type_name(jtype)) + end if + + end do + + if (lhook) call dr_hook('radiation_general_cloud_optics:setup_general_cloud_optics',1,hook_handle) + + end subroutine setup_general_cloud_optics + + !--------------------------------------------------------------------- + ! Compute cloud optical properties + subroutine general_cloud_optics(nlev,istartcol,iendcol, & + & config, thermodynamics, cloud, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulout + use radiation_config, only : config_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_cloud, only : cloud_type + use radiation_constants, only : AccelDueToGravity + !use radiation_general_cloud_optics_data, only : general_cloud_optics_type + + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in), target :: config + type(thermodynamics_type),intent(in) :: thermodynamics + type(cloud_type), intent(in) :: cloud + + ! Layer optical depth, single scattering albedo and g factor of + ! clouds in each longwave band, where the latter two + ! variables are only defined if cloud longwave scattering is + ! enabled (otherwise both are treated as zero). + real(jprb), dimension(config%n_bands_lw,nlev,istartcol:iendcol), intent(out) :: & + & od_lw_cloud + real(jprb), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol), & + & intent(out) :: ssa_lw_cloud, g_lw_cloud + + ! Layer optical depth, single scattering albedo and g factor of + ! clouds in each shortwave band + real(jprb), dimension(config%n_bands_sw,nlev,istartcol:iendcol), intent(out) :: & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud + + ! In-cloud water path of one cloud type (kg m-2) + real(jprb), dimension(istartcol:iendcol,nlev) :: water_path + + integer :: jtype, jcol, jlev, jg + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics:general_cloud_optics',0,hook_handle) + + if (config%iverbose >= 2) then + write(nulout,'(a)') 'Computing cloud absorption/scattering properties' + end if + + ! Array-wise assignment + od_lw_cloud = 0.0_jprb + od_sw_cloud = 0.0_jprb + ssa_sw_cloud = 0.0_jprb + g_sw_cloud = 0.0_jprb + if (config%do_lw_cloud_scattering) then + ssa_lw_cloud = 0.0_jprb + g_lw_cloud = 0.0_jprb + end if + + ! Loop over cloud types + do jtype = 1,config%n_cloud_types + ! Compute in-cloud water path + if (config%is_homogeneous) then + water_path = cloud%mixing_ratio(istartcol:iendcol,:,jtype) & + & * (thermodynamics%pressure_hl(istartcol:iendcol, 2:nlev+1) & + & -thermodynamics%pressure_hl(istartcol:iendcol, 1:nlev)) & + & * (1.0_jprb / AccelDueToGravity) + else + water_path = cloud%mixing_ratio(istartcol:iendcol,:,jtype) & + & * (thermodynamics%pressure_hl(istartcol:iendcol, 2:nlev+1) & + & -thermodynamics%pressure_hl(istartcol:iendcol, 1:nlev)) & + & * (1.0_jprb / (AccelDueToGravity & + & * max(config%cloud_fraction_threshold, & + & cloud%fraction(istartcol:iendcol,:)))) + end if + + ! Add optical properties to the cumulative total for the + ! longwave and shortwave + if (config%do_lw) then + ! For the moment, we use ssa_lw_cloud and g_lw_cloud as + ! containers for scattering optical depth and scattering + ! coefficient x asymmetry factor, then scale after + if (config%do_lw_cloud_scattering) then + call config%cloud_optics_lw(jtype)%add_optical_properties(config%n_bands_lw, nlev, & + & iendcol+1-istartcol, cloud%fraction(istartcol:iendcol,:), & + & water_path, cloud%effective_radius(istartcol:iendcol,:,jtype), & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud) + else + call config%cloud_optics_lw(jtype)%add_optical_properties(config%n_bands_lw, nlev, & + & iendcol+1-istartcol, cloud%fraction(istartcol:iendcol,:), & + & water_path, cloud%effective_radius(istartcol:iendcol,:,jtype), od_lw_cloud) + end if + end if + + if (config%do_sw) then + ! For the moment, we use ssa_sw_cloud and g_sw_cloud as + ! containers for scattering optical depth and scattering + ! coefficient x asymmetry factor, then scale after + call config%cloud_optics_sw(jtype)%add_optical_properties(config%n_bands_sw, nlev, & + & iendcol+1-istartcol, cloud%fraction(istartcol:iendcol,:), & + & water_path, cloud%effective_radius(istartcol:iendcol,:,jtype), & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + end if + end do + + ! Scale the combined longwave optical properties + if (config%do_lw_cloud_scattering) then + do jcol = istartcol, iendcol + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + ! Note that original cloud optics does not do + ! delta-Eddington scaling for liquid clouds in longwave + call delta_eddington_extensive(od_lw_cloud(:,jlev,jcol), & + & ssa_lw_cloud(:,jlev,jcol), g_lw_cloud(:,jlev,jcol)) + + ! Scale to get asymmetry factor and single scattering albedo + g_lw_cloud(:,jlev,jcol) = g_lw_cloud(:,jlev,jcol) & + & / max(ssa_lw_cloud(:,jlev,jcol), 1.0e-15_jprb) + ssa_lw_cloud(:,jlev,jcol) = ssa_lw_cloud(:,jlev,jcol) & + & / max(od_lw_cloud(:,jlev,jcol), 1.0e-15_jprb) + end if + end do + end do + end if + + ! Scale the combined shortwave optical properties + if (config%do_sw) then + if (.not. config%do_sw_delta_scaling_with_gases) then + do jcol = istartcol, iendcol + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + call delta_eddington_extensive(od_sw_cloud(:,jlev,jcol), & + & ssa_sw_cloud(:,jlev,jcol), g_sw_cloud(:,jlev,jcol)) + end if + end do + end do + end if + + do jcol = istartcol, iendcol + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + ! Scale to get asymmetry factor and single scattering albedo + do jg = 1, config%n_bands_sw + g_sw_cloud(jg,jlev,jcol) = g_sw_cloud(jg,jlev,jcol) & + & / max(ssa_sw_cloud(jg,jlev,jcol), 1.0e-15_jprb) + ssa_sw_cloud(jg,jlev,jcol) = ssa_sw_cloud(jg,jlev,jcol) & + & / max(od_sw_cloud(jg,jlev,jcol), 1.0e-15_jprb) + end do + end if + end do + end do + end if + + if (lhook) call dr_hook('radiation_general_cloud_optics:general_cloud_optics',1,hook_handle) + + end subroutine general_cloud_optics + + + !--------------------------------------------------------------------- + ! Save all the cloud optics look-up tables for sw/lw and for each + ! hydrometeor type + subroutine save_general_cloud_optics(config, file_prefix, iverbose) + + use yomhook, only : lhook, dr_hook, jphook + use easy_netcdf, only : netcdf_file + use radiation_config, only : config_type + + type(config_type), intent(in) :: config + character(len=*), intent(in) :: file_prefix + integer, optional, intent(in) :: iverbose + + integer :: jtype + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics:save',0,hook_handle) + + do jtype = 1,config%n_cloud_types + if (config%do_sw) then + associate(co_sw => config%cloud_optics_sw(jtype)) + call co_sw%save(file_prefix//"_sw_" & + & //trim(co_sw%type_name)//".nc", iverbose) + end associate + end if + + if (config%do_lw) then + associate(co_lw => config%cloud_optics_lw(jtype)) + call co_lw%save(file_prefix//"_lw_" & + & //trim(co_lw%type_name)//".nc", iverbose) + end associate + end if + end do + + if (lhook) call dr_hook('radiation_general_cloud_optics:save',1,hook_handle) + + end subroutine save_general_cloud_optics + +end module radiation_general_cloud_optics Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_general_cloud_optics_data.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_general_cloud_optics_data.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_general_cloud_optics_data.F90 (revision 6016) @@ -0,0 +1,422 @@ +! radiation_general_cloud_optics_data.F90 - Type to store generalized cloud optical properties +! +! (C) Copyright 2019- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +#include "ecrad_config.h" + +module radiation_general_cloud_optics_data + + use parkind1, only : jprb + + implicit none + + public + + !--------------------------------------------------------------------- + ! This type holds the configuration information to compute optical + ! properties for a particular type of cloud or hydrometeor in one of + ! the shortwave or longwave + type general_cloud_optics_type + ! Band-specific (or g-point-specific) values as a look-up table + ! versus effective radius dimensioned (nband,n_effective_radius) + + ! Extinction coefficient per unit mass (m2 kg-1) + real(jprb), allocatable, dimension(:,:) :: & + & mass_ext + + ! Single-scattering albedo and asymmetry factor (dimensionless) + real(jprb), allocatable, dimension(:,:) :: & + & ssa, asymmetry + + ! Number of effective radius coefficients, start value and + ! interval in look-up table + integer :: n_effective_radius = 0 + real(jprb) :: effective_radius_0, d_effective_radius + + ! Name of cloud/precip type and scattering model + ! (e.g. "mie_droplet", "fu-muskatel_ice"). These are used to + ! generate the name of the data file from which the coefficients + ! are read. + character(len=511) :: type_name + + ! Do we use bands or g-points? + logical :: use_bands = .false. + + contains + procedure :: setup => setup_general_cloud_optics + procedure :: add_optical_properties + procedure :: save => save_general_cloud_optics_data + + end type general_cloud_optics_type + +contains + + ! Provides elemental function "delta_eddington" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Setup cloud optics coefficients by reading them from a file + subroutine setup_general_cloud_optics(this, file_name, specdef, & + & use_bands, use_thick_averaging, & + & weighting_temperature, & + & iverbose) + + use yomhook, only : lhook, dr_hook, jphook +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + use radiation_spectral_definition, only : spectral_definition_type + use radiation_io, only : nulout, nulerr, radiation_abort + + class(general_cloud_optics_type), intent(inout) :: this + character(len=*), intent(in) :: file_name + type(spectral_definition_type), intent(in) :: specdef + logical, intent(in), optional :: use_bands, use_thick_averaging + real(jprb), intent(in), optional :: weighting_temperature ! K + integer, intent(in), optional :: iverbose + + ! Spectral properties read from file, dimensioned (wavenumber, + ! n_effective_radius) + real(jprb), dimension(:,:), allocatable :: mass_ext, & ! m2 kg-1 + & ssa, asymmetry + + ! Reflectance of an infinitely thick cloud, needed for thick + ! averaging + real(jprb), dimension(:,:), allocatable :: ref_inf + + ! Coordinate variables from file + real(jprb), dimension(:), allocatable :: wavenumber ! cm-1 + real(jprb), dimension(:), allocatable :: effective_radius ! m + + ! Matrix mapping optical properties in the file to values per + ! g-point or band, such that in the thin-averaging case, + ! this%mass_ext=matmul(mapping,file%mass_ext), so mapping is + ! dimensioned (ngpoint,nwav) + real(jprb), dimension(:,:), allocatable :: mapping + + ! The NetCDF file containing the coefficients + type(netcdf_file) :: file + + real(jprb) :: diff_spread + integer :: iverb + integer :: nre ! Number of effective radii + integer :: nwav ! Number of wavenumbers describing cloud + + logical :: use_bands_local, use_thick_averaging_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:setup',0,hook_handle) + + ! Set local values of optional inputs + if (present(iverbose)) then + iverb = iverbose + else + iverb = 2 + end if + + if (present(use_bands)) then + use_bands_local = use_bands + else + use_bands_local = .false. + end if + + if (present(use_thick_averaging)) then + use_thick_averaging_local = use_thick_averaging + else + use_thick_averaging_local = .false. + end if + + ! Open the scattering file and configure the way it is read + call file%open(trim(file_name), iverbose=iverb) + !call file%transpose_matrices() + + ! Read coordinate variables + call file%get('wavenumber', wavenumber) + call file%get('effective_radius', effective_radius) + + ! Read the band-specific coefficients + call file%get('mass_extinction_coefficient', mass_ext) + call file%get('single_scattering_albedo', ssa) + call file%get('asymmetry_factor', asymmetry) + + ! Close scattering file + call file%close() + + ! Check effective radius is evenly spaced + nre = size(effective_radius) + ! Fractional range of differences, should be near zero for evenly + ! spaced data + diff_spread = (maxval(effective_radius(2:nre)-effective_radius(1:nre-1)) & + & -minval(effective_radius(2:nre)-effective_radius(1:nre-1))) & + & / minval(abs(effective_radius(2:nre)-effective_radius(1:nre-1))) + if (diff_spread > 0.01_jprb) then + write(nulerr, '(a,a,a)') '*** Error: effective_radius in ', & + & trim(file_name), ', is not evenly spaced to 1%' + call radiation_abort('Radiation configuration error') + end if + + ! Set up effective radius coordinate variable + this%n_effective_radius = nre + this%effective_radius_0 = effective_radius(1) + this%d_effective_radius = effective_radius(2) - effective_radius(1) + + nwav = size(wavenumber) + + ! Define the mapping matrix + call specdef%calc_mapping(wavenumber, mapping, & + weighting_temperature=weighting_temperature, use_bands=use_bands) + + ! Thick averaging should be performed on delta-Eddington scaled + ! quantities (it makes no difference to thin averaging) + call delta_eddington(mass_ext, ssa, asymmetry) + + ! Thin averaging + + ! Circumvent ifort bug (see https://github.com/ecmwf-ifs/ecrad/issues/13): + allocate(this%mass_ext(size(mapping, 1), nre)) + + this%mass_ext = matmul(mapping, mass_ext) + this%ssa = matmul(mapping, mass_ext*ssa) / this%mass_ext + this%asymmetry = matmul(mapping, mass_ext*ssa*asymmetry) / (this%mass_ext*this%ssa) + + if (use_thick_averaging_local) then + ! Thick averaging as described by Edwards and Slingo (1996), + ! modifying only the single-scattering albedo + allocate(ref_inf(nwav, nre)) + + ! Eqs. 18 and 17 of Edwards & Slingo (1996) + ref_inf = sqrt((1.0_jprb - ssa) / (1.0_jprb - ssa*asymmetry)) + ref_inf = (1.0_jprb - ref_inf) / (1.0_jprb + ref_inf) + ! Here the left-hand side is actually the averaged ref_inf + this%ssa = matmul(mapping, ref_inf) + ! Eq. 19 of Edwards and Slingo (1996) + this%ssa = 4.0_jprb * this%ssa / ((1.0_jprb + this%ssa)**2 & + & - this%asymmetry * (1.0_jprb - this%ssa)**2) + + deallocate(ref_inf) + end if + + deallocate(mapping) + + ! Revert back to unscaled quantities + call revert_delta_eddington(this%mass_ext, this%ssa, this%asymmetry) + + if (iverb >= 2) then + write(nulout,'(a,a)') ' File: ', trim(file_name) + if (present(weighting_temperature)) then + write(nulout,'(a,f7.1,a)') ' Weighting temperature: ', weighting_temperature, ' K' + else + write(nulout,'(a,f7.1,a)') ' Weighting temperature: ', specdef%reference_temperature, ' K' + end if + if (use_thick_averaging_local) then + write(nulout,'(a)') ' SSA averaging: optically thick limit' + else + write(nulout,'(a)') ' SSA averaging: optically thin limit' + end if + if (use_bands_local) then + write(nulout,'(a,i0,a)') ' Spectral discretization: ', specdef%nband, ' bands' + else + write(nulout,'(a,i0,a)') ' Spectral discretization: ', specdef%ng, ' g-points' + end if + write(nulout,'(a,i0,a,f6.1,a,f6.1,a)') ' Effective radius look-up: ', nre, ' points in range ', & + & effective_radius(1)*1.0e6_jprb, '-', effective_radius(nre)*1.0e6_jprb, ' um' + write(nulout,'(a,i0,a,i0,a)') ' Wavenumber range: ', int(specdef%min_wavenumber()), '-', & + & int(specdef%max_wavenumber()), ' cm-1' + end if + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:setup',1,hook_handle) + + end subroutine setup_general_cloud_optics + + + !--------------------------------------------------------------------- + ! Add the optical properties of a particular cloud type to the + ! accumulated optical properties of all cloud types + subroutine add_optical_properties(this, ng, nlev, ncol, & + & cloud_fraction, & + & water_path, effective_radius, & + & od, scat_od, scat_asymmetry) + + use yomhook, only : lhook, dr_hook, jphook + + class(general_cloud_optics_type), intent(in) :: this + + ! Number of g points, levels and columns + integer, intent(in) :: ng, nlev, ncol + + ! Properties of present cloud type, dimensioned (ncol,nlev) + real(jprb), intent(in) :: cloud_fraction(:,:) + real(jprb), intent(in) :: water_path(:,:) ! kg m-2 + real(jprb), intent(in) :: effective_radius(:,:) ! m + + ! Optical properties which are additive per cloud type, + ! dimensioned (ng,nlev,ncol) + real(jprb), intent(inout), dimension(ng,nlev,ncol) & + & :: od ! Optical depth of layer + real(jprb), intent(inout), dimension(ng,nlev,ncol), optional & + & :: scat_od, & ! Scattering optical depth of layer + & scat_asymmetry ! Scattering optical depth x asymmetry factor + + real(jprb) :: od_local + + real(jprb) :: re_index, weight1, weight2 + integer :: ire + + integer :: jcol, jlev, jg + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:add_optical_properties',0,hook_handle) + + if (present(scat_od)) then + do jcol = 1,ncol + do jlev = 1,nlev + if (cloud_fraction(jcol, jlev) > 0.0_jprb) then + re_index = max(1.0_jprb, min(1.0_jprb + (effective_radius(jcol,jlev)-this%effective_radius_0) & + & / this%d_effective_radius, this%n_effective_radius-0.0001_jprb)) + ire = int(re_index) + weight2 = re_index - ire + weight1 = 1.0_jprb - weight2 + do jg = 1, ng + od_local = water_path(jcol, jlev) * (weight1*this%mass_ext(jg,ire) & + & +weight2*this%mass_ext(jg,ire+1)) + od(jg,jlev,jcol) = od(jg,jlev,jcol) + od_local + od_local = od_local * (weight1*this%ssa(jg,ire) & + & +weight2*this%ssa(jg,ire+1)) + scat_od(jg,jlev,jcol) = scat_od(jg,jlev,jcol) + od_local + scat_asymmetry(jg,jlev,jcol) = scat_asymmetry(jg,jlev,jcol) & + & + od_local * (weight1*this%asymmetry(jg,ire) & + & +weight2*this%asymmetry(jg,ire+1)) + end do + + end if + end do + end do + else + ! No scattering: return the absorption optical depth + do jcol = 1,ncol + do jlev = 1,nlev + if (water_path(jcol, jlev) > 0.0_jprb) then + re_index = max(1.0_jprb, min(1.0_jprb + (effective_radius(jcol,jlev)-this%effective_radius_0) & + & / this%d_effective_radius, this%n_effective_radius-0.0001_jprb)) + ire = int(re_index) + weight2 = re_index - ire + weight1 = 1.0_jprb - weight2 + od(:,jlev,jcol) = od(:,jlev,jcol) & + & + water_path(jcol, jlev) * (weight1*this%mass_ext(:,ire) & + & +weight2*this%mass_ext(:,ire+1)) & + & * (1.0_jprb - (weight1*this%ssa(:,ire)+weight2*this%ssa(:,ire+1))) + end if + end do + end do + end if + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:add_optical_properties',1,hook_handle) + + end subroutine add_optical_properties + + + !--------------------------------------------------------------------- + ! Return the Planck function (in W m-2 (cm-1)-1) for a given + ! wavenumber (cm-1) and temperature (K), ensuring double precision + ! for internal calculation + elemental function calc_planck_function_wavenumber(wavenumber, temperature) + + use parkind1, only : jprb, jprd + use radiation_constants, only : SpeedOfLight, BoltzmannConstant, PlanckConstant + + real(jprb), intent(in) :: wavenumber ! cm-1 + real(jprb), intent(in) :: temperature ! K + real(jprb) :: calc_planck_function_wavenumber + + real(jprd) :: freq ! Hz + real(jprd) :: planck_fn_freq ! W m-2 Hz-1 + + freq = 100.0_jprd * real(SpeedOfLight,jprd) * real(wavenumber,jprd) + planck_fn_freq = 2.0_jprd * real(PlanckConstant,jprd) * freq**3 & + & / (real(SpeedOfLight,jprd)**2 * (exp(real(PlanckConstant,jprd)*freq & + & /(real(BoltzmannConstant,jprd)*real(temperature,jprd))) - 1.0_jprd)) + calc_planck_function_wavenumber = real(planck_fn_freq * 100.0_jprd * real(SpeedOfLight,jprd), jprb) + + end function calc_planck_function_wavenumber + + !--------------------------------------------------------------------- + ! Save cloud optical properties in the named file + subroutine save_general_cloud_optics_data(this, file_name, iverbose) + + use yomhook, only : lhook, dr_hook, jphook + use easy_netcdf, only : netcdf_file + + class(general_cloud_optics_type), intent(in) :: this + character(len=*), intent(in) :: file_name + integer, optional, intent(in) :: iverbose + + ! Object for output NetCDF file + type(netcdf_file) :: out_file + + real(jprb) :: effective_radius(this%n_effective_radius) + integer :: ire + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:save',0,hook_handle) + + ! Create the file + call out_file%create(trim(file_name), iverbose=iverbose) + + ! Define dimensions + call out_file%define_dimension("band", size(this%mass_ext,1)) + call out_file%define_dimension("effective_radius", this%n_effective_radius) + + ! Put global attributes + call out_file%put_global_attributes( & + & title_str="Optical properties of "//trim(this%type_name) & + & //" hydrometeors using the spectral intervals of ecRad", & + & source_str="ecRad offline radiation model") + + ! Define variables + call out_file%define_variable("effective_radius", units_str="m", & + & long_name="Effective radius", dim1_name="effective_radius") + call out_file%define_variable("mass_extinction_coefficient", units_str="m2 kg-1", & + & long_name="Mass-extinction coefficient", & + & dim2_name="effective_radius", dim1_name="band") + call out_file%define_variable("single_scattering_albedo", units_str="1", & + & long_name="Single scattering albedo", & + & dim2_name="effective_radius", dim1_name="band") + call out_file%define_variable("asymmetry_factor", units_str="1", & + & long_name="Asymmetry factor", & + & dim2_name="effective_radius", dim1_name="band") + + ! Define effective radius + do ire = 1,this%n_effective_radius + effective_radius(ire) = this%effective_radius_0 + this%d_effective_radius*(ire-1) + end do + + ! Write variables + call out_file%put("effective_radius", effective_radius) + call out_file%put("mass_extinction_coefficient", this%mass_ext) + call out_file%put("single_scattering_albedo", this%ssa) + call out_file%put("asymmetry_factor", this%asymmetry) + + call out_file%close() + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:save',1,hook_handle) + + end subroutine save_general_cloud_optics_data + +end module radiation_general_cloud_optics_data Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_homogeneous_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_homogeneous_lw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_homogeneous_lw.F90 (revision 6016) @@ -0,0 +1,317 @@ +! radiation_homogeneous_lw.F90 - Longwave homogeneous-column (no cloud fraction) solver +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive emission/albedo rather than planck/emissivity +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-10-23 R. Hogan Renamed single-character variables +! 2019-01-14 R. Hogan Save spectral flux profile if required + +module radiation_homogeneous_lw + + public + +contains + + !--------------------------------------------------------------------- + ! Longwave homogeneous solver, in which clouds are assumed to fill + ! the gridbox horizontally + subroutine solver_homogeneous_lw(nlev,istartcol,iendcol, & + & config, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, planck_hl, & + & emission, albedo, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config, only : config_type + use radiation_cloud, only : cloud_type + use radiation_flux, only : flux_type, indexed_sum_profile + use radiation_two_stream, only : calc_two_stream_gammas_lw, & + & calc_reflectance_transmittance_lw, & + & calc_no_scattering_transmittance_lw + use radiation_adding_ica_lw, only : adding_ica_lw, calc_fluxes_no_scattering_lw + use radiation_lw_derivatives, only : calc_lw_derivatives_ica + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, nlev, istartcol:iendcol) :: & + & od + real(jprb), intent(in), dimension(config%n_g_lw_if_scattering, nlev, istartcol:iendcol) :: & + & ssa, g + + ! Cloud and precipitation optical depth, single-scattering albedo and + ! asymmetry factor in each longwave band + real(jprb), intent(in), dimension(config%n_bands_lw,nlev,istartcol:iendcol) :: & + & od_cloud + real(jprb), intent(in), dimension(config%n_bands_lw_if_scattering, & + & nlev,istartcol:iendcol) :: ssa_cloud, g_cloud + + ! Planck function at each half-level and the surface + real(jprb), intent(in), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: & + & planck_hl + + ! Emission (Planck*emissivity) and albedo (1-emissivity) at the + ! surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, istartcol:iendcol) & + & :: emission, albedo + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! Diffuse reflectance and transmittance for each layer in clear + ! and all skies + real(jprb), dimension(config%n_g_lw, nlev) :: reflectance, transmittance + + ! Emission by a layer into the upwelling or downwelling diffuse + ! streams, in clear and all skies + real(jprb), dimension(config%n_g_lw, nlev) :: source_up, source_dn + + ! Fluxes per g point + real(jprb), dimension(config%n_g_lw, nlev+1) :: flux_up, flux_dn + + ! Combined gas+aerosol+cloud optical depth, single scattering + ! albedo and asymmetry factor + real(jprb), dimension(config%n_g_lw) :: od_total, ssa_total, g_total + + ! Two-stream coefficients + real(jprb), dimension(config%n_g_lw) :: gamma1, gamma2 + + ! Optical depth of cloud in g-point space + real(jprb), dimension(config%n_g_lw) :: od_cloud_g + + ! Is there any cloud in the profile? + logical :: is_cloudy_profile + + ! Number of g points + integer :: ng + + ! Loop indices for level and column + integer :: jlev, jcol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_homogeneous_lw:solver_homogeneous_lw',0,hook_handle) + + ng = config%n_g_lw + + ! Loop through columns + do jcol = istartcol,iendcol + + ! Is there any cloud in the profile? + is_cloudy_profile = .false. + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then + is_cloudy_profile = .true. + exit + end if + end do + + ! If clear-sky fluxes need to be computed then we first compute + ! the reflectance and transmittance of all layers, neglecting + ! clouds. If clear-sky fluxes are not required then we only do + ! the clear-sky layers since these will be needed when we come + ! to do the total-sky fluxes. + do jlev = 1,nlev + if (config%do_clear .or. cloud%fraction(jcol,jlev) & + & < config%cloud_fraction_threshold) then + if (config%do_lw_aerosol_scattering) then + ! Scattering case: first compute clear-sky reflectance, + ! transmittance etc at each model level + ssa_total = ssa(:,jlev,jcol) + g_total = g(:,jlev,jcol) + call calc_two_stream_gammas_lw(ng, ssa_total, g_total, & + & gamma1, gamma2) + call calc_reflectance_transmittance_lw(ng, & + & od(:,jlev,jcol), gamma1, gamma2, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & + & reflectance(:,jlev), transmittance(:,jlev), & + & source_up(:,jlev), source_dn(:,jlev)) + else + ! Non-scattering case: use simpler functions for + ! transmission and emission + call calc_no_scattering_transmittance_lw(ng, od(:,jlev,jcol), & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & transmittance(:,jlev), source_up(:,jlev), source_dn(:,jlev)) + ! Ensure that clear-sky reflectance is zero since it may be + ! used in cloudy-sky case + reflectance(:,jlev) = 0.0_jprb + end if + + end if + end do + + if (config%do_clear) then + if (config%do_lw_aerosol_scattering) then + ! Then use adding method to compute fluxes + call adding_ica_lw(ng, nlev, & + & reflectance, transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up, flux_dn) + else + ! Simpler down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up, flux_dn) + + end if + + ! Sum over g-points to compute broadband fluxes + flux%lw_up_clear(jcol,:) = sum(flux_up,1) + flux%lw_dn_clear(jcol,:) = sum(flux_dn,1) + ! Store surface spectral downwelling fluxes + flux%lw_dn_surf_clear_g(:,jcol) = flux_dn(:,nlev+1) + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum_profile(flux_up, config%i_spec_from_reordered_g_lw, & + & flux%lw_up_clear_band(:,jcol,:)) + call indexed_sum_profile(flux_dn, config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_clear_band(:,jcol,:)) + end if + + end if ! Do clear-sky calculations + + ! Now the total-sky calculation. If this is a clear profile and + ! clear-sky fluxes have been calculated then we can simply copy + ! over the clear-sky fluxes, otherwise we need to compute fluxes + ! now. + if (is_cloudy_profile .or. .not. config%do_clear) then + do jlev = 1,nlev + ! Compute combined gas+aerosol+cloud optical properties; + ! note that for clear layers, the reflectance and + ! transmittance have already been calculated + if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then + od_cloud_g = od_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) + od_total = od(:,jlev,jcol) + od_cloud_g + ssa_total = 0.0_jprb + g_total = 0.0_jprb + + if (config%do_lw_cloud_scattering) then + ! Scattering case: calculate reflectance and + ! transmittance at each model level + if (config%do_lw_aerosol_scattering) then + where (od_total > 0.0_jprb) + ssa_total = (ssa(:,jlev,jcol)*od(:,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_g) & + & / od_total + end where + where (ssa_total > 0.0_jprb .and. od_total > 0.0_jprb) + g_total = (g(:,jlev,jcol)*ssa(:,jlev,jcol)*od(:,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_g) & + & / (ssa_total*od_total) + end where + else + where (od_total > 0.0_jprb) + ssa_total = ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_g / od_total + end where + where (ssa_total > 0.0_jprb .and. od_total > 0.0_jprb) + g_total = g_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_g / (ssa_total*od_total) + end where + end if + + ! Compute cloudy-sky reflectance, transmittance etc at + ! each model level + call calc_two_stream_gammas_lw(ng, ssa_total, g_total, & + & gamma1, gamma2) + call calc_reflectance_transmittance_lw(ng, & + & od_total, gamma1, gamma2, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & + & reflectance(:,jlev), transmittance(:,jlev), & + & source_up(:,jlev), source_dn(:,jlev)) + else + ! No-scattering case: use simpler functions for + ! transmission and emission + call calc_no_scattering_transmittance_lw(ng, od_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & transmittance(:,jlev), source_up(:,jlev), source_dn(:,jlev)) + end if + end if ! is cloudy layer + end do + + if (config%do_lw_cloud_scattering) then + ! Use adding method to compute fluxes for an overcast sky + call adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up, flux_dn) + else + ! Simpler down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & transmittance, source_up, source_dn, emission(:,jcol), albedo(:,jcol), & + & flux_up, flux_dn) + end if + + ! Store overcast broadband fluxes + flux%lw_up(jcol,:) = sum(flux_up,1) + flux%lw_dn(jcol,:) = sum(flux_dn,1) + ! Store surface spectral downwelling fluxes + flux%lw_dn_surf_g(:,jcol) = flux_dn(:,nlev+1) + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum_profile(flux_up, config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,:)) + call indexed_sum_profile(flux_dn, config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_band(:,jcol,:)) + end if + + else + ! No cloud in profile and clear-sky fluxes already + ! calculated: copy them over + flux%lw_up(jcol,:) = flux%lw_up_clear(jcol,:) + flux%lw_dn(jcol,:) = flux%lw_dn_clear(jcol,:) + flux%lw_dn_surf_g(:,jcol) = flux%lw_dn_surf_clear_g(:,jcol) + + if (config%do_save_spectral_flux) then + flux%lw_up_band(:,jcol,:) = flux%lw_up_clear_band(:,jcol,:) + flux%lw_dn_band(:,jcol,:) = flux%lw_dn_clear_band(:,jcol,:) + end if + + end if + + ! Compute the longwave derivatives needed by Hogan and Bozzo + ! (2015) approximate radiation update scheme, using clear-sky + ! transmittance if no clouds were present in the profile, + ! all-sky transmittance otherwise + if (config%do_lw_derivatives) then + call calc_lw_derivatives_ica(ng, nlev, jcol, transmittance, flux_up(:,nlev+1), & + & flux%lw_derivatives) + + end if + + end do + + if (lhook) call dr_hook('radiation_homogeneous_lw:solver_homogeneous_lw',1,hook_handle) + + end subroutine solver_homogeneous_lw + +end module radiation_homogeneous_lw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_homogeneous_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_homogeneous_sw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_homogeneous_sw.F90 (revision 6016) @@ -0,0 +1,386 @@ +! This file has been modified for the use in ICON + +! radiation_homogeneous_sw.F90 - Shortwave homogeneous-column (no cloud fraction) solver +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive albedos at g-points +! 2017-04-22 R. Hogan Store surface fluxes at all g points +! 2017-10-23 R. Hogan Renamed single-character variables +! 2019-01-14 R. Hogan Save spectral flux profile if required + +module radiation_homogeneous_sw + + public + +contains + + ! Provides elemental function "delta_eddington" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Shortwave homogeneous solver, in which clouds are assumed to fill + ! the gridbox horizontally + subroutine solver_homogeneous_sw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, & + & albedo_direct, albedo_diffuse, incoming_sw, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_cloud, only : cloud_type + use radiation_flux, only : flux_type, & + & indexed_sum_profile, add_indexed_sum_profile + use radiation_two_stream, only : calc_two_stream_gammas_sw, & + & calc_reflectance_transmittance_sw + use radiation_constants, only : Pi, GasConstantDryAir, & + & AccelDueToGravity + use radiation_adding_ica_sw, only : adding_ica_sw + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each shortwave g-point + real(jprb), intent(in), dimension(config%n_g_sw, nlev, istartcol:iendcol) :: & + & od, ssa, g + + ! Cloud and precipitation optical depth, single-scattering albedo and + ! asymmetry factor in each shortwave band + real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: & + & od_cloud, ssa_cloud, g_cloud + + ! Direct and diffuse surface albedos, and the incoming shortwave + ! flux into a plane perpendicular to the incoming radiation at + ! top-of-atmosphere in each of the shortwave g points + real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) :: & + & albedo_direct, albedo_diffuse, incoming_sw + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! Cosine of solar zenith angle + real(jprb) :: cos_sza + + ! Diffuse reflectance and transmittance for each layer + real(jprb), dimension(config%n_g_sw, nlev) :: reflectance, transmittance + + ! Fraction of direct beam scattered by a layer into the upwelling + ! or downwelling diffuse streams + real(jprb), dimension(config%n_g_sw, nlev) :: ref_dir, trans_dir_diff + + ! Transmittance for the direct beam in clear and all skies + real(jprb), dimension(config%n_g_sw, nlev) :: trans_dir_dir + + ! Fluxes per g point + real(jprb), dimension(config%n_g_sw, nlev+1) :: flux_up, flux_dn_diffuse, flux_dn_direct + + ! Combined gas+aerosol+cloud optical depth, single scattering + ! albedo and asymmetry factor + real(jprb), dimension(config%n_g_sw) :: od_total, ssa_total, g_total + + ! Two-stream coefficients + real(jprb), dimension(config%n_g_sw) :: gamma1, gamma2, gamma3 + + ! Optical depth of cloud in g-point space + real(jprb), dimension(config%n_g_sw) :: od_cloud_g + + ! Temporary working array + real(jprb), dimension(config%n_g_sw,nlev+1) :: tmp_work_albedo, tmp_work_source + real(jprb), dimension(config%n_g_sw,nlev) :: tmp_work_inv_denominator + + ! Is there any cloud in the profile? + logical :: is_cloudy_profile + + ! Number of g points + integer :: ng + + ! Loop indices for level and column + integer :: jlev, jcol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_homogeneous_sw:solver_homogeneous_sw',0,hook_handle) + + ng = config%n_g_sw + + ! Loop through columns + do jcol = istartcol,iendcol + ! Only perform calculation if sun above the horizon + if (single_level%cos_sza(jcol) > 0.0_jprb) then + + cos_sza = single_level%cos_sza(jcol) + + ! Is there any cloud in the profile? + is_cloudy_profile = .false. + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then + is_cloudy_profile = .true. + exit + end if + end do + + ! If clear-sky fluxes need to be computed then we first + ! compute the reflectance and transmittance of all layers, + ! neglecting clouds. If clear-sky fluxes are not required then + ! we only do the clear-sky layers since these will be needed + ! when we come to do the total-sky fluxes. + if (.not. config%do_sw_delta_scaling_with_gases) then + ! Delta-Eddington scaling has already been performed to the + ! aerosol part of od, ssa and g + do jlev = 1,nlev + if (config%do_clear .or. cloud%fraction(jcol,jlev) & + & < config%cloud_fraction_threshold) then + call calc_two_stream_gammas_sw(ng, cos_sza, & + & ssa(:,jlev,jcol), g(:,jlev,jcol), & + & gamma1, gamma2, gamma3) + call calc_reflectance_transmittance_sw(ng, & + & cos_sza, & + & od(:,jlev,jcol), ssa(:,jlev,jcol), & + & gamma1, gamma2, gamma3, & + & reflectance(:,jlev), transmittance(:,jlev), & + & ref_dir(:,jlev), trans_dir_diff(:,jlev), & + & trans_dir_dir(:,jlev) ) + + end if + end do + else + ! Apply delta-Eddington scaling to the aerosol-gas mixture + do jlev = 1,nlev + if (config%do_clear .or. cloud%fraction(jcol,jlev) & + & < config%cloud_fraction_threshold) then + od_total = od(:,jlev,jcol) + ssa_total = ssa(:,jlev,jcol) + g_total = g(:,jlev,jcol) + call delta_eddington(od_total, ssa_total, g_total) + call calc_two_stream_gammas_sw(ng, & + & cos_sza, ssa_total, g_total, & + & gamma1, gamma2, gamma3) + call calc_reflectance_transmittance_sw(ng, & + & cos_sza, od_total, ssa_total, & + & gamma1, gamma2, gamma3, & + & reflectance(:,jlev), transmittance(:,jlev), & + & ref_dir(:,jlev), trans_dir_diff(:,jlev), & + & trans_dir_dir(:,jlev) ) + end if + end do + end if + + if (config%do_clear) then + ! Use adding method to compute fluxes + call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), & + & albedo_diffuse(:,jcol), albedo_direct(:,jcol), & + & cos_sza, reflectance, transmittance, ref_dir, trans_dir_diff, & + & trans_dir_dir, flux_up, flux_dn_diffuse, flux_dn_direct, & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + + ! Sum over g-points to compute and save clear-sky broadband + ! fluxes + flux%sw_up_clear(jcol,:) = sum(flux_up,1) + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,:) & + & = sum(flux_dn_direct,1) + flux%sw_dn_clear(jcol,:) = sum(flux_dn_diffuse,1) & + & + flux%sw_dn_direct_clear(jcol,:) + else + flux%sw_dn_clear(jcol,:) = sum(flux_dn_diffuse,1) & + & + sum(flux_dn_direct,1) + end if + ! Store spectral downwelling fluxes at surface + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = flux_dn_diffuse(:,nlev+1) + flux%sw_dn_direct_surf_clear_g(:,jcol) = flux_dn_direct(:,nlev+1) + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum_profile(flux_up, config%i_spec_from_reordered_g_sw, & + & flux%sw_up_clear_band(:,jcol,:)) + call indexed_sum_profile(flux_dn_direct, config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_clear_band(:,jcol,:)) + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,:) & + & = flux%sw_dn_clear_band(:,jcol,:) + end if + call add_indexed_sum_profile(flux_dn_diffuse, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_clear_band(:,jcol,:)) + end if + + end if ! Do clear-sky calculations + + ! Now the total-sky calculation. If this is a clear profile + ! and clear-sky fluxes have been calculated then we can simply + ! copy over the clear-sky fluxes, otherwise we need to compute + ! fluxes now. + if (is_cloudy_profile .or. .not. config%do_clear) then + do jlev = 1,nlev + ! Compute combined gas+aerosol+cloud optical properties; + ! note that for clear layers, the reflectance and + ! transmittance have already been calculated + if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then + od_cloud_g = od_cloud(config%i_band_from_reordered_g_sw,jlev,jcol) + od_total = od(:,jlev,jcol) + od_cloud_g + ssa_total = 0.0_jprb + g_total = 0.0_jprb + where (od_total > 0.0_jprb) + ssa_total = (ssa(:,jlev,jcol)*od(:,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_sw,jlev,jcol) & + & * od_cloud_g) & + & / od_total + end where + where (ssa_total > 0.0_jprb .and. od_total > 0.0_jprb) + g_total = (g(:,jlev,jcol)*ssa(:,jlev,jcol)*od(:,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_sw,jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_sw,jlev,jcol) & + & * od_cloud_g) & + & / (ssa_total*od_total) + end where + + ! Apply delta-Eddington scaling to the cloud-aerosol-gas + ! mixture + if (config%do_sw_delta_scaling_with_gases) then + call delta_eddington(od_total, ssa_total, g_total) + end if + + ! Compute cloudy-sky reflectance, transmittance etc at + ! each model level + call calc_two_stream_gammas_sw(ng, & + & cos_sza, ssa_total, g_total, & + & gamma1, gamma2, gamma3) + call calc_reflectance_transmittance_sw(ng, & + & cos_sza, od_total, ssa_total, & + & gamma1, gamma2, gamma3, & + & reflectance(:,jlev), transmittance(:,jlev), & + & ref_dir(:,jlev), trans_dir_diff(:,jlev), & + & trans_dir_dir(:,jlev) ) + + end if + end do + + ! Use adding method to compute fluxes for an overcast sky + call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), & + & albedo_diffuse(:,jcol), albedo_direct(:,jcol), & + & cos_sza, reflectance, transmittance, ref_dir, trans_dir_diff, & + & trans_dir_dir, flux_up, flux_dn_diffuse, flux_dn_direct, & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + + ! Store overcast broadband fluxes + flux%sw_up(jcol,:) = sum(flux_up,1) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = sum(flux_dn_direct,1) + flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) & + & + flux%sw_dn_direct(jcol,:) + else + flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) & + & + sum(flux_dn_direct,1) + end if + + ! Likewise for surface spectral fluxes + flux%sw_dn_diffuse_surf_g(:,jcol) = flux_dn_diffuse(:,nlev+1) + flux%sw_dn_direct_surf_g(:,jcol) = flux_dn_direct(:,nlev+1) + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum_profile(flux_up, config%i_spec_from_reordered_g_sw, & + & flux%sw_up_band(:,jcol,:)) + call indexed_sum_profile(flux_dn_direct, config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,:)) + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,:) & + & = flux%sw_dn_band(:,jcol,:) + end if + call add_indexed_sum_profile(flux_dn_diffuse, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,:)) + end if + + else + ! No cloud in profile and clear-sky fluxes already + ! calculated: copy them over + flux%sw_up(jcol,:) = flux%sw_up_clear(jcol,:) + flux%sw_dn(jcol,:) = flux%sw_dn_clear(jcol,:) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = flux%sw_dn_direct_clear(jcol,:) + end if + flux%sw_dn_diffuse_surf_g(:,jcol) = flux%sw_dn_diffuse_surf_clear_g(:,jcol) + flux%sw_dn_direct_surf_g(:,jcol) = flux%sw_dn_direct_surf_clear_g(:,jcol) + + if (config%do_save_spectral_flux) then + flux%sw_up_band(:,jcol,:) = flux%sw_up_clear_band(:,jcol,:) + flux%sw_dn_band(:,jcol,:) = flux%sw_dn_clear_band(:,jcol,:) + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,:) = flux%sw_dn_direct_clear_band(:,jcol,:) + end if + end if + + end if ! Cloud is present in profile + + else + ! Set fluxes to zero if sun is below the horizon + flux%sw_up(jcol,:) = 0.0_jprb + flux%sw_dn(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = 0.0_jprb + end if + flux%sw_dn_diffuse_surf_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_g(:,jcol) = 0.0_jprb + + if (config%do_clear) then + flux%sw_up_clear(jcol,:) = 0.0_jprb + flux%sw_dn_clear(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,:) = 0.0_jprb + end if + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_clear_g(:,jcol) = 0.0_jprb + end if + + if (config%do_save_spectral_flux) then + flux%sw_dn_band(:,jcol,:) = 0.0_jprb + flux%sw_up_band(:,jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,:) = 0.0_jprb + end if + if (config%do_clear) then + flux%sw_dn_clear_band(:,jcol,:) = 0.0_jprb + flux%sw_up_clear_band(:,jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,:) = 0.0_jprb + end if + end if + end if + + end if ! sun above horizon + end do + + if (lhook) call dr_hook('radiation_homogeneous_sw:solver_homogeneous_sw',1,hook_handle) + + end subroutine solver_homogeneous_sw + +end module radiation_homogeneous_sw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran.F90 (revision 6016) @@ -0,0 +1,111 @@ +! radiation_ice_optics_fu.F90 - Scheme for ice optical properties adapted from Baran's data +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_ice_optics_baran + + implicit none + public + + ! The number of ice coefficients depends on the parameterization + integer, parameter :: NIceOpticsCoeffsBaran = 9 + integer, parameter :: NIceOpticsCoeffsBaran2016 = 5 + +contains + + + !--------------------------------------------------------------------- + ! Compute ice-particle scattering properties using a + ! parameterization as a function of ice water mixing ratio only + subroutine calc_ice_optics_baran(nb, coeff, ice_wp, & + & qi, od, scat_od, g) + + use parkind1, only : jprb + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Ice water path (kg m-2) and mixing ratio (kg kg-1) + real(jprb), intent(in) :: ice_wp, qi + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + !real(jphook) :: hook_handle + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_baran',0,hook_handle) + + od = ice_wp * (coeff(1:nb,1) + coeff(1:nb,2) & + & / (1.0_jprb + qi*coeff(1:nb,3))) + scat_od = od * (coeff(1:nb,4) + coeff(1:nb,5) & + & / (1.0_jprb + qi*coeff(1:nb,6))) + ! To apply the simple parameterization in Baran et al. (2014), use the + ! following instead, but note that it overestimates shortwave absorption: + ! od = ice_wp * coeff(1:nb,1) + ! scat_od = od * coeff(1:nb,4) + g = coeff(1:nb,7) + coeff(1:nb,8) / (1.0_jprb + qi*coeff(1:nb,9)) + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_baran',1,hook_handle) + + end subroutine calc_ice_optics_baran + + + !--------------------------------------------------------------------- + ! Compute ice-particle scattering properties using a + ! parameterization as a function of ice water mixing ratio and + ! temperature + subroutine calc_ice_optics_baran2016(nb, coeff, ice_wp, & + & qi, temperature, od, scat_od, g) + + use parkind1, only : jprb + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Ice water path (kg m-2) and mixing ratio (kg kg-1) + real(jprb), intent(in) :: ice_wp, qi + ! Temperature (K) + real(jprb), intent(in) :: temperature + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Powers of temperature, some multiplied by qi + real(jprb) :: qi_T, T2, qi_over_T4 + + !real(jphook) :: hook_handle + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_baran2016',0,hook_handle) + + T2 = temperature * temperature + + if (qi < 1.0e-3_jprb) then + qi_T = qi * temperature + qi_over_T4 = 1.0_jprb / (T2 * T2) + else + qi_T = 1.0e-3_jprb * temperature + qi_over_T4 = 1.0_jprb / (T2 * T2) + end if + + od = ice_wp * coeff(1:nb,1) * qi_over_T4 + scat_od = od * (coeff(1:nb,2) + coeff(1:nb,3) * qi_T) + g = coeff(1:nb,4) + coeff(1:nb,5) * qi_T + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_baran2016',1,hook_handle) + + end subroutine calc_ice_optics_baran2016 + +end module radiation_ice_optics_baran Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran2016.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran2016.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran2016.F90 (revision 6016) @@ -0,0 +1,72 @@ +! radiation_ice_optics_baran2016.F90 - Baran et al. (2016) scheme for ice optical properties +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_ice_optics_baran2016 + + implicit none + + ! The number of ice coefficients depends on the parameterization + integer, parameter :: NIceOpticsCoeffsBaran2016 = 5 + +contains + + + !--------------------------------------------------------------------- + ! Compute ice-particle scattering properties using a + ! parameterization as a function of ice water mixing ratio and + ! temperature + subroutine calc_ice_optics_baran2016(nb, coeff, ice_wp, & + & qi, temperature, od, scat_od, g) + + use parkind1, only : jprb + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Ice water path (kg m-2) and mixing ratio (kg kg-1) + real(jprb), intent(in) :: ice_wp, qi + ! Temperature (K) + real(jprb), intent(in) :: temperature + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Powers of temperature, some multiplied by qi + real(jprb) :: qi_T, T2, qi_over_T4 + + !real(jphook) :: hook_handle + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_baran2016',0,hook_handle) + + T2 = temperature * temperature + + if (qi < 1.0e-3_jprb) then + qi_T = qi * temperature + qi_over_T4 = 1.0_jprb / (T2 * T2) + else + qi_T = 1.0e-3_jprb * temperature + qi_over_T4 = 1.0_jprb / (T2 * T2) + end if + + od = ice_wp * coeff(1:nb,1) * qi_over_T4 + scat_od = od * (coeff(1:nb,2) + coeff(1:nb,3) * qi_T) + g = coeff(1:nb,4) + coeff(1:nb,5) * qi_T + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_baran2016',1,hook_handle) + + end subroutine calc_ice_optics_baran2016 + +end module radiation_ice_optics_baran2016 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran2017.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran2017.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_baran2017.F90 (revision 6016) @@ -0,0 +1,71 @@ +! radiation_ice_optics_baran2017.F90 - 2017 parameterization of Baran's ice optical properties +! +! (C) Copyright 2017- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_ice_optics_baran2017 + + implicit none + public + + ! The number of ice coefficients depends on the parameterization + integer, parameter :: NIceOpticsCoeffsBaran2017 = 9 + integer, parameter :: NIceOpticsGeneralCoeffsBaran2017 = 5 + +contains + + + !--------------------------------------------------------------------- + ! Compute ice-particle scattering properties using a + ! parameterization as a function of ice water mixing ratio and + ! temperature + subroutine calc_ice_optics_baran2017(nb, coeff_gen, coeff, ice_wp, & + & qi, temperature, od, scat_od, g) + + use parkind1, only : jprb + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! General coefficients read from a data file + real(jprb), intent(in) :: coeff_gen(:) + ! Band-specific coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Ice water path (kg m-2) and mixing ratio (kg kg-1) + real(jprb), intent(in) :: ice_wp, qi + ! Temperature (K) + real(jprb), intent(in) :: temperature + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Modified ice mixing ratio, and the same raised to an appropriate power + real(jprb) :: qi_mod, qi_mod_od, qi_mod_ssa, qi_mod_g + + !real(jphook) :: hook_handle + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_baran2017',0,hook_handle) + + qi_mod = qi * exp(coeff_gen(1)*(temperature-coeff_gen(2))) + qi_mod_od = qi_mod ** coeff_gen(3) + qi_mod_ssa = qi_mod ** coeff_gen(4) + qi_mod_g = qi_mod ** coeff_gen(5) + + od = ice_wp * (coeff(1:nb,1) + coeff(1:nb,2)/(1.0_jprb+qi_mod_od *coeff(1:nb,3))) + scat_od = od * (coeff(1:nb,4) + coeff(1:nb,5)/(1.0_jprb+qi_mod_ssa*coeff(1:nb,6))) + g = coeff(1:nb,7) + coeff(1:nb,8)/(1.0_jprb+qi_mod_g *coeff(1:nb,9)) + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_baran2017',1,hook_handle) + + end subroutine calc_ice_optics_baran2017 + +end module radiation_ice_optics_baran2017 Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_fu.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_fu.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_fu.F90 (revision 6016) @@ -0,0 +1,146 @@ +! This file has been modified for the use in ICON + +! radiation_ice_optics_fu.F90 - Fu's scheme for ice optical properties +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2020-08-10 R. Hogan Bounded re to be <= 100um and g to be < 1.0 + +module radiation_ice_optics_fu + + use parkind1, only : jprb + + implicit none + public + + ! The number of ice coefficients depends on the parameterization + integer, parameter :: NIceOpticsCoeffsFuSW = 10 + integer, parameter :: NIceOpticsCoeffsFuLW = 11 + + ! Limits based on the range of validity of the parameterizations + real(jprb), parameter :: MaxAsymmetryFactor = 1.0_jprb - 10.0_jprb*epsilon(1.0_jprb) + real(jprb), parameter :: MaxEffectiveRadius = 100.0e-6_jprb ! metres + +contains + + !--------------------------------------------------------------------- + ! Compute shortwave ice-particle scattering properties using Fu + ! (1996) parameterization. The asymmetry factor in band 14 goes + ! larger than one for re > 100.8 um, so we cap re at 100 um. + ! Asymmetry factor is capped at just less than 1 because if it is + ! exactly 1 then delta-Eddington scaling leads to a zero scattering + ! optical depth and then division by zero. + subroutine calc_ice_optics_fu_sw(nb, coeff, ice_wp, & + & re, od, scat_od, g) + + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Ice water path (kg m-2) + real(jprb), intent(in) :: ice_wp + ! Effective radius (m) + real(jprb), intent(in) :: re + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Fu's effective diameter (microns) and its inverse + real(jprb) :: de_um, inv_de_um + ! Ice water path in g m-2 + real (jprb) :: iwp_gm_2 + + integer :: jb + !real(jphook) :: hook_handle + + !$ACC ROUTINE SEQ + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_fu_sw',0,hook_handle) + + ! Convert to effective diameter using the relationship in the IFS + de_um = min(re, MaxEffectiveRadius) * (1.0e6_jprb / 0.64952_jprb) + inv_de_um = 1.0_jprb / de_um + iwp_gm_2 = ice_wp * 1000.0_jprb + +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, nb + od(jb) = iwp_gm_2 * (coeff(jb,1) + coeff(jb,2) * inv_de_um) + scat_od(jb) = od(jb) * (1.0_jprb - (coeff(jb,3) + de_um*(coeff(jb,4) & + & + de_um*(coeff(jb,5) + de_um*coeff(jb,6))))) + g(jb) = min(coeff(jb,7) + de_um*(coeff(jb,8) & + & + de_um*(coeff(jb,9) + de_um*coeff(jb,10))), & + & MaxAsymmetryFactor) + end do + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_fu_sw',1,hook_handle) + + end subroutine calc_ice_optics_fu_sw + + + !--------------------------------------------------------------------- + ! Compute longwave ice-particle scattering properties using Fu et + ! al. (1998) parameterization + subroutine calc_ice_optics_fu_lw(nb, coeff, ice_wp, & + & re, od, scat_od, g) + + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Ice water path (kg m-2) + real(jprb), intent(in) :: ice_wp + ! Effective radius (m) + real(jprb), intent(in) :: re + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Fu's effective diameter (microns) and its inverse + real(jprb) :: de_um, inv_de_um + ! Ice water path in g m-2 + real (jprb) :: iwp_gm_2 + + integer :: jb + !real(jphook) :: hook_handle + + !$ACC ROUTINE SEQ + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_fu_lw',0,hook_handle) + + ! Convert to effective diameter using the relationship in the IFS + de_um = min(re, MaxEffectiveRadius) * (1.0e6_jprb / 0.64952_jprb) + + inv_de_um = 1.0_jprb / de_um + iwp_gm_2 = ice_wp * 1000.0_jprb + +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, nb + od(jb) = iwp_gm_2 * (coeff(jb,1) + inv_de_um*(coeff(jb,2) & + & + inv_de_um*coeff(jb,3))) + scat_od(jb) = od(jb) - iwp_gm_2*inv_de_um*(coeff(jb,4) + de_um*(coeff(jb,5) & + & + de_um*(coeff(jb,6) + de_um*coeff(jb,7)))) + g(jb) = min(coeff(jb,8) + de_um*(coeff(jb,9) & + & + de_um*(coeff(jb,10) + de_um*coeff(jb,11))), & + & MaxAsymmetryFactor) + end do + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_fu_lw',1,hook_handle) + + end subroutine calc_ice_optics_fu_lw + +end module radiation_ice_optics_fu Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_yi.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_yi.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ice_optics_yi.F90 (revision 6016) @@ -0,0 +1,148 @@ +! radiation_ice_optics_yi.F90 - Yi et al. (2013) ice optical properties +! +! (C) Copyright 2017- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Authors: Mark Fielding and Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! The reference for this ice optics parameterization is Yi, B., +! P. Yang, B.A. Baum, T. L'Ecuyer, L. Oreopoulos, E.J. Mlawer, +! A.J. Heymsfield, and K. Liou, 2013: Influence of Ice Particle +! Surface Roughening on the Global Cloud Radiative +! Effect. J. Atmos. Sci., 70, 2794-2807, +! https://doi.org/10.1175/JAS-D-13-020.1 + +module radiation_ice_optics_yi + + implicit none + public + + ! The number of ice coefficients depends on the parameterization + integer, parameter :: NIceOpticsCoeffsYiSW = 69 + integer, parameter :: NIceOpticsCoeffsYiLW = 69 + + integer, parameter :: NSingleCoeffs = 23 + +contains + + !--------------------------------------------------------------------- + ! Compute shortwave ice-particle scattering properties using Yi et + ! al. (2013) parameterization + subroutine calc_ice_optics_yi_sw(nb, coeff, ice_wp, & + & re, od, scat_od, g) + + use parkind1, only : jprb, jpim + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Ice water path (kg m-2) + real(jprb), intent(in) :: ice_wp + ! Effective radius (m) + real(jprb), intent(in) :: re + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Yi's effective diameter (microns) + real(jprb) :: de_um + ! Ice water path in g m-2 + real (jprb) :: iwp_gm_2 + ! LUT temp variables + real(jprb) :: wts_1, wts_2 + integer(jpim) :: lu_idx + real(kind=jprb), parameter :: lu_scale = 0.2_jprb + real(kind=jprb), parameter :: lu_offset = 1.0_jprb + !real(jphook) :: hook_handle + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_yi_sw',0,hook_handle) + + ! Convert to effective diameter using the relationship in the IFS + !de_um = re * (1.0e6_jprb / 0.64952_jprb) + de_um = re * 2.0e6_jprb + + ! limit de_um to validity of LUT + de_um = max(de_um,10.0_jprb) + de_um = min(de_um,119.99_jprb) !avoid greater than or equal to 120 um + + iwp_gm_2 = ice_wp * 1000.0_jprb + + lu_idx = floor(de_um * lu_scale - lu_offset) + wts_2 = (de_um * lu_scale - lu_offset) - lu_idx + wts_1 = 1.0_jprb - wts_2 + od = 0.001_jprb * iwp_gm_2 * & + & ( wts_1 * coeff(1:nb,lu_idx) + wts_2 * coeff(1:nb,lu_idx+1) ) + scat_od = od * & + & ( wts_1 * coeff(1:nb,lu_idx+NSingleCoeffs) + wts_2 * coeff(1:nb,lu_idx+NSingleCoeffs+1) ) + g = wts_1 * coeff(1:nb,lu_idx+2*NSingleCoeffs) + wts_2 * coeff(1:nb,lu_idx+2*NSingleCoeffs+1) + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_yi_sw',1,hook_handle) + + end subroutine calc_ice_optics_yi_sw + + + !--------------------------------------------------------------------- + ! Compute longwave ice-particle scattering properties using Yi et + ! al. (2013) parameterization + subroutine calc_ice_optics_yi_lw(nb, coeff, ice_wp, & + & re, od, scat_od, g) + + use parkind1, only : jprb, jpim + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Ice water path (kg m-2) + real(jprb), intent(in) :: ice_wp + ! Effective radius (m) + real(jprb), intent(in) :: re + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Yi's effective diameter (microns) + real(jprb) :: de_um + ! Ice water path in g m-2 + real (jprb) :: iwp_gm_2 + ! LUT temp variables + real(jprb) :: wts_1, wts_2 + integer(jpim) :: lu_idx + real(kind=jprb), parameter :: lu_scale = 0.2_jprb + real(kind=jprb), parameter :: lu_offset = 1.0_jprb + !real(jphook) :: hook_handle + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_yi_sw',0,hook_handle) + + ! Convert to effective diameter using the relationship in the IFS + !de_um = re * (1.0e6_jprb / 0.64952_jprb) + de_um = re * 2.0e6_jprb + + ! limit de_um to validity of LUT + de_um = max(de_um,10.0_jprb) + de_um = min(de_um,119.99_jprb) !avoid greater than or equal to 120 um + + iwp_gm_2 = ice_wp * 1000.0_jprb + + lu_idx = floor(de_um * lu_scale - lu_offset) + wts_2 = (de_um * lu_scale - lu_offset) - lu_idx + wts_1 = 1.0_jprb - wts_2 + od = 0.001_jprb * iwp_gm_2 * & + & ( wts_1 * coeff(1:nb,lu_idx) + wts_2 * coeff(1:nb,lu_idx+1) ) + scat_od = od * & + & ( wts_1 * coeff(1:nb,lu_idx+NSingleCoeffs) + wts_2 * coeff(1:nb,lu_idx+NSingleCoeffs+1) ) + g = wts_1 * coeff(1:nb,lu_idx+2*NSingleCoeffs) + wts_2 * coeff(1:nb,lu_idx+2*NSingleCoeffs+1) + + !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_yi_lw',1,hook_handle) + + end subroutine calc_ice_optics_yi_lw + +end module radiation_ice_optics_yi Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ifs_rrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ifs_rrtm.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_ifs_rrtm.F90 (revision 6016) @@ -0,0 +1,1057 @@ +! This file has been modified for the use in ICON + +! radiation_ifs_rrtm.F90 - Interface to IFS implementation of RRTM-G +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive "surface" dummy argument +! 2017-09-08 R. Hogan Reverted some changes +! 2017-10-18 R. Hogan Added planck_function public function +! 2018-01-11 R. Hogan Added optional spectral scaling of incoming solar radiation +! 2018-02-22 R. Hogan Optimized reverse indexing of heights +! 2018-05-05 R. Hogan gas_optics can be called for reduced number of levels +! 2019-01-02 R. Hogan Initialize shortwave props to zero in case sun below horizon + +module radiation_ifs_rrtm + + implicit none + + public :: setup_gas_optics, gas_optics, planck_function, set_gas_units + +contains + + !--------------------------------------------------------------------- + ! Setup the IFS implementation of RRTM-G gas absorption model + subroutine setup_gas_optics(config, directory) + + use yoerrtm, only : jpglw + use yoesrtm, only : jpgsw + use yoerrtftr, only : ngb_lw => ngb + use yoesrtm, only : ngb_sw => ngbsw + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config + use radiation_spectral_definition, only & + & : SolarReferenceTemperature, TerrestrialReferenceTemperature + + type(config_type), intent(inout), target :: config + character(len=*), intent(in) :: directory + + integer :: irep ! For implied do + + integer, parameter :: RRTM_GPOINT_REORDERING_LW(140) = (/ & + & 89, 90, 139, 77, 137, 69, 131, 97, 91, 70, 78, 71, 53, 72, 123, 54, 79, 98, & + & 92, 55, 80, 132, 124, 81, 73, 56, 99, 82, 57, 23, 125, 100, 24, 74, 93, 58, 25, & + & 83, 126, 75, 26, 11, 101, 133, 59, 27, 76, 140, 12, 84, 102, 94, 28, 127, 85, & + & 13, 39, 60, 86, 103, 87, 109, 14, 29, 115, 40, 95, 15, 61, 88, 41, 110, 104, 1, & + & 116, 42, 30, 134, 128, 138, 96, 62, 16, 43, 117, 63, 111, 44, 2, 64, 31, 65, & + & 105, 17, 45, 66, 118, 32, 3, 33, 67, 18, 129, 135, 46, 112, 34, 106, 68, 35, 4, & + & 119, 36, 47, 107, 19, 37, 38, 113, 48, 130, 5, 120, 49, 108, 20, 50, 51, 114, & + & 21, 121, 52, 136, 122, 6, 22, 7, 8, 9, 10 & + & /) + integer, parameter :: RRTM_GPOINT_REORDERING_SW(112) = (/ & + & 35, 45, 19, 27, 36, 57, 20, 46, 58, 21, 28, 67, 55, 68, 37, 1, 69, 22, 29, 59, & + & 78, 101, 79, 77, 70, 76, 47, 75, 30, 81, 60, 102, 80, 82, 23, 2, 83, 84, 85, & + & 86, 103, 61, 31, 87, 56, 38, 71, 48, 88, 3, 62, 89, 24, 7, 49, 32, 104, 72, 90, & + & 63, 39, 4, 8, 50, 91, 64, 40, 33, 25, 51, 95, 96, 73, 65, 9, 41, 97, 92, 105, & + & 52, 5, 98, 10, 42, 99, 100, 66, 11, 74, 34, 53, 26, 6, 106, 12, 43, 13, 54, 93, & + & 44, 107, 94, 14, 108, 15, 16, 109, 17, 18, 110, 111, 112 & + & /) + + logical :: do_sw, do_lw + + real(jphook) :: hook_handle + +!#include "surdi.intfb.h" +#include "surrtab.intfb.h" +#include "surrtpk.intfb.h" +#include "surrtrf.intfb.h" +#include "rrtm_init_140gp.intfb.h" +#include "srtm_init.intfb.h" + + if (lhook) call dr_hook('radiation_ifs_rrtm:setup_gas_optics',0,hook_handle) + + do_sw = (config%do_sw .and. config%i_gas_model_sw == IGasModelIFSRRTMG) + do_lw = (config%do_lw .and. config%i_gas_model_lw == IGasModelIFSRRTMG) + + ! The IFS implementation of RRTMG uses many global variables. In + ! the IFS these will have been set up already; otherwise set them + ! up now. + if (config%do_setup_ifsrrtm) then + !call SURDI + call SURRTAB + call SURRTPK + call SURRTRF + if (do_lw) then + call RRTM_INIT_140GP(directory) + end if + if (do_sw) then + call SRTM_INIT(directory) + end if + end if + + if (do_sw) then + + ! Cloud and aerosol properties can only be defined per band + config%do_cloud_aerosol_per_sw_g_point = .false. + config%n_g_sw = jpgsw + config%n_bands_sw = 14 + ! Wavenumber ranges of each band may be needed so that the user + ! can compute UV and photosynthetically active radiation for a + ! particular wavelength range + call config%gas_optics_sw%spectral_def%allocate_bands_only(SolarReferenceTemperature, & + & [2600.0_jprb, 3250.0_jprb, 4000.0_jprb, 4650.0_jprb, 5150.0_jprb, 6150.0_jprb, 7700.0_jprb, & + & 8050.0_jprb, 12850.0_jprb, 16000.0_jprb, 22650.0_jprb, 29000.0_jprb, 38000.0_jprb, 820.0_jprb], & + & [3250.0_jprb, 4000.0_jprb, 4650.0_jprb, 5150.0_jprb, 6150.0_jprb, 7700.0_jprb, 8050.0_jprb, & + & 12850.0_jprb, 16000.0_jprb, 22650.0_jprb, 29000.0_jprb, 38000.0_jprb, 50000.0_jprb, 2600.0_jprb]) + allocate(config%i_band_from_g_sw (config%n_g_sw)) + allocate(config%i_band_from_reordered_g_sw(config%n_g_sw)) + allocate(config%i_g_from_reordered_g_sw (config%n_g_sw)) + ! Shortwave starts at 16: need to start at 1 + config%i_band_from_g_sw = ngb_sw - ngb_sw(1)+1 + + if (config%i_solver_sw == ISolverSpartacus) then + ! SPARTACUS requires g points ordered in approximately + ! increasing order of optical depth + config%i_g_from_reordered_g_sw = RRTM_GPOINT_REORDERING_SW + else + ! Implied-do for no reordering + ! config%i_g_from_reordered_g_sw = RRTM_GPOINT_REORDERING_SW + config%i_g_from_reordered_g_sw = (/ (irep, irep=1,config%n_g_sw) /) + end if + + config%i_band_from_reordered_g_sw & + = config%i_band_from_g_sw(config%i_g_from_reordered_g_sw) + + ! The i_spec_* variables are used solely for storing spectral + ! data, and this can either be by band or by g-point + if (config%do_save_spectral_flux .or. config%do_toa_spectral_flux) then + if (config%do_save_gpoint_flux) then + config%n_spec_sw = config%n_g_sw + config%i_spec_from_reordered_g_sw => config%i_g_from_reordered_g_sw + else + config%n_spec_sw = config%n_bands_sw + config%i_spec_from_reordered_g_sw => config%i_band_from_reordered_g_sw + end if + else + config%n_spec_sw = 0 + nullify(config%i_spec_from_reordered_g_sw) + end if + + end if + + if (do_lw) then + ! Cloud and aerosol properties can only be defined per band + config%do_cloud_aerosol_per_lw_g_point = .false. + config%n_g_lw = jpglw + config%n_bands_lw = 16 + call config%gas_optics_lw%spectral_def%allocate_bands_only(TerrestrialReferenceTemperature, & + & [10.0_jprb, 350.0_jprb, 500.0_jprb, 630.0_jprb, 700.0_jprb, 820.0_jprb, 980.0_jprb, 1080.0_jprb, & + & 1180.0_jprb, 1390.0_jprb, 1480.0_jprb, 1800.0_jprb, 2080.0_jprb, 2250.0_jprb, 2380.0_jprb, 2600.0_jprb], & + & [350.0_jprb, 500.0_jprb, 630.0_jprb, 700.0_jprb, 820.0_jprb, 980.0_jprb, 1080.0_jprb, 1180.0_jprb, & + & 1390.0_jprb, 1480.0_jprb, 1800.0_jprb, 2080.0_jprb, 2250.0_jprb, 2380.0_jprb, 2600.0_jprb, 3250.0_jprb]) + allocate(config%i_band_from_g_lw (config%n_g_lw)) + allocate(config%i_band_from_reordered_g_lw(config%n_g_lw)) + allocate(config%i_g_from_reordered_g_lw (config%n_g_lw)) + config%i_band_from_g_lw = ngb_lw + + if (config%i_solver_lw == ISolverSpartacus) then + ! SPARTACUS requires g points ordered in approximately + ! increasing order of optical depth + config%i_g_from_reordered_g_lw = RRTM_GPOINT_REORDERING_LW + else + ! Implied-do for no reordering + config%i_g_from_reordered_g_lw = (/ (irep, irep=1,config%n_g_lw) /) + end if + + config%i_band_from_reordered_g_lw & + = config%i_band_from_g_lw(config%i_g_from_reordered_g_lw) + + ! The i_spec_* variables are used solely for storing spectral + ! data, and this can either be by band or by g-point + if (config%do_save_spectral_flux .or. config%do_toa_spectral_flux) then + if (config%do_save_gpoint_flux) then + config%n_spec_lw = config%n_g_lw + config%i_spec_from_reordered_g_lw => config%i_g_from_reordered_g_lw + else + config%n_spec_lw = config%n_bands_lw + config%i_spec_from_reordered_g_lw => config%i_band_from_reordered_g_lw + end if + else + config%n_spec_lw = 0 + nullify(config%i_spec_from_reordered_g_lw) + end if + + end if + + if (lhook) call dr_hook('radiation_ifs_rrtm:setup_gas_optics',1,hook_handle) + + end subroutine setup_gas_optics + + + !--------------------------------------------------------------------- + ! Scale gas mixing ratios according to required units + subroutine set_gas_units(gas) + + use radiation_gas, only : gas_type, IMassMixingRatio + type(gas_type), intent(inout) :: gas + + call gas%set_units(IMassMixingRatio) + + end subroutine set_gas_units + + + !--------------------------------------------------------------------- + ! Compute gas optical depths, shortwave scattering, Planck function + ! and incoming shortwave radiation at top-of-atmosphere + subroutine gas_optics(ncol,nlev,istartcol,iendcol, & + & config, single_level, thermodynamics, gas, & + & od_lw, od_sw, ssa_sw, lw_albedo, planck_hl, lw_emission, & + & incoming_sw) + + use parkind1, only : jprb, jpim +#ifdef _OPENACC + use radiation_io, only : nulerr, radiation_abort +#endif + + USE PARRRTM , ONLY : JPBAND, JPXSEC, JPINPX + USE YOERRTM , ONLY : JPGPT_LW => JPGPT + USE YOESRTM , ONLY : JPGPT_SW => JPGPT + use yomhook , only : lhook, dr_hook, jphook + + use radiation_config, only : config_type, ISolverSpartacus, IGasModelIFSRRTMG + use radiation_thermodynamics, only : thermodynamics_type + use radiation_single_level, only : single_level_type + use radiation_gas + + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type),intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + + ! Longwave albedo of the surface + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), & + & intent(in), optional :: lw_albedo + + ! Gaseous layer optical depth in longwave and shortwave, and + ! shortwave single scattering albedo (i.e. fraction of extinction + ! due to Rayleigh scattering) at each g-point + real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol), intent(out) :: & + & od_lw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(out) :: & + & od_sw, ssa_sw + + ! The Planck function (emitted flux from a black body) at half + ! levels at each longwave g-point + real(jprb), dimension(config%n_g_lw,nlev+1,istartcol:iendcol), & + & intent(out), optional :: planck_hl + ! Planck function for the surface (W m-2) + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), & + & intent(out), optional :: lw_emission + + ! The incoming shortwave flux into a plane perpendicular to the + ! incoming radiation at top-of-atmosphere in each of the shortwave + ! g-points + real(jprb), dimension(config%n_g_sw,istartcol:iendcol), & + & intent(out), optional :: incoming_sw + + real(jprb) :: incoming_sw_scale(istartcol:iendcol) + + ! The variables in capitals are used in the same way as the + ! equivalent routine in the IFS + + real(jprb) :: ZOD_LW(JPGPT_LW,nlev,istartcol:iendcol) ! Note ordering of dimensions + real(jprb) :: ZOD_SW(istartcol:iendcol,nlev,JPGPT_SW) + real(jprb) :: ZSSA_SW(istartcol:iendcol,nlev,JPGPT_SW) + real(jprb) :: ZINCSOL(istartcol:iendcol,JPGPT_SW) + + real(jprb) :: ZCOLMOL(istartcol:iendcol,nlev) + real(jprb) :: ZCOLDRY(istartcol:iendcol,nlev) + real(jprb) :: ZWBRODL(istartcol:iendcol,nlev) !BROADENING GASES,column density (mol/cm2) + real(jprb) :: ZCOLBRD(istartcol:iendcol,nlev) !BROADENING GASES, column amount + real(jprb) :: ZWKL(istartcol:iendcol,JPINPX,nlev) + + real(jprb) :: ZWX(istartcol:iendcol,JPXSEC,nlev) ! Amount of trace gases + + real(jprb) :: ZFLUXFAC, ZPI + + ! - from AER + real(jprb) :: ZTAUAERL(istartcol:iendcol,nlev,JPBAND) + + !- from INTFAC + real(jprb) :: ZFAC00(istartcol:iendcol,nlev) + real(jprb) :: ZFAC01(istartcol:iendcol,nlev) + real(jprb) :: ZFAC10(istartcol:iendcol,nlev) + real(jprb) :: ZFAC11(istartcol:iendcol,nlev) + + !- from FOR + real(jprb) :: ZFORFAC(istartcol:iendcol,nlev) + real(jprb) :: ZFORFRAC(istartcol:iendcol,nlev) + integer :: INDFOR(istartcol:iendcol,nlev) + + !- from MINOR + integer :: INDMINOR(istartcol:iendcol,nlev) + real(jprb) :: ZSCALEMINOR(istartcol:iendcol,nlev) + real(jprb) :: ZSCALEMINORN2(istartcol:iendcol,nlev) + real(jprb) :: ZMINORFRAC(istartcol:iendcol,nlev) + + real(jprb) :: & + & ZRAT_H2OCO2(istartcol:iendcol,nlev),ZRAT_H2OCO2_1(istartcol:iendcol,nlev), & + & ZRAT_H2OO3(istartcol:iendcol,nlev) ,ZRAT_H2OO3_1(istartcol:iendcol,nlev), & + & ZRAT_H2ON2O(istartcol:iendcol,nlev),ZRAT_H2ON2O_1(istartcol:iendcol,nlev), & + & ZRAT_H2OCH4(istartcol:iendcol,nlev),ZRAT_H2OCH4_1(istartcol:iendcol,nlev), & + & ZRAT_N2OCO2(istartcol:iendcol,nlev),ZRAT_N2OCO2_1(istartcol:iendcol,nlev), & + & ZRAT_O3CO2(istartcol:iendcol,nlev) ,ZRAT_O3CO2_1(istartcol:iendcol,nlev) + + !- from INTIND + integer :: JP(istartcol:iendcol,nlev) + integer :: JT(istartcol:iendcol,nlev) + integer :: JT1(istartcol:iendcol,nlev) + + !- from PRECISE + real(jprb) :: ZONEMINUS, ZONEMINUS_ARRAY(istartcol:iendcol) + + !- from PROFDATA + real(jprb) :: ZCOLH2O(istartcol:iendcol,nlev) + real(jprb) :: ZCOLCO2(istartcol:iendcol,nlev) + real(jprb) :: ZCOLO3(istartcol:iendcol,nlev) + real(jprb) :: ZCOLN2O(istartcol:iendcol,nlev) + real(jprb) :: ZCOLCH4(istartcol:iendcol,nlev) + real(jprb) :: ZCOLO2(istartcol:iendcol,nlev) + real(jprb) :: ZCO2MULT(istartcol:iendcol,nlev) + integer :: ILAYTROP(istartcol:iendcol) + integer :: ILAYSWTCH(istartcol:iendcol) + integer :: ILAYLOW(istartcol:iendcol) + + !- from PROFILE + real(jprb) :: ZPAVEL(istartcol:iendcol,nlev) + real(jprb) :: ZTAVEL(istartcol:iendcol,nlev) + real(jprb) :: ZPZ(istartcol:iendcol,0:nlev) + real(jprb) :: ZTZ(istartcol:iendcol,0:nlev) + + !- from SELF + real(jprb) :: ZSELFFAC(istartcol:iendcol,nlev) + real(jprb) :: ZSELFFRAC(istartcol:iendcol,nlev) + integer :: INDSELF(istartcol:iendcol,nlev) + + !- from SP + real(jprb) :: ZPFRAC(istartcol:iendcol,JPGPT_LW,nlev) + + !- from SURFACE + integer :: IREFLECT(istartcol:iendcol) + + real(jprb) :: pressure_fl(ncol, nlev), temperature_fl(ncol, nlev) + + ! If nlev is less than the number of heights at which gas mixing + ! ratios are stored, then we assume that the lower part of the + ! atmosphere is required. This enables nlev=1 to be passed in to + ! the routine, in which case the gas properties of the lowest + ! layer are provided, useful for canopy radiative transfer. + integer :: istartlev, iendlev + + logical :: do_sw, do_lw + + integer :: jlev, jgreorder, jg, ig, iband, jcol + + real(jphook) :: hook_handle + +#include "rrtm_prepare_gases.intfb.h" +#include "rrtm_setcoef_140gp.intfb.h" +#include "rrtm_gas_optical_depth.intfb.h" +#include "srtm_setcoef.intfb.h" +#include "srtm_gas_optical_depth.intfb.h" + + if (lhook) call dr_hook('radiation_ifs_rrtm:gas_optics',0,hook_handle) + + do_sw = (config%do_sw .and. config%i_gas_model_sw == IGasModelIFSRRTMG) + do_lw = (config%do_lw .and. config%i_gas_model_lw == IGasModelIFSRRTMG) + +#ifdef _OPENACC + if (.not. single_level%is_simple_surface) then + write(nulerr,'(a)') '*** Error: radiation_ifs_rrtm:gas_optics single_level%is_simple_surface==.false not ported to GPU' + call radiation_abort() + endif + if (present(lw_albedo) == .FALSE.) then + write(nulerr,'(a)') '*** Error: radiation_ifs_rrtm:gas_optics present(lw_albedo) == .FALSE. not ported to GPU' + call radiation_abort() + endif +#endif + + !$ACC DATA CREATE(incoming_sw_scale, & + !$ACC ZOD_LW, ZOD_SW, ZSSA_SW, ZINCSOL, & + !$ACC ZCOLMOL, ZCOLDRY, ZWBRODL, ZCOLBRD, ZWKL, & + !$ACC ZWX, & + !$ACC ZTAUAERL, & + !$ACC ZFAC00, ZFAC01, ZFAC10, ZFAC11, & + !$ACC ZFORFAC, ZFORFRAC, INDFOR, & + !$ACC INDMINOR, ZSCALEMINOR, ZSCALEMINORN2, ZMINORFRAC, & + !$ACC ZRAT_H2OCO2,ZRAT_H2OCO2_1, & + !$ACC ZRAT_H2OO3 ,ZRAT_H2OO3_1, & + !$ACC ZRAT_H2ON2O,ZRAT_H2ON2O_1, & + !$ACC ZRAT_H2OCH4,ZRAT_H2OCH4_1, & + !$ACC ZRAT_N2OCO2,ZRAT_N2OCO2_1, & + !$ACC ZRAT_O3CO2 ,ZRAT_O3CO2_1, & + !$ACC JP, JT, JT1, & + !$ACC ZONEMINUS_ARRAY, & + !$ACC ZCOLH2O, ZCOLCO2, ZCOLO3, ZCOLN2O, ZCOLCH4, ZCOLO2, & + !$ACC ZCO2MULT, & + !$ACC ILAYTROP, ILAYSWTCH, ILAYLOW, & + !$ACC ZPAVEL, ZTAVEL, ZPZ, ZTZ, & + !$ACC ZSELFFAC, ZSELFFRAC, & + !$ACC INDSELF, & + !$ACC ZPFRAC, & + !$ACC IREFLECT, & + !$ACC pressure_fl, temperature_fl) & + !$ACC PRESENT(config, single_level, thermodynamics, gas, & + !$ACC od_lw, od_sw, ssa_sw, lw_albedo, planck_hl, lw_emission, & + !$ACC incoming_sw) + + ! Compute start and end levels for indexing the gas mixing ratio + ! and thermodynamics arrays + iendlev = ubound(gas%mixing_ratio,2) + istartlev = iendlev - nlev + 1 + + ZPI = 2.0_jprb*ASIN(1.0_jprb) + ZFLUXFAC = ZPI * 1.E+4 + ZONEMINUS = 1.0_jprb - 1.0e-6_jprb + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + do jcol= istartcol,iendcol + ZONEMINUS_ARRAY(jcol) = ZONEMINUS + end do + !$ACC END PARALLEL + + ! Are full level temperature and pressure available in thermodynmics? If not, interpolate. + if (thermodynamics%rrtm_pass_temppres_fl) then + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jlev=1,nlev + do jcol= istartcol,iendcol + pressure_fl (jcol,jlev) = thermodynamics%pressure_fl (jcol,jlev) + temperature_fl(jcol,jlev) = thermodynamics%temperature_fl(jcol,jlev) + end do + end do + !$ACC END PARALLEL + else + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jlev=1,nlev + do jcol= istartcol,iendcol + pressure_fl(jcol,jlev) & + & = 0.5_jprb * (thermodynamics%pressure_hl(jcol,jlev+istartlev-1) & + & +thermodynamics%pressure_hl(jcol,jlev+istartlev)) + temperature_fl(jcol,jlev) & + & = 0.5_jprb * (thermodynamics%temperature_hl(jcol,jlev+istartlev-1) & + & +thermodynamics%temperature_hl(jcol,jlev+istartlev)) + end do + end do + !$ACC END PARALLEL + end if + + ! Check we have gas mixing ratios in the right units + call gas%assert_units(IMassMixingRatio) + + ! Warning: O2 is hard-coded within the following function so the + ! user-provided concentrations of this gas are ignored for both + ! the longwave and shortwave + CALL RRTM_PREPARE_GASES & + & ( istartcol, iendcol, ncol, nlev, & + & thermodynamics%pressure_hl(:,istartlev:iendlev+1), & + & pressure_fl, & + & thermodynamics%temperature_hl(:,istartlev:iendlev+1), & + & temperature_fl, & + & gas%mixing_ratio(:,istartlev:iendlev,IH2O), & + & gas%mixing_ratio(:,istartlev:iendlev,ICO2), & + & gas%mixing_ratio(:,istartlev:iendlev,ICH4), & + & gas%mixing_ratio(:,istartlev:iendlev,IN2O), & + & gas%mixing_ratio(:,istartlev:iendlev,INO2), & + & gas%mixing_ratio(:,istartlev:iendlev,ICFC11), & + & gas%mixing_ratio(:,istartlev:iendlev,ICFC12), & + & gas%mixing_ratio(:,istartlev:iendlev,IHCFC22), & + & gas%mixing_ratio(:,istartlev:iendlev,ICCl4), & + & gas%mixing_ratio(:,istartlev:iendlev,IO3), & + & ZCOLDRY, ZWBRODL,ZWKL, ZWX, & + & ZPAVEL , ZTAVEL , ZPZ , ZTZ, IREFLECT) + + if (do_lw) then + + CALL RRTM_SETCOEF_140GP & + &( istartcol, iendcol, nlev , ZCOLDRY , ZWBRODL , ZWKL , & + & ZFAC00 , ZFAC01 , ZFAC10 , ZFAC11 , ZFORFAC,ZFORFRAC,INDFOR, JP, JT, JT1 , & + & ZCOLH2O, ZCOLCO2 , ZCOLO3 , ZCOLN2O, ZCOLCH4, ZCOLO2,ZCO2MULT , ZCOLBRD, & + & ILAYTROP,ILAYSWTCH, ILAYLOW, ZPAVEL , ZTAVEL , ZSELFFAC, ZSELFFRAC, INDSELF, & + & INDMINOR,ZSCALEMINOR,ZSCALEMINORN2,ZMINORFRAC,& + & ZRAT_H2OCO2, ZRAT_H2OCO2_1, ZRAT_H2OO3, ZRAT_H2OO3_1, & + & ZRAT_H2ON2O, ZRAT_H2ON2O_1, ZRAT_H2OCH4, ZRAT_H2OCH4_1, & + & ZRAT_N2OCO2, ZRAT_N2OCO2_1, ZRAT_O3CO2, ZRAT_O3CO2_1) + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + do jg = 1,JPBAND + do jlev = 1,nlev + do jcol = istartcol,iendcol + ZTAUAERL(jcol,jlev,jg) = 0.0_jprb + end do + end do + end do + !$ACC END PARALLEL + + CALL RRTM_GAS_OPTICAL_DEPTH & + &( istartcol, iendcol, nlev, ZOD_LW, ZPAVEL, ZCOLDRY, ZCOLBRD, ZWX ,& + & ZTAUAERL, ZFAC00 , ZFAC01, ZFAC10 , ZFAC11 , ZFORFAC,ZFORFRAC,INDFOR, & + & JP, JT, JT1, ZONEMINUS ,& + & ZCOLH2O , ZCOLCO2, ZCOLO3, ZCOLN2O, ZCOLCH4, ZCOLO2,ZCO2MULT ,& + & ILAYTROP, ILAYSWTCH,ILAYLOW, ZSELFFAC, ZSELFFRAC, INDSELF, ZPFRAC, & + & INDMINOR,ZSCALEMINOR,ZSCALEMINORN2,ZMINORFRAC,& + & ZRAT_H2OCO2, ZRAT_H2OCO2_1, ZRAT_H2OO3, ZRAT_H2OO3_1, & + & ZRAT_H2ON2O, ZRAT_H2ON2O_1, ZRAT_H2OCH4, ZRAT_H2OCH4_1, & + & ZRAT_N2OCO2, ZRAT_N2OCO2_1, ZRAT_O3CO2, ZRAT_O3CO2_1) + + if (present(lw_albedo)) then + + call planck_function_atmos(nlev, istartcol, iendcol, config, & + & thermodynamics, ZPFRAC, planck_hl) + + if (single_level%is_simple_surface) then + call planck_function_surf(istartcol, iendcol, config, & + & single_level%skin_temperature, ZPFRAC(:,:,1), & + & lw_emission) + + ! The following can be used to extract the parameters defined at + ! the top of the planck_function routine below: + !write(*,'(a,140(e12.5,","),a)') 'ZPFRAC_surf=[', & + !& sum(ZPFRAC(istartcol:iendcol,:,1),1) / (iendcol+1-istartcol), ']' + + ! lw_emission at this point is actually the planck function of + ! the surface + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jcol = istartcol,iendcol + do jg= 1,config%n_g_lw + lw_emission(jg,jcol) = lw_emission(jg,jcol) * (1.0_jprb - lw_albedo(jg,jcol)) + end do + end do + !$ACC END PARALLEL + else + ! Longwave emission has already been computed + if (config%use_canopy_full_spectrum_lw) then + lw_emission = transpose(single_level%lw_emission(istartcol:iendcol,:)) + else + lw_emission = transpose(single_level%lw_emission(istartcol:iendcol, & + & config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw))) + end if + end if + + end if + + if (config%i_solver_lw == ISolverSpartacus) then + ! We need to rearrange the gas optics info in memory: reordering + ! the g points in order of approximately increasing optical + ! depth (for efficient 3D processing on only the regions of the + ! spectrum that are optically thin for gases) and reorder in + ! pressure since the the functions above treat pressure + ! decreasing with increasing index. Note that the output gas + ! arrays have dimensions in a different order to the inputs, + ! so there is some inefficiency here. + do jgreorder = 1,config%n_g_lw + iband = config%i_band_from_reordered_g_lw(jgreorder) + ig = config%i_g_from_reordered_g_lw(jgreorder) + + ! Top-of-atmosphere half level + do jlev = 1,nlev + do jcol = istartcol,iendcol + ! Some g points can return negative optical depths; + ! specifically original g points 54-56 which causes + ! unphysical single-scattering albedo when combined with + ! aerosol + od_lw(jgreorder,jlev,jcol) & + & = max(config%min_gas_od_lw, ZOD_LW(ig,nlev+1-jlev,jcol)) + end do + end do + end do + else + ! G points have not been reordered + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG COLLAPSE(3) + do jcol = istartcol,iendcol + do jlev = 1,nlev + do jg= 1,config%n_g_lw + ! Check for negative optical depth + od_lw(jg,jlev,jcol) = max(config%min_gas_od_lw, ZOD_LW(jg,nlev+1-jlev,jcol)) + end do + end do + end do + !$ACC END PARALLEL + end if + + end if + + if (do_sw) then + + CALL SRTM_SETCOEF & + & ( istartcol, iendcol, nlev,& + & ZPAVEL , ZTAVEL,& + & ZCOLDRY , ZWKL,& + & ILAYTROP,& + & ZCOLCH4 , ZCOLCO2 , ZCOLH2O , ZCOLMOL , ZCOLO2 , ZCOLO3,& + & ZFORFAC , ZFORFRAC , INDFOR , ZSELFFAC, ZSELFFRAC, INDSELF, & + & ZFAC00 , ZFAC01 , ZFAC10 , ZFAC11,& + & JP , JT , JT1 , single_level%cos_sza(istartcol:iendcol) & + & ) + + ! SRTM_GAS_OPTICAL_DEPTH will not initialize profiles when the sun + ! is below the horizon, so we do it here + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(3) + do jg = 1, JPGPT_SW + do jlev = 1,nlev + do jcol = istartcol,iendcol + ZOD_SW(jcol,jlev,jg) = 0.0_jprb + ZSSA_SW(jcol,jlev,jg) = 0.0_jprb + end do + end do + end do + !$ACC END PARALLEL + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jg = 1, JPGPT_SW + do jcol = istartcol,iendcol + ZINCSOL(jcol,jg) = 0.0_jprb + end do + end do + !$ACC END PARALLEL + + CALL SRTM_GAS_OPTICAL_DEPTH & + &( istartcol, iendcol , nlev , ZONEMINUS_ARRAY,& + & single_level%cos_sza(istartcol:iendcol), ILAYTROP,& + & ZCOLCH4 , ZCOLCO2 , ZCOLH2O, ZCOLMOL , ZCOLO2 , ZCOLO3,& + & ZFORFAC , ZFORFRAC , INDFOR , ZSELFFAC, ZSELFFRAC, INDSELF,& + & ZFAC00 , ZFAC01 , ZFAC10 , ZFAC11 ,& + & JP , JT , JT1 ,& + & ZOD_SW , ZSSA_SW , ZINCSOL ) + + ! Scale the incoming solar per band, if requested + if (config%use_spectral_solar_scaling) then + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jg = 1,JPGPT_SW + do jcol = istartcol,iendcol + ZINCSOL(jcol,jg) = ZINCSOL(jcol,jg) * & + & single_level%spectral_solar_scaling(config%i_band_from_reordered_g_sw(jg)) + end do + end do + !$ACC END PARALLEL + end if + + ! Scaling factor to ensure that the total solar irradiance is as + ! requested. Note that if the sun is below the horizon then + ! ZINCSOL will be zero. + if (present(incoming_sw)) then + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + do jcol = istartcol,iendcol + if (single_level%cos_sza(jcol) > 0.0_jprb) then +! Added for DWD (2020) +!NEC$ nounroll + incoming_sw_scale(jcol) = single_level%solar_irradiance / sum(ZINCSOL(jcol,:)) + else + incoming_sw_scale(jcol) = 1.0_jprb + end if + end do + !$ACC END PARALLEL + end if + + if (config%i_solver_sw == ISolverSpartacus) then +! if (.true.) then + ! Account for reordered g points + do jgreorder = 1,config%n_g_sw + ig = config%i_g_from_reordered_g_sw(jgreorder) + do jlev = 1,nlev + do jcol = istartcol,iendcol + ! Check for negative optical depth + od_sw (jgreorder,nlev+1-jlev,jcol) & + & = max(config%min_gas_od_sw, ZOD_SW (jcol,jlev,ig)) + ssa_sw(jgreorder,nlev+1-jlev,jcol) = ZSSA_SW(jcol,jlev,ig) + end do + end do + if (present(incoming_sw)) then + incoming_sw(jgreorder,:) & + & = incoming_sw_scale(:) * ZINCSOL(:,ig) + end if + end do + else + ! G points have not been reordered + !$ACC PARALLEL DEFAULT(NONE) NUM_GANGS(iendcol-istartcol+1) NUM_WORKERS((config%n_g_sw-1)/32+1) & + !$ACC VECTOR_LENGTH(32) ASYNC(1) + !$ACC LOOP GANG + do jcol = istartcol,iendcol + !$ACC LOOP SEQ + do jlev = 1,nlev + !$ACC LOOP WORKER VECTOR + do jg = 1,config%n_g_sw + ! Check for negative optical depth + od_sw (jg,nlev+1-jlev,jcol) = max(config%min_gas_od_sw, ZOD_SW(jcol,jlev,jg)) + ssa_sw(jg,nlev+1-jlev,jcol) = ZSSA_SW(jcol,jlev,jg) + end do + end do + if (present(incoming_sw)) then + !$ACC LOOP WORKER VECTOR + do jg = 1,config%n_g_sw + incoming_sw(jg,jcol) = incoming_sw_scale(jcol) * ZINCSOL(jcol,jg) + end do + end if + end do + !$ACC END PARALLEL + end if + + end if + + !$ACC WAIT + !$ACC END DATA + + if (lhook) call dr_hook('radiation_ifs_rrtm:gas_optics',1,hook_handle) + + end subroutine gas_optics + + + !--------------------------------------------------------------------- + ! Compute Planck function of the atmosphere + subroutine planck_function_atmos(nlev,istartcol,iendcol, & + config, thermodynamics, PFRAC, & + planck_hl) + + use parkind1, only : jprb, jpim + + USE YOERRTM , ONLY : JPGPT_LW => JPGPT + use yoerrtwn, only : totplnk, delwave + + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config, only : config_type, ISolverSpartacus + use radiation_thermodynamics, only : thermodynamics_type + !use radiation_gas + + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(thermodynamics_type),intent(in) :: thermodynamics + real(jprb), intent(in) :: PFRAC(istartcol:iendcol,JPGPT_LW,nlev) + + ! The Planck function (emitted flux from a black body) at half + ! levels at each longwave g-point + real(jprb), dimension(config%n_g_lw,nlev+1,istartcol:iendcol), intent(out) :: & + & planck_hl + + ! Planck function values per band + real(jprb), dimension(istartcol:iendcol, config%n_bands_lw) :: planck_store + + ! Look-up table variables for Planck function + real(jprb), dimension(istartcol:iendcol) :: frac + integer, dimension(istartcol:iendcol) :: ind + + ! Temperature (K) of a half-level + real(jprb) :: temperature + + real(jprb) :: factor, planck_tmp(istartcol:iendcol,config%n_g_lw) + real(jprb) :: ZFLUXFAC + + integer :: jlev, jgreorder, jg, ig, iband, jband, jcol, ilevoffset + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ifs_rrtm:planck_function_atmos',0,hook_handle) + + ZFLUXFAC = 2.0_jprb*ASIN(1.0_jprb) * 1.0e4_jprb + + ! nlev may be less than the number of original levels, in which + ! case we assume that the user wants the lower part of the + ! atmosphere + ilevoffset = ubound(thermodynamics%temperature_hl,2)-nlev-1 + + ! Work out interpolations: for each half level, the index of the + ! lowest interpolation bound, and the fraction into interpolation + ! interval + !$ACC PARALLEL DEFAULT(NONE) CREATE(planck_store, frac, ind, planck_tmp) PRESENT(config, thermodynamics, PFRAC, & + !$ACC planck_hl) ASYNC(1) + !$ACC LOOP SEQ + do jlev = 1,nlev+1 + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(temperature) + do jcol = istartcol,iendcol + temperature = thermodynamics%temperature_hl(jcol,jlev+ilevoffset) + if (temperature < 339.0_jprb .and. temperature >= 160.0_jprb) then + ! Linear interpolation between -113 and 66 degC + ind(jcol) = int(temperature - 159.0_jprb) + frac(jcol) = temperature - int(temperature) + else if(temperature >= 339.0_jprb) then + ! Extrapolation above 66 degC + ind(jcol) = 180 + frac(jcol) = temperature - 339.0_jprb + else + ! Cap below -113 degC (to avoid possible negative Planck + ! function values) + ind(jcol) = 1 + frac(jcol) = 0.0_jprb + end if + end do + + ! Calculate Planck functions per band + !$ACC LOOP SEQ PRIVATE(factor) + do jband = 1,config%n_bands_lw + factor = zfluxfac * delwave(jband) + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + planck_store(jcol,jband) = factor & + & * (totplnk(ind(jcol),jband) & + & + frac(jcol)*(totplnk(ind(jcol)+1,jband)-totplnk(ind(jcol),jband))) + end do + end do + +#ifndef _OPENACC + if (config%i_solver_lw == ISolverSpartacus) then + ! We need to rearrange the gas optics info in memory: + ! reordering the g points in order of approximately increasing + ! optical depth (for efficient 3D processing on only the + ! regions of the spectrum that are optically thin for gases) + ! and reorder in pressure since the the functions above treat + ! pressure decreasing with increasing index. + if (jlev == 1) then + ! Top-of-atmosphere half level - note that PFRAC is on model + ! levels not half levels + do jgreorder = 1,config%n_g_lw + iband = config%i_band_from_reordered_g_lw(jgreorder) + ig = config%i_g_from_reordered_g_lw(jgreorder) + planck_hl(jgreorder,1,:) = planck_store(:,iband) & + & * PFRAC(:,ig,nlev) + end do + else + do jgreorder = 1,config%n_g_lw + iband = config%i_band_from_reordered_g_lw(jgreorder) + ig = config%i_g_from_reordered_g_lw(jgreorder) + planck_hl(jgreorder,jlev,:) & + & = planck_store(:,iband) & + & * PFRAC(:,ig,nlev+2-jlev) + end do + end if + else +#endif + ! G points have not been reordered + if (jlev == 1) then + ! Top-of-atmosphere half level - note that PFRAC is on model + ! levels not half levels + !$ACC LOOP SEQ PRIVATE(iband) + do jg = 1,config%n_g_lw + iband = config%i_band_from_g_lw(jg) + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + planck_hl(jg,1,jcol) = planck_store(jcol,iband) * PFRAC(jcol,jg,nlev) + end do + end do + else + !$ACC LOOP SEQ PRIVATE(iband) + do jg = 1,config%n_g_lw + iband = config%i_band_from_g_lw(jg) + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + planck_tmp(jcol,jg) = planck_store(jcol,iband) * PFRAC(jcol,jg,nlev+2-jlev) + end do + end do + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + do jg = 1,config%n_g_lw + planck_hl(jg,jlev,jcol) = planck_tmp(jcol,jg) + end do + end do + end if +#ifndef _OPENACC + end if +#endif + end do + !$ACC END PARALLEL + + !$ACC WAIT + + if (lhook) call dr_hook('radiation_ifs_rrtm:planck_function_atmos',1,hook_handle) + + end subroutine planck_function_atmos + + + !--------------------------------------------------------------------- + ! Compute Planck function of the surface + subroutine planck_function_surf(istartcol, iendcol, config, temperature, PFRAC, & + & planck_surf) + + use parkind1, only : jprb, jpim + + USE YOERRTM , ONLY : JPGPT_LW => JPGPT + use yoerrtwn, only : totplnk, delwave + + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config, only : config_type, ISolverSpartacus + ! use radiation_gas + + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + real(jprb), intent(in) :: temperature(:) + + real(jprb), intent(in) :: PFRAC(istartcol:iendcol,JPGPT_LW) + + ! Planck function of the surface (W m-2) + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), & + & intent(out) :: planck_surf + + ! Planck function values per band + real(jprb), dimension(istartcol:iendcol, config%n_bands_lw) :: planck_store + + ! Look-up table variables for Planck function + real(jprb), dimension(istartcol:iendcol) :: frac + integer, dimension(istartcol:iendcol) :: ind + + ! Temperature (K) + real(jprb) :: Tsurf + + real(jprb) :: factor + real(jprb) :: ZFLUXFAC + + integer :: jgreorder, jg, ig, iband, jband, jcol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_ifs_rrtm:planck_function_surf',0,hook_handle) + + ZFLUXFAC = 2.0_jprb*ASIN(1.0_jprb) * 1.0e4_jprb + + ! Work out surface interpolations + !$ACC PARALLEL DEFAULT(NONE) CREATE(planck_store, frac, ind) PRESENT(config, temperature, PFRAC, planck_surf) & + !$ACC ASYNC(1) + !$ACC LOOP GANG(STATIC:1) VECTOR PRIVATE(Tsurf) + do jcol = istartcol,iendcol + Tsurf = temperature(jcol) + if (Tsurf < 339.0_jprb .and. Tsurf >= 160.0_jprb) then + ! Linear interpolation between -113 and 66 degC + ind(jcol) = int(Tsurf - 159.0_jprb) + frac(jcol) = Tsurf - int(Tsurf) + else if(Tsurf >= 339.0_jprb) then + ! Extrapolation above 66 degC + ind(jcol) = 180 + frac(jcol) = Tsurf - 339.0_jprb + else + ! Cap below -113 degC (to avoid possible negative Planck + ! function values) + ind(jcol) = 1 + frac(jcol) = 0.0_jprb + end if + end do + + ! Calculate Planck functions per band + !$ACC LOOP SEQ PRIVATE(factor) + do jband = 1,config%n_bands_lw + factor = zfluxfac * delwave(jband) + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + planck_store(jcol,jband) = factor & + & * (totplnk(ind(jcol),jband) & + & + frac(jcol)*(totplnk(ind(jcol)+1,jband)-totplnk(ind(jcol),jband))) + end do + end do + + if (config%i_solver_lw == ISolverSpartacus) then + ! We need to rearrange the gas optics info in memory: reordering + ! the g points in order of approximately increasing optical + ! depth (for efficient 3D processing on only the regions of + ! the spectrum that are optically thin for gases) and reorder + ! in pressure since the the functions above treat pressure + ! decreasing with increasing index. + !$ACC LOOP SEQ PRIVATE(iband, ig) + do jgreorder = 1,config%n_g_lw + iband = config%i_band_from_reordered_g_lw(jgreorder) + ig = config%i_g_from_reordered_g_lw(jgreorder) + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + planck_surf(jgreorder,jcol) = planck_store(jcol,iband) * PFRAC(jcol,ig) + end do + end do + else + ! G points have not been reordered + !$ACC LOOP SEQ PRIVATE(iband) + do jg = 1,config%n_g_lw + iband = config%i_band_from_g_lw(jg) + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + planck_surf(jg,jcol) = planck_store(jcol,iband) * PFRAC(jcol,jg) + end do + end do + end if + !$ACC END PARALLEL + + !$ACC WAIT + + if (lhook) call dr_hook('radiation_ifs_rrtm:planck_function_surf',1,hook_handle) + + end subroutine planck_function_surf + + + !--------------------------------------------------------------------- + ! Externally facing function for computing the Planck function + ! without reference to any gas profile; typically this would be used + ! for computing the emission by facets of a complex surface. Note + ! that this uses fixed "PFRAC" values, obtained by averaging over + ! those derived from RRTM-G for near-surface conditions over a line + ! of meridian from the ECMWF model. + subroutine planck_function(config, temperature, planck_surf) + + use parkind1, only : jprb, jpim + + use radiation_config, only : config_type + + type(config_type), intent(in) :: config + real(jprb), intent(in) :: temperature + + ! Planck function of the surface (W m-2) + real(jprb), dimension(config%n_g_lw), & + & intent(out) :: planck_surf + + ! Fraction of each band contributed by each g-point within + ! it. Since there are 16 bands, this array sums to 16 + real(jprb), parameter, dimension(1,140) :: frac & + = reshape( (/ 0.21227E+00, 0.18897E+00, 0.25491E+00, 0.17864E+00, 0.11735E+00, 0.38298E-01, 0.57871E-02, & + & 0.31753E-02, 0.53169E-03, 0.76476E-04, 0.16388E+00, 0.15241E+00, 0.14290E+00, 0.12864E+00, & + & 0.11615E+00, 0.10047E+00, 0.80013E-01, 0.60445E-01, 0.44918E-01, 0.63395E-02, 0.32942E-02, & + & 0.54541E-03, 0.15380E+00, 0.15194E+00, 0.14339E+00, 0.13138E+00, 0.11701E+00, 0.10081E+00, & + & 0.82296E-01, 0.61735E-01, 0.41918E-01, 0.45918E-02, 0.37743E-02, 0.30121E-02, 0.22500E-02, & + & 0.14490E-02, 0.55410E-03, 0.78364E-04, 0.15938E+00, 0.15146E+00, 0.14213E+00, 0.13079E+00, & + & 0.11672E+00, 0.10053E+00, 0.81566E-01, 0.61126E-01, 0.41150E-01, 0.44488E-02, 0.36950E-02, & + & 0.29101E-02, 0.21357E-02, 0.19609E-02, 0.14134E+00, 0.14390E+00, 0.13913E+00, 0.13246E+00, & + & 0.12185E+00, 0.10596E+00, 0.87518E-01, 0.66164E-01, 0.44862E-01, 0.49402E-02, 0.40857E-02, & + & 0.32288E-02, 0.23613E-02, 0.15406E-02, 0.58258E-03, 0.82171E-04, 0.29127E+00, 0.28252E+00, & + & 0.22590E+00, 0.14314E+00, 0.45494E-01, 0.71792E-02, 0.38483E-02, 0.65712E-03, 0.29810E+00, & + & 0.27559E+00, 0.11997E+00, 0.10351E+00, 0.84515E-01, 0.62253E-01, 0.41050E-01, 0.44217E-02, & + & 0.36946E-02, 0.29113E-02, 0.34290E-02, 0.55993E-03, 0.31441E+00, 0.27586E+00, 0.21297E+00, & + & 0.14064E+00, 0.45588E-01, 0.65665E-02, 0.34232E-02, 0.53199E-03, 0.19811E+00, 0.16833E+00, & + & 0.13536E+00, 0.11549E+00, 0.10649E+00, 0.93264E-01, 0.75720E-01, 0.56405E-01, 0.41865E-01, & + & 0.59331E-02, 0.26510E-02, 0.40040E-03, 0.32328E+00, 0.26636E+00, 0.21397E+00, 0.14038E+00, & + & 0.52142E-01, 0.38852E-02, 0.14601E+00, 0.13824E+00, 0.27703E+00, 0.22388E+00, 0.15446E+00, & + & 0.48687E-01, 0.98054E-02, 0.18870E-02, 0.11961E+00, 0.12106E+00, 0.13215E+00, 0.13516E+00, & + & 0.25249E+00, 0.16542E+00, 0.68157E-01, 0.59725E-02, 0.49258E+00, 0.33651E+00, 0.16182E+00, & + & 0.90984E-02, 0.95202E+00, 0.47978E-01, 0.91716E+00, 0.82857E-01, 0.77464E+00, 0.22536E+00 /), (/ 1,140 /) ) + + call planck_function_surf(1, 1, config, spread(temperature,1,1), & + & frac, planck_surf) + + end subroutine planck_function + +end module radiation_ifs_rrtm Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_interface.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_interface.F90 (revision 6016) @@ -0,0 +1,698 @@ +! This file has been modified for the use in ICON + +! radiation_interface.F90 - Public interface to radiation scheme +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Changes to enable generalized surface description +! 2017-09-08 R. Hogan Reverted some changes +! +! To use the radiation scheme, create a configuration_type object, +! call "setup_radiation" on it once to load the look-up-tables and +! data describing how gas and hydrometeor absorption/scattering are to +! be represented, and call "radiation" multiple times on different +! input profiles. + +module radiation_interface + + implicit none + + public :: setup_radiation, set_gas_units, radiation + private :: radiation_reverse + +contains + + !--------------------------------------------------------------------- + ! Load the look-up-tables and data describing how gas and + ! hydrometeor absorption/scattering are to be represented + subroutine setup_radiation(config) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type, ISolverMcICA, ISolverMcICAACC, & + & IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD + use radiation_spectral_definition, only & + & : SolarReferenceTemperature, TerrestrialReferenceTemperature + ! Currently there are two gas absorption models: RRTMG (default) + ! and monochromatic + use radiation_monochromatic, only : & + & setup_gas_optics_mono => setup_gas_optics, & + & setup_cloud_optics_mono => setup_cloud_optics, & + & setup_aerosol_optics_mono => setup_aerosol_optics + use radiation_ifs_rrtm, only : setup_gas_optics_rrtmg => setup_gas_optics + use radiation_ecckd_interface,only : setup_gas_optics_ecckd => setup_gas_optics + use radiation_cloud_optics, only : setup_cloud_optics + use radiation_general_cloud_optics, only : setup_general_cloud_optics + use radiation_aerosol_optics, only : setup_aerosol_optics + + + type(config_type), intent(inout) :: config + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_interface:setup_radiation',0,hook_handle) + + ! Consolidate configuration data, including setting data file + ! names + call config%consolidate() + + ! Load the look-up tables from files in the specified directory + if (config%i_gas_model_sw == IGasModelMonochromatic) then + call setup_gas_optics_mono(config, trim(config%directory_name)) + else + ! Note that we can run RRTMG and ECCKD for different parts of + ! the spectrum: the setup routines only configure the relevant + ! part. + if (config%i_gas_model_sw == IGasModelIFSRRTMG .or. config%i_gas_model_lw == IGasModelIFSRRTMG) then + call setup_gas_optics_rrtmg(config, trim(config%directory_name)) + end if + if (config%i_gas_model_sw == IGasModelECCKD .or. config%i_gas_model_lw == IGasModelECCKD) then + call setup_gas_optics_ecckd(config) + end if + end if + + if (config%do_lw_aerosol_scattering & + & .and. .not. config%do_lw_cloud_scattering) then + write(nulerr, '(a)') '*** Error: longwave aerosol scattering requires longwave cloud scattering' + call radiation_abort('Radiation configuration error') + end if + + + ! Whether or not the "radiation" subroutine needs ssa_lw and g_lw + ! arrays depends on whether longwave scattering by aerosols is to + ! be included. If not, one of the array dimensions will be set to + ! zero. + if (config%do_lw_aerosol_scattering) then + config%n_g_lw_if_scattering = config%n_g_lw + else + config%n_g_lw_if_scattering = 0 + end if + + ! Whether or not the "radiation" subroutine needs ssa_lw_cloud and + ! g_lw_cloud arrays depends on whether longwave scattering by + ! hydrometeors is to be included. If not, one of the array + ! dimensions will be set to zero. + if (config%do_lw_cloud_scattering) then + config%n_bands_lw_if_scattering = config%n_bands_lw + else + config%n_bands_lw_if_scattering = 0 + end if + + ! If we have longwave scattering and McICA then even if there is + ! no aerosol, it is convenient if single scattering albedo and + ! g factor arrays are allocated before the call to + ! solver_lw as they will be needed. + if (config%do_lw_cloud_scattering & + & .and. (config%i_solver_lw == ISolverMcICA .or. config%i_solver_lw == ISolverMcICAACC) ) then + config%n_g_lw_if_scattering = config%n_g_lw + end if + + ! Consolidate the albedo/emissivity intervals with the shortwave + ! and longwave spectral bands + if (config%do_sw) then + call config%consolidate_sw_albedo_intervals + end if + if (config%do_lw) then + call config%consolidate_lw_emiss_intervals + end if + + if (config%do_clouds) then + if (config%i_gas_model_sw == IGasModelMonochromatic) then + ! call setup_cloud_optics_mono(config) + elseif (config%use_general_cloud_optics) then + call setup_general_cloud_optics(config) + else + call setup_cloud_optics(config) + end if + end if + + if (config%use_aerosols) then + if (config%i_gas_model_sw == IGasModelMonochromatic) then +! call setup_aerosol_optics_mono(config) + else + call setup_aerosol_optics(config) + end if + end if + + ! Load cloud water PDF look-up table for McICA + if ( config%i_solver_sw == ISolverMcICA & + & .or. config%i_solver_lw == ISolverMcICA & + & .or. config%i_solver_sw == ISolverMcICAACC & + & .or. config%i_solver_lw == ISolverMcICAACC ) then + call config%pdf_sampler%setup(config%cloud_pdf_file_name, & + & iverbose=config%iverbosesetup) + end if + + if (lhook) call dr_hook('radiation_interface:setup_radiation',1,hook_handle) + + end subroutine setup_radiation + + + !--------------------------------------------------------------------- + ! Scale the gas mixing ratios so that they have the units (and + ! possibly scale factors) required by the specific gas absorption + ! model. This subroutine simply passes the gas object on to the + ! module of the currently active gas model. + subroutine set_gas_units(config, gas) + + use radiation_config + use radiation_gas, only : gas_type + use radiation_monochromatic, only : set_gas_units_mono => set_gas_units + use radiation_ifs_rrtm, only : set_gas_units_ifs => set_gas_units + use radiation_ecckd_interface, only : set_gas_units_ecckd => set_gas_units + + type(config_type), intent(in) :: config + type(gas_type), intent(inout) :: gas + + if (config%i_gas_model_sw == IGasModelMonochromatic) then + call set_gas_units_mono(gas) + elseif (config%i_gas_model_sw == IGasModelIFSRRTMG & + & .or. config%i_gas_model_lw == IGasModelIFSRRTMG) then + ! Convert to mass-mixing ratio for RRTMG; note that ecCKD can + ! work with this but performs an internal scaling + call set_gas_units_ifs(gas) + else + ! Use volume mixing ratio preferred by ecCKD + call set_gas_units_ecckd(gas) + end if + + end subroutine set_gas_units + + + !--------------------------------------------------------------------- + ! Run the radiation scheme according to the configuration in the + ! config object. There are ncol profiles of which only istartcol to + ! iendcol are to be processed, and there are nlev model levels. The + ! output fluxes are written to the flux object, and all other + ! objects contain the input variables. The variables may be defined + ! either in order of increasing or decreasing pressure, but if in + ! order of decreasing pressure then radiation_reverse will be called + ! to reverse the order for the computation and then reverse the + ! order of the output fluxes to match the inputs. + subroutine radiation(ncol, nlev, istartcol, iendcol, config, & + & single_level, thermodynamics, gas, cloud, aerosol, flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulout, nulerr, radiation_abort + use radiation_config, only : config_type, & + & IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD, & + & ISolverMcICA, ISolverSpartacus, ISolverHomogeneous, & + & ISolverTripleclouds, ISolverMcICAACC + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type + use radiation_cloud, only : cloud_type + use radiation_aerosol, only : aerosol_type + use radiation_flux, only : flux_type + use radiation_spartacus_sw, only : solver_spartacus_sw + use radiation_spartacus_lw, only : solver_spartacus_lw + use radiation_tripleclouds_sw,only : solver_tripleclouds_sw + use radiation_tripleclouds_lw,only : solver_tripleclouds_lw + use radiation_mcica_sw, only : solver_mcica_sw + use radiation_mcica_lw, only : solver_mcica_lw + use radiation_mcica_acc_sw, only : solver_mcica_acc_sw + use radiation_mcica_acc_lw, only : solver_mcica_acc_lw + use radiation_cloudless_sw, only : solver_cloudless_sw + use radiation_cloudless_lw, only : solver_cloudless_lw + use radiation_homogeneous_sw, only : solver_homogeneous_sw + use radiation_homogeneous_lw, only : solver_homogeneous_lw + use radiation_save, only : save_radiative_properties + + ! Treatment of gas and hydrometeor optics + use radiation_monochromatic, only : & + & gas_optics_mono => gas_optics, & + & cloud_optics_mono => cloud_optics, & + & add_aerosol_optics_mono => add_aerosol_optics + use radiation_ifs_rrtm, only : gas_optics_rrtmg => gas_optics + use radiation_ecckd_interface,only : gas_optics_ecckd => gas_optics + use radiation_cloud_optics, only : cloud_optics + use radiation_general_cloud_optics, only : general_cloud_optics + use radiation_aerosol_optics, only : add_aerosol_optics + + ! Inputs + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type),intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + type(cloud_type), intent(inout):: cloud + type(aerosol_type), intent(in) :: aerosol + ! Output + type(flux_type), intent(inout):: flux + + + ! Local variables + + ! Layer optical depth, single scattering albedo and asymmetry factor of + ! gases and aerosols at each longwave g-point, where the latter + ! two variables are only defined if aerosol longwave scattering is + ! enabled (otherwise both are treated as zero). + real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol) :: od_lw + real(jprb), dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol) :: & + & ssa_lw, g_lw + + ! Layer in-cloud optical depth, single scattering albedo and + ! asymmetry factor of hydrometeors in each longwave band, where + ! the latter two variables are only defined if hydrometeor + ! longwave scattering is enabled (otherwise both are treated as + ! zero). + real(jprb), dimension(config%n_bands_lw,nlev,istartcol:iendcol) :: od_lw_cloud + real(jprb), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol) :: & + & ssa_lw_cloud, g_lw_cloud + + ! Layer optical depth, single scattering albedo and asymmetry factor of + ! gases and aerosols at each shortwave g-point + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol) :: od_sw, ssa_sw, g_sw + + ! Layer in-cloud optical depth, single scattering albedo and + ! asymmetry factor of hydrometeors in each shortwave band + real(jprb), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud + + ! The Planck function (emitted flux from a black body) at half + ! levels + real(jprb), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: planck_hl + + ! The longwave emission from and albedo of the surface in each + ! longwave g-point; note that these are weighted averages of the + ! values from individual tiles + real(jprb), dimension(config%n_g_lw, istartcol:iendcol) :: lw_emission + real(jprb), dimension(config%n_g_lw, istartcol:iendcol) :: lw_albedo + + ! Direct and diffuse shortwave surface albedo in each shortwave + ! g-point; note that these are weighted averages of the values + ! from individual tiles + real(jprb), dimension(config%n_g_sw, istartcol:iendcol) :: sw_albedo_direct + real(jprb), dimension(config%n_g_sw, istartcol:iendcol) :: sw_albedo_diffuse + + ! The incoming shortwave flux into a plane perpendicular to the + ! incoming radiation at top-of-atmosphere in each of the shortwave + ! g-points + real(jprb), dimension(config%n_g_sw,istartcol:iendcol) :: incoming_sw + + character(len=100) :: rad_prop_file_name + character(*), parameter :: rad_prop_base_file_name = "radiative_properties" + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_interface:radiation',0,hook_handle) + + !$ACC DATA CREATE(od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + !$ACC od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, g_sw_cloud, & + !$ACC planck_hl, lw_emission, lw_albedo, sw_albedo_direct, & + !$ACC sw_albedo_diffuse, incoming_sw) + + if (thermodynamics%pressure_hl(istartcol,2) & + & < thermodynamics%pressure_hl(istartcol,1)) then + ! Input arrays are arranged in order of decreasing pressure / + ! increasing height: the following subroutine reverses them, + ! call the radiation scheme and then reverses the returned + ! fluxes + call radiation_reverse(ncol, nlev, istartcol, iendcol, config, & + & single_level, thermodynamics, gas, cloud, aerosol, flux) + else + + ! Input arrays arranged in order of increasing pressure / + ! decreasing height: progress normally + + ! Extract surface albedos at each gridpoint + call single_level%get_albedos(istartcol, iendcol, config, & + & sw_albedo_direct, sw_albedo_diffuse, & + & lw_albedo) + + ! Compute gas absorption optical depth in shortwave and + ! longwave, shortwave single scattering albedo (i.e. fraction of + ! extinction due to Rayleigh scattering), Planck functions and + ! incoming shortwave flux at each g-point, for the specified + ! range of atmospheric columns + if (config%i_gas_model_sw == IGasModelMonochromatic) then + call gas_optics_mono(ncol,nlev,istartcol,iendcol, config, & + & single_level, thermodynamics, gas, lw_albedo, & + & od_lw, od_sw, ssa_sw, & + & planck_hl, lw_emission, incoming_sw) + else + if (config%i_gas_model_sw == IGasModelIFSRRTMG & + & .or. config%i_gas_model_lw == IGasModelIFSRRTMG) then + call gas_optics_rrtmg(ncol,nlev,istartcol,iendcol, config, & + & single_level, thermodynamics, gas, & + & od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, & + & planck_hl=planck_hl, lw_emission=lw_emission, & + & incoming_sw=incoming_sw) + end if + if (config%i_gas_model_sw == IGasModelECCKD & + & .or. config%i_gas_model_lw == IGasModelECCKD) then + call gas_optics_ecckd(ncol,nlev,istartcol,iendcol, config, & + & single_level, thermodynamics, gas, & + & od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, & + & planck_hl=planck_hl, lw_emission=lw_emission, & + & incoming_sw=incoming_sw) + end if + end if + + if (config%do_clouds) then + ! Crop the cloud fraction to remove clouds that have too small + ! a fraction or water content; after this, we can safely + ! assume that a cloud is present if cloud%fraction > 0.0. + ! WARNING: not 100% tested on GPU as it has no effect on result + call cloud%crop_cloud_fraction(istartcol, iendcol, & + & config%cloud_fraction_threshold, & + & config%cloud_mixing_ratio_threshold) + + ! Compute hydrometeor absorption/scattering properties in each + ! shortwave and longwave band + if (config%i_gas_model_sw == IGasModelMonochromatic) then + call cloud_optics_mono(nlev, istartcol, iendcol, & + & config, thermodynamics, cloud, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + elseif (config%use_general_cloud_optics) then + call general_cloud_optics(nlev, istartcol, iendcol, & + & config, thermodynamics, cloud, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + else + call cloud_optics(nlev, istartcol, iendcol, & + & config, thermodynamics, cloud, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + end if + end if ! do_clouds + + if (config%use_aerosols) then + if (config%i_gas_model_sw == IGasModelMonochromatic) then +! call add_aerosol_optics_mono(nlev,istartcol,iendcol, & +! & config, thermodynamics, gas, aerosol, & +! & od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw) + else + call add_aerosol_optics(nlev,istartcol,iendcol, & + & config, thermodynamics, gas, aerosol, & + & od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw) + end if + else + g_sw(:,:,istartcol:iendcol) = 0.0_jprb + if (config%do_lw_aerosol_scattering) then + ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb + g_lw(:,:,istartcol:iendcol) = 0.0_jprb + end if + end if + + ! For diagnostic purposes, save these intermediate variables to + ! a NetCDF file + if (config%do_save_radiative_properties) then + if (istartcol == 1 .and. iendcol == ncol) then + rad_prop_file_name = rad_prop_base_file_name // ".nc" + else + write(rad_prop_file_name,'(a,a,i4.4,a,i4.4,a)') & + & rad_prop_base_file_name, '_', istartcol, '-',iendcol,'.nc' + end if + call save_radiative_properties(trim(rad_prop_file_name), & + & nlev, istartcol, iendcol, & + & config, single_level, thermodynamics, cloud, & + & planck_hl, lw_emission, lw_albedo, & + & sw_albedo_direct, sw_albedo_diffuse, incoming_sw, & + & od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + end if + + if (config%do_lw) then + if (config%iverbose >= 2) then + write(nulout,'(a)') 'Computing longwave fluxes' + end if + + !$ACC WAIT + if (config%i_solver_lw == ISolverMcICA) then + ! Compute fluxes using the McICA longwave solver + call solver_mcica_lw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, & + & g_lw_cloud, planck_hl, lw_emission, lw_albedo, flux) + else if (config%i_solver_lw == ISolverMcICAACC) then + ! Compute fluxes using the McICA ACC longwave solver + call solver_mcica_acc_lw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, & + & g_lw_cloud, planck_hl, lw_emission, lw_albedo, flux) + else if (config%i_solver_lw == ISolverSPARTACUS) then + ! Compute fluxes using the SPARTACUS longwave solver + call solver_spartacus_lw(nlev,istartcol,iendcol, & + & config, thermodynamics, cloud, & + & od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & planck_hl, lw_emission, lw_albedo, flux) + else if (config%i_solver_lw == ISolverTripleclouds) then + ! Compute fluxes using the Tripleclouds longwave solver + call solver_tripleclouds_lw(nlev,istartcol,iendcol, & + & config, cloud, & + & od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & planck_hl, lw_emission, lw_albedo, flux) + elseif (config%i_solver_lw == ISolverHomogeneous) then + ! Compute fluxes using the homogeneous solver + call solver_homogeneous_lw(nlev,istartcol,iendcol, & + & config, cloud, & + & od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, & + & g_lw_cloud, planck_hl, lw_emission, lw_albedo, flux) + else + ! Compute fluxes using the cloudless solver + call solver_cloudless_lw(nlev,istartcol,iendcol, & + & config, od_lw, ssa_lw, g_lw, & + & planck_hl, lw_emission, lw_albedo, flux) + end if + end if + + if (config%do_sw) then + if (config%iverbose >= 2) then + write(nulout,'(a)') 'Computing shortwave fluxes' + end if + + !$ACC WAIT + if (config%i_solver_sw == ISolverMcICA) then + ! Compute fluxes using the McICA shortwave solver + call solver_mcica_sw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, & + & g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, & + & incoming_sw, flux) + else if (config%i_solver_sw == ISolverMcICAACC) then + ! Compute fluxes using the McICA ACC shortwave solver + call solver_mcica_acc_sw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, & + & g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, & + & incoming_sw, flux) + else if (config%i_solver_sw == ISolverSPARTACUS) then + ! Compute fluxes using the SPARTACUS shortwave solver + call solver_spartacus_sw(nlev,istartcol,iendcol, & + & config, single_level, thermodynamics, cloud, & + & od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, & + & g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, & + & incoming_sw, flux) + else if (config%i_solver_sw == ISolverTripleclouds) then + ! Compute fluxes using the Tripleclouds shortwave solver + call solver_tripleclouds_sw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, & + & g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, & + & incoming_sw, flux) + elseif (config%i_solver_sw == ISolverHomogeneous) then + ! Compute fluxes using the homogeneous solver + call solver_homogeneous_sw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, & + & g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, & + & incoming_sw, flux) + else + ! Compute fluxes using the cloudless solver + call solver_cloudless_sw(nlev,istartcol,iendcol, & + & config, single_level, od_sw, ssa_sw, g_sw, & + & sw_albedo_direct, sw_albedo_diffuse, & + & incoming_sw, flux) + end if + end if + + ! Store surface downwelling, and TOA, fluxes in bands from + ! fluxes in g points + call flux%calc_surface_spectral(config, istartcol, iendcol) + call flux%calc_toa_spectral (config, istartcol, iendcol) + + end if + + !$ACC WAIT + !$ACC END DATA + + if (lhook) call dr_hook('radiation_interface:radiation',1,hook_handle) + + end subroutine radiation + + + !--------------------------------------------------------------------- + ! If the input arrays are arranged in order of decreasing pressure / + ! increasing height then this subroutine reverses them, calls the + ! radiation scheme and then reverses the returned fluxes. Since this + ! subroutine calls, and is called by "radiation", it must be in this + ! module to avoid circular dependencies. + subroutine radiation_reverse(ncol, nlev, istartcol, iendcol, config, & + & single_level, thermodynamics, gas, cloud, aerosol, flux) + + use parkind1, only : jprb + + use radiation_io, only : nulout, nulerr, radiation_abort + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type + use radiation_cloud, only : cloud_type + use radiation_aerosol, only : aerosol_type + use radiation_flux, only : flux_type + + ! Inputs + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type),intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + type(cloud_type), intent(in) :: cloud + type(aerosol_type), intent(in) :: aerosol + ! Output + type(flux_type), intent(inout):: flux + + ! Reversed data structures + type(thermodynamics_type) :: thermodynamics_rev + type(gas_type) :: gas_rev + type(cloud_type) :: cloud_rev + type(aerosol_type) :: aerosol_rev + type(flux_type) :: flux_rev + + ! Start and end levels for aerosol data + integer :: istartlev, iendlev + + if (config%iverbose >= 2) then + write(nulout,'(a)') 'Reversing arrays to be in order of increasing pressure' + end if + +#ifdef _OPENACC + write(nulerr,'(a)') '*** Error: radiation_interface:radiation_reverse not ported to GPU' + call radiation_abort() +#endif + + ! Allocate reversed arrays + call thermodynamics_rev%allocate(ncol, nlev) + call cloud_rev%allocate(ncol, nlev) + call flux_rev%allocate(config, istartcol, iendcol, nlev) + if (allocated(aerosol%mixing_ratio)) then + istartlev = nlev + 1 - aerosol%iendlev + iendlev = nlev + 1 - aerosol%istartlev + call aerosol_rev%allocate(ncol, istartlev, iendlev, & + & config%n_aerosol_types) + end if + + ! Fill reversed thermodynamic arrays + thermodynamics_rev%pressure_hl(istartcol:iendcol,:) & + & = thermodynamics%pressure_hl(istartcol:iendcol, nlev+1:1:-1) + thermodynamics_rev%temperature_hl(istartcol:iendcol,:) & + & = thermodynamics%temperature_hl(istartcol:iendcol, nlev+1:1:-1) + + ! Fill reversed gas arrays + call gas%reverse(istartcol, iendcol, gas_rev) + + if (config%do_clouds) then + ! Fill reversed cloud arrays + cloud_rev%q_liq(istartcol:iendcol,:) & + & = cloud%q_liq(istartcol:iendcol,nlev:1:-1) + cloud_rev%re_liq(istartcol:iendcol,:) & + & = cloud%re_liq(istartcol:iendcol,nlev:1:-1) + cloud_rev%q_ice(istartcol:iendcol,:) & + & = cloud%q_ice(istartcol:iendcol,nlev:1:-1) + cloud_rev%re_ice(istartcol:iendcol,:) & + & = cloud%re_ice(istartcol:iendcol,nlev:1:-1) + cloud_rev%fraction(istartcol:iendcol,:) & + & = cloud%fraction(istartcol:iendcol,nlev:1:-1) + cloud_rev%overlap_param(istartcol:iendcol,:) & + & = cloud%overlap_param(istartcol:iendcol,nlev-1:1:-1) + if (allocated(cloud%fractional_std)) then + cloud_rev%fractional_std(istartcol:iendcol,:) & + & = cloud%fractional_std(istartcol:iendcol,nlev:1:-1) + else + cloud_rev%fractional_std(istartcol:iendcol,:) = 0.0_jprb + end if + if (allocated(cloud%inv_cloud_effective_size)) then + cloud_rev%inv_cloud_effective_size(istartcol:iendcol,:) & + & = cloud%inv_cloud_effective_size(istartcol:iendcol,nlev:1:-1) + else + cloud_rev%inv_cloud_effective_size(istartcol:iendcol,:) = 0.0_jprb + end if + end if + + if (allocated(aerosol%mixing_ratio)) then + aerosol_rev%mixing_ratio(:,istartlev:iendlev,:) & + & = aerosol%mixing_ratio(:,aerosol%iendlev:aerosol%istartlev:-1,:) + end if + + ! Run radiation scheme on reversed profiles + call radiation(ncol, nlev,istartcol,iendcol, & + & config, single_level, thermodynamics_rev, gas_rev, & + & cloud_rev, aerosol_rev, flux_rev) + + ! Reorder fluxes + if (allocated(flux%lw_up)) then + flux%lw_up(istartcol:iendcol,:) & + & = flux_rev%lw_up(istartcol:iendcol,nlev+1:1:-1) + flux%lw_dn(istartcol:iendcol,:) & + & = flux_rev%lw_dn(istartcol:iendcol,nlev+1:1:-1) + if (allocated(flux%lw_up_clear)) then + flux%lw_up_clear(istartcol:iendcol,:) & + & = flux_rev%lw_up_clear(istartcol:iendcol,nlev+1:1:-1) + flux%lw_dn_clear(istartcol:iendcol,:) & + & = flux_rev%lw_dn_clear(istartcol:iendcol,nlev+1:1:-1) + end if + end if + if (allocated(flux%sw_up)) then + flux%sw_up(istartcol:iendcol,:) & + & = flux_rev%sw_up(istartcol:iendcol,nlev+1:1:-1) + flux%sw_dn(istartcol:iendcol,:) & + & = flux_rev%sw_dn(istartcol:iendcol,nlev+1:1:-1) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(istartcol:iendcol,:) & + & = flux_rev%sw_dn_direct(istartcol:iendcol,nlev+1:1:-1) + end if + if (allocated(flux%sw_up_clear)) then + flux%sw_up_clear(istartcol:iendcol,:) & + & = flux_rev%sw_up_clear(istartcol:iendcol,nlev+1:1:-1) + flux%sw_dn_clear(istartcol:iendcol,:) & + & = flux_rev%sw_dn_clear(istartcol:iendcol,nlev+1:1:-1) + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(istartcol:iendcol,:) & + & = flux_rev%sw_dn_direct_clear(istartcol:iendcol,nlev+1:1:-1) + end if + end if + end if + + ! Deallocate reversed arrays + call thermodynamics_rev%deallocate + call gas_rev%deallocate + call cloud_rev%deallocate + call flux_rev%deallocate + if (allocated(aerosol%mixing_ratio)) then + call aerosol_rev%deallocate + end if + + end subroutine radiation_reverse + +end module radiation_interface Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_liquid_optics_slingo.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_liquid_optics_slingo.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_liquid_optics_slingo.F90 (revision 6016) @@ -0,0 +1,109 @@ +! radiation_liquid_optics_slingo.F90 - Slingo SW & Lindner-Li LW parameterization of liquid droplet optics +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_liquid_optics_slingo + + implicit none + public + + integer, parameter :: NLiqOpticsCoeffsSlingoSW = 6 + integer, parameter :: NLiqOpticsCoeffsLindnerLiLW = 13 + +contains + + !--------------------------------------------------------------------- + ! Compute liquid-droplet scattering properties in the shortwave from + ! Slingo (1989). WARNING: this parameterization is known not to be + ! very accurate: see Nielsen et al. (GMD 2014). + subroutine calc_liq_optics_slingo(nb, coeff, lwp, re, od, scat_od, g) + + use parkind1, only : jprb + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Liquid water path (kg m-2) and effective radius (m) + real(jprb), intent(in) :: lwp, re + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Liquid water path in g m-2 + real(jprb) :: lwp_gm_2 + ! Effective radius in microns, and its inverse + real(jprb) :: re_um, inv_re_um + + !real(jphook) :: hook_handle + + !if (lhook) call dr_hook('radiation_liquid_optics_slingo:calc_liq_optics_slingo',0,hook_handle) + + lwp_gm_2 = lwp * 1000.0_jprb + ! Range of validity reported by Slingo (1989): 4.2-16.6 microns + re_um = min(max(4.2_jprb, re * 1.0e6_jprb), 16.6_jprb) + inv_re_um = 1.0_jprb / re_um + + od = lwp_gm_2 * (coeff(1:nb,1) + inv_re_um*coeff(1:nb,2)) + scat_od = od * (1.0_jprb - coeff(1:nb,3) - re_um*coeff(1:nb,4)) + g = coeff(1:nb,5) + re_um*coeff(1:nb,6) + + !if (lhook) call dr_hook('radiation_liquid_optics_slingo:calc_liq_optics_slingo',1,hook_handle) + + end subroutine calc_liq_optics_slingo + + + !--------------------------------------------------------------------- + ! Compute liquid-droplet scattering properties in the longwave from + ! Lindner & Li (2000) + subroutine calc_liq_optics_lindner_li(nb, coeff, lwp, re, od, scat_od, g) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Liquid water path (kg m-2) and effective radius (m) + real(jprb), intent(in) :: lwp, re + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + ! Liquid water path in g m-2 + real(jprb) :: lwp_gm_2 + ! Effective radius in microns, and its inverse + real(jprb) :: re_um, inv_re_um + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_liquid_optics_slingo:calc_liq_optics_lindner_li',0,hook_handle) + + lwp_gm_2 = lwp * 1000.0_jprb + ! Range of validity reported by Lindner and Li (2000): 2-40 microns + re_um = min(max(2.0_jprb, re * 1.0e6_jprb), 40.0_jprb) + inv_re_um = 1.0_jprb / re_um + + od = lwp_gm_2 * (coeff(1:nb,1) + re_um*coeff(1:nb,2) + inv_re_um*(coeff(1:nb,3) & + & + inv_re_um*(coeff(1:nb,4) + inv_re_um*coeff(1:nb,5)))) + scat_od = od * (1.0_jprb - (coeff(1:nb,6) + inv_re_um*coeff(1:nb,7) & + & + re_um*(coeff(1:nb,8) + re_um*coeff(1:nb,9)))) + g = coeff(1:nb,10) + inv_re_um*coeff(1:nb,11) & + & + re_um*(coeff(1:nb,12) + re_um*coeff(1:nb,13)) + + if (lhook) call dr_hook('radiation_liquid_optics_slingo:calc_liq_optics_lindner_li',1,hook_handle) + + end subroutine calc_liq_optics_lindner_li + +end module radiation_liquid_optics_slingo Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_liquid_optics_socrates.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_liquid_optics_socrates.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_liquid_optics_socrates.F90 (revision 6016) @@ -0,0 +1,86 @@ +! This file has been modified for the use in ICON + +! radiation_liquid_optics_socrates.F90 - SOCRATES method for parameterizing liquid droplet optics +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2020-08-10 R. Hogan Bounded re to be >=1.2um and <=50um + +module radiation_liquid_optics_socrates + + use parkind1, only : jprb + + implicit none + public + + ! SOCRATES (Edwards-Slingo) parameterizes info on the dependence of + ! the scattering properties in each band on effective radius in + ! terms of 16 coefficients + integer, parameter :: NLiqOpticsCoeffsSOCRATES = 16 + + ! Range of valid input effective radius, in microns + real(jprb), parameter :: MinEffectiveRadius = 1.2e-6 + real(jprb), parameter :: MaxEffectiveRadius = 50.0e-6 + +contains + + !--------------------------------------------------------------------- + ! Compute liquid-droplet scattering properties using a + ! parameterization consisting of Pade approximants from the + ! SOCRATES (Edwards-Slingo) code + subroutine calc_liq_optics_socrates(nb, coeff, lwp, re_in, od, scat_od, g) + + use parkind1, only : jprb + !use yomhook, only : lhook, dr_hook, jphook + + ! Number of bands + integer, intent(in) :: nb + ! Coefficients read from a data file + real(jprb), intent(in) :: coeff(:,:) + ! Liquid water path (kg m-2) and effective radius (m) + real(jprb), intent(in) :: lwp, re_in + ! Total optical depth, scattering optical depth and asymmetry factor + real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + + integer :: jb + ! Local effective radius (m), after applying bounds + real(jprb) :: re + + !real(jphook) :: hook_handle + + !$ACC ROUTINE SEQ + + !if (lhook) call dr_hook('radiation_liquid_optics_socrates:calc_liq_optics_socrates',0,hook_handle) + + ! Apply the bounds of validity to effective radius + re = max(MinEffectiveRadius, min(re_in, MaxEffectiveRadius)) + +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, nb + od(jb) = lwp * (coeff(jb,1) + re*(coeff(jb,2) + re*coeff(jb,3))) & + & / (1.0_jprb + re*(coeff(jb,4) + re*(coeff(jb,5) & + & + re*coeff(jb,6)))) + scat_od(jb) = od(jb) * (1.0_jprb & + & - (coeff(jb,7) + re*(coeff(jb,8) + re*coeff(jb,9))) & + & / (1.0_jprb + re*(coeff(jb,10) + re*coeff(jb,11)))) + g(jb) = (coeff(jb,12) + re*(coeff(jb,13) + re*coeff(jb,14))) & + & / (1.0_jprb + re*(coeff(jb,15) + re*coeff(jb,16))) + end do + + !if (lhook) call dr_hook('radiation_liquid_optics_socrates:calc_liq_optics_socrates',1,hook_handle) + + end subroutine calc_liq_optics_socrates + +end module radiation_liquid_optics_socrates Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_lw_derivatives.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_lw_derivatives.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_lw_derivatives.F90 (revision 6016) @@ -0,0 +1,293 @@ +! radiation_lw_derivatives.F90 - Compute longwave derivatives for Hogan and Bozzo (2015) method +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! This module provides routines to compute the rate of change of +! broadband upwelling longwave flux at each half level with respect to +! the surface broadband upwelling flux. This is done from the surface +! spectral fluxes and the spectral transmittance of each atmospheric +! layer, assuming no longwave scattering. The result may be used to +! perform approximate updates to the longwave flux profile in between +! calls to the full radiation scheme, accounting for the change in +! skin temperature, following the method of Hogan and Bozzo (JAMES +! 2015). Separate routines are provided for each solver. +! +! Note that currently a more approximate calculation is performed from +! the exact one in Hogan and Bozzo (2015); here we assume that a +! change in temperature increases the spectral fluxes in proportion, +! when in reality there is a change in shape of the Planck function in +! addition to an overall increase in the total emission. +! +! Modifications +! 2017-10-23 R. Hogan Renamed single-character variables +! 2022-11-22 P. Ukkonen / R. Hogan Optimized calc_lw_derivatives_region + +module radiation_lw_derivatives + + public + +contains + + !--------------------------------------------------------------------- + ! Calculation for the Independent Column Approximation + subroutine calc_lw_derivatives_ica(ng, nlev, icol, transmittance, flux_up_surf, lw_derivatives) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + implicit none + + ! Inputs + integer, intent(in) :: ng ! number of spectral intervals + integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: icol ! Index of column for output + real(jprb), intent(in) :: transmittance(ng,nlev) + real(jprb), intent(in) :: flux_up_surf(ng) ! Upwelling surface spectral flux (W m-2) + + ! Output + real(jprb), intent(out) :: lw_derivatives(:,:) ! dimensioned (ncol,nlev+1) + + ! Rate of change of spectral flux at a given height with respect + ! to the surface value + real(jprb) :: lw_derivatives_g(ng) + + integer :: jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_lw_derivatives:calc_lw_derivatives_ica',0,hook_handle) + + ! Initialize the derivatives at the surface + lw_derivatives_g = flux_up_surf / sum(flux_up_surf) + lw_derivatives(icol, nlev+1) = 1.0_jprb + + ! Move up through the atmosphere computing the derivatives at each + ! half-level + do jlev = nlev,1,-1 + lw_derivatives_g = lw_derivatives_g * transmittance(:,jlev) + lw_derivatives(icol,jlev) = sum(lw_derivatives_g) + end do + + if (lhook) call dr_hook('radiation_lw_derivatives:calc_lw_derivatives_ica',1,hook_handle) + + end subroutine calc_lw_derivatives_ica + + + !--------------------------------------------------------------------- + ! Calculation for the Independent Column Approximation + subroutine modify_lw_derivatives_ica(ng, nlev, icol, transmittance, & + & flux_up_surf, weight, lw_derivatives) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + implicit none + + ! Inputs + integer, intent(in) :: ng ! number of spectral intervals + integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: icol ! Index of column for output + real(jprb), intent(in) :: transmittance(ng,nlev) + real(jprb), intent(in) :: flux_up_surf(ng) ! Upwelling surface spectral flux (W m-2) + real(jprb), intent(in) :: weight ! Weight new values against existing + + ! Output + real(jprb), intent(inout) :: lw_derivatives(:,:) ! dimensioned (ncol,nlev+1) + + ! Rate of change of spectral flux at a given height with respect + ! to the surface value + real(jprb) :: lw_derivatives_g(ng) + + integer :: jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_lw_derivatives:modify_lw_derivatives_ica',0,hook_handle) + + ! Initialize the derivatives at the surface + lw_derivatives_g = flux_up_surf / sum(flux_up_surf) + ! This value must be 1 so no weighting applied + lw_derivatives(icol, nlev+1) = 1.0_jprb + + ! Move up through the atmosphere computing the derivatives at each + ! half-level + do jlev = nlev,1,-1 + lw_derivatives_g = lw_derivatives_g * transmittance(:,jlev) + lw_derivatives(icol,jlev) = (1.0_jprb - weight) * lw_derivatives(icol,jlev) & + & + weight * sum(lw_derivatives_g) + end do + + if (lhook) call dr_hook('radiation_lw_derivatives:modify_lw_derivatives_ica',1,hook_handle) + + end subroutine modify_lw_derivatives_ica + + + + !--------------------------------------------------------------------- + ! Calculation for solvers involving multiple regions and matrices + subroutine calc_lw_derivatives_matrix(ng, nlev, nreg, icol, transmittance, & + & u_matrix, flux_up_surf, lw_derivatives) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_matrix + + implicit none + + ! Inputs + integer, intent(in) :: ng ! number of spectral intervals + integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: nreg ! number of regions + integer, intent(in) :: icol ! Index of column for output + real(jprb), intent(in) :: transmittance(ng,nreg,nreg,nlev) + real(jprb), intent(in) :: u_matrix(nreg,nreg,nlev+1) ! Upward overlap matrix + real(jprb), intent(in) :: flux_up_surf(ng) ! Upwelling surface spectral flux (W m-2) + + ! Output + real(jprb), intent(out) :: lw_derivatives(:,:) ! dimensioned (ncol,nlev+1) + + ! Rate of change of spectral flux at a given height with respect + ! to the surface value + real(jprb) :: lw_derivatives_g_reg(ng,nreg) + + integer :: jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_lw_derivatives:calc_lw_derivatives_matrix',0,hook_handle) + + ! Initialize the derivatives at the surface; the surface is + ! treated as a single clear-sky layer so we only need to put + ! values in region 1. + lw_derivatives_g_reg = 0.0_jprb + lw_derivatives_g_reg(:,1) = flux_up_surf / sum(flux_up_surf) + lw_derivatives(icol, nlev+1) = 1.0_jprb + + ! Move up through the atmosphere computing the derivatives at each + ! half-level + do jlev = nlev,1,-1 + ! Compute effect of overlap at half-level jlev+1, yielding + ! derivatives just above that half-level + lw_derivatives_g_reg = singlemat_x_vec(ng,ng,nreg,u_matrix(:,:,jlev+1),lw_derivatives_g_reg) + + ! Compute effect of transmittance of layer jlev, yielding + ! derivatives just below the half-level above (jlev) + lw_derivatives_g_reg = mat_x_vec(ng,ng,nreg,transmittance(:,:,:,jlev),lw_derivatives_g_reg) + + lw_derivatives(icol, jlev) = sum(lw_derivatives_g_reg) + end do + + if (lhook) call dr_hook('radiation_lw_derivatives:calc_lw_derivatives_matrix',1,hook_handle) + + end subroutine calc_lw_derivatives_matrix + + + !--------------------------------------------------------------------- + ! Calculation for solvers involving multiple regions but no 3D + ! effects: the difference from calc_lw_derivatives_matrix is that transmittance + ! has one fewer dimensions + subroutine calc_lw_derivatives_region(ng, nlev, nreg, icol, transmittance, & + & u_matrix, flux_up_surf, lw_derivatives) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_matrix + + implicit none + + ! Inputs + integer, intent(in) :: ng ! number of spectral intervals + integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: nreg ! number of regions + integer, intent(in) :: icol ! Index of column for output + real(jprb), intent(in) :: transmittance(ng,nreg,nlev) + real(jprb), intent(in) :: u_matrix(nreg,nreg,nlev+1) ! Upward overlap matrix + real(jprb), intent(in) :: flux_up_surf(ng) ! Upwelling surface spectral flux (W m-2) + + ! Output + real(jprb), intent(out) :: lw_derivatives(:,:) ! dimensioned (ncol,nlev+1) + + ! Rate of change of spectral flux at a given height with respect + ! to the surface value + real(jprb) :: lw_deriv(ng,nreg), lw_deriv_below(ng,nreg) + real(jprb) :: partial_sum(ng) + + integer :: jlev, jg + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_lw_derivatives:calc_lw_derivatives_region',0,hook_handle) + + ! Initialize the derivatives at the surface; the surface is + ! treated as a single clear-sky layer so we only need to put + ! values in region 1. + lw_deriv = 0.0_jprb + lw_deriv(:,1) = flux_up_surf / sum(flux_up_surf) + lw_derivatives(icol, nlev+1) = 1.0_jprb + + if (nreg == 3) then + ! Optimize the most common case of 3 regions by removing the + ! nested call to singlemat_x_vec and unrolling the matrix + ! multiplication inline + + do jlev = nlev,1,-1 + ! Compute effect of overlap at half-level jlev+1, yielding + ! derivatives just above that half-level + lw_deriv_below = lw_deriv + + associate(A=>u_matrix(:,:,jlev+1), b=>lw_deriv_below) + do jg = 1,ng + ! Both inner and outer loop of the matrix loops j1 and j2 unrolled + ! inner loop: j2=1 j2=2 j2=3 + lw_deriv(jg,1) = A(1,1)*b(jg,1) + A(1,2)*b(jg,2) + A(1,3)*b(jg,3) + lw_deriv(jg,2) = A(2,1)*b(jg,1) + A(2,2)*b(jg,2) + A(2,3)*b(jg,3) + lw_deriv(jg,3) = A(3,1)*b(jg,1) + A(3,2)*b(jg,2) + A(3,3)*b(jg,3) + + ! Compute effect of transmittance of layer jlev, yielding + ! derivatives just below the half-level above (jlev) + lw_deriv(jg,1) = lw_deriv(jg,1) * transmittance(jg,1,jlev) + lw_deriv(jg,2) = lw_deriv(jg,2) * transmittance(jg,2,jlev) + lw_deriv(jg,3) = lw_deriv(jg,3) * transmittance(jg,3,jlev) + + partial_sum(jg) = lw_deriv(jg,1) + lw_deriv(jg,2) + lw_deriv(jg,3) + end do + end associate + + lw_derivatives(icol, jlev) = sum(partial_sum) + end do + else + ! General case when number of regions is not 3 + + ! Move up through the atmosphere computing the derivatives at each + ! half-level + do jlev = nlev,1,-1 + ! Compute effect of overlap at half-level jlev+1, yielding + ! derivatives just above that half-level + lw_deriv = singlemat_x_vec(ng,ng,nreg,u_matrix(:,:,jlev+1),lw_deriv) + + ! Compute effect of transmittance of layer jlev, yielding + ! derivatives just below the half-level above (jlev) + lw_deriv = transmittance(:,:,jlev) * lw_deriv + + lw_derivatives(icol, jlev) = sum(lw_deriv) + end do + end if + + if (lhook) call dr_hook('radiation_lw_derivatives:calc_lw_derivatives_region',1,hook_handle) + + end subroutine calc_lw_derivatives_region + + +end module radiation_lw_derivatives Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_matrix.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_matrix.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_matrix.F90 (revision 6016) @@ -0,0 +1,1033 @@ +! radiation_matrix.F90 - SPARTACUS matrix operations +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2018-10-15 R. Hogan Added fast_expm_exchange_[23] +! +! This module provides the neccessary mathematical functions for the +! SPARTACUS radiation scheme: matrix multiplication, matrix solvers +! and matrix exponentiation, but (a) multiple matrices are operated on +! at once with array access indended to facilitate vectorization, and +! (b) optimization for 2x2 and 3x3 matrices. There is probably +! considerable scope for further optimization. Note that this module +! is not used by the McICA solver. + +module radiation_matrix + + use parkind1, only : jprb + + implicit none + public + + ! Codes to describe sparseness pattern, where the SHORTWAVE + ! pattern is of the form: + ! (x x x) + ! (x x x) + ! (0 0 x) + ! where each element may itself be a square matrix. + integer, parameter :: IMatrixPatternDense = 0 + integer, parameter :: IMatrixPatternShortwave = 1 + + public :: mat_x_vec, singlemat_x_vec, mat_x_mat, & + & singlemat_x_mat, mat_x_singlemat, & + & identity_minus_mat_x_mat, solve_vec, solve_mat, expm, & + & fast_expm_exchange_2, fast_expm_exchange_3, & + & sparse_x_dense + + private :: solve_vec_2, solve_vec_3, solve_mat_2, & + & solve_mat_3, lu_factorization, lu_substitution, solve_mat_n, & + & diag_mat_right_divide_3 + + interface fast_expm_exchange + module procedure fast_expm_exchange_2, fast_expm_exchange_3 + end interface fast_expm_exchange + +contains + + ! --- MATRIX-VECTOR MULTIPLICATION --- + + !--------------------------------------------------------------------- + ! Treat A as n m-by-m square matrices (with the n dimension varying + ! fastest) and b as n m-element vectors, and perform matrix-vector + ! multiplications on first iend pairs + function mat_x_vec(n,iend,m,A,b,do_top_left_only_in) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + real(jprb), intent(in), dimension(:,:,:) :: A + real(jprb), intent(in), dimension(:,:) :: b + logical, intent(in), optional :: do_top_left_only_in + real(jprb), dimension(iend,m):: mat_x_vec + + integer :: j1, j2 + logical :: do_top_left_only + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:mat_x_vec',0,hook_handle) + + if (present(do_top_left_only_in)) then + do_top_left_only = do_top_left_only_in + else + do_top_left_only = .false. + end if + + ! Array-wise assignment + mat_x_vec = 0.0_jprb + + if (do_top_left_only) then + mat_x_vec(1:iend,1) = A(1:iend,1,1)*b(1:iend,1) + else + do j1 = 1,m + do j2 = 1,m + mat_x_vec(1:iend,j1) = mat_x_vec(1:iend,j1) & + & + A(1:iend,j1,j2)*b(1:iend,j2) + end do + end do + end if + + if (lhook) call dr_hook('radiation_matrix:mat_x_vec',1,hook_handle) + + end function mat_x_vec + + + !--------------------------------------------------------------------- + ! Treat A as an m-by-m square matrix and b as n m-element vectors + ! (with the n dimension varying fastest), and perform matrix-vector + ! multiplications on first iend pairs + function singlemat_x_vec(n,iend,m,A,b) + +! use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + real(jprb), intent(in), dimension(m,m) :: A + real(jprb), intent(in), dimension(:,:) :: b + real(jprb), dimension(iend,m) :: singlemat_x_vec + + integer :: j1, j2 +! real(jphook) :: hook_handle + +! if (lhook) call dr_hook('radiation_matrix:single_mat_x_vec',0,hook_handle) + + ! Array-wise assignment + singlemat_x_vec = 0.0_jprb + + do j1 = 1,m + do j2 = 1,m + singlemat_x_vec(1:iend,j1) = singlemat_x_vec(1:iend,j1) & + & + A(j1,j2)*b(1:iend,j2) + end do + end do + +! if (lhook) call dr_hook('radiation_matrix:single_mat_x_vec',1,hook_handle) + + end function singlemat_x_vec + + + ! --- SQUARE MATRIX-MATRIX MULTIPLICATION --- + + !--------------------------------------------------------------------- + ! Treat A and B each as n m-by-m square matrices (with the n + ! dimension varying fastest) and perform matrix multiplications on + ! all n matrix pairs + function mat_x_mat(n,iend,m,A,B,i_matrix_pattern) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + integer, intent(in), optional :: i_matrix_pattern + real(jprb), intent(in), dimension(:,:,:) :: A, B + + real(jprb), dimension(iend,m,m) :: mat_x_mat + integer :: j1, j2, j3 + integer :: mblock, m2block + integer :: i_actual_matrix_pattern + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:mat_x_mat',0,hook_handle) + + if (present(i_matrix_pattern)) then + i_actual_matrix_pattern = i_matrix_pattern + else + i_actual_matrix_pattern = IMatrixPatternDense + end if + + ! Array-wise assignment + mat_x_mat = 0.0_jprb + + if (i_actual_matrix_pattern == IMatrixPatternShortwave) then + ! Matrix has a sparsity pattern + ! (C D E) + ! A = (F G H) + ! (0 0 I) + mblock = m/3 + m2block = 2*mblock + ! Do the top-left (C, D, F, G) + do j2 = 1,m2block + do j1 = 1,m2block + do j3 = 1,m2block + mat_x_mat(1:iend,j1,j2) = mat_x_mat(1:iend,j1,j2) & + & + A(1:iend,j1,j3)*B(1:iend,j3,j2) + end do + end do + end do + do j2 = m2block+1,m + ! Do the top-right (E & H) + do j1 = 1,m2block + do j3 = 1,m + mat_x_mat(1:iend,j1,j2) = mat_x_mat(1:iend,j1,j2) & + & + A(1:iend,j1,j3)*B(1:iend,j3,j2) + end do + end do + ! Do the bottom-right (I) + do j1 = m2block+1,m + do j3 = m2block+1,m + mat_x_mat(1:iend,j1,j2) = mat_x_mat(1:iend,j1,j2) & + & + A(1:iend,j1,j3)*B(1:iend,j3,j2) + end do + end do + end do + else + ! Ordinary dense matrix + do j2 = 1,m + do j1 = 1,m + do j3 = 1,m + mat_x_mat(1:iend,j1,j2) = mat_x_mat(1:iend,j1,j2) & + & + A(1:iend,j1,j3)*B(1:iend,j3,j2) + end do + end do + end do + end if + + if (lhook) call dr_hook('radiation_matrix:mat_x_mat',1,hook_handle) + + end function mat_x_mat + + + !--------------------------------------------------------------------- + ! Treat A as an m-by-m matrix and B as n m-by-m square matrices + ! (with the n dimension varying fastest) and perform matrix + ! multiplications on the first iend matrix pairs + function singlemat_x_mat(n,iend,m,A,B) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + real(jprb), intent(in), dimension(m,m) :: A + real(jprb), intent(in), dimension(:,:,:) :: B + real(jprb), dimension(iend,m,m) :: singlemat_x_mat + + integer :: j1, j2, j3 + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:singlemat_x_mat',0,hook_handle) + + ! Array-wise assignment + singlemat_x_mat = 0.0_jprb + + do j2 = 1,m + do j1 = 1,m + do j3 = 1,m + singlemat_x_mat(1:iend,j1,j2) = singlemat_x_mat(1:iend,j1,j2) & + & + A(j1,j3)*B(1:iend,j3,j2) + end do + end do + end do + + if (lhook) call dr_hook('radiation_matrix:singlemat_x_mat',1,hook_handle) + + end function singlemat_x_mat + + + !--------------------------------------------------------------------- + ! Treat B as an m-by-m matrix and A as n m-by-m square matrices + ! (with the n dimension varying fastest) and perform matrix + ! multiplications on the first iend matrix pairs + function mat_x_singlemat(n,iend,m,A,B) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + real(jprb), intent(in), dimension(:,:,:) :: A + real(jprb), intent(in), dimension(m,m) :: B + + real(jprb), dimension(iend,m,m) :: mat_x_singlemat + integer :: j1, j2, j3 + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:mat_x_singlemat',0,hook_handle) + + ! Array-wise assignment + mat_x_singlemat = 0.0_jprb + + do j2 = 1,m + do j1 = 1,m + do j3 = 1,m + mat_x_singlemat(1:iend,j1,j2) = mat_x_singlemat(1:iend,j1,j2) & + & + A(1:iend,j1,j3)*B(j3,j2) + end do + end do + end do + + if (lhook) call dr_hook('radiation_matrix:mat_x_singlemat',1,hook_handle) + + end function mat_x_singlemat + + + !--------------------------------------------------------------------- + ! Compute I-A*B where I is the identity matrix and A & B are n + ! m-by-m square matrices + function identity_minus_mat_x_mat(n,iend,m,A,B,i_matrix_pattern) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + integer, intent(in), optional :: i_matrix_pattern + real(jprb), intent(in), dimension(:,:,:) :: A, B + real(jprb), dimension(iend,m,m) :: identity_minus_mat_x_mat + + integer :: j + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:identity_mat_x_mat',0,hook_handle) + + if (present(i_matrix_pattern)) then + identity_minus_mat_x_mat = mat_x_mat(n,iend,m,A,B,i_matrix_pattern) + else + identity_minus_mat_x_mat = mat_x_mat(n,iend,m,A,B) + end if + + identity_minus_mat_x_mat = - identity_minus_mat_x_mat + do j = 1,m + identity_minus_mat_x_mat(1:iend,j,j) & + & = 1.0_jprb + identity_minus_mat_x_mat(1:iend,j,j) + end do + + if (lhook) call dr_hook('radiation_matrix:identity_mat_x_mat',1,hook_handle) + + end function identity_minus_mat_x_mat + + + + !--------------------------------------------------------------------- + ! Replacement for matmul in the case that the first matrix is sparse + function sparse_x_dense(sparse, dense) + + real(jprb), intent(in) :: sparse(:,:), dense(:,:) + real(jprb) :: sparse_x_dense(size(sparse,1),size(dense,2)) + + integer :: j1, j2, j3 ! Loop indices + integer :: n1, n2, n3 ! Array sizes + + n1 = size(sparse,1) + n2 = size(sparse,2) + n3 = size(dense,2) + + sparse_x_dense = 0.0_jprb + do j2 = 1,n2 + do j1 = 1,n1 + if (sparse(j1,j2) /= 0.0_jprb) then + sparse_x_dense(j1,:) = sparse_x_dense(j1,:) + sparse(j1,j2)*dense(j2,:) + end if + end do + end do + + end function sparse_x_dense + + + ! --- REPEATEDLY SQUARE A MATRIX --- + + !--------------------------------------------------------------------- + ! Square m-by-m matrix "A" nrepeat times. A will be corrupted by + ! this function. + function repeated_square(m,A,nrepeat,i_matrix_pattern) + integer, intent(in) :: m, nrepeat + real(jprb), intent(inout) :: A(m,m) + integer, intent(in), optional :: i_matrix_pattern + real(jprb) :: repeated_square(m,m) + + integer :: j1, j2, j3, j4 + integer :: mblock, m2block + integer :: i_actual_matrix_pattern + + if (present(i_matrix_pattern)) then + i_actual_matrix_pattern = i_matrix_pattern + else + i_actual_matrix_pattern = IMatrixPatternDense + end if + + if (i_actual_matrix_pattern == IMatrixPatternShortwave) then + ! Matrix has a sparsity pattern + ! (C D E) + ! A = (F G H) + ! (0 0 I) + mblock = m/3 + m2block = 2*mblock + do j4 = 1,nrepeat + repeated_square = 0.0_jprb + ! Do the top-left (C, D, F & G) + do j2 = 1,m2block + do j1 = 1,m2block + do j3 = 1,m2block + repeated_square(j1,j2) = repeated_square(j1,j2) & + & + A(j1,j3)*A(j3,j2) + end do + end do + end do + do j2 = m2block+1, m + ! Do the top-right (E & H) + do j1 = 1,m2block + do j3 = 1,m + repeated_square(j1,j2) = repeated_square(j1,j2) & + & + A(j1,j3)*A(j3,j2) + end do + end do + ! Do the bottom-right (I) + do j1 = m2block+1, m + do j3 = m2block+1,m + repeated_square(j1,j2) = repeated_square(j1,j2) & + & + A(j1,j3)*A(j3,j2) + end do + end do + end do + if (j4 < nrepeat) then + A = repeated_square + end if + end do + else + ! Ordinary dense matrix + do j4 = 1,nrepeat + repeated_square = 0.0_jprb + do j2 = 1,m + do j1 = 1,m + do j3 = 1,m + repeated_square(j1,j2) = repeated_square(j1,j2) & + & + A(j1,j3)*A(j3,j2) + end do + end do + end do + if (j4 < nrepeat) then + A = repeated_square + end if + end do + end if + + end function repeated_square + + + ! --- SOLVE LINEAR EQUATIONS --- + + !--------------------------------------------------------------------- + ! Solve Ax=b to obtain x. Version optimized for 2x2 matrices using + ! Cramer's method: "A" contains n 2x2 matrices and "b" contains n + ! 2-element vectors; returns A^-1 b. + pure subroutine solve_vec_2(n,iend,A,b,x) + + integer, intent(in) :: n, iend + real(jprb), intent(in) :: A(:,:,:) + real(jprb), intent(in) :: b(:,:) + real(jprb), intent(out) :: x(:,:) + + real(jprb) :: inv_det(iend) + + inv_det = 1.0_jprb / ( A(1:iend,1,1)*A(1:iend,2,2) & + & - A(1:iend,1,2)*A(1:iend,2,1)) + + x(1:iend,1) = inv_det*(A(1:iend,2,2)*b(1:iend,1)-A(1:iend,1,2)*b(1:iend,2)) + x(1:iend,2) = inv_det*(A(1:iend,1,1)*b(1:iend,2)-A(1:iend,2,1)*b(1:iend,1)) + + end subroutine solve_vec_2 + + + !--------------------------------------------------------------------- + ! Solve AX=B to obtain X, i.e. the matrix right-hand-side version of + ! solve_vec_2, with A, X and B all containing n 2x2 matrices; + ! returns A^-1 B using Cramer's method. + pure subroutine solve_mat_2(n,iend,A,B,X) + integer, intent(in) :: n, iend + real(jprb), intent(in) :: A(:,:,:) + real(jprb), intent(in) :: B(:,:,:) + real(jprb), intent(out) :: X(:,:,:) + + real(jprb) :: inv_det(iend) + + inv_det = 1.0_jprb / ( A(1:iend,1,1)*A(1:iend,2,2) & + & - A(1:iend,1,2)*A(1:iend,2,1)) + + X(1:iend,1,1) = inv_det*( A(1:iend,2,2)*B(1:iend,1,1) & + & -A(1:iend,1,2)*B(1:iend,2,1)) + X(1:iend,2,1) = inv_det*( A(1:iend,1,1)*B(1:iend,2,1) & + & -A(1:iend,2,1)*B(1:iend,1,1)) + X(1:iend,1,2) = inv_det*( A(1:iend,2,2)*B(1:iend,1,2) & + & -A(1:iend,1,2)*B(1:iend,2,2)) + X(1:iend,2,2) = inv_det*( A(1:iend,1,1)*B(1:iend,2,2) & + & -A(1:iend,2,1)*B(1:iend,1,2)) + + end subroutine solve_mat_2 + + + !--------------------------------------------------------------------- + ! Solve Ax=b optimized for 3x3 matrices, using LU + ! factorization and substitution without pivoting. + pure subroutine solve_vec_3(n,iend,A,b,x) + integer, intent(in) :: n, iend + real(jprb), intent(in) :: A(:,:,:) + real(jprb), intent(in) :: b(:,:) + real(jprb), intent(out) :: x(:,:) + + real(jprb), dimension(iend) :: L21, L31, L32 + real(jprb), dimension(iend) :: U22, U23, U33 + real(jprb), dimension(iend) :: y2, y3 + + ! Some compilers unfortunately don't support assocate + ! associate (U11 => A(:,1,1), U12 => A(:,1,2), U13 => A(1,3), & + ! y1 => b(:,1), x1 => solve_vec3(:,1), & + ! x2 => solve_vec3(:,2), x3 => solve_vec3(:,3)) + + ! LU decomposition: + ! ( 1 ) (U11 U12 U13) + ! A = (L21 1 ) * ( U22 U23) + ! (L31 L32 1) ( U33) + L21 = A(1:iend,2,1) / A(1:iend,1,1) + L31 = A(1:iend,3,1) / A(1:iend,1,1) + U22 = A(1:iend,2,2) - L21*A(1:iend,1,2) + U23 = A(1:iend,2,3) - L21*A(1:iend,1,3) + L32 =(A(1:iend,3,2) - L31*A(1:iend,1,2)) / U22 + U33 = A(1:iend,3,3) - L31*A(1:iend,1,3) - L32*U23 + + ! Solve Ly = b by forward substitution + y2 = b(1:iend,2) - L21*b(1:iend,1) + y3 = b(1:iend,3) - L31*b(1:iend,1) - L32*y2 + + ! Solve Ux = y by back substitution + x(1:iend,3) = y3/U33 + x(1:iend,2) = (y2 - U23*x(1:iend,3)) / U22 + x(1:iend,1) = (b(1:iend,1) - A(1:iend,1,2)*x(1:iend,2) & + & - A(1:iend,1,3)*x(1:iend,3)) / A(1:iend,1,1) + ! end associate + + end subroutine solve_vec_3 + + + !--------------------------------------------------------------------- + ! Solve AX=B optimized for 3x3 matrices, using LU factorization and + ! substitution with no pivoting. + pure subroutine solve_mat_3(n,iend,A,B,X) + integer, intent(in) :: n, iend + real(jprb), intent(in) :: A(:,:,:) + real(jprb), intent(in) :: B(:,:,:) + real(jprb), intent(out) :: X(:,:,:) + + real(jprb), dimension(iend) :: L21, L31, L32 + real(jprb), dimension(iend) :: U22, U23, U33 + real(jprb), dimension(iend) :: y2, y3 + + integer :: j + + ! associate (U11 => A(:,1,1), U12 => A(:,1,2), U13 => A(1,3)) + ! LU decomposition: + ! ( 1 ) (U11 U12 U13) + ! A = (L21 1 ) * ( U22 U23) + ! (L31 L32 1) ( U33) + L21 = A(1:iend,2,1) / A(1:iend,1,1) + L31 = A(1:iend,3,1) / A(1:iend,1,1) + U22 = A(1:iend,2,2) - L21*A(1:iend,1,2) + U23 = A(1:iend,2,3) - L21*A(1:iend,1,3) + L32 =(A(1:iend,3,2) - L31*A(1:iend,1,2)) / U22 + U33 = A(1:iend,3,3) - L31*A(1:iend,1,3) - L32*U23 + + do j = 1,3 + ! Solve Ly = B(:,:,j) by forward substitution + ! y1 = B(:,1,j) + y2 = B(1:iend,2,j) - L21*B(1:iend,1,j) + y3 = B(1:iend,3,j) - L31*B(1:iend,1,j) - L32*y2 + ! Solve UX(:,:,j) = y by back substitution + X(1:iend,3,j) = y3 / U33 + X(1:iend,2,j) = (y2 - U23*X(1:iend,3,j)) / U22 + X(1:iend,1,j) = (B(1:iend,1,j) - A(1:iend,1,2)*X(1:iend,2,j) & + & - A(1:iend,1,3)*X(1:iend,3,j)) / A(1:iend,1,1) + end do + + end subroutine solve_mat_3 + + + !--------------------------------------------------------------------- + ! Return X = B A^-1 = (A^-T B)^T optimized for 3x3 matrices, where B + ! is a diagonal matrix, using LU factorization and substitution with + ! no pivoting. + pure subroutine diag_mat_right_divide_3(n,iend,A,B,X) + integer, intent(in) :: n, iend + real(jprb), intent(in) :: A(iend,3,3) + real(jprb), intent(in) :: B(iend,3) + real(jprb), intent(out) :: X(n,3,3) + + real(jprb), dimension(iend) :: L21, L31, L32 + real(jprb), dimension(iend) :: U22, U23, U33 + real(jprb), dimension(iend) :: y2, y3 + + ! associate (U11 => A(:,1,1), U12 => A(:,1,2), U13 => A(1,3)) + ! LU decomposition of the *transpose* of A: + ! ( 1 ) (U11 U12 U13) + ! A^T = (L21 1 ) * ( U22 U23) + ! (L31 L32 1) ( U33) + L21 = A(1:iend,1,2) / A(1:iend,1,1) + L31 = A(1:iend,1,3) / A(1:iend,1,1) + U22 = A(1:iend,2,2) - L21*A(1:iend,2,1) + U23 = A(1:iend,3,2) - L21*A(1:iend,3,1) + L32 =(A(1:iend,2,3) - L31*A(1:iend,2,1)) / U22 + U33 = A(1:iend,3,3) - L31*A(1:iend,3,1) - L32*U23 + + ! Solve X(1,:) = A^-T ( B(1) ) + ! ( 0 ) + ! ( 0 ) + ! Solve Ly = B(:,:,j) by forward substitution + ! y1 = B(:,1) + y2 = - L21*B(1:iend,1) + y3 = - L31*B(1:iend,1) - L32*y2 + ! Solve UX(:,:,j) = y by back substitution + X(1:iend,1,3) = y3 / U33 + X(1:iend,1,2) = (y2 - U23*X(1:iend,1,3)) / U22 + X(1:iend,1,1) = (B(1:iend,1) - A(1:iend,2,1)*X(1:iend,1,2) & + & - A(1:iend,3,1)*X(1:iend,1,3)) / A(1:iend,1,1) + + ! Solve X(2,:) = A^-T ( 0 ) + ! ( B(2) ) + ! ( 0 ) + ! Solve Ly = B(:,:,j) by forward substitution + ! y1 = 0 + ! y2 = B(1:iend,2) + y3 = - L32*B(1:iend,2) + ! Solve UX(:,:,j) = y by back substitution + X(1:iend,2,3) = y3 / U33 + X(1:iend,2,2) = (B(1:iend,2) - U23*X(1:iend,2,3)) / U22 + X(1:iend,2,1) = (-A(1:iend,2,1)*X(1:iend,2,2) & + & -A(1:iend,3,1)*X(1:iend,2,3)) / A(1:iend,1,1) + + ! Solve X(3,:) = A^-T ( 0 ) + ! ( 0 ) + ! ( B(3) ) + ! Solve Ly = B(:,:,j) by forward substitution + ! y1 = 0 + ! y2 = 0 + ! y3 = B(1:iend,3) + ! Solve UX(:,:,j) = y by back substitution + X(1:iend,3,3) = B(1:iend,3) / U33 + X(1:iend,3,2) = -U23*X(1:iend,3,3) / U22 + X(1:iend,3,1) = (-A(1:iend,2,1)*X(1:iend,3,2) & + & - A(1:iend,3,1)*X(1:iend,3,3)) / A(1:iend,1,1) + + end subroutine diag_mat_right_divide_3 + + + !--------------------------------------------------------------------- + ! Treat A as n m-by-m matrices and return the LU factorization of A + ! compressed into a single matrice (with L below the diagonal and U + ! on and above the diagonal; the diagonal elements of L are 1). No + ! pivoting is performed. + pure subroutine lu_factorization(n, iend, m, A, LU) + integer, intent(in) :: n, m, iend + real(jprb), intent(in) :: A(:,:,:) + real(jprb), intent(out) :: LU(iend,m,m) + + real(jprb) :: s(iend) + integer :: j1, j2, j3 + + ! This routine is adapted from an in-place one, so we first copy + ! the input into the output. + LU(1:iend,1:m,1:m) = A(1:iend,1:m,1:m) + + do j2 = 1, m + do j1 = 1, j2-1 + s = LU(1:iend,j1,j2) + do j3 = 1, j1-1 + s = s - LU(1:iend,j1,j3) * LU(1:iend,j3,j2) + end do + LU(1:iend,j1,j2) = s + end do + do j1 = j2, m + s = LU(1:iend,j1,j2) + do j3 = 1, j2-1 + s = s - LU(1:iend,j1,j3) * LU(1:iend,j3,j2) + end do + LU(1:iend,j1,j2) = s + end do + if (j2 /= m) then + s = 1.0_jprb / LU(1:iend,j2,j2) + do j1 = j2+1, m + LU(1:iend,j1,j2) = LU(1:iend,j1,j2) * s + end do + end if + end do + + end subroutine lu_factorization + + + !--------------------------------------------------------------------- + ! Treat LU as an LU-factorization of an original matrix A, and + ! return x where Ax=b. LU consists of n m-by-m matrices and b as n + ! m-element vectors. + pure subroutine lu_substitution(n,iend,m,LU,b,x) + ! CHECK: dimensions should be ":"? + integer, intent(in) :: n, m, iend + real(jprb), intent(in) :: LU(iend,m,m) + real(jprb), intent(in) :: b(:,:) + real(jprb), intent(out):: x(iend,m) + + integer :: j1, j2 + + x(1:iend,1:m) = b(1:iend,1:m) + + ! First solve Ly=b + do j2 = 2, m + do j1 = 1, j2-1 + x(1:iend,j2) = x(1:iend,j2) - x(1:iend,j1)*LU(1:iend,j2,j1) + end do + end do + ! Now solve Ux=y + do j2 = m, 1, -1 + do j1 = j2+1, m + x(1:iend,j2) = x(1:iend,j2) - x(1:iend,j1)*LU(1:iend,j2,j1) + end do + x(1:iend,j2) = x(1:iend,j2) / LU(1:iend,j2,j2) + end do + + end subroutine lu_substitution + + + !--------------------------------------------------------------------- + ! Return matrix X where AX=B. LU, A, X, B all consist of n m-by-m + ! matrices. + pure subroutine solve_mat_n(n,iend,m,A,B,X) + integer, intent(in) :: n, m, iend + real(jprb), intent(in) :: A(:,:,:) + real(jprb), intent(in) :: B(:,:,:) + real(jprb), intent(out):: X(iend,m,m) + + real(jprb) :: LU(iend,m,m) + + integer :: j + + call lu_factorization(n,iend,m,A,LU) + + do j = 1, m + call lu_substitution(n,iend,m,LU,B(1:,1:m,j),X(1:iend,1:m,j)) +! call lu_substitution(n,iend,m,LU,B(1:n,1:m,j),X(1:iend,1:m,j)) + end do + + end subroutine solve_mat_n + + + !--------------------------------------------------------------------- + ! Solve Ax=b, where A consists of n m-by-m matrices and x and b + ! consist of n m-element vectors. For m=2 or m=3, this function + ! calls optimized versions, otherwise it uses general LU + ! decomposition without pivoting. + function solve_vec(n,iend,m,A,b) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + real(jprb), intent(in) :: A(:,:,:) + real(jprb), intent(in) :: b(:,:) + + real(jprb) :: solve_vec(iend,m) + real(jprb) :: LU(iend,m,m) + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:solve_vec',0,hook_handle) + + if (m == 2) then + call solve_vec_2(n,iend,A,b,solve_vec) + elseif (m == 3) then + call solve_vec_3(n,iend,A,b,solve_vec) + else + call lu_factorization(n,iend,m,A,LU) + call lu_substitution(n,iend,m,LU,b,solve_vec) + end if + + if (lhook) call dr_hook('radiation_matrix:solve_vec',1,hook_handle) + + end function solve_vec + + + !--------------------------------------------------------------------- + ! Solve AX=B, where A, X and B consist of n m-by-m matrices. For m=2 + ! or m=3, this function calls optimized versions, otherwise it uses + ! general LU decomposition without pivoting. + function solve_mat(n,iend,m,A,B) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + real(jprb), intent(in) :: A(:,:,:) + real(jprb), intent(in) :: B(:,:,:) + + real(jprb) :: solve_mat(iend,m,m) + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:solve_mat',0,hook_handle) + + if (m == 2) then + call solve_mat_2(n,iend,A,B,solve_mat) + elseif (m == 3) then + call solve_mat_3(n,iend,A,B,solve_mat) + else + call solve_mat_n(n,iend,m,A,B,solve_mat) + end if + + if (lhook) call dr_hook('radiation_matrix:solve_mat',1,hook_handle) + + end function solve_mat + + + ! --- MATRIX EXPONENTIATION --- + + !--------------------------------------------------------------------- + ! Perform matrix exponential of n m-by-m matrices stored in A (where + ! index n varies fastest) using the Higham scaling and squaring + ! method. The result is placed in A. This routine is intended for + ! speed so is accurate only to single precision. For simplicity and + ! to aid vectorization, the Pade approximant of order 7 is used for + ! all input matrices, perhaps leading to a few too many + ! multiplications for matrices with a small norm. + subroutine expm(n,iend,m,A,i_matrix_pattern) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, m, iend + real(jprb), intent(inout) :: A(n,m,m) + integer, intent(in) :: i_matrix_pattern + + real(jprb), parameter :: theta(3) = (/4.258730016922831e-01_jprb, & + & 1.880152677804762e+00_jprb, & + & 3.925724783138660e+00_jprb/) + real(jprb), parameter :: c(8) = (/17297280.0_jprb, 8648640.0_jprb, & + & 1995840.0_jprb, 277200.0_jprb, 25200.0_jprb, & + & 1512.0_jprb, 56.0_jprb, 1.0_jprb/) + + real(jprb), dimension(iend,m,m) :: A2, A4, A6 + real(jprb), dimension(iend,m,m) :: U, V + + real(jprb) :: normA(iend), sum_column(iend) + + integer :: j1, j2, j3 + real(jprb) :: frac(iend) + integer :: expo(iend) + real(jprb) :: scaling(iend) + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:expm',0,hook_handle) + + normA = 0.0_jprb + + ! Compute the 1-norms of A + do j3 = 1,m + sum_column(:) = 0.0_jprb + do j2 = 1,m + do j1 = 1,iend + sum_column(j1) = sum_column(j1) + abs(A(j1,j2,j3)) + end do + end do + do j1 = 1,iend + if (sum_column(j1) > normA(j1)) then + normA(j1) = sum_column(j1) + end if + end do + end do + + frac = fraction(normA/theta(3)) + expo = exponent(normA/theta(3)) + where (frac == 0.5_jprb) + expo = expo - 1 + end where + + where (expo < 0) + expo = 0 + end where + + ! Scale the input matrices by a power of 2 + scaling = 2.0_jprb**(-expo) + do j3 = 1,m + do j2 = 1,m + A(1:iend,j2,j3) = A(1:iend,j2,j3) * scaling + end do + end do + ! Pade approximant of degree 7 + A2 = mat_x_mat(n,iend,m,A, A, i_matrix_pattern) + A4 = mat_x_mat(n,iend,m,A2,A2,i_matrix_pattern) + A6 = mat_x_mat(n,iend,m,A2,A4,i_matrix_pattern) + + V = c(8)*A6 + c(6)*A4 + c(4)*A2 + do j3 = 1,m + V(:,j3,j3) = V(:,j3,j3) + c(2) + end do + U = mat_x_mat(n,iend,m,A,V,i_matrix_pattern) + V = c(7)*A6 + c(5)*A4 + c(3)*A2 + ! Add a multiple of the identity matrix + do j3 = 1,m + V(:,j3,j3) = V(:,j3,j3) + c(1) + end do + + V = V-U + U = 2.0_jprb*U + A(1:iend,1:m,1:m) = solve_mat(n,iend,m,V,U) + + ! Add the identity matrix + do j3 = 1,m + A(1:iend,j3,j3) = A(1:iend,j3,j3) + 1.0_jprb + end do + + ! Loop through the matrices + do j1 = 1,iend + if (expo(j1) > 0) then + ! Square matrix j1 expo(j1) times + A(j1,:,:) = repeated_square(m,A(j1,:,:),expo(j1),i_matrix_pattern) + end if + end do + + if (lhook) call dr_hook('radiation_matrix:expm',1,hook_handle) + + end subroutine expm + + + !--------------------------------------------------------------------- + ! Return the matrix exponential of n 2x2 matrices representing + ! conservative exchange between SPARTACUS regions, where the + ! matrices have the structure + ! (-a b) + ! ( a -b) + ! and a and b are assumed to be positive or zero. The solution uses + ! Putzer's algorithm - see the appendix of Hogan et al. (GMD 2018) + subroutine fast_expm_exchange_2(n,iend,a,b,R) + + use yomhook, only : lhook, dr_hook, jphook + + integer, intent(in) :: n, iend + real(jprb), dimension(n), intent(in) :: a, b + real(jprb), dimension(n,2,2), intent(out) :: R + + real(jprb), dimension(iend) :: factor + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:fast_expm_exchange_2',0,hook_handle) + + ! Security to ensure that if a==b==0 then the identity matrix is returned + factor = (1.0_jprb - exp(-(a(1:iend)+b(1:iend))))/max(1.0e-12_jprb,a(1:iend)+b(1:iend)) + + R(1:iend,1,1) = 1.0_jprb - factor*a(1:iend) + R(1:iend,2,1) = factor*a(1:iend) + R(1:iend,1,2) = factor*b(1:iend) + R(1:iend,2,2) = 1.0_jprb - factor*b(1:iend) + + if (lhook) call dr_hook('radiation_matrix:fast_expm_exchange_2',1,hook_handle) + + end subroutine fast_expm_exchange_2 + + + !--------------------------------------------------------------------- + ! Return the matrix exponential of n 3x3 matrices representing + ! conservative exchange between SPARTACUS regions, where the + ! matrices have the structure + ! (-a b 0) + ! ( a -b-c d) + ! ( 0 c -d) + ! and a-d are assumed to be positive or zero. The solution uses the + ! diagonalization method and is a slight generalization of the + ! solution provided in the appendix of Hogan et al. (GMD 2018), + ! which assumed c==d. + subroutine fast_expm_exchange_3(n,iend,a,b,c,d,R) + + use yomhook, only : lhook, dr_hook, jphook + + real(jprb), parameter :: my_epsilon = 1.0e-12_jprb + + integer, intent(in) :: n, iend + real(jprb), dimension(n), intent(in) :: a, b, c, d + real(jprb), dimension(n,3,3), intent(out) :: R + + ! Eigenvectors + real(jprb), dimension(iend,3,3) :: V + + ! Non-zero Eigenvalues + real(jprb), dimension(iend) :: lambda1, lambda2 + + ! Diagonal matrix of the exponential of the eigenvalues + real(jprb), dimension(iend,3) :: diag + + ! Result of diag right-divided by V + real(jprb), dimension(iend,3,3) :: diag_rdivide_V + + ! Intermediate arrays + real(jprb), dimension(iend) :: tmp1, tmp2 + + integer :: j1, j2 + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_matrix:fast_expm_exchange_3',0,hook_handle) + + ! Eigenvalues lambda1 and lambda2 + tmp1 = 0.5_jprb * (a(1:iend)+b(1:iend)+c(1:iend)+d(1:iend)) + tmp2 = sqrt(max(0.0_jprb, tmp1*tmp1 - (a(1:iend)*c(1:iend) & + & + a(1:iend)*d(1:iend) + b(1:iend)*d(1:iend)))) + ! The eigenvalues must not be the same or the LU decomposition + ! fails; this can occur occasionally in single precision, which we + ! avoid by limiting the minimum value of tmp2 + tmp2 = max(tmp2, epsilon(1.0_jprb) * tmp1) + lambda1 = -tmp1 + tmp2 + lambda2 = -tmp1 - tmp2 + + ! Eigenvectors, with securities such that if a--d are all zero + ! then V is non-singular and the identity matrix is returned in R; + ! note that lambdaX is typically negative so we need a + ! sign-preserving security + V(1:iend,1,1) = max(my_epsilon, b(1:iend)) & + & / sign(max(my_epsilon, abs(a(1:iend) + lambda1)), a(1:iend) + lambda1) + V(1:iend,1,2) = b(1:iend) & + & / sign(max(my_epsilon, abs(a(1:iend) + lambda2)), a(1:iend) + lambda2) + V(1:iend,1,3) = b(1:iend) / max(my_epsilon, a(1:iend)) + V(1:iend,2,:) = 1.0_jprb + V(1:iend,3,1) = c(1:iend) & + & / sign(max(my_epsilon, abs(d(1:iend) + lambda1)), d(1:iend) + lambda1) + V(1:iend,3,2) = c(1:iend) & + & / sign(max(my_epsilon, abs(d(1:iend) + lambda2)), d(1:iend) + lambda2) + V(1:iend,3,3) = max(my_epsilon, c(1:iend)) / max(my_epsilon, d(1:iend)) + + diag(:,1) = exp(lambda1) + diag(:,2) = exp(lambda2) + diag(:,3) = 1.0_jprb + + ! Compute diag_rdivide_V = diag * V^-1 + call diag_mat_right_divide_3(iend,iend,V,diag,diag_rdivide_V) + + ! Compute V * diag_rdivide_V + do j1 = 1,3 + do j2 = 1,3 + R(1:iend,j2,j1) = V(1:iend,j2,1)*diag_rdivide_V(1:iend,1,j1) & + & + V(1:iend,j2,2)*diag_rdivide_V(1:iend,2,j1) & + & + V(1:iend,j2,3)*diag_rdivide_V(1:iend,3,j1) + end do + end do + + if (lhook) call dr_hook('radiation_matrix:fast_expm_exchange_3',1,hook_handle) + + end subroutine fast_expm_exchange_3 + +! generic :: fast_expm_exchange => fast_expm_exchange_2, fast_expm_exchange_3 + + +end module radiation_matrix Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_acc_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_acc_lw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_acc_lw.F90 (revision 6016) @@ -0,0 +1,579 @@ +! This file has been modified for the use in ICON + +! radiation_mcica_acc_lw.F90 - Monte-Carlo Independent Column Approximation longtwave solver +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive emission/albedo rather than planck/emissivity +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-07-12 R. Hogan Call fast adding method if only clouds scatter +! 2017-10-23 R. Hogan Renamed single-character variables + +#include "ecrad_config.h" + +module radiation_mcica_acc_lw + + public + +contains + + !--------------------------------------------------------------------- + ! Longwave Monte Carlo Independent Column Approximation + ! (McICA). This implementation performs a clear-sky and a cloudy-sky + ! calculation, and then weights the two to get the all-sky fluxes + ! according to the total cloud cover. This method reduces noise for + ! low cloud cover situations, and exploits the clear-sky + ! calculations that are usually performed for diagnostic purposes + ! simultaneously. The cloud generator has been carefully written + ! such that the stochastic cloud field satisfies the prescribed + ! overlap parameter accounting for this weighting. + subroutine solver_mcica_acc_lw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, planck_hl, & + & emission, albedo, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook + + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_cloud, only : cloud_type + use radiation_flux, only : flux_type + use radiation_two_stream, only : calc_ref_trans_lw, & + & calc_no_scattering_transmittance_lw + use radiation_adding_ica_lw, only : adding_ica_lw, fast_adding_ica_lw, & + & calc_fluxes_no_scattering_lw + use radiation_lw_derivatives, only : calc_lw_derivatives_ica, modify_lw_derivatives_ica + use radiation_cloud_generator_acc, only: cloud_generator_acc + use radiation_cloud_cover, only : beta2alpha, MaxCloudFrac + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, nlev, istartcol:iendcol) :: & + & od + real(jprb), intent(in), dimension(config%n_g_lw_if_scattering, nlev, istartcol:iendcol) :: & + & ssa, g + + ! Cloud and precipitation optical depth, single-scattering albedo and + ! asymmetry factor in each longwave band + real(jprb), intent(in), dimension(config%n_bands_lw,nlev,istartcol:iendcol) :: & + & od_cloud + real(jprb), intent(in), dimension(config%n_bands_lw_if_scattering, & + & nlev,istartcol:iendcol) :: ssa_cloud, g_cloud + + ! Planck function at each half-level and the surface + real(jprb), intent(in), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: & + & planck_hl + + ! Emission (Planck*emissivity) and albedo (1-emissivity) at the + ! surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, istartcol:iendcol) :: emission, albedo + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! Diffuse reflectance and transmittance for each layer in clear + ! and all skies + real(jprb), dimension(config%n_g_lw, nlev) :: ref_clear, trans_clear, reflectance, transmittance + + ! Emission by a layer into the upwelling or downwelling diffuse + ! streams, in clear and all skies + real(jprb), dimension(config%n_g_lw, nlev) :: source_up_clear, source_dn_clear, source_up, source_dn + + ! Fluxes per g point + real(jprb), dimension(config%n_g_lw, nlev+1, istartcol:iendcol) :: flux_up, flux_dn + real(jprb), dimension(config%n_g_lw, nlev+1, istartcol:iendcol) :: flux_up_clear, flux_dn_clear + + ! Combined gas+aerosol+cloud optical depth, single scattering + ! albedo and asymmetry factor + real(jprb), dimension(config%n_g_lw) :: od_total, ssa_total, g_total + + ! Combined scattering optical depth + real(jprb) :: scat_od, scat_od_total(config%n_g_lw) + + ! Optical depth scaling from the cloud generator, zero indicating + ! clear skies + real(jprb), dimension(config%n_g_lw,nlev) :: od_scaling + + ! Modified optical depth after McICA scaling to represent cloud + ! inhomogeneity + real(jprb), dimension(config%n_g_lw) :: od_cloud_new + + ! Total cloud cover output from the cloud generator + real(jprb) :: total_cloud_cover + + ! Identify clear-sky layers + logical :: is_clear_sky_layer(nlev, istartcol:iendcol) + + ! workaround that allows inling of cloud generator + real(jprb), dimension(config%pdf_sampler%ncdf, config%pdf_sampler%nfsd) :: sample_val + + ! temporary arrays to increase performance + real(jprb), dimension(nlev, istartcol:iendcol) :: frac, frac_std + real(jprb), dimension(nlev-1, istartcol:iendcol) :: overlap_param + + ! temporary arrays + real(jprb), dimension(nlev, istartcol:iendcol) :: cum_cloud_cover + real(jprb), dimension(nlev-1, istartcol:iendcol) :: pair_cloud_cover + + ! "Alpha" overlap parameter + real(jprb) :: overlap_alpha + + ! Cumulative product needed in computation of total_cloud_cover + real(jprb) :: cum_product(istartcol:iendcol) + + ! First and last cloudy layers + integer :: ibegin(istartcol:iendcol), iend(istartcol:iendcol) + + ! Temporary working array + real(jprb), dimension(config%n_g_lw,nlev+1) :: tmp_work_albedo, & + & tmp_work_source + real(jprb), dimension(config%n_g_lw,nlev) :: tmp_work_inv_denominator + ! Temporary storage for more efficient summation + real(jprb) :: sum_up, sum_dn, sum_up_clr, sum_dn_clr + + ! Index of the highest cloudy layer + integer :: i_cloud_top + + ! Number of g points + integer :: ng + + ! Loop indices for level, column and g point + integer :: jlev, jcol, jg + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_mcica_acc_lw:solver_mcica_acc_lw',0,hook_handle) + + if (.not. config%do_clear) then + write(nulerr,'(a)') '*** Error: longwave McICA ACC requires clear-sky calculation to be performed' + call radiation_abort() + end if + + ng = config%n_g_lw + + !$ACC DATA CREATE(flux_up, flux_dn, flux_up_clear, flux_dn_clear, & + !$ACC is_clear_sky_layer, & + !$ACC sample_val, frac, frac_std, overlap_param, cum_cloud_cover, & + !$ACC pair_cloud_cover, cum_product, ibegin, iend) & + !$ACC PRESENT(config, single_level, cloud, od, ssa, g, od_cloud, ssa_cloud, & + !$ACC g_cloud, planck_hl, emission, albedo, flux) + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jlev = 1,config%pdf_sampler%nfsd + do jcol = 1,config%pdf_sampler%ncdf + sample_val(jcol,jlev) = config%pdf_sampler%val(jcol,jlev) + end do + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jcol = istartcol,iendcol + do jlev = 1, nlev + frac(jlev, jcol) = cloud%fraction(jcol,jlev) + frac_std(jlev, jcol) = cloud%fractional_std(jcol,jlev) + is_clear_sky_layer(jlev,jcol) = .true. + end do + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jcol = istartcol,iendcol + do jlev = 1, nlev-1 + overlap_param(jlev, jcol) = cloud%overlap_param(jcol,jlev) + end do + end do + !$ACC END PARALLEL + + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(overlap_alpha) + do jcol = istartcol,iendcol + !--------------------------------------------------------------------- + ! manual inline from cum_cloud_cover_exp_ran >>>>>>>>>>>>>>>>>>>>>>>> + ! Loop to compute total cloud cover and the cumulative cloud cover + ! down to the base of each layer + do jlev = 1,nlev-1 + ! Convert to "alpha" overlap parameter if necessary + if (config%use_beta_overlap) then + overlap_alpha = beta2alpha(overlap_param(jlev,jcol), & + & frac(jlev,jcol), frac(jlev+1,jcol)) + else + overlap_alpha = overlap_param(jlev,jcol) + end if + + ! Compute the combined cloud cover of layers jlev and jlev+1 + pair_cloud_cover(jlev, jcol) = overlap_alpha*max(frac(jlev,jcol),frac(jlev+1,jcol)) & + & + (1.0_jprb - overlap_alpha) & + & * (frac(jlev,jcol)+frac(jlev+1,jcol)-frac(jlev,jcol)*frac(jlev+1,jcol)) + end do + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + do jcol = istartcol,iendcol + cum_cloud_cover(1, jcol) = frac(1,jcol) + cum_product(jcol) = 1.0_jprb - frac(1,jcol) + !$ACC LOOP SEQ + do jlev = 1,nlev-1 + if (frac(jlev,jcol) >= MaxCloudFrac) then + ! Cloud cover has reached one + cum_product(jcol) = 0.0_jprb + else + cum_product(jcol) = cum_product(jcol) * (1.0_jprb - pair_cloud_cover(jlev, jcol)) & + & / (1.0_jprb - frac(jlev,jcol)) + end if + cum_cloud_cover(jlev+1, jcol) = 1.0_jprb - cum_product(jcol) + end do + flux%cloud_cover_lw(jcol) = cum_cloud_cover(nlev,jcol); + if (flux%cloud_cover_lw(jcol) < config%cloud_fraction_threshold) then + ! Treat column as clear sky: calling function therefore will not + ! use od_scaling so we don't need to calculate it + flux%cloud_cover_lw(jcol) = 0.0_jprb + end if + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + do jcol = istartcol,iendcol + if (flux%cloud_cover_lw(jcol) >= config%cloud_fraction_threshold) then + ! Cloud is present: need to calculate od_scaling + ! Find range of cloudy layers + ibegin(jcol) = nlev + !$ACC LOOP SEQ + do jlev = 1, nlev + if( frac(jlev,jcol) > 0.0_jprb ) then + ibegin(jcol) = min(jlev, ibegin(jcol)) + end if + end do + + iend(jcol) = ibegin(jcol) + !$ACC LOOP SEQ + do jlev = ibegin(jcol)+1,nlev + if (frac(jlev,jcol) > 0.0_jprb) then + iend(jcol) = max(jlev, iend(jcol)) + end if + end do + end if + end do + !$ACC END PARALLEL + + + ! Loop through columns + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) & + !$ACC NUM_GANGS(iendcol-istartcol+1) NUM_WORKERS((config%n_g_lw-1)/32+1) VECTOR_LENGTH(32) + !$ACC LOOP GANG PRIVATE(g_total, i_cloud_top, od_cloud_new, od_scaling, od_total, ref_clear, & + !$ACC reflectance, tmp_work_inv_denominator, tmp_work_albedo, tmp_work_source, & + !$ACC scat_od_total, source_dn, source_dn_clear, source_up, source_up_clear, ssa_total, & + !$ACC trans_clear, transmittance) + do jcol = istartcol,iendcol + + ! Clear-sky calculation +#ifndef _OPENACC + if (config%do_lw_aerosol_scattering) then + ! Scattering case: first compute clear-sky reflectance, + ! transmittance etc at each model level + call calc_ref_trans_lw(ng*nlev, & + & od(:,:,jcol), ssa(:,:,jcol), g(:,:,jcol), & + & planck_hl(:,1:jlev,jcol), planck_hl(:,2:jlev+1,jcol), & + & ref_clear, trans_clear, & + & source_up_clear, source_dn_clear) + ! Then use adding method to compute fluxes + call adding_ica_lw(ng, nlev, & + & ref_clear, trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear(:,:,jcol), flux_dn_clear(:,:,jcol)) + else +#endif + ! Non-scattering case: use simpler functions for + ! transmission and emission + !$ACC LOOP SEQ + do jlev = 1,nlev + call calc_no_scattering_transmittance_lw(ng, od(:,jlev,jcol), & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & trans_clear(:,jlev), source_up_clear(:,jlev), & + & source_dn_clear(:,jlev)) + end do + ! Ensure that clear-sky reflectance is zero since it may be + ! used in cloudy-sky case + !$ACC LOOP SEQ + do jlev = 1,nlev + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + ref_clear(jg,jlev) = 0.0_jprb + end do + end do + ! Simpler down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear(:,:,jcol), flux_dn_clear(:,:,jcol)) +#ifndef _OPENACC + end if +#endif + + ! Store surface spectral downwelling fluxes + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + flux%lw_dn_surf_clear_g(jg,jcol) = flux_dn_clear(jg,nlev+1,jcol) + end do + + ! Do cloudy-sky calculation; add a prime number to the seed in + ! the longwave + call cloud_generator_acc(ng, nlev, & + & single_level%iseed(jcol) + 997, & + & config%cloud_fraction_threshold, & + & frac(:,jcol), overlap_param(:,jcol), & + & config%cloud_inhom_decorr_scaling, frac_std(:,jcol), & + & config%pdf_sampler%ncdf, config%pdf_sampler%nfsd, & + & config%pdf_sampler%fsd1, config%pdf_sampler%inv_fsd_interval, & + & sample_val, & + & od_scaling, flux%cloud_cover_lw(jcol)+0.0_jprb, & ! Workaround for nvhpc-24.1 + & ibegin(jcol), iend(jcol), & + & cum_cloud_cover=cum_cloud_cover(:,jcol), & + & pair_cloud_cover=pair_cloud_cover(:,jcol)) + + if (flux%cloud_cover_lw(jcol) >= config%cloud_fraction_threshold) then + ! Total-sky calculation + + i_cloud_top = nlev+1 + !$ACC LOOP SEQ + do jlev = 1,nlev + ! Compute combined gas+aerosol+cloud optical properties + if (frac(jlev,jcol) >= config%cloud_fraction_threshold) then + is_clear_sky_layer(jlev,jcol) = .false. + ! Get index to the first cloudy layer from the top + if (i_cloud_top > jlev) then + i_cloud_top = jlev + end if + + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + od_cloud_new(jg) = od_scaling(jg,jlev) & + & * od_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) + od_total(jg) = od(jg,jlev,jcol) + od_cloud_new(jg) + ssa_total(jg) = 0.0_jprb + g_total(jg) = 0.0_jprb + end do + + if (config%do_lw_cloud_scattering) then + ! Scattering case: calculate reflectance and + ! transmittance at each model level + +#ifndef _OPENACC + if (config%do_lw_aerosol_scattering) then + ! In single precision we need to protect against the + ! case that od_total > 0.0 and ssa_total > 0.0 but + ! od_total*ssa_total == 0 due to underflow + do jg = 1,ng + if (od_total(jg) > 0.0_jprb) then + scat_od_total(jg) = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg) + ssa_total(jg) = scat_od_total(jg) / od_total(jg) + + if (scat_od_total(jg) > 0.0_jprb) then + g_total(jg) = (g(jg,jlev,jcol)*ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg)) & + & / scat_od_total(jg) + end if + end if + end do + + else +#endif + + !$ACC LOOP WORKER VECTOR PRIVATE(scat_od) + do jg = 1,ng + if (od_total(jg) > 0.0_jprb) then + scat_od = ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg) + ssa_total(jg) = scat_od / od_total(jg) + if (scat_od > 0.0_jprb) then + g_total(jg) = g_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg) / scat_od + end if + end if + end do + +#ifndef _OPENACC + end if +#endif + + ! Compute cloudy-sky reflectance, transmittance etc at + ! each model level + call calc_ref_trans_lw(ng, & + & od_total, ssa_total, g_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & + & reflectance(:,jlev), transmittance(:,jlev), & + & source_up(:,jlev), source_dn(:,jlev)) + else + ! No-scattering case: use simpler functions for + ! transmission and emission + call calc_no_scattering_transmittance_lw(ng, od_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & transmittance(:,jlev), source_up(:,jlev), & + & source_dn(:,jlev)) + end if + + else + ! Clear-sky layer: copy over clear-sky values + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + reflectance(jg,jlev) = ref_clear(jg,jlev) + transmittance(jg,jlev) = trans_clear(jg,jlev) + source_up(jg,jlev) = source_up_clear(jg,jlev) + source_dn(jg,jlev) = source_dn_clear(jg,jlev) + end do + end if + end do + +#ifndef _OPENACC + if (config%do_lw_aerosol_scattering) then + ! Use adding method to compute fluxes for an overcast sky, + ! allowing for scattering in all layers + call adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up(:,:,jcol), flux_dn(:,:,jcol)) + else if (config%do_lw_cloud_scattering) then +#else + if(config%do_lw_cloud_scattering) then +#endif + ! Use adding method to compute fluxes but optimize for the + ! presence of clear-sky layers + call fast_adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & is_clear_sky_layer(:,jcol), i_cloud_top, flux_dn_clear(:,:,jcol), & + & flux_up(:,:,jcol), flux_dn(:,:,jcol), & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + else + ! Simpler down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & transmittance, source_up, source_dn, emission(:,jcol), albedo(:,jcol), & + & flux_up(:,:,jcol), flux_dn(:,:,jcol)) + end if + + ! Cloudy flux profiles currently assume completely overcast + ! skies; perform weighted average with clear-sky profile + ! Store surface spectral downwelling fluxes + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + flux%lw_dn_surf_g(jg,jcol) = flux%cloud_cover_lw(jcol)*flux_dn(jg,nlev+1,jcol) & + & + (1.0_jprb - flux%cloud_cover_lw(jcol))*flux%lw_dn_surf_clear_g(jg,jcol) + end do + + ! Compute the longwave derivatives needed by Hogan and Bozzo + ! (2015) approximate radiation update scheme +#ifndef _OPENACC + if (config%do_lw_derivatives) then + call calc_lw_derivatives_ica(ng, nlev, jcol, transmittance, flux_up(:,nlev+1,jcol), & + & flux%lw_derivatives) + if (flux%cloud_cover_lw(jcol) < 1.0_jprb - config%cloud_fraction_threshold) then + ! Modify the existing derivative with the contribution from the clear sky + call modify_lw_derivatives_ica(ng, nlev, jcol, trans_clear, flux_up_clear(:,nlev+1,jcol), & + & 1.0_jprb-flux%cloud_cover_lw(jcol), flux%lw_derivatives) + end if + end if +#endif + + else + ! No cloud in profile and clear-sky fluxes already + ! calculated: copy them over + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + flux%lw_dn_surf_g(jg,jcol) = flux%lw_dn_surf_clear_g(jg,jcol) + end do +#ifndef _OPENACC + if (config%do_lw_derivatives) then + call calc_lw_derivatives_ica(ng, nlev, jcol, trans_clear, flux_up_clear(:,nlev+1,jcol), & + & flux%lw_derivatives) + + end if +#endif + end if ! Cloud is present in profile + end do + !$ACC END PARALLEL + + ! Loop through columns + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) & + !$ACC NUM_GANGS((iendcol-istartcol+1)*(nlev+1)) NUM_WORKERS(1) VECTOR_LENGTH(32*((config%n_g_lw-1)/32+1)) + !$ACC LOOP GANG COLLAPSE(2) PRIVATE(total_cloud_cover, sum_up, sum_dn, sum_up_clr, sum_dn_clr) + do jcol = istartcol,iendcol + do jlev = 1,nlev+1 + + sum_up_clr = 0._jprb + sum_dn_clr = 0._jprb + !$ACC LOOP VECTOR REDUCTION(+:sum_up_clr, sum_dn_clr) + do jg = 1,ng + sum_up_clr = sum_up_clr + flux_up_clear(jg,jlev,jcol) + sum_dn_clr = sum_dn_clr + flux_dn_clear(jg,jlev,jcol) + end do + flux%lw_up_clear(jcol,jlev) = sum_up_clr + flux%lw_dn_clear(jcol,jlev) = sum_dn_clr + + total_cloud_cover = flux%cloud_cover_lw(jcol) + if (total_cloud_cover >= config%cloud_fraction_threshold) then + + ! Store overcast broadband fluxes + sum_up = 0._jprb + sum_dn = 0._jprb + !$ACC LOOP VECTOR REDUCTION(+:sum_up, sum_dn) + do jg = 1,ng + sum_up = sum_up + flux_up(jg,jlev,jcol) + sum_dn = sum_dn + flux_dn(jg,jlev,jcol) + end do + flux%lw_up(jcol,jlev) = total_cloud_cover*sum_up + (1.0_jprb - total_cloud_cover)*sum_up_clr + flux%lw_dn(jcol,jlev) = total_cloud_cover*sum_dn + (1.0_jprb - total_cloud_cover)*sum_dn_clr + + else + + flux%lw_up(jcol,jlev) = sum_up_clr + flux%lw_dn(jcol,jlev) = sum_dn_clr + + end if + end do + end do + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + + if (lhook) call dr_hook('radiation_mcica_acc_lw:solver_mcica_acc_lw',1,hook_handle) + + end subroutine solver_mcica_acc_lw + +end module radiation_mcica_acc_lw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_acc_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_acc_sw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_acc_sw.F90 (revision 6016) @@ -0,0 +1,578 @@ +! This file has been modified for the use in ICON + +! radiation_mcica_acc_sw.F90 - Monte-Carlo Independent Column Approximation shortwave solver +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive albedos at g-points +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-10-23 R. Hogan Renamed single-character variables + +#include "ecrad_config.h" + +module radiation_mcica_acc_sw + + public + +contains + + ! Provides elemental function "delta_eddington" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Shortwave Monte Carlo Independent Column Approximation + ! (McICA). This implementation performs a clear-sky and a cloudy-sky + ! calculation, and then weights the two to get the all-sky fluxes + ! according to the total cloud cover. This method reduces noise for + ! low cloud cover situations, and exploits the clear-sky + ! calculations that are usually performed for diagnostic purposes + ! simultaneously. The cloud generator has been carefully written + ! such that the stochastic cloud field satisfies the prescribed + ! overlap parameter accounting for this weighting. + subroutine solver_mcica_acc_sw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, & + & albedo_direct, albedo_diffuse, incoming_sw, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook + + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_cloud, only : cloud_type + use radiation_flux, only : flux_type + use radiation_two_stream, only : calc_ref_trans_sw + use radiation_adding_ica_sw, only : adding_ica_sw + use radiation_cloud_generator_acc, only: cloud_generator_acc + use radiation_cloud_cover, only : beta2alpha, MaxCloudFrac + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each shortwave g-point + real(jprb), intent(in), dimension(config%n_g_sw, nlev, istartcol:iendcol) :: & + & od, ssa, g + + ! Cloud and precipitation optical depth, single-scattering albedo and + ! asymmetry factor in each shortwave band + real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: & + & od_cloud, ssa_cloud, g_cloud + + ! Direct and diffuse surface albedos, and the incoming shortwave + ! flux into a plane perpendicular to the incoming radiation at + ! top-of-atmosphere in each of the shortwave g points + real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) :: & + & albedo_direct, albedo_diffuse, incoming_sw + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! Cosine of solar zenith angle + real(jprb) :: cos_sza + + ! Diffuse reflectance and transmittance for each layer in clear + ! and all skies + real(jprb), dimension(config%n_g_sw, nlev) :: ref_clear, trans_clear, reflectance, transmittance + + ! Fraction of direct beam scattered by a layer into the upwelling + ! or downwelling diffuse streams, in clear and all skies + real(jprb), dimension(config%n_g_sw, nlev) :: ref_dir_clear, trans_dir_diff_clear, ref_dir, trans_dir_diff + + ! Transmittance for the direct beam in clear and all skies + real(jprb), dimension(config%n_g_sw, nlev) :: trans_dir_dir_clear, trans_dir_dir + + ! Fluxes per g point + real(jprb), dimension(config%n_g_sw, nlev+1, istartcol:iendcol) :: flux_up, flux_dn_diffuse, flux_dn_direct + real(jprb), dimension(config%n_g_sw, nlev+1, istartcol:iendcol) :: flux_up_clear, flux_dn_diffuse_clear, flux_dn_direct_clear + + ! Combined gas+aerosol+cloud optical depth, single scattering + ! albedo and asymmetry factor + real(jprb), dimension(config%n_g_sw) :: od_total, ssa_total, g_total + + ! Combined scattering optical depth + real(jprb) :: scat_od + + ! Optical depth scaling from the cloud generator, zero indicating + ! clear skies + real(jprb), dimension(config%n_g_sw,nlev) :: od_scaling + + ! Modified optical depth after McICA scaling to represent cloud + ! inhomogeneity + real(jprb), dimension(config%n_g_sw) :: od_cloud_new + + ! workaround that allows inling of cloud generator + real(jprb), dimension(config%pdf_sampler%ncdf, config%pdf_sampler%nfsd) :: sample_val + + ! copies to increase performance + real(jprb), dimension(nlev, istartcol:iendcol) :: frac, frac_std + real(jprb), dimension(nlev-1, istartcol:iendcol) :: overlap_param + + real(jprb), dimension(nlev, istartcol:iendcol) :: cum_cloud_cover + real(jprb), dimension(nlev-1, istartcol:iendcol) :: pair_cloud_cover + + ! "Alpha" overlap parameter + real(jprb) :: overlap_alpha + + ! Cumulative product needed in computation of total_cloud_cover + real(jprb) :: cum_product(istartcol:iendcol) + + ! First and last cloudy layers + integer :: ibegin(istartcol:iendcol), iend(istartcol:iendcol) + + ! Temporary working array + real(jprb), dimension(config%n_g_sw,nlev+1) :: tmp_work_albedo, & + & tmp_work_source + real(jprb), dimension(config%n_g_sw,nlev) :: tmp_work_inv_denominator + + ! Auxiliary for more efficient summation + real(jprb) :: sum_up, sum_dn_direct, sum_dn_diffuse + + ! Number of g points + integer :: ng + + ! Loop indices for level, column and g point + integer :: jlev, jcol, jg + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_mcica_acc_sw:solver_mcica_acc_sw',0,hook_handle) + + if (.not. config%do_clear) then + write(nulerr,'(a)') '*** Error: shortwave McICA ACC requires clear-sky calculation to be performed' + call radiation_abort() + end if + + !$ACC DATA CREATE(flux_up, flux_dn_diffuse, flux_dn_direct, & + !$ACC flux_up_clear, flux_dn_diffuse_clear, flux_dn_direct_clear, & + !$ACC sample_val, frac, frac_std, overlap_param, & + !$ACC cum_cloud_cover, pair_cloud_cover, cum_product, ibegin, iend) & + !$ACC PRESENT(config, single_level, cloud, od, ssa, g, od_cloud, & + !$ACC ssa_cloud, g_cloud, albedo_direct, albedo_diffuse, & + !$ACC incoming_sw, flux) + + ng = config%n_g_sw + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jlev = 1,config%pdf_sampler%nfsd + do jcol = 1,config%pdf_sampler%ncdf + sample_val(jcol,jlev) = config%pdf_sampler%val(jcol,jlev) + end do + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jcol = istartcol,iendcol + do jlev = 1, nlev + frac(jlev, jcol) = cloud%fraction(jcol,jlev) + frac_std(jlev, jcol) = cloud%fractional_std(jcol,jlev) + end do + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jcol = istartcol,iendcol + do jlev = 1, nlev-1 + overlap_param(jlev, jcol) = cloud%overlap_param(jcol,jlev) + end do + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(overlap_alpha) + do jcol = istartcol,iendcol + !Only perform calculation if sun above the horizon + !--------------------------------------------------------------------- + ! manual inline from cum_cloud_cover_exp_ran >>>>>>>>>>>>>>>>>>>>>>>> + ! Loop to compute total cloud cover and the cumulative cloud cover + ! down to the base of each layer + do jlev = 1,nlev-1 + if (single_level%cos_sza(jcol) > 0.0_jprb ) then + ! Convert to "alpha" overlap parameter if necessary + if (config%use_beta_overlap) then + overlap_alpha = beta2alpha(overlap_param(jlev,jcol), & + & frac(jlev,jcol), frac(jlev+1,jcol)) + else + overlap_alpha = overlap_param(jlev,jcol) + end if + ! Compute the combined cloud cover of layers jlev and jlev+1 + pair_cloud_cover(jlev, jcol) = overlap_alpha*max(frac(jlev,jcol),frac(jlev+1,jcol)) & + & + (1.0_jprb - overlap_alpha) & + & * (frac(jlev,jcol)+frac(jlev+1,jcol)-frac(jlev,jcol)*frac(jlev+1,jcol)) + end if + end do + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + do jcol = istartcol,iendcol + !Only perform calculation if sun above the horizon + if (single_level%cos_sza(jcol) > 0.0_jprb ) then + cum_cloud_cover(1, jcol) = frac(1,jcol) + cum_product(jcol) = 1.0_jprb - frac(1,jcol) + !$ACC LOOP SEQ + do jlev = 1,nlev-1 + if (frac(jlev,jcol) >= MaxCloudFrac) then + ! Cloud cover has reached one + cum_product(jcol) = 0.0_jprb + else + cum_product(jcol) = cum_product(jcol) * (1.0_jprb - pair_cloud_cover(jlev, jcol)) & + & / (1.0_jprb - frac(jlev,jcol)) + end if + cum_cloud_cover(jlev+1, jcol) = 1.0_jprb - cum_product(jcol) + end do + flux%cloud_cover_sw(jcol) = cum_cloud_cover(nlev,jcol); + if (flux%cloud_cover_sw(jcol) < config%cloud_fraction_threshold) then + ! Treat column as clear sky: calling function therefore will not + ! use od_scaling so we don't need to calculate it + flux%cloud_cover_sw(jcol) = 0.0_jprb + end if + end if + end do + !$ACC END PARALLEL + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR + do jcol = istartcol,iendcol + !Only perform calculation if sun above the horizon + if (single_level%cos_sza(jcol) > 0.0_jprb .and. flux%cloud_cover_sw(jcol) >= config%cloud_fraction_threshold) then + ! Cloud is present: need to calculate od_scaling + ! Find range of cloudy layers + ibegin(jcol) = nlev + !$ACC LOOP SEQ + do jlev = 1, nlev + if( frac(jlev,jcol) > 0.0_jprb ) then + ibegin(jcol) = min(jlev, ibegin(jcol)) + end if + end do + + iend(jcol) = ibegin(jcol) + !$ACC LOOP SEQ + do jlev = ibegin(jcol)+1,nlev + if (frac(jlev,jcol) > 0.0_jprb) then + iend(jcol) = max(jlev, iend(jcol)) + end if + end do + end if + end do + !$ACC END PARALLEL + + ! Loop through columns + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) & + !$ACC NUM_GANGS(iendcol-istartcol+1) NUM_WORKERS((config%n_g_sw-1)/32+1) VECTOR_LENGTH(32) + !$ACC LOOP GANG PRIVATE(cos_sza, g_total, od_cloud_new, od_scaling, od_total, ref_clear, & + !$ACC ref_dir, ref_dir_clear, reflectance, ssa_total, tmp_work_inv_denominator, tmp_work_albedo, & + !$ACC tmp_work_source, trans_clear, trans_dir_diff, trans_dir_diff_clear, & + !$ACC trans_dir_dir, trans_dir_dir_clear, transmittance) + do jcol = istartcol,iendcol + ! Only perform calculation if sun above the horizon + if (single_level%cos_sza(jcol) > 0.0_jprb) then + cos_sza = single_level%cos_sza(jcol) + +#ifndef _OPENACC + ! Clear-sky calculation - first compute clear-sky reflectance, + ! transmittance etc at each model level + if (.not. config%do_sw_delta_scaling_with_gases) then +#endif + ! Delta-Eddington scaling has already been performed to the + ! aerosol part of od, ssa and g + call calc_ref_trans_sw(ng*nlev, & + & cos_sza, od(:,:,jcol), ssa(:,:,jcol), g(:,:,jcol), & + & ref_clear, trans_clear, & + & ref_dir_clear, trans_dir_diff_clear, & + & trans_dir_dir_clear) +#ifndef _OPENACC + else + ! Apply delta-Eddington scaling to the aerosol-gas mixture + do jlev = 1,nlev + od_total = od(:,jlev,jcol) + ssa_total = ssa(:,jlev,jcol) + g_total = g(:,jlev,jcol) + call delta_eddington(od_total, ssa_total, g_total) + call calc_ref_trans_sw(ng, & + & cos_sza, od_total, ssa_total, g_total, & + & ref_clear(:,jlev), trans_clear(:,jlev), & + & ref_dir_clear(:,jlev), trans_dir_diff_clear(:,jlev), & + & trans_dir_dir_clear(:,jlev) ) + end do + end if +#endif + + ! Use adding method to compute fluxes + call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), & + & albedo_diffuse(:,jcol), albedo_direct(:,jcol), cos_sza, & + & ref_clear, trans_clear, ref_dir_clear, trans_dir_diff_clear, & + & trans_dir_dir_clear, flux_up(:,:,jcol), flux_dn_diffuse(:,:,jcol), flux_dn_direct(:,:,jcol), & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + + ! save temporarily clear-sky broadband fluxes + !$ACC LOOP SEQ + do jlev = 1,nlev+1 + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + flux_up_clear(jg,jlev,jcol) = flux_up(jg,jlev,jcol) + flux_dn_direct_clear(jg,jlev,jcol) = flux_dn_direct(jg,jlev,jcol) + flux_dn_diffuse_clear(jg,jlev,jcol) = flux_dn_diffuse(jg,jlev,jcol) + end do + end do + + ! Store spectral downwelling fluxes at surface + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + flux%sw_dn_diffuse_surf_clear_g(jg,jcol) = flux_dn_diffuse(jg,nlev+1,jcol) + flux%sw_dn_direct_surf_clear_g(jg,jcol) = flux_dn_direct(jg,nlev+1,jcol) + end do + + ! Do cloudy-sky calculation + call cloud_generator_acc(ng, nlev, & + & single_level%iseed(jcol) + 0, & ! Workaround for nvhpc-24.1 + & config%cloud_fraction_threshold, & + & frac(:,jcol), overlap_param(:,jcol), & + & config%cloud_inhom_decorr_scaling, frac_std(:,jcol), & + & config%pdf_sampler%ncdf, config%pdf_sampler%nfsd, & + & config%pdf_sampler%fsd1, config%pdf_sampler%inv_fsd_interval, & + & sample_val, & + & od_scaling, flux%cloud_cover_sw(jcol)+0.0_jprb, & ! Workaround for nvhpc-24.1 + & ibegin(jcol), iend(jcol), & + & cum_cloud_cover=cum_cloud_cover(:,jcol), & + & pair_cloud_cover=pair_cloud_cover(:,jcol)) + + if (flux%cloud_cover_sw(jcol) >= config%cloud_fraction_threshold) then + ! Total-sky calculation + !$ACC LOOP SEQ + do jlev = 1,nlev + ! Compute combined gas+aerosol+cloud optical properties + if (frac(jlev,jcol) >= config%cloud_fraction_threshold) then + !$ACC LOOP WORKER VECTOR PRIVATE(scat_od) + do jg = 1,ng + od_cloud_new(jg) = od_scaling(jg,jlev) & + & * od_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) + od_total(jg) = od(jg,jlev,jcol) + od_cloud_new(jg) + ssa_total(jg) = 0.0_jprb + g_total(jg) = 0.0_jprb + + ! In single precision we need to protect against the + ! case that od_total > 0.0 and ssa_total > 0.0 but + ! od_total*ssa_total == 0 due to underflow + if (od_total(jg) > 0.0_jprb) then + scat_od = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) & + & * od_cloud_new(jg) + ssa_total(jg) = scat_od / od_total(jg) + if (scat_od > 0.0_jprb) then + g_total(jg) = (g(jg,jlev,jcol)*ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) & + & * od_cloud_new(jg)) & + & / scat_od + end if + end if + end do + +#ifndef _OPENACC + ! Apply delta-Eddington scaling to the cloud-aerosol-gas + ! mixture + if (config%do_sw_delta_scaling_with_gases) then + call delta_eddington(od_total, ssa_total, g_total) + end if +#endif + + ! Compute cloudy-sky reflectance, transmittance etc at + ! each model level + call calc_ref_trans_sw(ng, & + & cos_sza, od_total, ssa_total, g_total, & + & reflectance(:,jlev), transmittance(:,jlev), & + & ref_dir(:,jlev), trans_dir_diff(:,jlev), & + & trans_dir_dir(:,jlev)) + + else + ! Clear-sky layer: copy over clear-sky values + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + reflectance(jg,jlev) = ref_clear(jg,jlev) + transmittance(jg,jlev) = trans_clear(jg,jlev) + ref_dir(jg,jlev) = ref_dir_clear(jg,jlev) + trans_dir_diff(jg,jlev) = trans_dir_diff_clear(jg,jlev) + trans_dir_dir(jg,jlev) = trans_dir_dir_clear(jg,jlev) + end do + end if + end do + + ! Use adding method to compute fluxes for an overcast sky + call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), & + & albedo_diffuse(:,jcol), albedo_direct(:,jcol), cos_sza, & + & reflectance, transmittance, ref_dir, trans_dir_diff, & + & trans_dir_dir, flux_up(:,:,jcol), flux_dn_diffuse(:,:,jcol), flux_dn_direct(:,:,jcol), & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + + ! Likewise for surface spectral fluxes + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + flux%sw_dn_diffuse_surf_g(jg,jcol) = flux_dn_diffuse(jg,nlev+1,jcol) + flux%sw_dn_direct_surf_g(jg,jcol) = flux_dn_direct(jg,nlev+1,jcol) + flux%sw_dn_diffuse_surf_g(jg,jcol) = flux%cloud_cover_sw(jcol) *flux%sw_dn_diffuse_surf_g(jg,jcol) & + & + (1.0_jprb - flux%cloud_cover_sw(jcol))*flux%sw_dn_diffuse_surf_clear_g(jg,jcol) + flux%sw_dn_direct_surf_g(jg,jcol) = flux%cloud_cover_sw(jcol) *flux%sw_dn_direct_surf_g(jg,jcol) & + & + (1.0_jprb - flux%cloud_cover_sw(jcol))*flux%sw_dn_direct_surf_clear_g(jg,jcol) + end do + + else + ! No cloud in profile and clear-sky fluxes already + ! calculated: copy them over + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + flux%sw_dn_diffuse_surf_g(jg,jcol) = flux%sw_dn_diffuse_surf_clear_g(jg,jcol) + flux%sw_dn_direct_surf_g(jg,jcol) = flux%sw_dn_direct_surf_clear_g(jg,jcol) + end do + + end if ! Cloud is present in profile + else + !$ACC LOOP WORKER VECTOR + do jg = 1,ng + flux%sw_dn_diffuse_surf_g(jg,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_g(jg,jcol) = 0.0_jprb + flux%sw_dn_diffuse_surf_clear_g(jg,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_clear_g(jg,jcol) = 0.0_jprb + end do + + end if ! Sun above horizon + + end do ! Loop over columns + !$ACC END PARALLEL + + ! Loop through columns + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) PRIVATE(sum_dn_diffuse, sum_dn_direct, sum_up) & + !$ACC NUM_GANGS((iendcol-istartcol+1)*(nlev+1)) NUM_WORKERS(1) VECTOR_LENGTH(32*((config%n_g_sw-1)/32+1)) + !$ACC LOOP GANG COLLAPSE(2) PRIVATE(cos_sza) + do jcol = istartcol,iendcol + do jlev = 1, nlev+1 + + ! Only perform calculation if sun above the horizon + if (single_level%cos_sza(jcol) > 0.0_jprb) then + cos_sza = single_level%cos_sza(jcol) + + ! Sum over g-points to compute and save clear-sky broadband + ! fluxes + sum_up = 0.0_jprb + sum_dn_direct = 0.0_jprb + sum_dn_diffuse = 0.0_jprb + !$ACC LOOP VECTOR REDUCTION(+:sum_dn_diffuse, sum_dn_direct, sum_up) + do jg = 1,ng + sum_up = sum_up + flux_up_clear(jg,jlev,jcol) + sum_dn_direct = sum_dn_direct + flux_dn_direct_clear(jg,jlev,jcol) + sum_dn_diffuse = sum_dn_diffuse + flux_dn_diffuse_clear(jg,jlev,jcol) + end do + flux%sw_up_clear(jcol,jlev) = sum_up + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,jlev) = sum_dn_direct + end if + flux%sw_dn_clear(jcol,jlev) = sum_dn_diffuse + sum_dn_direct + + if (flux%cloud_cover_sw(jcol) >= config%cloud_fraction_threshold) then + ! Store overcast broadband fluxes + sum_up = 0.0_jprb + sum_dn_direct = 0.0_jprb + sum_dn_diffuse = 0.0_jprb + !$ACC LOOP VECTOR REDUCTION(+:sum_dn_diffuse, sum_dn_direct, sum_up) + do jg = 1,ng + sum_up = sum_up + flux_up(jg,jlev,jcol) + sum_dn_direct = sum_dn_direct + flux_dn_direct(jg,jlev,jcol) + sum_dn_diffuse = sum_dn_diffuse + flux_dn_diffuse(jg,jlev,jcol) + end do + flux%sw_up(jcol,jlev) = sum_up + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,jlev) = sum_dn_direct + end if + flux%sw_dn(jcol,jlev) = sum_dn_diffuse + sum_dn_direct + + end if + end if ! Sun above horizon + end do ! Loop over columns + end do + !$ACC END PARALLEL + + ! Loop through columns + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(cos_sza) + do jlev = 1, nlev+1 + do jcol = istartcol,iendcol + ! Only perform calculation if sun above the horizon + if (single_level%cos_sza(jcol) > 0.0_jprb) then + cos_sza = single_level%cos_sza(jcol) + + if (flux%cloud_cover_sw(jcol) >= config%cloud_fraction_threshold) then + ! Cloudy flux profiles currently assume completely overcast + ! skies; perform weighted average with clear-sky profile + flux%sw_up(jcol,jlev) = flux%cloud_cover_sw(jcol) *flux%sw_up(jcol,jlev) & + & + (1.0_jprb - flux%cloud_cover_sw(jcol))*flux%sw_up_clear(jcol,jlev) + flux%sw_dn(jcol,jlev) = flux%cloud_cover_sw(jcol) *flux%sw_dn(jcol,jlev) & + & + (1.0_jprb - flux%cloud_cover_sw(jcol))*flux%sw_dn_clear(jcol,jlev) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,jlev) = flux%cloud_cover_sw(jcol) *flux%sw_dn_direct(jcol,jlev) & + & + (1.0_jprb - flux%cloud_cover_sw(jcol))*flux%sw_dn_direct_clear(jcol,jlev) + end if + + else + ! No cloud in profile and clear-sky fluxes already + ! calculated: copy them over + flux%sw_up(jcol,jlev) = flux%sw_up_clear(jcol,jlev) + flux%sw_dn(jcol,jlev) = flux%sw_dn_clear(jcol,jlev) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,jlev) = flux%sw_dn_direct_clear(jcol,jlev) + end if + + end if ! Cloud is present in profile + else + ! Set fluxes to zero if sun is below the horizon + flux%sw_up(jcol,jlev) = 0.0_jprb + flux%sw_dn(jcol,jlev) = 0.0_jprb + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,jlev) = 0.0_jprb + end if + flux%sw_up_clear(jcol,jlev) = 0.0_jprb + flux%sw_dn_clear(jcol,jlev) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,jlev) = 0.0_jprb + end if + end if ! Sun above horizon + end do ! Loop over columns + end do ! Loop over levels + !$ACC END PARALLEL + + !$ACC WAIT + !$ACC END DATA + + if (lhook) call dr_hook('radiation_mcica_acc_sw:solver_mcica_acc_sw',1,hook_handle) + + end subroutine solver_mcica_acc_sw + +end module radiation_mcica_acc_sw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_lw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_lw.F90 (revision 6016) @@ -0,0 +1,363 @@ +! This file has been modified for the use in ICON + +! radiation_mcica_lw.F90 - Monte-Carlo Independent Column Approximation longtwave solver +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive emission/albedo rather than planck/emissivity +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-07-12 R. Hogan Call fast adding method if only clouds scatter +! 2017-10-23 R. Hogan Renamed single-character variables + +module radiation_mcica_lw + + public + +contains + + !--------------------------------------------------------------------- + ! Longwave Monte Carlo Independent Column Approximation + ! (McICA). This implementation performs a clear-sky and a cloudy-sky + ! calculation, and then weights the two to get the all-sky fluxes + ! according to the total cloud cover. This method reduces noise for + ! low cloud cover situations, and exploits the clear-sky + ! calculations that are usually performed for diagnostic purposes + ! simultaneously. The cloud generator has been carefully written + ! such that the stochastic cloud field satisfies the prescribed + ! overlap parameter accounting for this weighting. + subroutine solver_mcica_lw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, planck_hl, & + & emission, albedo, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_cloud, only : cloud_type + use radiation_flux, only : flux_type + use radiation_two_stream, only : calc_ref_trans_lw, & + & calc_no_scattering_transmittance_lw + use radiation_adding_ica_lw, only : adding_ica_lw, fast_adding_ica_lw, & + & calc_fluxes_no_scattering_lw + use radiation_lw_derivatives, only : calc_lw_derivatives_ica, modify_lw_derivatives_ica + use radiation_cloud_generator, only: cloud_generator + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, nlev, istartcol:iendcol) :: & + & od + real(jprb), intent(in), dimension(config%n_g_lw_if_scattering, nlev, istartcol:iendcol) :: & + & ssa, g + + ! Cloud and precipitation optical depth, single-scattering albedo and + ! asymmetry factor in each longwave band + real(jprb), intent(in), dimension(config%n_bands_lw,nlev,istartcol:iendcol) :: & + & od_cloud + real(jprb), intent(in), dimension(config%n_bands_lw_if_scattering, & + & nlev,istartcol:iendcol) :: ssa_cloud, g_cloud + + ! Planck function at each half-level and the surface + real(jprb), intent(in), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: & + & planck_hl + + ! Emission (Planck*emissivity) and albedo (1-emissivity) at the + ! surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, istartcol:iendcol) :: emission, albedo + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! Diffuse reflectance and transmittance for each layer in clear + ! and all skies + real(jprb), dimension(config%n_g_lw, nlev) :: ref_clear, trans_clear, reflectance, transmittance + + ! Emission by a layer into the upwelling or downwelling diffuse + ! streams, in clear and all skies + real(jprb), dimension(config%n_g_lw, nlev) :: source_up_clear, source_dn_clear, source_up, source_dn + + ! Fluxes per g point + real(jprb), dimension(config%n_g_lw, nlev+1) :: flux_up, flux_dn + real(jprb), dimension(config%n_g_lw, nlev+1) :: flux_up_clear, flux_dn_clear + + ! Combined gas+aerosol+cloud optical depth, single scattering + ! albedo and asymmetry factor + real(jprb), dimension(config%n_g_lw) :: od_total, ssa_total, g_total + + ! Combined scattering optical depth + real(jprb) :: scat_od, scat_od_total(config%n_g_lw) + + ! Optical depth scaling from the cloud generator, zero indicating + ! clear skies + real(jprb), dimension(config%n_g_lw,nlev) :: od_scaling + + ! Modified optical depth after McICA scaling to represent cloud + ! inhomogeneity + real(jprb), dimension(config%n_g_lw) :: od_cloud_new + + ! Total cloud cover output from the cloud generator + real(jprb) :: total_cloud_cover + + ! Identify clear-sky layers + logical :: is_clear_sky_layer(nlev) + + ! Temporary working array + real(jprb), dimension(config%n_g_lw,nlev+1) :: tmp_work_albedo, & + & tmp_work_source + real(jprb), dimension(config%n_g_lw,nlev) :: tmp_work_inv_denominator + + + ! Index of the highest cloudy layer + integer :: i_cloud_top + + ! Number of g points + integer :: ng + + ! Loop indices for level, column and g point + integer :: jlev, jcol, jg + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_mcica_lw:solver_mcica_lw',0,hook_handle) + + if (.not. config%do_clear) then + write(nulerr,'(a)') '*** Error: longwave McICA requires clear-sky calculation to be performed' + call radiation_abort() + end if + + ng = config%n_g_lw + + ! Loop through columns + do jcol = istartcol,iendcol + + ! Clear-sky calculation + if (config%do_lw_aerosol_scattering) then + ! Scattering case: first compute clear-sky reflectance, + ! transmittance etc at each model level + call calc_ref_trans_lw(ng*nlev, & + & od(:,:,jcol), ssa(:,:,jcol), g(:,:,jcol), & + & planck_hl(:,1:nlev,jcol), planck_hl(:,2:nlev+1,jcol), & + & ref_clear, trans_clear, & + & source_up_clear, source_dn_clear) + ! Then use adding method to compute fluxes + call adding_ica_lw(ng, nlev, & + & ref_clear, trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear, flux_dn_clear) + else + ! Non-scattering case: use simpler functions for + ! transmission and emission + call calc_no_scattering_transmittance_lw(ng*nlev, od(:,:,jcol), & + & planck_hl(:,1:nlev,jcol), planck_hl(:,2:nlev+1, jcol), & + & trans_clear, source_up_clear, source_dn_clear) + ! Ensure that clear-sky reflectance is zero since it may be + ! used in cloudy-sky case + ref_clear = 0.0_jprb + ! Simpler down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear, flux_dn_clear) + end if + + ! Sum over g-points to compute broadband fluxes + flux%lw_up_clear(jcol,:) = sum(flux_up_clear,1) + flux%lw_dn_clear(jcol,:) = sum(flux_dn_clear,1) + ! Store surface spectral downwelling fluxes + flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear(:,nlev+1) + + ! Do cloudy-sky calculation; add a prime number to the seed in + ! the longwave + call cloud_generator(ng, nlev, config%i_overlap_scheme, & + & single_level%iseed(jcol) + 997, & + & config%cloud_fraction_threshold, & + & cloud%fraction(jcol,:), cloud%overlap_param(jcol,:), & + & config%cloud_inhom_decorr_scaling, cloud%fractional_std(jcol,:), & + & config%pdf_sampler, od_scaling, total_cloud_cover, & + & use_beta_overlap=config%use_beta_overlap, & + & use_vectorizable_generator=config%use_vectorizable_generator) + + ! Store total cloud cover + flux%cloud_cover_lw(jcol) = total_cloud_cover + + if (total_cloud_cover >= config%cloud_fraction_threshold) then + ! Total-sky calculation + + is_clear_sky_layer = .true. + i_cloud_top = nlev+1 + do jlev = 1,nlev + ! Compute combined gas+aerosol+cloud optical properties + if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then + is_clear_sky_layer(jlev) = .false. + ! Get index to the first cloudy layer from the top + if (i_cloud_top > jlev) then + i_cloud_top = jlev + end if + + do jg = 1,ng + od_cloud_new(jg) = od_scaling(jg,jlev) & + & * od_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) + od_total(jg) = od(jg,jlev,jcol) + od_cloud_new(jg) + ssa_total(jg) = 0.0_jprb + g_total(jg) = 0.0_jprb + end do + + if (config%do_lw_cloud_scattering) then + ! Scattering case: calculate reflectance and + ! transmittance at each model level + + if (config%do_lw_aerosol_scattering) then + ! In single precision we need to protect against the + ! case that od_total > 0.0 and ssa_total > 0.0 but + ! od_total*ssa_total == 0 due to underflow + do jg = 1,ng + if (od_total(jg) > 0.0_jprb) then + scat_od_total(jg) = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg) + ssa_total(jg) = scat_od_total(jg) / od_total(jg) + + if (scat_od_total(jg) > 0.0_jprb) then + g_total(jg) = (g(jg,jlev,jcol)*ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg)) & + & / scat_od_total(jg) + end if + end if + end do + + else + + do jg = 1,ng + if (od_total(jg) > 0.0_jprb) then + scat_od = ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg) + ssa_total(jg) = scat_od / od_total(jg) + if (scat_od > 0.0_jprb) then + g_total(jg) = g_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg) / scat_od + end if + end if + end do + + end if + + ! Compute cloudy-sky reflectance, transmittance etc at + ! each model level + call calc_ref_trans_lw(ng, & + & od_total, ssa_total, g_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & + & reflectance(:,jlev), transmittance(:,jlev), & + & source_up(:,jlev), source_dn(:,jlev)) + else + ! No-scattering case: use simpler functions for + ! transmission and emission + call calc_no_scattering_transmittance_lw(ng, od_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & transmittance(:,jlev), source_up(:,jlev), source_dn(:,jlev)) + end if + + else + ! Clear-sky layer: copy over clear-sky values + reflectance(:,jlev) = ref_clear(:,jlev) + transmittance(:,jlev) = trans_clear(:,jlev) + source_up(:,jlev) = source_up_clear(:,jlev) + source_dn(:,jlev) = source_dn_clear(:,jlev) + end if + end do + + if (config%do_lw_aerosol_scattering) then + ! Use adding method to compute fluxes for an overcast sky, + ! allowing for scattering in all layers + call adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up, flux_dn) + else if (config%do_lw_cloud_scattering) then + ! Use adding method to compute fluxes but optimize for the + ! presence of clear-sky layers + call fast_adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, & + & emission(:,jcol), albedo(:,jcol), & + & is_clear_sky_layer, i_cloud_top, flux_dn_clear, & + & flux_up, flux_dn, & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + else + ! Simpler down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & transmittance, source_up, source_dn, emission(:,jcol), albedo(:,jcol), & + & flux_up, flux_dn) + end if + + ! Store overcast broadband fluxes + flux%lw_up(jcol,:) = sum(flux_up,1) + flux%lw_dn(jcol,:) = sum(flux_dn,1) + + ! Cloudy flux profiles currently assume completely overcast + ! skies; perform weighted average with clear-sky profile + flux%lw_up(jcol,:) = total_cloud_cover *flux%lw_up(jcol,:) & + & + (1.0_jprb - total_cloud_cover)*flux%lw_up_clear(jcol,:) + flux%lw_dn(jcol,:) = total_cloud_cover *flux%lw_dn(jcol,:) & + & + (1.0_jprb - total_cloud_cover)*flux%lw_dn_clear(jcol,:) + ! Store surface spectral downwelling fluxes + flux%lw_dn_surf_g(:,jcol) = total_cloud_cover*flux_dn(:,nlev+1) & + & + (1.0_jprb - total_cloud_cover)*flux%lw_dn_surf_clear_g(:,jcol) + + ! Compute the longwave derivatives needed by Hogan and Bozzo + ! (2015) approximate radiation update scheme + if (config%do_lw_derivatives) then + call calc_lw_derivatives_ica(ng, nlev, jcol, transmittance, flux_up(:,nlev+1), & + & flux%lw_derivatives) + if (total_cloud_cover < 1.0_jprb - config%cloud_fraction_threshold) then + ! Modify the existing derivative with the contribution from the clear sky + call modify_lw_derivatives_ica(ng, nlev, jcol, trans_clear, flux_up_clear(:,nlev+1), & + & 1.0_jprb-total_cloud_cover, flux%lw_derivatives) + end if + end if + + else + ! No cloud in profile and clear-sky fluxes already + ! calculated: copy them over + flux%lw_up(jcol,:) = flux%lw_up_clear(jcol,:) + flux%lw_dn(jcol,:) = flux%lw_dn_clear(jcol,:) + flux%lw_dn_surf_g(:,jcol) = flux%lw_dn_surf_clear_g(:,jcol) + if (config%do_lw_derivatives) then + call calc_lw_derivatives_ica(ng, nlev, jcol, trans_clear, flux_up_clear(:,nlev+1), & + & flux%lw_derivatives) + + end if + end if ! Cloud is present in profile + end do + + if (lhook) call dr_hook('radiation_mcica_lw:solver_mcica_lw',1,hook_handle) + + end subroutine solver_mcica_lw + +end module radiation_mcica_lw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_sw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_mcica_sw.F90 (revision 6016) @@ -0,0 +1,344 @@ +! This file has been modified for the use in ICON + +! radiation_mcica_sw.F90 - Monte-Carlo Independent Column Approximation shortwave solver +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive albedos at g-points +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-10-23 R. Hogan Renamed single-character variables + +module radiation_mcica_sw + + public + +contains + + ! Provides elemental function "delta_eddington" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Shortwave Monte Carlo Independent Column Approximation + ! (McICA). This implementation performs a clear-sky and a cloudy-sky + ! calculation, and then weights the two to get the all-sky fluxes + ! according to the total cloud cover. This method reduces noise for + ! low cloud cover situations, and exploits the clear-sky + ! calculations that are usually performed for diagnostic purposes + ! simultaneously. The cloud generator has been carefully written + ! such that the stochastic cloud field satisfies the prescribed + ! overlap parameter accounting for this weighting. + subroutine solver_mcica_sw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, & + & albedo_direct, albedo_diffuse, incoming_sw, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulerr, radiation_abort + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_cloud, only : cloud_type + use radiation_flux, only : flux_type + use radiation_two_stream, only : calc_ref_trans_sw + use radiation_adding_ica_sw, only : adding_ica_sw + use radiation_cloud_generator, only: cloud_generator + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each shortwave g-point + real(jprb), intent(in), dimension(config%n_g_sw, nlev, istartcol:iendcol) :: & + & od, ssa, g + + ! Cloud and precipitation optical depth, single-scattering albedo and + ! asymmetry factor in each shortwave band + real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: & + & od_cloud, ssa_cloud, g_cloud + + ! Direct and diffuse surface albedos, and the incoming shortwave + ! flux into a plane perpendicular to the incoming radiation at + ! top-of-atmosphere in each of the shortwave g points + real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) :: & + & albedo_direct, albedo_diffuse, incoming_sw + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! Cosine of solar zenith angle + real(jprb) :: cos_sza + + ! Diffuse reflectance and transmittance for each layer in clear + ! and all skies + real(jprb), dimension(config%n_g_sw, nlev) :: ref_clear, trans_clear, reflectance, transmittance + + ! Fraction of direct beam scattered by a layer into the upwelling + ! or downwelling diffuse streams, in clear and all skies + real(jprb), dimension(config%n_g_sw, nlev) :: ref_dir_clear, trans_dir_diff_clear, ref_dir, trans_dir_diff + + ! Transmittance for the direct beam in clear and all skies + real(jprb), dimension(config%n_g_sw, nlev) :: trans_dir_dir_clear, trans_dir_dir + + ! Fluxes per g point + real(jprb), dimension(config%n_g_sw, nlev+1) :: flux_up, flux_dn_diffuse, flux_dn_direct + + ! Combined gas+aerosol+cloud optical depth, single scattering + ! albedo and asymmetry factor + real(jprb), dimension(config%n_g_sw) :: od_total, ssa_total, g_total + + ! Combined scattering optical depth + real(jprb) :: scat_od + + ! Optical depth scaling from the cloud generator, zero indicating + ! clear skies + real(jprb), dimension(config%n_g_sw,nlev) :: od_scaling + + ! Modified optical depth after McICA scaling to represent cloud + ! inhomogeneity + real(jprb), dimension(config%n_g_sw) :: od_cloud_new + + ! Temporary working array + real(jprb), dimension(config%n_g_sw,nlev+1) :: tmp_work_albedo, & + & tmp_work_source + real(jprb), dimension(config%n_g_sw,nlev) :: tmp_work_inv_denominator + + ! Total cloud cover output from the cloud generator + real(jprb) :: total_cloud_cover + + ! Number of g points + integer :: ng + + ! Loop indices for level, column and g point + integer :: jlev, jcol, jg + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_mcica_sw:solver_mcica_sw',0,hook_handle) + + if (.not. config%do_clear) then + write(nulerr,'(a)') '*** Error: shortwave McICA requires clear-sky calculation to be performed' + call radiation_abort() + end if + + ng = config%n_g_sw + + ! Loop through columns + do jcol = istartcol,iendcol + ! Only perform calculation if sun above the horizon + if (single_level%cos_sza(jcol) > 0.0_jprb) then + cos_sza = single_level%cos_sza(jcol) + + ! Clear-sky calculation - first compute clear-sky reflectance, + ! transmittance etc at each model level + if (.not. config%do_sw_delta_scaling_with_gases) then + ! Delta-Eddington scaling has already been performed to the + ! aerosol part of od, ssa and g + call calc_ref_trans_sw(ng*nlev, & + & cos_sza, od(:,:,jcol), ssa(:,:,jcol), g(:,:,jcol), & + & ref_clear, trans_clear, & + & ref_dir_clear, trans_dir_diff_clear, & + & trans_dir_dir_clear) + else + ! Apply delta-Eddington scaling to the aerosol-gas mixture + do jlev = 1,nlev + od_total = od(:,jlev,jcol) + ssa_total = ssa(:,jlev,jcol) + g_total = g(:,jlev,jcol) + call delta_eddington(od_total, ssa_total, g_total) + call calc_ref_trans_sw(ng, & + & cos_sza, od_total, ssa_total, g_total, & + & ref_clear(:,jlev), trans_clear(:,jlev), & + & ref_dir_clear(:,jlev), trans_dir_diff_clear(:,jlev), & + & trans_dir_dir_clear(:,jlev) ) + end do + end if + + ! Use adding method to compute fluxes + call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), & + & albedo_diffuse(:,jcol), albedo_direct(:,jcol), cos_sza, & + & ref_clear, trans_clear, ref_dir_clear, trans_dir_diff_clear, & + & trans_dir_dir_clear, flux_up, flux_dn_diffuse, flux_dn_direct, & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + + ! Sum over g-points to compute and save clear-sky broadband + ! fluxes + flux%sw_up_clear(jcol,:) = sum(flux_up,1) + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,:) & + & = sum(flux_dn_direct,1) + flux%sw_dn_clear(jcol,:) = sum(flux_dn_diffuse,1) & + & + flux%sw_dn_direct_clear(jcol,:) + else + flux%sw_dn_clear(jcol,:) = sum(flux_dn_diffuse,1) & + & + sum(flux_dn_direct,1) + end if + ! Store spectral downwelling fluxes at surface + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = flux_dn_diffuse(:,nlev+1) + flux%sw_dn_direct_surf_clear_g(:,jcol) = flux_dn_direct(:,nlev+1) + + ! Do cloudy-sky calculation + call cloud_generator(ng, nlev, config%i_overlap_scheme, & + & single_level%iseed(jcol), & + & config%cloud_fraction_threshold, & + & cloud%fraction(jcol,:), cloud%overlap_param(jcol,:), & + & config%cloud_inhom_decorr_scaling, cloud%fractional_std(jcol,:), & + & config%pdf_sampler, od_scaling, total_cloud_cover, & + & use_beta_overlap=config%use_beta_overlap, & + & use_vectorizable_generator=config%use_vectorizable_generator) + + ! Store total cloud cover + flux%cloud_cover_sw(jcol) = total_cloud_cover + + if (total_cloud_cover >= config%cloud_fraction_threshold) then + ! Total-sky calculation + do jlev = 1,nlev + ! Compute combined gas+aerosol+cloud optical properties + if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then + do jg = 1,ng + od_cloud_new(jg) = od_scaling(jg,jlev) & + & * od_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) + od_total(jg) = od(jg,jlev,jcol) + od_cloud_new(jg) + ssa_total(jg) = 0.0_jprb + g_total(jg) = 0.0_jprb + + ! In single precision we need to protect against the + ! case that od_total > 0.0 and ssa_total > 0.0 but + ! od_total*ssa_total == 0 due to underflow + if (od_total(jg) > 0.0_jprb) then + scat_od = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) & + & * od_cloud_new(jg) + ssa_total(jg) = scat_od / od_total(jg) + if (scat_od > 0.0_jprb) then + g_total(jg) = (g(jg,jlev,jcol)*ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) & + & * od_cloud_new(jg)) & + & / scat_od + end if + end if + end do + + ! Apply delta-Eddington scaling to the cloud-aerosol-gas + ! mixture + if (config%do_sw_delta_scaling_with_gases) then + call delta_eddington(od_total, ssa_total, g_total) + end if + + ! Compute cloudy-sky reflectance, transmittance etc at + ! each model level + call calc_ref_trans_sw(ng, & + & cos_sza, od_total, ssa_total, g_total, & + & reflectance(:,jlev), transmittance(:,jlev), & + & ref_dir(:,jlev), trans_dir_diff(:,jlev), & + & trans_dir_dir(:,jlev)) + + else + ! Clear-sky layer: copy over clear-sky values + reflectance(:,jlev) = ref_clear(:,jlev) + transmittance(:,jlev) = trans_clear(:,jlev) + ref_dir(:,jlev) = ref_dir_clear(:,jlev) + trans_dir_diff(:,jlev) = trans_dir_diff_clear(:,jlev) + trans_dir_dir(:,jlev) = trans_dir_dir_clear(:,jlev) + end if + end do + + ! Use adding method to compute fluxes for an overcast sky + call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), & + & albedo_diffuse(:,jcol), albedo_direct(:,jcol), cos_sza, & + & reflectance, transmittance, ref_dir, trans_dir_diff, & + & trans_dir_dir, flux_up, flux_dn_diffuse, flux_dn_direct, & + & albedo=tmp_work_albedo, & + & source=tmp_work_source, & + & inv_denominator=tmp_work_inv_denominator) + + ! Store overcast broadband fluxes + flux%sw_up(jcol,:) = sum(flux_up,1) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = sum(flux_dn_direct,1) + flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) & + & + flux%sw_dn_direct(jcol,:) + else + flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) & + & + sum(flux_dn_direct,1) + end if + + ! Cloudy flux profiles currently assume completely overcast + ! skies; perform weighted average with clear-sky profile + flux%sw_up(jcol,:) = total_cloud_cover *flux%sw_up(jcol,:) & + & + (1.0_jprb - total_cloud_cover)*flux%sw_up_clear(jcol,:) + flux%sw_dn(jcol,:) = total_cloud_cover *flux%sw_dn(jcol,:) & + & + (1.0_jprb - total_cloud_cover)*flux%sw_dn_clear(jcol,:) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = total_cloud_cover *flux%sw_dn_direct(jcol,:) & + & + (1.0_jprb - total_cloud_cover)*flux%sw_dn_direct_clear(jcol,:) + end if + ! Likewise for surface spectral fluxes + flux%sw_dn_diffuse_surf_g(:,jcol) = flux_dn_diffuse(:,nlev+1) + flux%sw_dn_direct_surf_g(:,jcol) = flux_dn_direct(:,nlev+1) + flux%sw_dn_diffuse_surf_g(:,jcol) = total_cloud_cover *flux%sw_dn_diffuse_surf_g(:,jcol) & + & + (1.0_jprb - total_cloud_cover)*flux%sw_dn_diffuse_surf_clear_g(:,jcol) + flux%sw_dn_direct_surf_g(:,jcol) = total_cloud_cover *flux%sw_dn_direct_surf_g(:,jcol) & + & + (1.0_jprb - total_cloud_cover)*flux%sw_dn_direct_surf_clear_g(:,jcol) + + else + ! No cloud in profile and clear-sky fluxes already + ! calculated: copy them over + flux%sw_up(jcol,:) = flux%sw_up_clear(jcol,:) + flux%sw_dn(jcol,:) = flux%sw_dn_clear(jcol,:) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = flux%sw_dn_direct_clear(jcol,:) + end if + flux%sw_dn_diffuse_surf_g(:,jcol) = flux%sw_dn_diffuse_surf_clear_g(:,jcol) + flux%sw_dn_direct_surf_g(:,jcol) = flux%sw_dn_direct_surf_clear_g(:,jcol) + + end if ! Cloud is present in profile + + else + ! Set fluxes to zero if sun is below the horizon + flux%sw_up(jcol,:) = 0.0_jprb + flux%sw_dn(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = 0.0_jprb + end if + flux%sw_up_clear(jcol,:) = 0.0_jprb + flux%sw_dn_clear(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,:) = 0.0_jprb + end if + flux%sw_dn_diffuse_surf_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_g(:,jcol) = 0.0_jprb + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_clear_g(:,jcol) = 0.0_jprb + end if ! Sun above horizon + + end do ! Loop over columns + + if (lhook) call dr_hook('radiation_mcica_sw:solver_mcica_sw',1,hook_handle) + + end subroutine solver_mcica_sw + +end module radiation_mcica_sw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_monochromatic.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_monochromatic.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_monochromatic.F90 (revision 6016) @@ -0,0 +1,382 @@ +! radiation_interface.F90 - Monochromatic gas/cloud optics for testing +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive "surface" dummy argument +! 2017-09-13 R. Hogan Revert +! 2018-08-29 R. Hogan Particulate single-scattering albedo / asymmetry from namelist + +module radiation_monochromatic + + implicit none + + public :: setup_gas_optics, gas_optics, set_gas_units, & + & setup_cloud_optics, cloud_optics, & + & setup_aerosol_optics, add_aerosol_optics + +contains + + ! Provides elemental function "delta_eddington" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Setup the arrays in the config object corresponding to the + ! monochromatic gas optics model. The directory argument is not + ! used, since no look-up tables need to be loaded. + subroutine setup_gas_optics(config, directory) + + use radiation_config, only : config_type + + type(config_type), intent(inout) :: config + character(len=*), intent(in) :: directory + + ! In the monochromatic model we have simply one band and g-point + ! in both the longwave and shortwave parts of the spectrum + config%n_g_sw = 1 + config%n_g_lw = 1 + config%n_bands_sw = 1 + config%n_bands_lw = 1 + + ! Allocate arrays + allocate(config%i_band_from_g_sw (config%n_g_sw)) + allocate(config%i_band_from_g_lw (config%n_g_lw)) + allocate(config%i_band_from_reordered_g_sw(config%n_g_sw)) + allocate(config%i_band_from_reordered_g_lw(config%n_g_lw)) + allocate(config%i_g_from_reordered_g_sw(config%n_g_sw)) + allocate(config%i_g_from_reordered_g_lw(config%n_g_lw)) + + ! Indices are trivial... + config%i_band_from_g_sw = 1 + config%i_band_from_g_lw = 1 + config%i_g_from_reordered_g_sw = 1 + config%i_g_from_reordered_g_lw = 1 + config%i_band_from_reordered_g_sw = 1 + config%i_band_from_reordered_g_lw = 1 + + end subroutine setup_gas_optics + + + !--------------------------------------------------------------------- + ! Dummy routine for scaling gas mixing ratios + subroutine set_gas_units(gas) + + use radiation_gas, only : gas_type + type(gas_type), intent(inout) :: gas + + end subroutine set_gas_units + + + !--------------------------------------------------------------------- + ! Dummy setup routine for cloud optics: in fact, no setup is + ! required for monochromatic case + subroutine setup_cloud_optics(config) + + use radiation_config, only : config_type + type(config_type), intent(inout) :: config + + end subroutine setup_cloud_optics + + + !--------------------------------------------------------------------- + ! Dummy subroutine since no aerosols are represented in + ! monochromatic case + subroutine setup_aerosol_optics(config) + + use radiation_config, only : config_type + type(config_type), intent(inout) :: config + + end subroutine setup_aerosol_optics + + + !--------------------------------------------------------------------- + ! Compute gas optical depths, shortwave scattering, Planck function + ! and incoming shortwave radiation at top-of-atmosphere + subroutine gas_optics(ncol,nlev,istartcol,iendcol, & + config, single_level, thermodynamics, gas, lw_albedo, & + od_lw, od_sw, ssa_sw, planck_hl, lw_emission, & + incoming_sw) + + use parkind1, only : jprb + use radiation_config, only : config_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_single_level, only : single_level_type + use radiation_gas, only : gas_type + use radiation_constants, only : Pi, StefanBoltzmann + + ! Inputs + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type),intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + + ! Longwave albedo of the surface + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), & + & intent(in) :: lw_albedo + + ! Outputs + + ! Gaseous layer optical depth in longwave and shortwave, and + ! shortwave single scattering albedo (i.e. fraction of extinction + ! due to Rayleigh scattering) at each g-point + real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol), intent(out) :: & + & od_lw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(out) :: & + & od_sw, ssa_sw + + ! The Planck function (emitted flux from a black body) at half + ! levels and at the surface at each longwave g-point + real(jprb), dimension(config%n_g_lw,nlev+1,istartcol:iendcol), intent(out) :: & + & planck_hl + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), intent(out) :: & + & lw_emission + + ! The incoming shortwave flux into a plane perpendicular to the + ! incoming radiation at top-of-atmosphere in each of the shortwave + ! g-points + real(jprb), dimension(config%n_g_sw,istartcol:iendcol), intent(out) :: & + & incoming_sw + + ! Ratio of the optical depth of the entire atmospheric column that + ! is in the current layer + real(jprb), dimension(istartcol:iendcol) :: extinction_fraction + + ! In the monochromatic model, the absorption by the atmosphere is + ! assumed proportional to the mass in each layer, so is defined in + ! terms of a total zenith optical depth and then distributed with + ! height according to the pressure. + !real(jprb), parameter :: total_od_sw = 0.10536_jprb ! Transmittance 0.9 + !real(jprb), parameter :: total_od_lw = 1.6094_jprb ! Transmittance 0.2 + + integer :: jlev + + do jlev = 1,nlev + ! The fraction of the total optical depth in the current layer + ! is proportional to the fraction of the mass of the atmosphere + ! in the current layer, computed from pressure assuming + ! hydrostatic balance + extinction_fraction = & + & (thermodynamics%pressure_hl(istartcol:iendcol,jlev+1) & + & -thermodynamics%pressure_hl(istartcol:iendcol,jlev)) & + & /thermodynamics%pressure_hl(istartcol:iendcol,nlev) + + ! Assign longwave and shortwave optical depths + od_lw(1,jlev,:) = config%mono_lw_total_od*extinction_fraction + od_sw(1,jlev,:) = config%mono_sw_total_od*extinction_fraction + end do + + ! Shortwave single-scattering albedo is almost entirely Rayleigh + ! scattering + ssa_sw = 0.999999_jprb + + ! Entire shortwave spectrum represented in one band + incoming_sw(1,:) = single_level%solar_irradiance + + if (single_level%is_simple_surface) then + if (config%mono_lw_wavelength <= 0.0_jprb) then + ! Entire longwave spectrum represented in one band + lw_emission(1,istartcol:iendcol) & + & = StefanBoltzmann * single_level%skin_temperature(istartcol:iendcol)**4 & + & * single_level%lw_emissivity(istartcol:iendcol,1) + do jlev = 1,nlev+1 + planck_hl(1,jlev,istartcol:iendcol) = StefanBoltzmann * thermodynamics%temperature_hl(istartcol:iendcol,jlev)**4 + end do + else + ! Single wavelength: multiply by pi to convert W sr-1 m-3 to W m-3 + lw_emission(1,istartcol:iendcol) = Pi*planck_function(config%mono_lw_wavelength, & + & single_level%skin_temperature(istartcol:iendcol)) & + & * single_level%lw_emissivity(istartcol:iendcol,1) + do jlev = 1,nlev+1 + planck_hl(1,jlev,istartcol:iendcol) = Pi*planck_function(config%mono_lw_wavelength, & + & thermodynamics%temperature_hl(istartcol:iendcol,jlev)) + end do + end if + else + lw_emission = transpose(single_level%lw_emission) + end if + + end subroutine gas_optics + + + !--------------------------------------------------------------------- + ! Compute cloud optical depth, single-scattering albedo and + ! g factor in the longwave and shortwave + subroutine cloud_optics(nlev,istartcol,iendcol, & + & config, thermodynamics, cloud, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + + use parkind1, only : jprb + use radiation_config, only : config_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_cloud, only : cloud_type + use radiation_constants, only : AccelDueToGravity, & + & DensityLiquidWater, DensitySolidIce + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(thermodynamics_type),intent(in) :: thermodynamics + type(cloud_type), intent(in) :: cloud + + ! Outputs + + ! Layer optical depth, single scattering albedo and g factor of + ! clouds in each longwave band, where the latter two + ! variables are only defined if cloud longwave scattering is + ! enabled (otherwise both are treated as zero). + real(jprb), dimension(config%n_bands_lw,nlev,istartcol:iendcol), intent(out) :: & + & od_lw_cloud + real(jprb), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol), & + & intent(out) :: ssa_lw_cloud, g_lw_cloud + + ! Layer optical depth, single scattering albedo and g factor of + ! clouds in each shortwave band + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(out) :: & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud + + ! In-cloud liquid and ice water path in a layer, in kg m-2 + real(jprb), dimension(nlev,istartcol:iendcol) :: lwp_kg_m2, iwp_kg_m2 + + integer :: jlev, jcol + + ! Factor to convert from gridbox-mean mass mixing ratio to + ! in-cloud water path + real(jprb) :: factor + + ! Convert cloud mixing ratio into liquid and ice water path + ! in each layer + do jlev = 1, nlev + do jcol = istartcol, iendcol + ! Factor to convert from gridbox-mean mass mixing ratio to + ! in-cloud water path involves the pressure difference in + ! Pa, acceleration due to gravity and cloud fraction + ! adjusted to avoid division by zero. + factor = ( thermodynamics%pressure_hl(jcol,jlev+1) & + & -thermodynamics%pressure_hl(jcol,jlev ) ) & + & / (AccelDueToGravity & + & * max(epsilon(1.0_jprb), cloud%fraction(jcol,jlev))) + lwp_kg_m2(jlev,jcol) = factor * cloud%q_liq(jcol,jlev) + iwp_kg_m2(jlev,jcol) = factor * cloud%q_ice(jcol,jlev) + end do + end do + + ! Geometric optics approximation: particles treated as much larger + ! than the wavelength in both shortwave and longwave + od_sw_cloud(1,:,:) & + & = (3.0_jprb/(2.0_jprb*DensityLiquidWater)) & + & * lwp_kg_m2 / transpose(cloud%re_liq(istartcol:iendcol,:)) & + & + (3.0_jprb / (2.0_jprb * DensitySolidIce)) & + & * iwp_kg_m2 / transpose(cloud%re_ice(istartcol:iendcol,:)) + od_lw_cloud(1,:,:) = lwp_kg_m2 * 137.22_jprb & + & + (3.0_jprb / (2.0_jprb * DensitySolidIce)) & + & * iwp_kg_m2 / transpose(cloud%re_ice(istartcol:iendcol,:)) + + if (config%iverbose >= 4) then + do jcol = istartcol,iendcol + write(*,'(a,i0,a,f7.3,a,f7.3)') 'Profile ', jcol, ': shortwave optical depth = ', & + & sum(od_sw_cloud(1,:,jcol)*cloud%fraction(jcol,:)), & + & ', longwave optical depth = ', & + & sum(od_lw_cloud(1,:,jcol)*cloud%fraction(jcol,:)) + ! print *, 'LWP = ', sum(lwp_kg_m2(:,istartcol)*cloud%fraction(istartcol,:)) + end do + end if + + ssa_sw_cloud = config%mono_sw_single_scattering_albedo + g_sw_cloud = config%mono_sw_asymmetry_factor + + ! In-place delta-Eddington scaling + call delta_eddington(od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + + if (config%do_lw_cloud_scattering) then + ssa_lw_cloud = config%mono_lw_single_scattering_albedo + g_lw_cloud = config%mono_lw_asymmetry_factor + ! In-place delta-Eddington scaling + call delta_eddington(od_lw_cloud, ssa_lw_cloud, g_lw_cloud) + end if + + end subroutine cloud_optics + + + !--------------------------------------------------------------------- + ! Dummy subroutine since no aerosols are represented in + ! monochromatic case + subroutine add_aerosol_optics(nlev,istartcol,iendcol, & + & config, thermodynamics, gas, aerosol, & + & od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw) + + use parkind1, only : jprb + + use radiation_config, only : config_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas, only : gas_type + use radiation_aerosol, only : aerosol_type + + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in), target :: config + type(thermodynamics_type),intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + type(aerosol_type), intent(in) :: aerosol + ! Optical depth, single scattering albedo and asymmetry factor of + ! the atmosphere (gases on input, gases and aerosols on output) + ! for each g point. Note that longwave ssa and asymmetry and + ! shortwave asymmetry are all zero for gases, so are not yet + ! defined on input and are therefore intent(out). + real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol), intent(inout) :: od_lw + real(jprb), dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol), & + & intent(out) :: ssa_lw, g_lw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(inout) & + & :: od_sw, ssa_sw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(out) :: g_sw + + g_sw(:,:,istartcol:iendcol) = 0.0_jprb + + if (config%do_lw_aerosol_scattering) then + ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb + g_lw(:,:,istartcol:iendcol) = 0.0_jprb + end if + + end subroutine add_aerosol_optics + + !--------------------------------------------------------------------- + ! Planck function in terms of wavelength + elemental function planck_function(wavelength, temperature) + + use parkind1, only : jprb + + use radiation_constants, only : BoltzmannConstant, PlanckConstant, & + & SpeedOfLight + + real(jprb), intent(in) :: wavelength ! metres + real(jprb), intent(in) :: temperature ! Kelvin + + ! Output in W sr-1 m-3 + real(jprb) :: planck_function + + if (temperature > 0.0_jprb) then + planck_function = 2.0_jprb * PlanckConstant * SpeedOfLight**2 & + & / (wavelength**5 & + & * (exp(PlanckConstant*SpeedOfLight & + & /(wavelength*BoltzmannConstant*temperature)) - 1.0_jprb)) + else + planck_function = 0.0_jprb + end if + + end function planck_function + +end module radiation_monochromatic Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_optical_depth_scaling.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_optical_depth_scaling.h (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_optical_depth_scaling.h (revision 6016) @@ -0,0 +1,73 @@ +! radiation_optical_depth_scaling.h - Cloud optical-depth scaling for Tripleclouds +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-07-14 R. Hogan Incorporate gamma distribution option +! +! This file is intended to be included inside a module to ensure that +! this simple routine may be inlined + +!--------------------------------------------------------------------- +! Compute the optical depth scalings for the optically "thick" and +! "thin" regions of a Tripleclouds representation of a sub-grid PDF of +! cloud optical depth. Following Shonk and Hogan (2008), the 16th +! percentile is used for the thin region, and the formulas estimate +! this for both lognormal and gamma distributions. +pure subroutine optical_depth_scaling(nreg, frac_std, do_gamma, od_scaling) + + use parkind1, only : jprb + + ! Number of regions + integer, intent(in) :: nreg + + ! Fractional standard deviation of in-cloud water content + real(jprb), intent(in) :: frac_std + + ! Do we do a lognormal or gamma distribution? + logical, intent(in) :: do_gamma + + ! Optical depth scaling for the cloudy regions + real(jprb), intent(out) :: od_scaling(2:nreg) + + if (nreg == 2) then + ! Only one clear-sky and one cloudy region: cloudy region is + ! homogeneous + od_scaling(2) = 1.0_jprb + else + ! Two cloudy regions with optical depth scaled by 1-x and + ! 1+x. + ! Simple version which fails when fractional_std >= 1: + !od_scaling(2) = 1.0_jprb-cloud%fractional_std(jcol,jlev) + ! According to Shonk and Hogan (2008), 1-x should correspond to + ! the 16th percentile. + if (.not. do_gamma) then + ! If we treat the distribution as a lognormal such that the + ! equivalent Normal has a mean mu and standard deviation sigma, + ! then the 16th percentile of the lognormal is very close to + ! exp(mu-sigma). + od_scaling(2) & + & = exp(-sqrt(log(frac_std**2+1))) / sqrt(frac_std**2+1) + else + ! If we treat the distribution as a gamma then the 16th + ! percentile is close to the following + od_scaling(2) = exp(-frac_std*(1.0_jprb + 0.5_jprb*frac_std & + & *(1.0_jprb+0.5_jprb*frac_std))) + end if + + ! Ensure mean optical depth is conserved + od_scaling(3) = 2.0_jprb-od_scaling(2) + end if + +end subroutine optical_depth_scaling Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_overlap.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_overlap.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_overlap.F90 (revision 6016) @@ -0,0 +1,459 @@ +! radiation_overlap.F90 - Module to compute cloud overlap quantities +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-10-23 R. Hogan Renamed single-character variables +! 2018-10-05 R. Hogan Generalized alpha overlap for non-equal regions +! 2018-10-08 R. Hogan Removed calc_region_fractions + +module radiation_overlap + + implicit none + + public :: calc_overlap_matrices + +contains + + + ! This function now superceded by calc_region_properties in module + ! radiation_regions + ! !--------------------------------------------------------------------- + ! ! Return an array of length nreg containing the fraction of the + ! ! gridbox occupied by each region for the specified cloud fraction. + ! pure function calc_region_fractions(nreg, cloud_fraction) + + ! use parkind1, only : jprb + + ! integer, intent(in) :: nreg + ! real(jprb), intent(in) :: cloud_fraction + + ! real(jprb), dimension(nreg) :: calc_region_fractions + ! integer :: jreg + + ! if (nreg == 1) then + ! ! Only one region: must occupy all of gridbox + ! calc_region_fractions(1) = 1.0_jprb + ! else + ! ! Two or more regions: the first is the cloud-free region + ! calc_region_fractions(1) = 1.0_jprb - cloud_fraction + + ! do jreg = 2,nreg + ! ! The cloudy regions are assumed to each have the same + ! ! fraction - see Shonk and Hogan (2008) for justification + ! calc_region_fractions(jreg) = cloud_fraction / (nreg - 1.0_jprb) + ! end do + ! end if + + ! end function calc_region_fractions + + !--------------------------------------------------------------------- + ! Calculate a matrix expressing the overlap of regions in adjacent + ! layers, using the method of Shonk et al. (2010) in terms of their + ! "beta" overlap parameter + pure function calc_beta_overlap_matrix(nreg, op, frac_upper, frac_lower, & + & frac_threshold) result(overlap_matrix) + + use parkind1, only : jprb + + integer, intent(in) :: nreg ! Number of regions + + ! Overlap parameter for each region, and fraction of the gridbox + ! occupied by each region in the upper and lower layers + real(jprb), intent(in), dimension(nreg) :: op, frac_upper, frac_lower + + ! Cloud-fraction threshold below which cloud is deemed not to be + ! present + real(jprb), intent(in) :: frac_threshold + + ! Output overlap matrix + real(jprb) :: overlap_matrix(nreg,nreg) + + ! Denominator and its reciprocal in computing the random part of + ! the overlap matrix + real(jprb) :: denominator, factor + + ! Beta overlap parameter multiplied by the minimum region fraction + ! of the upper and lower layers + real(jprb) :: op_x_frac_min(nreg) + + integer :: jupper, jlower, jreg + + ! In computing the random part of the overlap matrix we need + ! to divide all elements by "denominator", or for efficiency + ! multiply by "factor" + denominator = 1.0_jprb + do jreg = 1,nreg + op_x_frac_min(jreg) = op(jreg) & + & * min(frac_upper(jreg), frac_lower(jreg)) + denominator = denominator - op_x_frac_min(jreg) + end do + ! In principle the denominator can be zero + if (denominator >= frac_threshold) then + factor = 1.0_jprb / denominator + ! Create the random part of the overlap matrix + do jupper = 1,nreg + do jlower = 1,nreg + overlap_matrix(jupper,jlower) = factor & + & * (frac_lower(jlower)-op_x_frac_min(jlower)) & + & * (frac_upper(jupper)-op_x_frac_min(jupper)) + end do + end do + else + overlap_matrix = 0.0_jprb + end if + + ! Add on the maximum part of the overlap matrix + do jreg = 1,nreg + overlap_matrix(jreg,jreg) = overlap_matrix(jreg,jreg) & + & + op_x_frac_min(jreg) + end do + + end function calc_beta_overlap_matrix + + + !--------------------------------------------------------------------- + ! Calculate a matrix expressing the overlap of regions in adjacent + ! layers, using the Hogan and Illingworth (2000) "alpha" overlap + ! parameter, but allowing for the two cloudy regions in the + ! Tripleclouds assumption to have different areas + pure function calc_alpha_overlap_matrix(nreg, op, op_inhom, & + & frac_upper, frac_lower) result(overlap_matrix) + + use parkind1, only : jprb + + integer, intent(in) :: nreg ! Number of regions + + ! Overlap parameter for cloud boundaries and for internal + ! inhomogeneities + real(jprb), intent(in) :: op, op_inhom + + ! Fraction of the gridbox occupied by each region in the upper and + ! lower layers + real(jprb), intent(in), dimension(nreg) :: frac_upper, frac_lower + + ! Output overlap matrix + real(jprb) :: overlap_matrix(nreg,nreg) + + ! Combined cloud cover of pair of layers + real(jprb) :: pair_cloud_cover + + ! Cloud fraction of upper and lower layers + real(jprb) :: cf_upper, cf_lower + + ! One divided by cloud fraction + real(jprb) :: one_over_cf + + ! Fraction of domain with cloud in both layers + real(jprb) :: frac_both + + cf_upper = sum(frac_upper(2:nreg)) + cf_lower = sum(frac_lower(2:nreg)) + + pair_cloud_cover = op*max(cf_upper,cf_lower) & + & + (1.0_jprb - op) & + & * (cf_upper+cf_lower-cf_upper*cf_lower) + + ! Clear in both layers + overlap_matrix(1,1) = 1.0_jprb - pair_cloud_cover + if (nreg == 2) then + ! Clear in upper layer, cloudy in lower layer + overlap_matrix(1,2) = pair_cloud_cover - cf_upper + ! Clear in lower layer, cloudy in upper layer + overlap_matrix(2,1) = pair_cloud_cover - cf_lower + ! Cloudy in both layers + overlap_matrix(2,2) = cf_upper + cf_lower - pair_cloud_cover + else + ! Clear in upper layer, cloudy in lower layer + one_over_cf = 1.0_jprb / max(cf_lower, 1.0e-6_jprb) + overlap_matrix(1,2) = (pair_cloud_cover - cf_upper) & + & * frac_lower(2) * one_over_cf + overlap_matrix(1,3) = (pair_cloud_cover - cf_upper) & + & * frac_lower(3) * one_over_cf + ! Clear in lower layer, cloudy in upper layer + one_over_cf = 1.0_jprb / max(cf_upper, 1.0e-6_jprb) + overlap_matrix(2,1) = (pair_cloud_cover - cf_lower) & + & * frac_upper(2) * one_over_cf + overlap_matrix(3,1) = (pair_cloud_cover - cf_lower) & + & * frac_upper(3) * one_over_cf + ! Cloudy in both layers: frac_both is the fraction of the + ! gridbox with cloud in both layers + frac_both = cf_upper + cf_lower - pair_cloud_cover + ! Treat low and high optical-depth regions within frac_both as + ! one treats clear and cloudy skies in the whole domain; + ! redefine the following variables treating the high + ! optical-depth region as the cloud + cf_upper = frac_upper(3) / max(cf_upper, 1.0e-6_jprb) + cf_lower = frac_lower(3) / max(cf_lower, 1.0e-6_jprb) + pair_cloud_cover = op_inhom*max(cf_upper,cf_lower) & + & + (1.0_jprb - op_inhom) & + & * (cf_upper+cf_lower-cf_upper*cf_lower) + ! Assign overlaps for this 2x2 section of the 3x3 matrix as for + ! the 2-region case above, but multiplied by frac_both + overlap_matrix(2,2) = frac_both * (1.0_jprb - pair_cloud_cover) + overlap_matrix(2,3) = frac_both * (pair_cloud_cover - cf_upper) + overlap_matrix(3,2) = frac_both * (pair_cloud_cover - cf_lower) + overlap_matrix(3,3) = frac_both * (cf_upper+cf_lower-pair_cloud_cover) + end if + + end function calc_alpha_overlap_matrix + + + !--------------------------------------------------------------------- + ! Calculate a matrix expressing the overlap of regions in adjacent + ! layers, using the Hogan and Illingworth (2000) "alpha" overlap + ! parameter, and assuming the two cloudy regions in the Tripleclouds + ! assumption have the same area + pure function calc_alpha_overlap_matrix_simple(nreg, op, op_inhom, & + & cf_upper, cf_lower) result(overlap_matrix) + + use parkind1, only : jprb + + integer, intent(in) :: nreg ! Number of regions + + ! Overlap parameter for cloud boundaries and for internal + ! inhomogeneities + real(jprb), intent(in) :: op, op_inhom + + ! Cloud fraction in the upper and lower layers + real(jprb), intent(in) :: cf_upper, cf_lower + + ! Output overlap matrix + real(jprb) :: overlap_matrix(nreg,nreg) + + ! Combined cloud cover of pair of layers + real(jprb) :: pair_cloud_cover + + real(jprb) :: cloud_unit + + pair_cloud_cover = op*max(cf_upper,cf_lower) & + & + (1.0_jprb - op) & + & * (cf_upper+cf_lower-cf_upper*cf_lower) + + ! Clear in both layers + overlap_matrix(1,1) = 1.0_jprb - pair_cloud_cover + if (nreg == 2) then + ! Clear in upper layer, cloudy in lower layer + overlap_matrix(1,2) = pair_cloud_cover - cf_upper + ! Clear in lower layer, cloudy in upper layer + overlap_matrix(2,1) = pair_cloud_cover - cf_lower + ! Cloudy in both layers + overlap_matrix(2,2) = cf_upper + cf_lower - pair_cloud_cover + else + ! The following assumes that the two cloudy regions are of equal area. + ! Clear in upper layer, cloudy in lower layer + overlap_matrix(1,2) = 0.5_jprb * (pair_cloud_cover - cf_upper) + overlap_matrix(1,3) = overlap_matrix(1,2) + ! Clear in lower layer, cloudy in upper layer + overlap_matrix(2,1) = 0.5_jprb * (pair_cloud_cover - cf_lower) + overlap_matrix(3,1) = overlap_matrix(2,1) + ! Cloudy in both layers + cloud_unit = 0.25_jprb * (cf_upper + cf_lower - pair_cloud_cover) + overlap_matrix(2,2) = cloud_unit * (1.0_jprb + op_inhom) + overlap_matrix(2,3) = cloud_unit * (1.0_jprb - op_inhom) + overlap_matrix(3,3) = overlap_matrix(2,2) + overlap_matrix(3,2) = overlap_matrix(2,3) + end if + + end function calc_alpha_overlap_matrix_simple + + + !--------------------------------------------------------------------- + ! Compute the upward and downward overlap matrices u_matrix and + ! v_matrix, respectively, where u_matrix is defined such that + ! y=u_matrix*x, where x is a vector of upwelling fluxes in each + ! region just below an interface, and y is a vector of upwelling + ! fluxes in each region just above that interface. For nlev model + ! levels there are nlev+1 interfaces including the ground and + ! top-of-atmosphere, and so that is one of the dimensions of + ! u_matrix and v_matrix. + subroutine calc_overlap_matrices(nlev,nreg,istartcol,iendcol, & + & region_fracs, overlap_param, u_matrix, v_matrix, decorrelation_scaling, & + & cloud_fraction_threshold, cloud_cover, use_beta_overlap) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + ! Number of levels and regions + integer, intent(in) :: nlev, nreg + + ! Range of columns to process (also outer dimensions of u_matrix + ! and v_matrix) + integer, intent(in) :: istartcol, iendcol + + ! Area fraction of each region: region 1 is clear sky, and 2+ are + ! the cloudy regions (only one or two cloudy regions are + ! supported) + real(jprb), intent(in), dimension(1:nreg,nlev,istartcol:iendcol) :: region_fracs + + ! The overlap parameter: either the "alpha" of Hogan & Illingworth + ! (2000) or the "beta" of Shonk et al. (2010) + real(jprb), intent(in), dimension(:,:) :: overlap_param ! (ncol,nlev-1) + + ! Output overlap matrices + real(jprb), intent(out), dimension(nreg,nreg,nlev+1,istartcol:iendcol) & + & :: u_matrix, v_matrix + + ! For regions 2 and above, the overlap decorrelation length for + ! cloud boundaries is scaled by this amount to obtain the overlap + ! decorrelation length for cloud inhomogeneities. Typically this + ! number is 0.5, but if omitted it will be assumed to be one (same + ! decorrelation for cloud boundaries and in-cloud inhomogeneities) + real(jprb), intent(in), optional :: decorrelation_scaling + + ! Regions smaller than this are ignored + real(jprb), intent(in), optional :: cloud_fraction_threshold + + ! The diagnosed cloud cover is an optional output + real(jprb), intent(out), optional :: cloud_cover(:) + + ! Do we use Shonk et al.'s (2010) "beta" overlap parameter? + logical, intent(in), optional :: use_beta_overlap + + ! Loop indices for column, level, region and the regions in the + ! upper and lower layers for an interface + integer :: jcol, jlev, jupper, jlower + + ! Overlap matrix (non-directional) + real(jprb) :: overlap_matrix(nreg,nreg) + + ! Fraction of the gridbox occupied by each region in the upper and + ! lower layers for an interface + real(jprb) :: frac_upper(nreg), frac_lower(nreg) + + ! Beta overlap parameter for each region + real(jprb) :: op(nreg) + + ! In case the user doesn't supply cloud_fraction_threshold we use + ! a default value + real(jprb) :: frac_threshold + + ! The decorrelation scaling to use, in case decorrelation_scaling + ! was not provided + real(jprb) :: used_decorrelation_scaling + + logical :: use_beta_overlap_param + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_overlap:calc_overlap_matrices',0,hook_handle) + + if (present(decorrelation_scaling)) then + used_decorrelation_scaling = decorrelation_scaling + else + used_decorrelation_scaling = 1.0_jprb + end if + + if (present(cloud_fraction_threshold)) then + frac_threshold = cloud_fraction_threshold + else + frac_threshold = 1.0e-20_jprb + end if + + if (present(use_beta_overlap)) then + use_beta_overlap_param = use_beta_overlap + else + use_beta_overlap_param = .false. + end if + + ! Loop through each atmospheric column + do jcol = istartcol, iendcol + ! For this column, outer space is treated as one clear-sky + ! region, so the fractions are assigned as such + frac_upper(1) = 1.0_jprb + frac_upper(2:nreg) = 0.0_jprb + + ! Overlap parameter is irrelevant when there is only one region + ! in the upper layer + op = 1.0_jprb + + ! Loop down through the atmosphere, where jlev indexes each + ! half-level starting at 1 for the top-of-atmosphere, as well + ! as indexing each level starting at 1 for the top-most level. + do jlev = 1,nlev+1 + ! Fraction of each region just below the interface + if (jlev > nlev) then + ! We are at the surface: treat as a single clear-sky + ! region + frac_lower(1) = 1.0_jprb + frac_lower(2:nreg) = 0.0_jprb + else + frac_lower = region_fracs(1:nreg,jlev,jcol) + end if + + ! Compute the overlap parameter of the interface just below + ! the current full level + if (jlev == 1 .or. jlev > nlev) then + ! We are at the surface or top-of-atmosphere: overlap + ! parameter is irrelevant + op = 1.0_jprb + else + ! We are not at the surface + op(1) = overlap_param(jcol,jlev-1) + ! For cloudy regions, scale the cloud-boundary overlap + ! parameter to obtain the cloud-inhomogeneity overlap + ! parameter as follows + if (op(1) >= 0.0_jprb) then + op(2:nreg) = op(1)**(1.0_jprb/used_decorrelation_scaling) + else + op(2:nreg) = op(1) + end if + end if + + if (use_beta_overlap_param) then + overlap_matrix = calc_beta_overlap_matrix(nreg, op, & + & frac_upper, frac_lower, frac_threshold) + else + ! Simpler scheme assuming the two cloudy regions have the + ! same fraction + !overlap_matrix = calc_alpha_overlap_matrix_simple(nreg, & + ! & op(1), op(2), & + ! & 1.0_jprb - frac_upper(1), 1.0_jprb - frac_lower(1)) + ! More general scheme + overlap_matrix = calc_alpha_overlap_matrix(nreg, & + & op(1), op(2), frac_upper, frac_lower) + end if + + ! Convert to directional overlap matrices + do jupper = 1,nreg + do jlower = 1,nreg + if (frac_lower(jlower) >= frac_threshold) then + u_matrix(jupper,jlower,jlev,jcol) = overlap_matrix(jupper,jlower) & + & / frac_lower(jlower) + else + u_matrix(jupper,jlower,jlev,jcol) = 0.0_jprb + end if + if (frac_upper(jupper) >= frac_threshold) then + v_matrix(jlower,jupper,jlev,jcol) = overlap_matrix(jupper,jlower) & + & / frac_upper(jupper) + else + v_matrix(jlower,jupper,jlev,jcol) = 0.0_jprb + end if + end do + end do + frac_upper = frac_lower + + end do ! levels + + ! Compute cloud cover from one of the directional overlap matrices + if (present(cloud_cover)) then + cloud_cover(jcol) = 1.0_jprb - product(v_matrix(1,1,:,jcol)) + end if + + end do ! columns + + if (lhook) call dr_hook('radiation_overlap:calc_overlap_matrices',1,hook_handle) + + end subroutine calc_overlap_matrices + +end module radiation_overlap Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_pdf_sampler.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_pdf_sampler.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_pdf_sampler.F90 (revision 6016) @@ -0,0 +1,323 @@ +! radiation_pdf_sampler.F90 - Get samples from a PDF for McICA +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_pdf_sampler + + use parkind1, only : jprb + + implicit none + public + + !--------------------------------------------------------------------- + ! Derived type for sampling from a lognormal or gamma distribution, + ! or other PDF, used to generate water content or optical depth + ! scalings for use in the Monte Carlo Independent Column + ! Approximation (McICA) + type pdf_sampler_type + ! Number of points in look-up table for cumulative distribution + ! function (CDF) and fractional standard deviation (FSD) + ! dimensions + integer :: ncdf, nfsd + + ! First value of FSD and the reciprocal of the interval between + ! FSD values (which are assumed to be uniformly distributed) + real(jprb) :: fsd1, inv_fsd_interval + + ! Value of the distribution for each CDF and FSD bin + real(jprb), allocatable, dimension(:,:) :: val + + contains + + procedure :: setup => setup_pdf_sampler + procedure :: sample => sample_from_pdf + procedure :: masked_sample => sample_from_pdf_masked + procedure :: block_sample => sample_from_pdf_block + procedure :: masked_block_sample => sample_from_pdf_masked_block + procedure :: deallocate => deallocate_pdf_sampler + + end type pdf_sampler_type + +contains + + !--------------------------------------------------------------------- + ! Load look-up table from a file + subroutine setup_pdf_sampler(this, file_name, iverbose) + + use yomhook, only : lhook, dr_hook, jphook + use easy_netcdf, only : netcdf_file + + class(pdf_sampler_type), intent(inout) :: this + character(len=*), intent(in) :: file_name + integer, optional, intent(in) :: iverbose + + type(netcdf_file) :: file + integer :: iverb + real(jprb), allocatable :: fsd(:) + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_pdf_sampler:setup',0,hook_handle) + + if (present(iverbose)) then + iverb = iverbose + else + iverb = 2 + end if + + if (allocated(this%val)) then + deallocate(this%val) + end if + + call file%open(trim(file_name), iverbose=iverb) + + call file%get('fsd',fsd) + call file%get('x', this%val) + + call file%close() + + this%ncdf = size(this%val,1) + this%nfsd = size(this%val,2) + this%fsd1 = fsd(1) + this%inv_fsd_interval = 1.0_jprb / (fsd(2)-fsd(1)) + + deallocate(fsd) + + if (lhook) call dr_hook('radiation_pdf_sampler:setup',1,hook_handle) + + end subroutine setup_pdf_sampler + + !--------------------------------------------------------------------- + ! Deallocate data in pdf_sampler_type derived type + subroutine deallocate_pdf_sampler(this) + + use yomhook, only : lhook, dr_hook, jphook + + class(pdf_sampler_type), intent(inout) :: this + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_pdf_sampler:deallocate',0,hook_handle) + + if (allocated(this%val)) then + deallocate(this%val) + end if + + if (lhook) call dr_hook('radiation_pdf_sampler:deallocate',1,hook_handle) + + end subroutine deallocate_pdf_sampler + + + !--------------------------------------------------------------------- + ! Extract the value from a PDF with fractional standard deviation + ! "fsd" corresponding to the cumulative distribution function value + ! "cdf", and return it in val. Since this is an elemental + ! subroutine, fsd, cdf and val may be arrays. + elemental subroutine sample_from_pdf(this, fsd, cdf, val) + + class(pdf_sampler_type), intent(in) :: this + + ! Fractional standard deviation (0 to 4) and cumulative + ! distribution function (0 to 1) + real(jprb), intent(in) :: fsd, cdf + + ! Sample from distribution + real(jprb), intent(out) :: val + + ! Index to look-up table + integer :: ifsd, icdf + + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + ! Bilinear interpolation with bounds + wcdf = cdf * (this%ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), this%ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fsd-this%fsd1) * this%inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), this%nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + val = (1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf ,ifsd) & + & + (1.0_jprb-wcdf)* wfsd * this%val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd) & + & + wcdf * wfsd * this%val(icdf+1,ifsd+1) + + end subroutine sample_from_pdf + + + !--------------------------------------------------------------------- + ! For true elements of mask, extract the values of a PDF with + ! fractional standard deviation "fsd" corresponding to the + ! cumulative distribution function values "cdf", and return in + ! val. For false elements of mask, return zero in val. + subroutine sample_from_pdf_masked(this, nsamp, fsd, cdf, val, mask) + + class(pdf_sampler_type), intent(in) :: this + + ! Number of samples + integer, intent(in) :: nsamp + + ! Fractional standard deviation (0 to 4) and cumulative + ! distribution function (0 to 1) + real(jprb), intent(in) :: fsd(nsamp), cdf(nsamp) + + ! Sample from distribution + real(jprb), intent(out) :: val(:) + + ! Mask + logical, intent(in) :: mask(nsamp) + + ! Loop index + integer :: jsamp + + ! Index to look-up table + integer :: ifsd, icdf + + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + do jsamp = 1,nsamp + if (mask(jsamp)) then + ! Bilinear interpolation with bounds + wcdf = cdf(jsamp) * (this%ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), this%ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fsd(jsamp)-this%fsd1) * this%inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), this%nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + val(jsamp)=(1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf ,ifsd) & + & +(1.0_jprb-wcdf)* wfsd * this%val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd) & + & + wcdf * wfsd * this%val(icdf+1,ifsd+1) + else + val(jsamp) = 0.0_jprb + end if + end do + end subroutine sample_from_pdf_masked + + !--------------------------------------------------------------------- + ! Extract the values of a PDF with fractional standard deviation + ! "fsd" corresponding to the cumulative distribution function values + ! "cdf", and return in val. This version works on 2D blocks of data. + subroutine sample_from_pdf_block(this, nz, ng, fsd, cdf, val) + + class(pdf_sampler_type), intent(in) :: this + + ! Number of samples + integer, intent(in) :: nz, ng + + ! Fractional standard deviation (0 to 4) and cumulative + ! distribution function (0 to 1) + real(jprb), intent(in) :: fsd(nz), cdf(ng, nz) + + ! Sample from distribution + real(jprb), intent(out) :: val(:,:) + + ! Loop index + integer :: jz, jg + + ! Index to look-up table + integer :: ifsd, icdf + + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + do jz = 1,nz + do jg = 1,ng + if (cdf(jg, jz) > 0.0_jprb) then + ! Bilinear interpolation with bounds + wcdf = cdf(jg,jz) * (this%ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), this%ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fsd(jz)-this%fsd1) * this%inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), this%nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + val(jg,jz)=(1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf ,ifsd) & + & +(1.0_jprb-wcdf)* wfsd * this%val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd) & + & + wcdf * wfsd * this%val(icdf+1,ifsd+1) + else + val(jg,jz) = 0.0_jprb + end if + end do + end do + + end subroutine sample_from_pdf_block + + !--------------------------------------------------------------------- + ! Extract the values of a PDF with fractional standard deviation + ! "fsd" corresponding to the cumulative distribution function values + ! "cdf", and return in val. This version works on 2D blocks of data. + subroutine sample_from_pdf_masked_block(this, nz, ng, fsd, cdf, val, mask) + + class(pdf_sampler_type), intent(in) :: this + + ! Number of samples + integer, intent(in) :: nz, ng + + ! Fractional standard deviation (0 to 4) and cumulative + ! distribution function (0 to 1) + real(jprb), intent(in) :: fsd(nz), cdf(ng, nz) + + ! Sample from distribution + real(jprb), intent(out) :: val(:,:) + + ! Mask + logical, intent(in), optional :: mask(nz) + + ! Loop index + integer :: jz, jg + + ! Index to look-up table + integer :: ifsd, icdf + + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + do jz = 1,nz + + if (mask(jz)) then + + do jg = 1,ng + if (cdf(jg, jz) > 0.0_jprb) then + ! Bilinear interpolation with bounds + wcdf = cdf(jg,jz) * (this%ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), this%ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fsd(jz)-this%fsd1) * this%inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), this%nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + val(jg,jz)=(1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf ,ifsd) & + & +(1.0_jprb-wcdf)* wfsd * this%val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd) & + & + wcdf * wfsd * this%val(icdf+1,ifsd+1) + else + val(jg,jz) = 0.0_jprb + end if + end do + + end if + + end do + + end subroutine sample_from_pdf_masked_block + +end module radiation_pdf_sampler Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_random_numbers.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_random_numbers.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_random_numbers.F90 (revision 6016) @@ -0,0 +1,350 @@ +! This file has been modified for the use in ICON + +! radiation_random_numbers.F90 - Generate random numbers for McICA solver +! +! (C) Copyright 2020- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! The derived type "rng_type" is a random number generator that uses +! either (1) Fortran's built-in random_number function, or (2) a +! vectorized version of the MINSTD linear congruential generator. In +! the case of (2), an rng_type object is initialized with a seed that +! is used to fill up a state of "nmaxstreams" elements using the C++ +! minstd_rand0 version of the MINSTD linear congruential generator +! (LNG), which has the form istate[i+1] = mod(istate[i]*A0, M) from +! i=1 to i=nmaxstreams. Subsequent requests for blocks of nmaxstreams +! of random numbers use the C++ minstd_ran algorithm in a vectorizable +! form, which modifies the state elements via istate[i] <- +! mod(istate[i]*A, M). Uniform deviates are returned that normalize +! the state elements to the range 0-1. +! +! The MINSTD generator was coded because the random_numbers_mix +! generator in the IFS was found not to vectorize well on some +! hardware. I am no expert on random number generators, so my +! implementation should really be looked at and improved by someone +! who knows what they are doing. +! +! Reference for MINSTD: Park, Stephen K.; Miller, Keith +! W. (1988). "Random Number Generators: Good Ones Are Hard To Find" +! (PDF). Communications of the ACM. 31 (10): +! 1192-1201. doi:10.1145/63039.63042 +! +! Modifications +! 2022-12-01 R. Hogan Fixed zeroed state in single precision + +module radiation_random_numbers + + use parkind1, only : jprb, jprd, jpim, jpib + + implicit none + + public :: rng_type, IRngMinstdVector, IRngNative, initialize_acc, & + & uniform_distribution_acc, IMinstdA0, IMinstdA, IMinstdM + + enum, bind(c) + enumerator IRngNative, & ! Built-in Fortran-90 RNG + & IRngMinstdVector ! Vector MINSTD algorithm + end enum + + ! Maximum number of random numbers that can be computed in one call + ! - this can be increased + integer(kind=jpim), parameter :: NMaxStreams = 512 + + ! A requirement of the generator is that the operation mod(A*X,M) is + ! performed with no loss of precision, so type used for A and X must + ! be able to hold the largest possible value of A*X without + ! overflowing, going negative or losing precision. The largest + ! possible value is 48271*2147483647 = 103661183124337. This number + ! can be held in either a double-precision real number, or an 8-byte + ! integer. Either may be used, but on some hardwares it has been + ! found that operations on double-precision reals are faster. Select + ! which you prefer by defining USE_REAL_RNG_STATE for double + ! precision, or undefining it for an 8-byte integer. +#define USE_REAL_RNG_STATE 1 + + ! Define RNG_STATE_TYPE based on USE_REAL_RNG_STATE, where jprd + ! refers to a double-precision number regardless of the working + ! precision described by jprb, while jpib describes an 8-byte + ! integer +#ifdef USE_REAL_RNG_STATE +#define RNG_STATE_TYPE real(kind=jprd) +#else +#define RNG_STATE_TYPE integer(kind=jpib) +#endif + + ! The constants used in the main random number generator + RNG_STATE_TYPE , parameter :: IMinstdA = 48271 + RNG_STATE_TYPE , parameter :: IMinstdM = 2147483647 + + ! An alternative value of A that can be used to initialize the + ! members of the state from a single seed + RNG_STATE_TYPE , parameter :: IMinstdA0 = 16807 + + ! Scaling to convert the state to a uniform deviate in the range 0 + ! to 1 in working precision + real(kind=jprb), parameter :: IMinstdScale = 1.0_jprb / real(IMinstdM,jprb) + + !--------------------------------------------------------------------- + ! A random number generator type: after being initialized with a + ! seed, type and optionally a number of vector streams, subsequent + ! calls to "uniform_distribution" are used to fill 1D or 2D arrays + ! with random numbers in a way that ought to be fast. + type rng_type + + integer(kind=jpim) :: itype = IRngNative + RNG_STATE_TYPE :: istate(NMaxStreams) + integer(kind=jpim) :: nmaxstreams = NMaxStreams + integer(kind=jpim) :: iseed + + contains + procedure :: initialize + procedure :: uniform_distribution_1d, & + & uniform_distribution_2d, & + & uniform_distribution_2d_masked + generic :: uniform_distribution => uniform_distribution_1d, & + & uniform_distribution_2d, & + & uniform_distribution_2d_masked + + end type rng_type + +contains + + !--------------------------------------------------------------------- + ! Initialize a random number generator, where "itype" may be either + ! IRngNative, indicating to use Fortran's native random_number + ! subroutine, or IRngMinstdVector, indicating to use the MINSTD + ! linear congruential generator (LCG). In the latter case + ! "nmaxstreams" should be provided indicating that random numbers + ! will be requested in blocks of this length. The generator is + ! seeded with "iseed". + subroutine initialize(this, itype, iseed, nmaxstreams) + + class(rng_type), intent(inout) :: this + integer(kind=jpim), intent(in), optional :: itype + integer(kind=jpim), intent(in), optional :: iseed + integer(kind=jpim), intent(in), optional :: nmaxstreams + + integer, allocatable :: iseednative(:) + integer :: nseed, jseed, jstr + real(jprd) :: rseed ! Note this must be in double precision + + if (present(itype)) then + this%itype = itype + else + this%itype = IRngNative + end if + + if (present(iseed)) then + this%iseed = iseed + else + this%iseed = 1 + end if + + if (present(nmaxstreams)) then + this%nmaxstreams = nmaxstreams + else + this%nmaxstreams = NMaxStreams + end if + + if (this%itype == IRngMinstdVector) then + ! ! OPTION 1: Use the C++ minstd_rand0 algorithm to populate the + ! ! state: this loop is not vectorizable because the state in + ! ! one stream depends on the one in the previous stream. + ! this%istate(1) = this%iseed + ! do jseed = 2,this%nmaxstreams + ! this%istate(jseed) = mod(IMinstdA0 * this%istate(jseed-1), IMinstdM) + ! end do + + ! OPTION 2: Use a modified (and vectorized) C++ minstd_rand0 algorithm to + ! populate the state + rseed = real(abs(this%iseed),jprd) + do jstr = 1,this%nmaxstreams + ! Note that nint returns an integer of type jpib (8-byte) + ! which may be converted to double if that is the type of + ! istate + this%istate(jstr) = nint(mod(rseed*jstr*(1.0_jprd-0.05_jprd*jstr & + & +0.005_jprd*jstr**2)*IMinstdA0, real(IMinstdM,jprd)),kind=jpib) + end do + + ! One warmup of the C++ minstd_rand algorithm + do jstr = 1,this%nmaxstreams + this%istate(jstr) = mod(IMinstdA * this%istate(jstr), IMinstdM) + end do + + else + ! Native generator by default + call random_seed(size=nseed) + allocate(iseednative(nseed)) + do jseed = 1,nseed + iseednative(jseed) = this%iseed + jseed - 1 + end do + call random_seed(put=iseednative) + deallocate(iseednative) + end if + + end subroutine initialize + + !--------------------------------------------------------------------- + ! Populate vector "randnum" with pseudo-random numbers; if rannum is + ! of length greater than nmaxstreams (specified when the generator + ! was initialized) then only the first nmaxstreams elements will be + ! assigned. + subroutine uniform_distribution_1d(this, randnum) + + class(rng_type), intent(inout) :: this + real(kind=jprb), intent(out) :: randnum(:) + + integer :: imax, i + + if (this%itype == IRngMinstdVector) then + + imax = min(this%nmaxstreams, size(randnum)) + + ! C++ minstd_rand algorithm + do i = 1, imax + ! The following calculation is computed entirely with 8-byte + ! numbers (whether real or integer) + this%istate(i) = mod(IMinstdA * this%istate(i), IMinstdM) + ! Scale the current state to a number in working precision + ! (jprb) between 0 and 1 + randnum(i) = IMinstdScale * this%istate(i) + end do + + else + + call random_number(randnum) + + end if + + end subroutine uniform_distribution_1d + + + !--------------------------------------------------------------------- + ! Populate matrix "randnum" with pseudo-random numbers; if the inner + ! dimension of rannum is of length greater than nmaxstreams + ! (specified when the generator was initialized) then only the first + ! nmaxstreams elements along this dimension will be assigned. + subroutine uniform_distribution_2d(this, randnum) + + class(rng_type), intent(inout) :: this + real(kind=jprb), intent(out) :: randnum(:,:) + + integer :: imax, jblock, i + + if (this%itype == IRngMinstdVector) then + + imax = min(this%nmaxstreams, size(randnum,1)) + + ! C++ minstd_ran algorithm + do jblock = 1,size(randnum,2) + ! These lines should be vectorizable + do i = 1, imax + this%istate(i) = mod(IMinstdA * this%istate(i), IMinstdM) + randnum(i,jblock) = IMinstdScale * this%istate(i) + end do + end do + + else + + call random_number(randnum) + + end if + + end subroutine uniform_distribution_2d + + !--------------------------------------------------------------------- + ! Populate matrix "randnum" with pseudo-random numbers; if the inner + ! dimension of rannum is of length greater than nmaxstreams + ! (specified when the generator was initialized) then only the first + ! nmaxstreams elements along this dimension will be assigned. This + ! version only operates on outer dimensions for which "mask" is true. + subroutine uniform_distribution_2d_masked(this, randnum, mask) + + class(rng_type), intent(inout) :: this + real(kind=jprb), intent(inout) :: randnum(:,:) + logical, intent(in) :: mask(:) + + integer :: imax, jblock, i + + if (this%itype == IRngMinstdVector) then + + imax = min(this%nmaxstreams, size(randnum,1)) + + ! C++ minstd_ran algorithm + do jblock = 1,size(randnum,2) + if (mask(jblock)) then + ! These lines should be vectorizable + do i = 1, imax + this%istate(i) = mod(IMinstdA * this%istate(i), IMinstdM) + randnum(i,jblock) = IMinstdScale * this%istate(i) + end do + end if + end do + + else + + do jblock = 1,size(randnum,2) + if (mask(jblock)) then + call random_number(randnum(:,jblock)) + end if + end do + + end if + + end subroutine uniform_distribution_2d_masked + + !--------------------------------------------------------------------- + ! Initialize a random number generator, using the MINSTD + ! linear congruential generator (LCG). The generator is + ! seeded with "iseed" and "jseed". + ! Note that this function is not used but manually inlined as the compiler didnot succed. + ! The seperate function stays in the code, so that hopefully, when the + ! compiler issue is fixed, it can be used instead of the manual inline. + pure function initialize_acc(iseed, jseed) result(istate) + + integer(kind=jpim), intent(in) :: iseed + integer, intent(in) :: jseed + + real(kind=jprb) :: istate + + !$ACC ROUTINE SEQ + + istate = REAL(ABS(iseed),jprb) + ! Use a modified (and vectorized) C++ minstd_rand0 algorithm to populate the state + istate = nint(mod( istate*jseed*(1._jprb-0.05_jprb*jseed+0.005_jprb*jseed**2)*IMinstdA0, IMinstdM)) + + ! One warmup of the C++ minstd_rand algorithm + istate = mod(IMinstdA * istate, IMinstdM) + + end function initialize_acc + + !--------------------------------------------------------------------- + ! Populate vector "randnum" with pseudo-random numbers; if rannum is + ! of length greater than nmaxstreams (specified when the generator + ! was initialized) then only the first nmaxstreams elements will be + ! assigned. + function uniform_distribution_acc(istate) result(randnum) + + real(kind=jprb), intent(inout) :: istate + real(kind=jprb) :: randnum + + !$ACC ROUTINE SEQ + + ! C++ minstd_rand algorithm + istate = mod(IMinstdA * istate, IMinstdM) + randnum = IMinstdScale * istate + + end function uniform_distribution_acc + + +end module radiation_random_numbers + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_regions.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_regions.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_regions.F90 (revision 6016) @@ -0,0 +1,202 @@ +! radiation_regions.F90 -- Properties of horizontal regions in Tripleclouds & SPARTACUS +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-07-14 R. Hogan Incorporate gamma distribution option +! 2018-10-06 R. Hogan Merged from radiation_optical_depth_scaling.h and radiation_overlap.F90 + +module radiation_regions + + implicit none + + public :: calc_region_properties + +contains + + !--------------------------------------------------------------------- + ! Compute the optical depth scalings for the optically "thick" and + ! "thin" regions of a Tripleclouds representation of a sub-grid PDF + ! of cloud optical depth. Following Shonk and Hogan (2008), the 16th + ! percentile is used for the thin region, and the formulas estimate + ! this for both lognormal and gamma distributions. However, an + ! adjustment is needed for the gamma distribution at large + ! fractional standard deviations. + subroutine calc_region_properties(nlev, nreg, istartcol, iendcol, do_gamma, & + & cloud_fraction, frac_std, reg_fracs, od_scaling, cloud_fraction_threshold) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + + ! Minimum od_scaling in the case of a Gamma distribution + real(jprb), parameter :: MinGammaODScaling = 0.025_jprb + + ! At large fractional standard deviations (FSDs), we cannot + ! capture the behaviour of a gamma distribution with two equally + ! weighted points; we need to weight the first ("lower") point + ! more. The weight of the first point is normally 0.5, but for + ! FSDs between 1.5 and 3.725 it rises linearly to 0.9, and for + ! higher FSD it is capped at this value. The weight of the second + ! point is one minus the first point. + real(jprb), parameter :: MinLowerFrac = 0.5_jprb + real(jprb), parameter :: MaxLowerFrac = 0.9_jprb + real(jprb), parameter :: FSDAtMinLowerFrac = 1.5_jprb + real(jprb), parameter :: FSDAtMaxLowerFrac = 3.725_jprb + ! Between FSDAtMinLowerFrac and FSDAtMaxLowerFrac, + ! LowerFrac=LowerFracFSDIntercept+FSD*LowerFracFSDGradient + real(jprb), parameter :: LowerFracFSDGradient & + & = (MaxLowerFrac-MinLowerFrac) / (FSDAtMaxLowerFrac-FSDAtMinLowerFrac) + real(jprb), parameter :: LowerFracFSDIntercept & + & = MinLowerFrac - FSDAtMinLowerFrac*LowerFracFSDGradient + + ! Number of levels and regions + integer, intent(in) :: nlev, nreg + + ! Range of columns to process + integer, intent(in) :: istartcol, iendcol + + ! Do we do a lognormal or gamma distribution? + logical, intent(in) :: do_gamma + + ! Cloud fraction, i.e. the fraction of the gridbox assigned to all + ! regions numbered 2 and above (region 1 is clear sky) + real(jprb), intent(in), dimension(:,:) :: cloud_fraction ! (ncol,nlev) + + ! Fractional standard deviation of in-cloud water content + real(jprb), intent(in), dimension(:,:) :: frac_std ! (ncol,nlev) + + ! Fractional area coverage of each region + real(jprb), intent(out) :: reg_fracs(1:nreg,nlev,istartcol:iendcol) + + ! Optical depth scaling for the cloudy regions + real(jprb), intent(out) :: od_scaling(2:nreg,nlev,istartcol:iendcol) + + ! Regions smaller than this are ignored + real(jprb), intent(in), optional :: cloud_fraction_threshold + + ! In case the user doesn't supply cloud_fraction_threshold we use + ! a default value + real(jprb) :: frac_threshold + + ! Loop indices + integer :: jcol, jlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_region_properties:calc_region_properties',0,hook_handle) + + if (present(cloud_fraction_threshold)) then + frac_threshold = cloud_fraction_threshold + else + frac_threshold = 1.0e-20_jprb + end if + + if (nreg == 2) then + ! Only one clear-sky and one cloudy region: cloudy region is + ! homogeneous + reg_fracs(2,1:nlev,istartcol:iendcol) = transpose(cloud_fraction(istartcol:iendcol,1:nlev)) + reg_fracs(1,1:nlev,istartcol:iendcol) = 1.0_jprb - reg_fracs(2,1:nlev,istartcol:iendcol) + od_scaling(2,1:nlev,istartcol:iendcol) = 1.0_jprb + + else if (nreg == 3) then + ! Two cloudy regions with optical depth scaled by 1-x and + ! 1+x. + ! Simple version which fails when fractional_std >= 1: + !od_scaling(2) = 1.0_jprb-cloud%fractional_std(jcol,jlev) + ! According to Shonk and Hogan (2008), 1-FSD should correspond to + ! the 16th percentile. + if (.not. do_gamma) then + ! If we treat the distribution as a lognormal such that the + ! equivalent Normal has a mean mu and standard deviation + ! sigma, then the 16th percentile of the lognormal is very + ! close to exp(mu-sigma). + do jcol = istartcol,iendcol + do jlev = 1,nlev + if (cloud_fraction(jcol,jlev) < frac_threshold) then + reg_fracs(1,jlev,jcol) = 1.0_jprb + reg_fracs(2:3,jlev,jcol) = 0.0_jprb + od_scaling(2:3,jlev,jcol) = 1.0_jprb + else + reg_fracs(1,jlev,jcol) = 1.0_jprb - cloud_fraction(jcol,jlev) + reg_fracs(2:3,jlev,jcol) = cloud_fraction(jcol,jlev)*0.5_jprb + od_scaling(2,jlev,jcol) & + & = exp(-sqrt(log(frac_std(jcol,jlev)**2+1))) & + & / sqrt(frac_std(jcol,jlev)**2+1) + od_scaling(3,jlev,jcol) = 2.0_jprb - od_scaling(2,jlev,jcol) + end if + end do + end do + else + ! If we treat the distribution as a gamma then the 16th + ! percentile is close to the following. Note that because it + ! becomes vanishingly small for FSD >~ 2, we have a lower + ! limit of 1/40, and for higher FSDs reduce the fractional + ! cover of the denser region - see region_fractions routine + ! below + do jcol = istartcol,iendcol + do jlev = 1,nlev + if (cloud_fraction(jcol,jlev) < frac_threshold) then + reg_fracs(1,jlev,jcol) = 1.0_jprb + reg_fracs(2:3,jlev,jcol) = 0.0_jprb + od_scaling(2:3,jlev,jcol) = 1.0_jprb + else + ! Fraction of the clear-sky region + reg_fracs(1,jlev,jcol) = 1.0_jprb - cloud_fraction(jcol,jlev) +!#define OLD_GAMMA_REGION_BEHAVIOUR 1 +#ifdef OLD_GAMMA_REGION_BEHAVIOUR + ! Use previous behaviour (ecRad version 1.1.5 and + ! earlier): cloudy fractions are the same and there is + ! no minimum optical depth scaling; this tends to lead + ! to an overprediction of the reflection from scenes + ! with a large fractional standard deviation of optical + ! depth. + ! Fraction and optical-depth scaling of the lower of the + ! two cloudy regions + reg_fracs(2,jlev,jcol) = cloud_fraction(jcol,jlev) * 0.5_jprb + od_scaling(2,jlev,jcol) = & + & exp(-frac_std(jcol,jlev)*(1.0_jprb + 0.5_jprb*frac_std(jcol,jlev) & + & *(1.0_jprb+0.5_jprb*frac_std(jcol,jlev)))) + +#else + ! Improved behaviour. + ! Fraction and optical-depth scaling of the lower of the + ! two cloudy regions + reg_fracs(2,jlev,jcol) = cloud_fraction(jcol,jlev) & + & * max(MinLowerFrac, min(MaxLowerFrac, & + & LowerFracFSDIntercept + frac_std(jcol,jlev)*LowerFracFSDGradient)) + od_scaling(2,jlev,jcol) = MinGammaODScaling & + & + (1.0_jprb - MinGammaODScaling) & + & * exp(-frac_std(jcol,jlev)*(1.0_jprb + 0.5_jprb*frac_std(jcol,jlev) & + & *(1.0_jprb+0.5_jprb*frac_std(jcol,jlev)))) +#endif + ! Fraction of the upper of the two cloudy regions + reg_fracs(3,jlev,jcol) = 1.0_jprb-reg_fracs(1,jlev,jcol)-reg_fracs(2,jlev,jcol) + ! Ensure conservation of the mean optical depth + od_scaling(3,jlev,jcol) = (cloud_fraction(jcol,jlev) & + & -reg_fracs(2,jlev,jcol)*od_scaling(2,jlev,jcol)) / reg_fracs(3,jlev,jcol) + end if + end do + end do + end if + else ! nreg > 3 + write(nulerr,'(a)') '*** Error: only 2 or 3 regions may be specified' + call radiation_abort() + end if + + if (lhook) call dr_hook('radiation_region_properties:calc_region_properties',1,hook_handle) + + end subroutine calc_region_properties + +end module radiation_regions + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_save.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_save.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_save.F90 (revision 6016) @@ -0,0 +1,1475 @@ +! radiation_save.F90 - Save data to NetCDF files +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-22 R. Hogan Adapt for new way of describing longwave properties +! 2019-01-02 R. Hogan Only save cloud properties if do_clouds==.true. + +module radiation_save + + use parkind1, only : jprb + + implicit none + + ! Save final fluxes and save intermediate radiative properties + public :: save_fluxes, save_radiative_properties, save_inputs + ! Save net fluxes IFS style, where upwelling fluxes are actually net down + public :: save_net_fluxes + +contains + + !--------------------------------------------------------------------- + ! Save fluxes in "flux" to NetCDF file_name, plus pressure from the + ! thermodynamics object + subroutine save_fluxes(file_name, config, thermodynamics, flux, & + & iverbose, is_hdf5_file, experiment_name, & + & is_double_precision) + + use yomhook, only : lhook, dr_hook, jphook + + use easy_netcdf + + use radiation_io, only : nulout + use radiation_config, only : config_type, IGasModelMonochromatic + use radiation_thermodynamics, only : thermodynamics_type + use radiation_flux, only : flux_type + + character(len=*), intent(in) :: file_name + type(config_type), intent(in) :: config + type(thermodynamics_type), intent(in) :: thermodynamics + type(flux_type), intent(in) :: flux + integer, optional, intent(in) :: iverbose + logical, optional, intent(in) :: is_hdf5_file + logical, optional, intent(in) :: is_double_precision + character(len=*), optional, intent(in) :: experiment_name + + type(netcdf_file) :: out_file + integer :: ncol, n_lev_plus1 + character(5), parameter :: default_lw_units_str = 'W m-2' + character(5) :: lw_units_str + integer :: i_local_verbose + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_save:save_fluxes',0,hook_handle) + + if (present(iverbose)) then + i_local_verbose = iverbose + else + i_local_verbose = config%iverbose + end if + + ! Work out array dimensions + if (config%do_sw) then + ncol = size(flux%sw_up,1) + n_lev_plus1 = size(flux%sw_up,2) + elseif (config%do_lw) then + ncol = size(flux%lw_up,1) + n_lev_plus1 = size(flux%lw_up,2) + else + if (i_local_verbose >= 1) then + write(nulout,'(a,a,a)') 'Warning: neither longwave nor shortwave computed so ', & + & trim(file_name),' not written' + end if + return + end if + + if (config%i_gas_model_lw == IGasModelMonochromatic & + .and. config%mono_lw_wavelength > 0.0_jprb) then + lw_units_str = 'W m-3' + else + lw_units_str = default_lw_units_str + end if + + ! Open the file + call out_file%create(trim(file_name), iverbose=i_local_verbose, is_hdf5_file=is_hdf5_file) + + ! Variables stored internally with column varying fastest, but in + ! output file column varies most slowly so need to transpose + call out_file%transpose_matrices(.true.) + + ! Set default precision for file, if specified + if (present(is_double_precision)) then + call out_file%double_precision(is_double_precision) + end if + + ! Spectral fluxes in memory are dimensioned (nband,ncol,nlev), but + ! are reoriented in the output file to be (nband,nlev,ncol), where + ! the convention here is first dimension varying fastest + call out_file%permute_3d_arrays( (/ 1, 3, 2 /) ) + + ! Define dimensions + call out_file%define_dimension("column", ncol) + call out_file%define_dimension("half_level", n_lev_plus1) + + if (config%do_save_spectral_flux .or. config%do_toa_spectral_flux) then + if (config%do_lw) then + call out_file%define_dimension("band_lw", config%n_spec_lw) + end if + if (config%do_sw) then + call out_file%define_dimension("band_sw", config%n_spec_sw) + end if + else if (config%do_surface_sw_spectral_flux) then + if (config%do_sw) then + call out_file%define_dimension("band_sw", config%n_bands_sw) + end if + end if + + if (config%do_lw .and. config%do_canopy_fluxes_lw) then + call out_file%define_dimension("canopy_band_lw", & + & size(flux%lw_dn_surf_canopy, 1)) + end if + if (config%do_sw .and. config%do_canopy_fluxes_sw) then + call out_file%define_dimension("canopy_band_sw", & + & size(flux%sw_dn_diffuse_surf_canopy, 1)) + end if + + ! Put global attributes + call out_file%put_global_attributes( & + & title_str="Radiative flux profiles from the ecRad offline radiation model", & + & references_str="Hogan, R. J., and A. Bozzo, 2018: A flexible and efficient radiation " & + & //"scheme for the ECMWF model. J. Adv. Modeling Earth Sys., 10, 1990–2008", & + & source_str="ecRad offline radiation model") + + ! Save "experiment" global attribute if present and not empty + if (present(experiment_name)) then + if (experiment_name /= " ") then + call out_file%put_global_attribute("experiment", experiment_name) + end if + end if + + ! Define variables + call out_file%define_variable("pressure_hl", & + & dim2_name="column", dim1_name="half_level", & + & units_str="Pa", long_name="Pressure", & + & standard_name="air_pressure") + + if (config%do_lw) then + call out_file%define_variable("flux_up_lw", & + & dim2_name="column", dim1_name="half_level", & + & units_str=lw_units_str, long_name="Upwelling longwave flux", & + & standard_name="upwelling_longwave_flux_in_air") + call out_file%define_variable("flux_dn_lw", & + & dim2_name="column", dim1_name="half_level", & + & units_str=lw_units_str, long_name="Downwelling longwave flux", & + & standard_name="downwelling_longwave_flux_in_air") + if (config%do_clear) then + call out_file%define_variable("flux_up_lw_clear", & + & dim2_name="column", dim1_name="half_level", & + & units_str=lw_units_str, & + & long_name="Upwelling clear-sky longwave flux") + call out_file%define_variable("flux_dn_lw_clear", & + & dim2_name="column", dim1_name="half_level", & + & units_str=lw_units_str, & + & long_name="Downwelling clear-sky longwave flux") + end if + + if (config%do_lw_derivatives) then + call out_file%define_variable("lw_derivative", & + & dim2_name="column", dim1_name="half_level", & + & units_str="1", & + & long_name="Derivative of upwelling LW flux w.r.t. surface value") + end if + + if (config%do_save_spectral_flux) then + call out_file%define_variable("spectral_flux_up_lw", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_lw", units_str=lw_units_str, & + & long_name="Spectral upwelling longwave flux") + call out_file%define_variable("spectral_flux_dn_lw", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_lw", units_str=lw_units_str, & + & long_name="Spectral downwelling longwave flux") + if (config%do_clear) then + call out_file%define_variable("spectral_flux_up_lw_clear", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_lw", units_str=lw_units_str, & + & long_name="Spectral upwelling clear-sky longwave flux") + call out_file%define_variable("spectral_flux_dn_lw_clear", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_lw", units_str=lw_units_str, & + & long_name="Spectral downwelling clear-sky longwave flux") + end if + end if + + if (config%do_toa_spectral_flux) then + call out_file%define_variable("spectral_flux_up_lw_toa", & + & dim2_name="column", dim1_name="band_lw", units_str="W m-2", & + & long_name="Spectral upwelling longwave flux at top-of-atmosphere") + if (config%do_clear) then + call out_file%define_variable("spectral_flux_up_lw_toa_clear", & + & dim2_name="column", dim1_name="band_lw", units_str="W m-2", & + & long_name="Spectral upwelling clear-sky longwave flux at top-of-atmosphere") + end if + end if + + if (config%do_canopy_fluxes_lw) then + call out_file%define_variable("canopy_flux_dn_lw_surf", & + & dim2_name="column", dim1_name="canopy_band_lw", units_str=lw_units_str, & + & long_name="Surface downwelling longwave flux in canopy bands") + end if + + end if + + if (config%do_sw) then + call out_file%define_variable("flux_up_sw", & + & dim2_name="column", dim1_name="half_level", & + & units_str="W m-2", long_name="Upwelling shortwave flux", & + & standard_name="upwelling_shortwave_flux_in_air") + call out_file%define_variable("flux_dn_sw", & + & dim2_name="column", dim1_name="half_level", & + & units_str="W m-2", long_name="Downwelling shortwave flux", & + & standard_name="downwelling_shortwave_flux_in_air") + if (config%do_sw_direct) then + call out_file%define_variable("flux_dn_direct_sw", & + & dim2_name="column", dim1_name="half_level", & + & units_str="W m-2", & + & long_name="Downwelling direct shortwave flux") + end if + if (config%do_clear) then + call out_file%define_variable("flux_up_sw_clear", & + & dim2_name="column", dim1_name="half_level", & + & units_str="W m-2", & + & long_name="Upwelling clear-sky shortwave flux") + call out_file%define_variable("flux_dn_sw_clear", & + & dim2_name="column", dim1_name="half_level", & + & units_str="W m-2", & + & long_name="Downwelling clear-sky shortwave flux") + if (config%do_sw_direct) then + call out_file%define_variable("flux_dn_direct_sw_clear", & + & dim2_name="column", dim1_name="half_level", & + & units_str="W m-2", & + & long_name="Downwelling clear-sky direct shortwave flux") + end if + end if + + if (config%do_save_spectral_flux) then + call out_file%define_variable("spectral_flux_up_sw", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral upwelling shortwave flux") + call out_file%define_variable("spectral_flux_dn_sw", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling shortwave flux") + if (config%do_sw_direct) then + call out_file%define_variable("spectral_flux_dn_direct_sw", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling direct shortwave flux") + end if + if (config%do_clear) then + call out_file%define_variable("spectral_flux_up_sw_clear", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral upwelling clear-sky shortwave flux") + call out_file%define_variable("spectral_flux_dn_sw_clear", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling clear-sky shortwave flux") + if (config%do_sw_direct) then + call out_file%define_variable("spectral_flux_dn_direct_sw_clear", & + & dim3_name="column", dim2_name="half_level", & + & dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling clear-sky direct shortwave flux") + end if + end if + else if (config%do_surface_sw_spectral_flux) then + call out_file%define_variable("spectral_flux_dn_sw_surf", & + & dim2_name="column", dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling shortwave flux at surface") + call out_file%define_variable("spectral_flux_dn_direct_sw_surf", & + & dim2_name="column", dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling direct shortwave flux at surface") + if (config%do_clear) then + call out_file%define_variable("spectral_flux_dn_sw_surf_clear", & + & dim2_name="column", dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling clear-sky shortwave flux at surface") + call out_file%define_variable("spectral_flux_dn_direct_sw_surf_clear", & + & dim2_name="column", dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling clear-sky direct shortwave flux at surface") + end if + end if + + if (config%do_toa_spectral_flux) then + call out_file%define_variable("spectral_flux_dn_sw_toa", & + & dim2_name="column", dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral downwelling shortwave flux at top-of-atmosphere") + call out_file%define_variable("spectral_flux_up_sw_toa", & + & dim2_name="column", dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral upwelling shortwave flux at top-of-atmosphere") + if (config%do_clear) then + call out_file%define_variable("spectral_flux_up_sw_toa_clear", & + & dim2_name="column", dim1_name="band_sw", units_str="W m-2", & + & long_name="Spectral upwelling clear-sky shortwave flux at top-of-atmosphere") + end if + end if + + if (config%do_canopy_fluxes_sw) then + call out_file%define_variable("canopy_flux_dn_diffuse_sw_surf", & + & dim2_name="column", dim1_name="canopy_band_sw", units_str="W m-2", & + & long_name="Surface downwelling diffuse shortwave flux in canopy bands") + call out_file%define_variable("canopy_flux_dn_direct_sw_surf", & + & dim2_name="column", dim1_name="canopy_band_sw", units_str="W m-2", & + & long_name="Surface downwelling direct shortwave flux in canopy bands") + end if + + end if + + if (config%do_lw .and. config%do_clouds) then + call out_file%define_variable("cloud_cover_lw", & + & dim1_name="column", units_str="1", & + & long_name="Total cloud cover diagnosed by longwave solver", & + & standard_name="cloud_area_fraction") + end if + if (config%do_sw .and. config%do_clouds) then + call out_file%define_variable("cloud_cover_sw", & + & dim1_name="column", units_str="1", & + & long_name="Total cloud cover diagnosed by shortwave solver", & + & standard_name="cloud_area_fraction") + end if + + ! Write variables + + call out_file%put("pressure_hl", thermodynamics%pressure_hl) + + if (config%do_lw) then + call out_file%put("flux_up_lw", flux%lw_up) + call out_file%put("flux_dn_lw", flux%lw_dn) + if (config%do_clear) then + call out_file%put("flux_up_lw_clear", flux%lw_up_clear) + call out_file%put("flux_dn_lw_clear", flux%lw_dn_clear) + end if + + if (config%do_lw_derivatives) then + call out_file%put("lw_derivative", flux%lw_derivatives) + end if + + if (config%do_save_spectral_flux) then + call out_file%put("spectral_flux_up_lw", flux%lw_up_band) + call out_file%put("spectral_flux_dn_lw", flux%lw_dn_band) + if (config%do_clear) then + call out_file%put("spectral_flux_up_lw_clear", flux%lw_up_clear_band) + call out_file%put("spectral_flux_dn_lw_clear", flux%lw_dn_clear_band) + end if + end if + + if (config%do_toa_spectral_flux) then + call out_file%put("spectral_flux_up_lw_toa", flux%lw_up_toa_band, & + & do_transp=.false.) + if (config%do_clear) then + call out_file%put("spectral_flux_up_lw_toa_clear", flux%lw_up_toa_clear_band, & + & do_transp=.false.) + end if + end if + + if (config%do_canopy_fluxes_lw) then + call out_file%put("canopy_flux_dn_lw_surf", flux%lw_dn_surf_canopy, & + & do_transp = .false.) + end if + + end if + + if (config%do_sw) then + call out_file%put("flux_up_sw", flux%sw_up) + call out_file%put("flux_dn_sw", flux%sw_dn) + if (config%do_sw_direct) then + call out_file%put("flux_dn_direct_sw", flux%sw_dn_direct) + end if + if (config%do_clear) then + call out_file%put("flux_up_sw_clear", flux%sw_up_clear) + call out_file%put("flux_dn_sw_clear", flux%sw_dn_clear) + if (config%do_sw_direct) then + call out_file%put("flux_dn_direct_sw_clear", flux%sw_dn_direct_clear) + end if + end if + + if (config%do_save_spectral_flux) then + call out_file%put("spectral_flux_up_sw", flux%sw_up_band) + call out_file%put("spectral_flux_dn_sw", flux%sw_dn_band) + if (config%do_sw_direct) then + call out_file%put("spectral_flux_dn_direct_sw", & + & flux%sw_dn_direct_band) + end if + if (config%do_clear) then + call out_file%put("spectral_flux_up_sw_clear", flux%sw_up_clear_band) + call out_file%put("spectral_flux_dn_sw_clear", flux%sw_dn_clear_band) + if (config%do_sw_direct) then + call out_file%put("spectral_flux_dn_direct_sw_clear", & + & flux%sw_dn_direct_clear_band) + end if + end if + else if (config%do_surface_sw_spectral_flux) then + call out_file%put("spectral_flux_dn_sw_surf", flux%sw_dn_surf_band, & + & do_transp=.false.) + call out_file%put("spectral_flux_dn_direct_sw_surf", flux%sw_dn_direct_surf_band, & + & do_transp=.false.) + if (config%do_clear) then + call out_file%put("spectral_flux_dn_sw_surf_clear", flux%sw_dn_surf_clear_band, & + & do_transp=.false.) + call out_file%put("spectral_flux_dn_direct_sw_surf_clear", & + & flux%sw_dn_direct_surf_clear_band, do_transp=.false.) + end if + end if + + if (config%do_toa_spectral_flux) then + call out_file%put("spectral_flux_dn_sw_toa", flux%sw_dn_toa_band, & + & do_transp=.false.) + call out_file%put("spectral_flux_up_sw_toa", flux%sw_up_toa_band, & + & do_transp=.false.) + if (config%do_clear) then + call out_file%put("spectral_flux_up_sw_toa_clear", flux%sw_up_toa_clear_band, & + & do_transp=.false.) + end if + end if + + if (config%do_canopy_fluxes_sw) then + call out_file%put("canopy_flux_dn_diffuse_sw_surf", flux%sw_dn_diffuse_surf_canopy, & + & do_transp = .false.) + call out_file%put("canopy_flux_dn_direct_sw_surf", flux%sw_dn_direct_surf_canopy, & + & do_transp = .false.) + end if + + end if + + if (config%do_lw .and. config%do_clouds) then + call out_file%put("cloud_cover_lw", flux%cloud_cover_lw) + end if + if (config%do_sw .and. config%do_clouds) then + call out_file%put("cloud_cover_sw", flux%cloud_cover_sw) + end if + + ! Close file + call out_file%close() + + if (lhook) call dr_hook('radiation_save:save_fluxes',1,hook_handle) + + end subroutine save_fluxes + + + !--------------------------------------------------------------------- + ! Save IFS-style net fluxes in "flux" to NetCDF file_name, plus + ! pressure from the thermodynamics object + subroutine save_net_fluxes(file_name, config, thermodynamics, flux, & + & iverbose, is_hdf5_file, experiment_name, & + & is_double_precision) + + use yomhook, only : lhook, dr_hook, jphook + + use easy_netcdf + + use radiation_io, only : nulout + use radiation_config, only : config_type, IGasModelMonochromatic + use radiation_thermodynamics, only : thermodynamics_type + use radiation_flux, only : flux_type + + character(len=*), intent(in) :: file_name + type(config_type), intent(in) :: config + type(thermodynamics_type), intent(in) :: thermodynamics + type(flux_type), intent(in) :: flux + integer, optional, intent(in) :: iverbose + logical, optional, intent(in) :: is_hdf5_file + logical, optional, intent(in) :: is_double_precision + character(len=*), optional, intent(in) :: experiment_name + + type(netcdf_file) :: out_file + integer :: ncol, n_lev_plus1 + character(5), parameter :: default_lw_units_str = 'W m-2' + character(5) :: lw_units_str + integer :: i_local_verbose + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_save:save_net_fluxes',0,hook_handle) + + if (present(iverbose)) then + i_local_verbose = iverbose + else + i_local_verbose = config%iverbose + end if + + ! Work out array dimensions + if (config%do_sw) then + ncol = size(flux%sw_up,1) + n_lev_plus1 = size(flux%sw_up,2) + elseif (config%do_lw) then + ncol = size(flux%lw_up,1) + n_lev_plus1 = size(flux%lw_up,2) + else + if (i_local_verbose >= 1) then + write(nulout,'(a,a,a)') 'Warning: neither longwave nor shortwave computed so ', & + & file_name,' not written' + end if + return + end if + + if (config%i_gas_model_lw == IGasModelMonochromatic & + .and. config%mono_lw_wavelength > 0.0_jprb) then + lw_units_str = 'W m-3' + else + lw_units_str = default_lw_units_str + end if + + ! Open the file + call out_file%create(trim(file_name), iverbose=i_local_verbose, is_hdf5_file=is_hdf5_file) + + ! Variables stored internally with column varying fastest, but in + ! output file column varies most slowly so need to transpose + call out_file%transpose_matrices(.true.) + + ! Set default precision for file, if specified + if (present(is_double_precision)) then + call out_file%double_precision(is_double_precision) + end if + + ! Spectral fluxes in memory are dimensioned (nband,ncol,nlev), but + ! are reoriented in the output file to be (nband,nlev,ncol), where + ! the convention here is first dimension varying fastest + call out_file%permute_3d_arrays( (/ 1, 3, 2 /) ) + + ! Define dimensions + call out_file%define_dimension("column", ncol) + call out_file%define_dimension("half_level", n_lev_plus1) + + if (config%do_lw .and. config%do_canopy_fluxes_lw) then + call out_file%define_dimension("canopy_band_lw", & + & size(flux%lw_dn_surf_canopy, 1)) + end if + if (config%do_sw .and. config%do_canopy_fluxes_sw) then + call out_file%define_dimension("canopy_band_sw", & + & size(flux%sw_dn_diffuse_surf_canopy, 1)) + end if + + ! Put global attributes + call out_file%put_global_attributes( & + & title_str="Radiative flux profiles from the ecRad offline radiation model", & + & references_str="Hogan, R. J., and A. Bozzo, 2018: A flexible and efficient radiation " & + & //"scheme for the ECMWF model. J. Adv. Modeling Earth Sys., 10, 1990–2008", & + & source_str="ecRad offline radiation model") + + ! Save "experiment" global attribute if present and not empty + if (present(experiment_name)) then + if (experiment_name /= " ") then + call out_file%put_global_attribute("experiment", experiment_name) + end if + end if + + ! Define variables + call out_file%define_variable("pressure_hl", & + & dim2_name="column", dim1_name="half_level", & + & units_str="Pa", long_name="Pressure", & + & standard_name="air_pressure") + + if (config%do_lw) then + call out_file%define_variable("flux_net_lw", & + & dim2_name="column", dim1_name="half_level", & + & units_str=lw_units_str, long_name="Net downward longwave flux", & + & standard_name="net_downward_longwave_flux_in_air") + call out_file%define_variable("flux_dn_lw_surf", & + & dim1_name="column", & + & units_str=lw_units_str, long_name="Surface downwelling longwave flux", & + & standard_name="surface_downwelling_longwave_flux_in_air") + if (config%do_clear) then + call out_file%define_variable("flux_net_lw_clear", & + & dim2_name="column", dim1_name="half_level", & + & units_str=lw_units_str, & + & long_name="Net downward clear-sky longwave flux", & + & standard_name="net_downward_longwave_flux_in_air_assuming_clear_sky") + call out_file%define_variable("flux_dn_lw_clear_surf", & + & dim1_name="column", & + & units_str=lw_units_str, & + & long_name="Surface downwelling clear-sky longwave flux", & + & standard_name="surface_downwelling_longwave_flux_in_air_assuming_clear_sky") + end if + + if (config%do_lw_derivatives) then + call out_file%define_variable("lw_derivative", & + & dim2_name="column", dim1_name="half_level", & + & units_str="1", & + & long_name="Derivative of upwelling LW flux w.r.t. surface value") + end if + + if (config%do_canopy_fluxes_lw) then + call out_file%define_variable("canopy_flux_dn_lw_surf", & + & dim2_name="column", dim1_name="canopy_band_lw", units_str=lw_units_str, & + & long_name="Surface downwelling longwave flux in canopy bands") + end if + + end if + + if (config%do_sw) then + call out_file%define_variable("flux_net_sw", & + & dim2_name="column", dim1_name="half_level", & + & units_str="W m-2", long_name="Net downward shortwave flux", & + & standard_name="net_downward_shortwave_flux_in_air") + call out_file%define_variable("flux_dn_sw_surf", & + & dim1_name="column", & + & units_str="W m-2", long_name="Surface downwelling shortwave flux", & + & standard_name="surface_downwelling_shortwave_flux_in_air") + call out_file%define_variable("flux_dn_sw_toa", & + & dim1_name="column", & + & units_str="W m-2", long_name="Top-of-atmosphere downwelling shortwave flux", & + & standard_name="toa_incoming_shortwave_flux") + if (config%do_sw_direct) then + call out_file%define_variable("flux_dn_direct_sw_surf", & + & dim1_name="column", & + & units_str="W m-2", & + & long_name="Surface downwelling direct shortwave flux") + end if + if (config%do_clear) then + call out_file%define_variable("flux_net_sw_clear", & + & dim2_name="column", dim1_name="half_level", & + & units_str="W m-2", & + & long_name="Net downward clear-sky shortwave flux") + call out_file%define_variable("flux_dn_sw_clear_surf", & + & dim1_name="column", & + & units_str="W m-2", & + & long_name="Surface downwelling clear-sky shortwave flux") + if (config%do_sw_direct) then + call out_file%define_variable("flux_dn_direct_sw_clear_surf", & + & dim1_name="column", & + & units_str="W m-2", & + & long_name="Surface downwelling clear-sky direct shortwave flux") + end if + end if + + if (config%do_canopy_fluxes_sw) then + call out_file%define_variable("canopy_flux_dn_diffuse_sw_surf", & + & dim2_name="column", dim1_name="canopy_band_sw", units_str="W m-2", & + & long_name="Surface downwelling diffuse shortwave flux in canopy bands") + call out_file%define_variable("canopy_flux_dn_direct_sw_surf", & + & dim2_name="column", dim1_name="canopy_band_sw", units_str="W m-2", & + & long_name="Surface downwelling direct shortwave flux in canopy bands") + end if + + end if + + ! Write variables + + call out_file%put("pressure_hl", thermodynamics%pressure_hl) + + if (config%do_lw) then + call out_file%put("flux_net_lw", flux%lw_dn-flux%lw_up) + call out_file%put("flux_dn_lw_surf", flux%lw_dn(:,n_lev_plus1)) + if (config%do_clear) then + call out_file%put("flux_net_lw_clear", flux%lw_dn_clear-flux%lw_up_clear) + call out_file%put("flux_dn_lw_clear_surf", flux%lw_dn_clear(:,n_lev_plus1)) + end if + + if (config%do_lw_derivatives) then + call out_file%put("lw_derivative", flux%lw_derivatives) + end if + + if (config%do_canopy_fluxes_lw) then + call out_file%put("canopy_flux_dn_lw_surf", flux%lw_dn_surf_canopy, & + & do_transp = .false.) + end if + + end if + + if (config%do_sw) then + call out_file%put("flux_net_sw", flux%sw_dn-flux%sw_up) + call out_file%put("flux_dn_sw_surf", flux%sw_dn(:,n_lev_plus1)) + call out_file%put("flux_dn_sw_toa", flux%sw_dn(:,1)) + if (config%do_sw_direct) then + call out_file%put("flux_dn_direct_sw_surf", flux%sw_dn_direct(:,n_lev_plus1)) + end if + if (config%do_clear) then + call out_file%put("flux_net_sw_clear", flux%sw_dn_clear-flux%sw_up_clear) + call out_file%put("flux_dn_sw_clear_surf", flux%sw_dn_clear(:,n_lev_plus1)) + if (config%do_sw_direct) then + call out_file%put("flux_dn_direct_sw_clear_surf", flux%sw_dn_direct_clear(:,n_lev_plus1)) + end if + end if + + if (config%do_canopy_fluxes_sw) then + call out_file%put("canopy_flux_dn_diffuse_sw_surf", flux%sw_dn_diffuse_surf_canopy, & + & do_transp = .false.) + call out_file%put("canopy_flux_dn_direct_sw_surf", flux%sw_dn_direct_surf_canopy, & + & do_transp = .false.) + end if + + end if + + ! Close file + call out_file%close() + + if (lhook) call dr_hook('radiation_save:save_net_fluxes',1,hook_handle) + + end subroutine save_net_fluxes + + + !--------------------------------------------------------------------- + ! Save intermediate radiative properties, specifically the + ! scattering and absorption properties at each g-point/band + subroutine save_radiative_properties(file_name, nlev, & + & istartcol, iendcol, & + & config, single_level, thermodynamics, cloud, & + & planck_hl, lw_emission, lw_albedo, & + & sw_albedo_direct, sw_albedo_diffuse, & + & incoming_sw, & + & od_lw, ssa_lw, g_lw, & + & od_sw, ssa_sw, g_sw, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_thermodynamics,only : thermodynamics_type + use radiation_cloud, only : cloud_type + use easy_netcdf + + character(len=*), intent(in) :: file_name + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type),intent(in) :: thermodynamics + type(cloud_type), intent(in) :: cloud + + integer, intent(in) :: nlev, istartcol, iendcol + + ! Input variables, as defined in radiation_interface.F90 + + ! Layer optical depth, single scattering albedo and asymmetry factor of + ! gases and aerosols at each shortwave g-point + real(jprb), intent(in), dimension(config%n_g_sw,nlev,istartcol:iendcol) :: od_sw, ssa_sw, g_sw + + ! Layer optical depth, single scattering albedo and asymmetry factor of + ! hydrometeors in each shortwave band + real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud + + ! Direct and diffuse surface albedo, and the incoming shortwave + ! flux into a plane perpendicular to the incoming radiation at + ! top-of-atmosphere in each of the shortwave g-points + real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) & + & :: sw_albedo_direct, sw_albedo_diffuse, incoming_sw + + ! Layer optical depth, single scattering albedo and asymmetry factor of + ! gases and aerosols at each longwave g-point, where the latter + ! two variables are only defined if aerosol longwave scattering is + ! enabled (otherwise both are treated as zero). + real(jprb), intent(in), dimension(config%n_g_lw,nlev,istartcol:iendcol) :: od_lw + real(jprb), intent(in), dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol) :: & + & ssa_lw, g_lw + + ! Layer optical depth, single scattering albedo and asymmetry factor of + ! hydrometeors in each longwave band, where the latter two + ! variables are only defined if hydrometeor longwave scattering is + ! enabled (otherwise both are treated as zero). + real(jprb), intent(in), dimension(config%n_bands_lw,nlev,istartcol:iendcol) :: od_lw_cloud + real(jprb), intent(in), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol) :: & + & ssa_lw_cloud, g_lw_cloud + + ! The Planck function (emitted flux from a black body) at half + ! levels and at the surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: planck_hl + + ! Emission (Planck*emissivity) and albedo (1-emissivity) at the + ! surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, istartcol:iendcol) :: lw_emission, lw_albedo + + ! Local variables + + integer :: n_col_local ! Number of columns from istartcol to iendcol + + ! Object for output NetCDF file + type(netcdf_file) :: out_file + + n_col_local = iendcol + 1 - istartcol + + ! Alas the NetCDF library is not thread-safe for writing, so we + ! must write radiative-property files serially + + !$OMP CRITICAL + + ! Open the file + call out_file%create(trim(file_name), iverbose=config%iverbose) + + ! Configure matrix and 3D-array orientation + call out_file%transpose_matrices(.true.) + + ! Sometimes the Planck function values are very large or small + ! even if the fluxes are within a manageable range + call out_file%double_precision(.true.) + + ! Define dimensions + ! call out_file%define_dimension("column", n_col_local) + call out_file%define_dimension("column", 0) ! "Unlimited" dimension + call out_file%define_dimension("level", nlev) + call out_file%define_dimension("half_level", nlev+1) + if (config%do_clouds) then + call out_file%define_dimension("level_interface", nlev-1) + end if + + if (config%do_lw) then + call out_file%define_dimension("gpoint_lw", config%n_g_lw) + if (config%do_clouds) then + call out_file%define_dimension("band_lw", config%n_bands_lw) + end if + end if + if (config%do_sw) then + call out_file%define_dimension("gpoint_sw", config%n_g_sw) + if (config%do_clouds) then + call out_file%define_dimension("band_sw", config%n_bands_sw) + end if + end if + + ! Put global attributes + call out_file%put_global_attributes( & + & title_str="Spectral radiative properties from the ecRad offline radiation model", & + & references_str="Hogan, R. J., and A. Bozzo, 2018: A flexible and efficient radiation " & + & //"scheme for the ECMWF model. J. Adv. Modeling Earth Sys., 10, 1990–2008", & + & source_str="ecRad offline radiation model") + + ! Define variables + call out_file%define_variable("pressure_hl", & + & dim2_name="column", dim1_name="half_level", & + & units_str="Pa", long_name="Pressure on half-levels") + + if (allocated(thermodynamics%h2o_sat_liq) .and. config%use_aerosols) then + call out_file%define_variable("q_sat_liquid", & + & dim2_name="column", dim1_name="level", & + & units_str="kg kg-1", long_name="Specific humidity at liquid saturation") + end if + + if (config%do_sw) then + call out_file%define_variable("cos_solar_zenith_angle", & + & dim1_name="column", units_str="1", & + & long_name="Cosine of the solar zenith angle") + end if + + if (config%do_clouds) then + call out_file%define_variable("cloud_fraction", & + & dim2_name="column", dim1_name="level", & + & units_str="1", long_name="Cloud fraction") + call out_file%define_variable("overlap_param", & + & dim2_name="column", dim1_name="level_interface", & + & units_str="1", long_name="Cloud overlap parameter") + end if + + if (config%do_lw) then + call out_file%define_variable("planck_hl", & + & dim3_name="column", dim2_name="half_level", dim1_name="gpoint_lw", & + & units_str="W m-2", long_name="Planck function on half-levels") + call out_file%define_variable("lw_emission", & + & dim2_name="column", dim1_name="gpoint_lw", & + & units_str="W m-2", long_name="Longwave surface emission") + call out_file%define_variable("lw_emissivity", & + & dim2_name="column", dim1_name="gpoint_lw", & + & units_str="1", long_name="Surface longwave emissivity") + + call out_file%define_variable("od_lw", & + & dim3_name="column", dim2_name="level", dim1_name="gpoint_lw", & + & units_str="1", long_name="Clear-sky longwave optical depth") + if (config%do_lw_aerosol_scattering) then + call out_file%define_variable("ssa_lw", & + & dim3_name="column", dim2_name="level", dim1_name="gpoint_lw", & + & units_str="1", long_name="Clear-sky longwave single scattering albedo") + call out_file%define_variable("asymmetry_lw", & + & dim3_name="column", dim2_name="level", dim1_name="gpoint_lw", & + & units_str="1", long_name="Clear-sky longwave asymmetry factor") + end if + + if (config%do_clouds) then + call out_file%define_variable("od_lw_cloud", & + & dim3_name="column", dim2_name="level", dim1_name="band_lw", & + & units_str="1", long_name="In-cloud longwave optical depth") + if (config%do_lw_cloud_scattering) then + call out_file%define_variable("ssa_lw_cloud", & + & dim3_name="column", dim2_name="level", dim1_name="band_lw", & + & units_str="1", long_name="Cloud longwave single scattering albedo") + call out_file%define_variable("asymmetry_lw_cloud", & + & dim3_name="column", dim2_name="level", dim1_name="band_lw", & + & units_str="1", long_name="Cloud longwave asymmetry factor") + end if + end if ! do_clouds + end if ! do_lw + + if (config%do_sw) then + call out_file%define_variable("incoming_sw", & + & dim2_name="column", dim1_name="gpoint_sw", & + & units_str="W m-2", long_name="Incoming shortwave flux at top-of-atmosphere in direction of sun") + + call out_file%define_variable("sw_albedo", & + & dim2_name="column", dim1_name="gpoint_sw", & + & units_str="1", long_name="Surface shortwave albedo to diffuse radiation") + call out_file%define_variable("sw_albedo_direct", & + & dim2_name="column", dim1_name="gpoint_sw", & + & units_str="1", long_name="Surface shortwave albedo to direct radiation") + + call out_file%define_variable("od_sw", & + & dim3_name="column", dim2_name="level", dim1_name="gpoint_sw", & + & units_str="1", long_name="Clear-sky shortwave optical depth") + call out_file%define_variable("ssa_sw", & + & dim3_name="column", dim2_name="level", dim1_name="gpoint_sw", & + & units_str="1", long_name="Clear-sky shortwave single scattering albedo") + call out_file%define_variable("asymmetry_sw", & + & dim3_name="column", dim2_name="level", dim1_name="gpoint_sw", & + & units_str="1", long_name="Clear-sky shortwave asymmetry factor") + + if (config%do_clouds) then + call out_file%define_variable("od_sw_cloud", & + & dim3_name="column", dim2_name="level", dim1_name="band_sw", & + & units_str="1", long_name="In-cloud shortwave optical depth") + call out_file%define_variable("ssa_sw_cloud", & + & dim3_name="column", dim2_name="level", dim1_name="band_sw", & + & units_str="1", long_name="Cloud shortwave single scattering albedo") + call out_file%define_variable("asymmetry_sw_cloud", & + & dim3_name="column", dim2_name="level", dim1_name="band_sw", & + & units_str="1", long_name="Cloud shortwave asymmetry factor") + end if + end if + + if (config%do_clouds) then + if (allocated(cloud%fractional_std)) then + call out_file%define_variable("fractional_std", & + & dim2_name="column", dim1_name="level", units_str="1", & + & long_name="Fractional standard deviation of cloud optical depth") + end if + if (allocated(cloud%inv_cloud_effective_size)) then + call out_file%define_variable("inv_cloud_effective_size", & + & dim2_name="column", dim1_name="level", units_str="m-1", & + & long_name="Inverse of cloud effective horizontal size") + end if + if (allocated(cloud%inv_inhom_effective_size)) then + call out_file%define_variable("inv_inhom_effective_size", & + & dim2_name="column", dim1_name="level", units_str="m-1", & + & long_name="Inverse of cloud inhomogeneity effective horizontal size") + end if + end if + + ! Write variables + call out_file%put("pressure_hl", thermodynamics%pressure_hl(istartcol:iendcol,:)) + + if (allocated(thermodynamics%h2o_sat_liq) .and. config%use_aerosols) then + call out_file%put("q_sat_liquid", thermodynamics%h2o_sat_liq(istartcol:iendcol,:)) + end if + + if (config%do_clouds) then + call out_file%put("cloud_fraction", cloud%fraction(istartcol:iendcol,:)) + call out_file%put("overlap_param", cloud%overlap_param(istartcol:iendcol,:)) + end if + + if (config%do_sw) then + call out_file%put("cos_solar_zenith_angle", single_level%cos_sza(istartcol:iendcol)) + call out_file%put("sw_albedo", sw_albedo_diffuse, do_transp=.false.) + call out_file%put("sw_albedo_direct", sw_albedo_direct, do_transp=.false.) + end if + + if (config%do_lw) then + call out_file%put("lw_emissivity", 1.0_jprb - lw_albedo, do_transp=.false.) + call out_file%put("planck_hl", planck_hl) + call out_file%put("lw_emission", lw_emission, do_transp=.false.) + + call out_file%put("od_lw", od_lw) + if (config%do_lw_aerosol_scattering) then + call out_file%put("ssa_lw", ssa_lw) + call out_file%put("asymmetry_lw", g_lw) + end if + + if (config%do_clouds) then + call out_file%put("od_lw_cloud", od_lw_cloud) + if (config%do_lw_cloud_scattering) then + call out_file%put("ssa_lw_cloud", ssa_lw_cloud) + call out_file%put("asymmetry_lw_cloud", g_lw_cloud) + end if + end if + end if + + if (config%do_sw) then + call out_file%put("incoming_sw", incoming_sw, do_transp=.false.) + + call out_file%put("od_sw", od_sw) + call out_file%put("ssa_sw", ssa_sw) + call out_file%put("asymmetry_sw", g_sw) + + if (config%do_clouds) then + call out_file%put("od_sw_cloud", od_sw_cloud) + call out_file%put("ssa_sw_cloud", ssa_sw_cloud) + call out_file%put("asymmetry_sw_cloud", g_sw_cloud) + end if + end if + + if (config%do_clouds) then + if (allocated(cloud%fractional_std)) then + call out_file%put("fractional_std", cloud%fractional_std(istartcol:iendcol,:)) + end if + if (allocated(cloud%inv_cloud_effective_size)) then + call out_file%put("inv_cloud_effective_size", cloud%inv_cloud_effective_size(istartcol:iendcol,:)) + end if + if (allocated(cloud%inv_inhom_effective_size)) then + call out_file%put("inv_inhom_effective_size", cloud%inv_inhom_effective_size(istartcol:iendcol,:)) + end if + end if + + ! Close the file + call out_file%close() + + !$OMP END CRITICAL + + end subroutine save_radiative_properties + + + !--------------------------------------------------------------------- + ! Save inputs to the radiation scheme + subroutine save_inputs(file_name, config, single_level, thermodynamics, & + & gas, cloud, aerosol, lat, lon, iverbose) + use yomhook, only : lhook, dr_hook, jphook + + use radiation_config, only : config_type + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_gas + use radiation_cloud, only : cloud_type + use radiation_aerosol, only : aerosol_type + use easy_netcdf + + character(len=*), intent(in) :: file_name + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type), intent(in) :: thermodynamics + type(gas_type), intent(inout):: gas + type(cloud_type), intent(in) :: cloud + type(aerosol_type), optional, intent(in) :: aerosol + real(jprb), optional, intent(in) :: lat(:), lon(:) + integer, optional, intent(in) :: iverbose + + real(jprb), allocatable :: mixing_ratio(:,:) + real(jprb), allocatable :: aerosol_mmr(:,:,:) + real(jprb), allocatable :: seed(:) + integer :: i_local_verbose + integer :: ncol, nlev + integer :: jgas + character(32) :: var_name, long_name + + ! Object for output NetCDF file + type(netcdf_file) :: out_file + + logical :: do_aerosol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_save:save_inputs',0,hook_handle) + + if (present(iverbose)) then + i_local_verbose = iverbose + else + i_local_verbose = config%iverbose + end if + + ! Work out array dimensions + ncol = size(thermodynamics%pressure_hl,1) + nlev = size(thermodynamics%pressure_hl,2) + nlev = nlev - 1 + + do_aerosol = config%use_aerosols .and. present(aerosol) + + ! Open the file + call out_file%create(trim(file_name), iverbose=i_local_verbose) + + ! Variables stored internally with column varying fastest, but in + ! output file column varies most slowly so need to transpose + call out_file%transpose_matrices(.true.) + + ! In the case of aerosols we convert dimensions (ncol,nlev,ntype) + ! in memory to (nlev,ntype,ncol) in file (in both cases the first + ! dimension varying fastest). + call out_file%permute_3d_arrays( (/ 2, 3, 1 /) ) ! For aerosols + + ! Define dimensions + call out_file%define_dimension("column", ncol) + call out_file%define_dimension("level", nlev) + call out_file%define_dimension("half_level", nlev+1) + if (allocated(cloud%overlap_param)) then + call out_file%define_dimension("level_interface", nlev-1) + end if + call out_file%define_dimension("sw_albedo_band", & + & size(single_level%sw_albedo,2)) + call out_file%define_dimension("lw_emissivity_band", & + & size(single_level%lw_emissivity,2)) + + if (do_aerosol) then + call out_file%define_dimension("aerosol_type", size(aerosol%mixing_ratio,3)) + end if + + ! Put global attributes + call out_file%put_global_attributes( & + & title_str="Input profiles to the ecRad offline radiation model", & + & references_str="Hogan, R. J., and A. Bozzo, 2018: A flexible and efficient radiation " & + & //"scheme for the ECMWF model. J. Adv. Modeling Earth Sys., 10, 1990–2008", & + & source_str="ecRad offline radiation model") + + ! Define single-level variables + call out_file%define_variable("solar_irradiance", & + & units_str="W m-2", long_name="Solar irradiance at Earth's orbit") + if (present(lat)) then + call out_file%define_variable("lat", & + & dim1_name="column", units_str="degrees_north", long_name="Latitude") + end if + if (present(lon)) then + call out_file%define_variable("lon", & + & dim1_name="column", units_str="degrees_east", long_name="Longitude") + end if + call out_file%define_variable("skin_temperature", & + & dim1_name="column", units_str="K", long_name="Skin_temperature") + if (config%do_sw) then + call out_file%define_variable("cos_solar_zenith_angle", & + & dim1_name="column", units_str="1", & + & long_name="Cosine of the solar zenith angle") + end if + + if (allocated(single_level%sw_albedo_direct)) then + call out_file%define_variable("sw_albedo", & + & dim2_name="column", dim1_name="sw_albedo_band", & + & units_str="1", long_name="Shortwave surface albedo to diffuse radiation") + call out_file%define_variable("sw_albedo_direct", & + & dim2_name="column", dim1_name="sw_albedo_band", & + & units_str="1", long_name="Shortwave surface albedo to direct radiation") + else + call out_file%define_variable("sw_albedo", & + & dim2_name="column", dim1_name="sw_albedo_band", & + & units_str="1", long_name="Shortwave surface albedo") + + end if + call out_file%define_variable("lw_emissivity", & + & dim2_name="column", dim1_name="lw_emissivity_band", & + & units_str="1", long_name="Longwave surface emissivity") + + if (allocated(single_level%iseed)) then + call out_file%define_variable("iseed", & + & dim1_name="column", units_str="1", is_double=.true., & + & long_name="Seed for random-number generator") + end if + + ! Define thermodynamic variables on half levels + call out_file%define_variable("pressure_hl", & + & dim2_name="column", dim1_name="half_level", & + & units_str="Pa", long_name="Pressure") + call out_file%define_variable("temperature_hl", & + & dim2_name="column", dim1_name="half_level", & + & units_str="K", long_name="Temperature") + + ! Define gas mixing ratios on full levels + call out_file%define_variable("q", & + & dim2_name="column", dim1_name="level", & + & units_str="1", long_name="Specific humidity") + call out_file%define_variable("o3_mmr", & + & dim2_name="column", dim1_name="level", & + & units_str="1", long_name="Ozone mass mixing ratio") + do jgas = 1,NMaxGases + if (gas%is_present(jgas) .and. jgas /= IH2O .and. jgas /= IO3) then + write(var_name,'(a,a)') trim(GasLowerCaseName(jgas)), '_vmr' + write(long_name,'(a,a)') trim(GasName(jgas)), ' volume mixing ratio' + call out_file%define_variable(trim(var_name), & + & dim2_name="column", dim1_name="level", & + & units_str="1", long_name=trim(long_name)) + end if + end do + + if (config%do_clouds) then + ! Define cloud variables on full levels + call out_file%define_variable("cloud_fraction", & + & dim2_name="column", dim1_name="level", & + & units_str="1", long_name="Cloud fraction") + call out_file%define_variable("q_liquid", & + & dim2_name="column", dim1_name="level", & + & units_str="1", long_name="Gridbox-mean liquid water mixing ratio") + call out_file%define_variable("q_ice", & + & dim2_name="column", dim1_name="level", & + & units_str="1", long_name="Gridbox-mean ice water mixing ratio") + call out_file%define_variable("re_liquid", & + & dim2_name="column", dim1_name="level", & + & units_str="m", long_name="Ice effective radius") + if (associated(cloud%re_ice)) then + call out_file%define_variable("re_ice", & + & dim2_name="column", dim1_name="level", & + & units_str="m", long_name="Ice effective radius") + end if + if (allocated(cloud%overlap_param)) then + call out_file%define_variable("overlap_param", & + & dim2_name="column", dim1_name="level_interface", & + & units_str="1", long_name="Cloud overlap parameter") + end if + if (allocated(cloud%fractional_std)) then + call out_file%define_variable("fractional_std", & + & dim2_name="column", dim1_name="level", units_str="1", & + & long_name="Fractional standard deviation of cloud optical depth") + end if + if (allocated(cloud%inv_cloud_effective_size)) then + call out_file%define_variable("inv_cloud_effective_size", & + & dim2_name="column", dim1_name="level", units_str="m-1", & + & long_name="Inverse of cloud effective horizontal size") + end if + if (allocated(cloud%inv_inhom_effective_size)) then + call out_file%define_variable("inv_inhom_effective_size", & + & dim2_name="column", dim1_name="level", units_str="m-1", & + & long_name="Inverse of cloud inhomogeneity effective horizontal size") + end if + end if ! do_clouds + + ! Define aerosol mass mixing ratio + if (do_aerosol) then + call out_file%define_variable("aerosol_mmr", & + & dim3_name="column", dim2_name="aerosol_type", & + & dim1_name="level", units_str="kg kg-1", & + & long_name="Aerosol mass mixing ratio") + end if + + ! Write variables + call out_file%put("solar_irradiance", single_level%solar_irradiance) + if (present(lat)) then + call out_file%put("lat", lat) + end if + if (present(lon)) then + call out_file%put("lon", lon) + end if + call out_file%put("skin_temperature", single_level%skin_temperature) + if (config%do_sw) then + call out_file%put("cos_solar_zenith_angle", single_level%cos_sza) + end if + call out_file%put("sw_albedo", single_level%sw_albedo) + if (allocated(single_level%sw_albedo_direct)) then + call out_file%put("sw_albedo_direct", single_level%sw_albedo_direct) + end if + call out_file%put("lw_emissivity", single_level%lw_emissivity) + if (config%do_clouds .and. allocated(single_level%iseed)) then + allocate(seed(ncol)) + seed = single_level%iseed + call out_file%put("iseed", seed) + deallocate(seed) + end if + + call out_file%put("pressure_hl", thermodynamics%pressure_hl) + call out_file%put("temperature_hl", thermodynamics%temperature_hl) + + allocate(mixing_ratio(ncol,nlev)) + call gas%get(IH2O, IMassMixingRatio, mixing_ratio) + call out_file%put("q", mixing_ratio) + call gas%get(IO3, IMassMixingRatio, mixing_ratio) + call out_file%put("o3_mmr", mixing_ratio) + do jgas = 1,NMaxGases + if (gas%is_present(jgas) .and. jgas /= IH2O .and. jgas /= IO3) then + write(var_name,'(a,a)') trim(GasLowerCaseName(jgas)), '_vmr' + call gas%get(jgas, IVolumeMixingRatio, mixing_ratio) + call out_file%put(trim(var_name), mixing_ratio) + end if + end do + deallocate(mixing_ratio) + + if (config%do_clouds) then + call out_file%put("cloud_fraction", cloud%fraction) + call out_file%put("q_liquid", cloud%q_liq) + call out_file%put("q_ice", cloud%q_ice) + call out_file%put("re_liquid", cloud%re_liq) + if (associated(cloud%re_ice)) then + call out_file%put("re_ice", cloud%re_ice) + end if + if (allocated(cloud%overlap_param)) then + call out_file%put("overlap_param", cloud%overlap_param) + end if + if (allocated(cloud%fractional_std)) then + call out_file%put("fractional_std", cloud%fractional_std) + end if + if (allocated(cloud%inv_cloud_effective_size)) then + call out_file%put("inv_cloud_effective_size", cloud%inv_cloud_effective_size) + end if + if (allocated(cloud%inv_inhom_effective_size)) then + call out_file%put("inv_inhom_effective_size", cloud%inv_inhom_effective_size) + end if + end if + + if (do_aerosol) then + allocate(aerosol_mmr(ncol, nlev, size(aerosol%mixing_ratio,3))) + aerosol_mmr = 0.0_jprb + aerosol_mmr(:,aerosol%istartlev:aerosol%iendlev,:) = aerosol%mixing_ratio + call out_file%put("aerosol_mmr", aerosol_mmr) + deallocate(aerosol_mmr) + end if + + ! Close the file + call out_file%close() + + if (lhook) call dr_hook('radiation_save:save_inputs',1,hook_handle) + + end subroutine save_inputs + + + !--------------------------------------------------------------------- + ! Save shortwave diagnostics computed from "flux" to NetCDF + ! file_name. The "mapping" matrix maps from fluxes in bands or + ! g-points to user specified spectral intervals, and should have + ! been produced by config%get_sw_mapping. See the example in + ! ecrad_driver.F90. + subroutine save_sw_diagnostics(file_name, config, wavelength_bound, mapping, flux, & + & iverbose, is_hdf5_file, experiment_name, & + & is_double_precision) + + use yomhook, only : lhook, dr_hook, jphook + + use easy_netcdf + + use radiation_io, only : nulout + use radiation_flux, only : flux_type + use radiation_config, only : config_type + use radiation_matrix, only : sparse_x_dense + + character(len=*), intent(in) :: file_name + type(config_type), intent(in) :: config + real(jprb), intent(in) :: wavelength_bound(:) ! m + real(jprb), intent(in) :: mapping(:,:) + type(flux_type), intent(in) :: flux + integer, optional, intent(in) :: iverbose + logical, optional, intent(in) :: is_hdf5_file + logical, optional, intent(in) :: is_double_precision + character(len=*), optional, intent(in) :: experiment_name + + integer :: nwav ! Number of wavelength intervals + real(jprb), allocatable :: flux_out(:,:) + type(netcdf_file) :: out_file + integer :: ncol, n_lev_plus1 + integer :: i_local_verbose + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_save:save_sw_diagnostics',0,hook_handle) + + if (present(iverbose)) then + i_local_verbose = iverbose + else + i_local_verbose = config%iverbose + end if + + ! Open the file + call out_file%create(trim(file_name), iverbose=i_local_verbose, is_hdf5_file=is_hdf5_file) + + ! Set default precision for file, if specified + if (present(is_double_precision)) then + call out_file%double_precision(is_double_precision) + end if + + ! Define dimensions + ncol = size(flux%sw_up,1) + call out_file%define_dimension("column", ncol) + nwav = size(wavelength_bound)-1 + call out_file%define_dimension("wavelength", nwav) + + ! Put global attributes + call out_file%put_global_attributes( & + & title_str="Shortwave spectral diagnostics from the ecRad offline radiation model", & + & references_str="Hogan, R. J., and A. Bozzo, 2018: A flexible and efficient radiation " & + & //"scheme for the ECMWF model. J. Adv. Modeling Earth Sys., 10, 1990–2008", & + & source_str="ecRad offline radiation model") + + ! Save "experiment" global attribute if present and not empty + if (present(experiment_name)) then + if (experiment_name /= " ") then + call out_file%put_global_attribute("experiment", experiment_name) + end if + end if + + ! Define variables + call out_file%define_variable("wavelength1", dim1_name="wavelength", & + units_str="m", long_name="Wavelength lower bound") + call out_file%define_variable("wavelength2", dim1_name="wavelength", & + units_str="m", long_name="Wavelength upper bound") + + ! These are always available if + ! config%do_surface_sw_spectral_flux=true, which is required for + ! this routine + call out_file%define_variable("flux_dn_sw_surf", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Surface downwelling shortwave flux") + call out_file%define_variable("flux_dn_direct_sw_surf", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Surface downwelling direct shortwave flux") + if (config%do_clear) then + call out_file%define_variable("flux_dn_sw_surf_clear", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Surface downwelling clear-sky shortwave flux") + call out_file%define_variable("flux_dn_direct_sw_surf_clear", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Surface downwelling clear-sky direct shortwave flux") + end if + + ! The following are only availble if + ! config%do_save_spectral_flux=true + if (allocated(flux%sw_up_band)) then + call out_file%define_variable("flux_up_sw_toa", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Top-of-atmosphere upwelling shortwave flux") + call out_file%define_variable("flux_dn_sw_toa", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Top-of-atmosphere downwelling shortwave flux") + call out_file%define_variable("flux_up_sw_surf", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Surface upwelling shortwave flux") + if (allocated(flux%sw_up_clear_band)) then + call out_file%define_variable("flux_up_sw_toa_clear", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Top-of-atmosphere upwelling clear-sky shortwave flux") + call out_file%define_variable("flux_up_sw_surf_clear", & + & dim2_name="column", dim1_name="wavelength", & + & units_str="W m-2", long_name="Surface upwelling clear-sky shortwave flux") + end if + end if + + ! Write variables + call out_file%put("wavelength1", wavelength_bound(1:nwav)) + call out_file%put("wavelength2", wavelength_bound(2:nwav+1)) + + n_lev_plus1 = size(flux%sw_up,2) + + ! The mapping matrix is usually sparse, in which case we can check + ! its elements before multiplying a column of bandwise fluxes by + ! it. +#define USE_SPARSE_MATMUL 1 +#ifdef USE_SPARSE_MATMUL +#define MY_MATMUL sparse_x_dense +#else +#define MY_MATMUL matmul +#endif + + flux_out = MY_MATMUL(mapping, flux%sw_dn_surf_band) + call out_file%put("flux_dn_sw_surf", flux_out) + flux_out = MY_MATMUL(mapping, flux%sw_dn_direct_surf_band) + call out_file%put("flux_dn_direct_sw_surf", flux_out) + if (config%do_clear) then + flux_out = MY_MATMUL(mapping, flux%sw_dn_surf_clear_band) + call out_file%put("flux_dn_sw_surf_clear", flux_out) + flux_out = MY_MATMUL(mapping, flux%sw_dn_direct_surf_clear_band) + call out_file%put("flux_dn_direct_sw_surf_clear", flux_out) + end if + + if (allocated(flux%sw_up_band)) then + flux_out = MY_MATMUL(mapping, flux%sw_up_band(:,:,n_lev_plus1)) + call out_file%put("flux_up_sw_surf", flux_out) + flux_out = MY_MATMUL(mapping, flux%sw_up_band(:,:,1)) + call out_file%put("flux_up_sw_toa", flux_out) + flux_out = MY_MATMUL(mapping, flux%sw_dn_band(:,:,1)) + call out_file%put("flux_dn_sw_toa", flux_out) + if (allocated(flux%sw_up_clear_band)) then + flux_out = MY_MATMUL(mapping, flux%sw_up_clear_band(:,:,1)) + call out_file%put("flux_up_sw_toa_clear", flux_out) + flux_out = MY_MATMUL(mapping, flux%sw_up_clear_band(:,:,n_lev_plus1)) + call out_file%put("flux_up_sw_surf_clear", flux_out) + end if + end if + + call out_file%close() + + if (lhook) call dr_hook('radiation_save:save_sw_diagnostics',1,hook_handle) + + end subroutine save_sw_diagnostics + +end module radiation_save Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_single_level.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_single_level.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_single_level.F90 (revision 6016) @@ -0,0 +1,596 @@ +! This file has been modified for the use in ICON + +! radiation_single_level.F90 - Derived type for single-level fields +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2019-01-14 R. Hogan Added out_of_physical_bounds routine +! 2019-01-18 R. Hogan Added weighted albedo mapping + +module radiation_single_level + + use parkind1, only : jprb + use radiation_io, only : nulerr, radiation_abort + + implicit none + public + + !--------------------------------------------------------------------- + ! Derived type to contain variables that don't vary with height; + ! mostly they are surface properties + type single_level_type + ! Note that skin temperature is only defined if + ! is_simple_surface==.true. + real(jprb), allocatable, dimension(:) :: & + & cos_sza, & ! (ncol) Cosine of solar zenith angle + & skin_temperature ! (ncol) Skin temperature (K) + + ! Shortwave albedo: if sw_albedo_direct is not allocated then + ! sw_albedo will be used for both direct and diffuse solar + ! radiation; otherwise, sw_albedo will be used for diffuse + ! radiation and sw_albedo_direct for direct radiation. + real(jprb), allocatable, dimension(:,:) :: & + & sw_albedo, & ! (ncol,nalbedobands) + & sw_albedo_direct ! (ncol,nalbedobands) + + ! If is_simple_surface==.true., we provide longwave emissivity + ! coarser spectral intervals, while if + ! is_simple_surface==.false. it will be generated by the surface + ! radiation scheme and may optionally be on the full spectral grid + ! of the atmospheric model. + real(jprb), allocatable, dimension(:,:) :: & + & lw_emissivity ! (ncol,nemissbands) If + ! is_simple_surface==.false. then we specify the emission instead + ! of the skin temperature, and again this may be on the emissivity + ! bands or the full spectral grid + real(jprb), allocatable, dimension(:,:) :: & + & lw_emission ! (ncol,nemissbands) + + ! Incoming solar irradiance at the Earth is specified as the total + ! across the shortwave spectrum. Note that this needs to be + ! adjusted for Earth-Sun distance, solar cycle etc. To get + ! normalized fluxes out, simply set this to 1.0. + real(jprb) :: solar_irradiance = 1366.0_jprb ! W m-2 + + ! In addition to the effect of the solar cycle on total solar + ! irradiance (which the user is expected to input via + ! solar_irradiance), it can change the balance between different + ! parts of the solar spectrum, e.g. more UV at solar maximum. This + ! variable provides the scaling to be applied to the spectral + ! amplitude of the solar cycle (assuming it has been provided), + ! e.g. 1.0 for solar maximum, -1.0 for solar maximum and 0.0 for + ! a mean solar spectrum. + real(jprb) :: spectral_solar_cycle_multiplier = 0.0_jprb + + ! If config%use_spectral_solar_irradiance==true then this will be + ! scaled by spectral_solar_scaling + real(jprb), allocatable, dimension(:) :: & + & spectral_solar_scaling ! (n_bands_sw) + + ! Seed for random number generator in McICA; it is expected that + ! the host model generates this from the model time, longitude + ! and latitude, in order that the model is deterministic + integer, allocatable, dimension(:) :: iseed ! (ncol) + + ! Is the underlying surface a simple single "flat" tile? If so we + ! describe it with skin_temperature and lw_emissivity. Otherwise + ! we describe it with lw_emission and lw_emissivity coming out of + ! the surface radiation scheme. + logical :: is_simple_surface = .true. + + ! If is_simple_surface==.false., do we use the full number of g + ! points for dimensioning sw_albedo, sw_albedo_direct and + ! lw_emission? + !logical :: use_full_spectrum_sw = .false. + !logical :: use_full_spectrum_lw = .true. + + contains + procedure :: allocate => allocate_single_level + procedure :: deallocate => deallocate_single_level + procedure :: init_seed_simple + procedure :: get_albedos + procedure :: out_of_physical_bounds +#ifdef _OPENACC + procedure :: update_host + procedure :: update_device +#endif + + end type single_level_type + +contains + + !--------------------------------------------------------------------- + ! Allocate the arrays of a single-level type + subroutine allocate_single_level(this, ncol, nalbedobands, nemisbands, & + & use_sw_albedo_direct, is_simple_surface) + + use yomhook, only : lhook, dr_hook, jphook + + class(single_level_type), intent(inout) :: this + integer, intent(in) :: ncol, nalbedobands, nemisbands + logical, optional, intent(in) :: use_sw_albedo_direct + logical, optional, intent(in) :: is_simple_surface + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_single_level:allocate',0,hook_handle) + + call this%deallocate() + + if (present(is_simple_surface)) then + this%is_simple_surface = is_simple_surface + else + this%is_simple_surface = .true. + end if + + allocate(this%cos_sza(ncol)) + !$ACC ENTER DATA CREATE(this%cos_sza) ASYNC(1) + + if (this%is_simple_surface) then + allocate(this%skin_temperature(ncol)) + !$ACC ENTER DATA CREATE(this%skin_temperature) ASYNC(1) + else + allocate(this%lw_emission(ncol, nemisbands)) + !$ACC ENTER DATA CREATE(this%lw_emission) ASYNC(1) + end if + allocate(this%lw_emissivity(ncol, nemisbands)) + !$ACC ENTER DATA CREATE(this%lw_emissivity) ASYNC(1) + + allocate(this%sw_albedo(ncol, nalbedobands)) + !$ACC ENTER DATA CREATE(this%sw_albedo) ASYNC(1) + + if (present(use_sw_albedo_direct)) then + if (use_sw_albedo_direct) then + allocate(this%sw_albedo_direct(ncol, nalbedobands)) + !$ACC ENTER DATA CREATE(this%sw_albedo_direct) ASYNC(1) + end if + end if + + allocate(this%iseed(ncol)) + !$ACC ENTER DATA CREATE(this%iseed) ASYNC(1) + + if (lhook) call dr_hook('radiation_single_level:allocate',1,hook_handle) + + end subroutine allocate_single_level + + + !--------------------------------------------------------------------- + ! Deallocate the arrays of a single-level type + subroutine deallocate_single_level(this) + + use yomhook, only : lhook, dr_hook, jphook + + class(single_level_type), intent(inout) :: this + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_single_level:deallocate',0,hook_handle) + + if (allocated(this%cos_sza)) then + !$ACC EXIT DATA DELETE(this%cos_sza) WAIT(1) + deallocate(this%cos_sza) + end if + if (allocated(this%skin_temperature)) then + !$ACC EXIT DATA DELETE(this%skin_temperature) WAIT(1) + deallocate(this%skin_temperature) + end if + if (allocated(this%sw_albedo)) then + !$ACC EXIT DATA DELETE(this%sw_albedo) WAIT(1) + deallocate(this%sw_albedo) + end if + if (allocated(this%sw_albedo_direct)) then + !$ACC EXIT DATA DELETE(this%sw_albedo_direct) WAIT(1) + deallocate(this%sw_albedo_direct) + end if + if (allocated(this%lw_emissivity)) then + !$ACC EXIT DATA DELETE(this%lw_emissivity) WAIT(1) + deallocate(this%lw_emissivity) + end if + if (allocated(this%lw_emission)) then + !$ACC EXIT DATA DELETE(this%lw_emission) WAIT(1) + deallocate(this%lw_emission) + end if + if (allocated(this%spectral_solar_scaling)) then + !$ACC EXIT DATA DELETE(this%spectral_solar_scaling) WAIT(1) + deallocate(this%spectral_solar_scaling) + end if + if (allocated(this%iseed)) then + !$ACC EXIT DATA DELETE(this%iseed) WAIT(1) + deallocate(this%iseed) + end if + + if (lhook) call dr_hook('radiation_single_level:deallocate',1,hook_handle) + + end subroutine deallocate_single_level + + + !--------------------------------------------------------------------- + ! Unimaginative initialization of random-number seeds + subroutine init_seed_simple(this, istartcol, iendcol) + class(single_level_type), intent(inout) :: this + integer, intent(in) :: istartcol, iendcol + + integer :: jcol + + if (.not. allocated(this%iseed)) then + allocate(this%iseed(istartcol:iendcol)) + !$ACC ENTER DATA CREATE(this%iseed) + end if + + !$ACC PARALLEL DEFAULT(PRESENT) + !$ACC LOOP GANG VECTOR + do jcol = istartcol,iendcol + this%iseed(jcol) = jcol + end do + !$ACC END PARALLEL + + !$ACC UPDATE HOST(this%iseed) + + end subroutine init_seed_simple + + + !--------------------------------------------------------------------- + ! Extract the shortwave and longwave surface albedos in each g-point + subroutine get_albedos(this, istartcol, iendcol, config, & + & sw_albedo_direct, sw_albedo_diffuse, lw_albedo) + + use radiation_config, only : config_type + use radiation_io, only : nulerr, radiation_abort + use yomhook, only : lhook, dr_hook, jphook + + class(single_level_type), intent(in) :: this + type(config_type), intent(in) :: config + integer, intent(in) :: istartcol, iendcol + + ! The longwave albedo of the surface in each longwave g-point; + ! note that these are weighted averages of the values from + ! individual tiles + real(jprb), intent(out), optional & + & :: lw_albedo(config%n_g_lw, istartcol:iendcol) + + ! Direct and diffuse shortwave surface albedo in each shortwave + ! g-point; note that these are weighted averages of the values + ! from individual tiles + real(jprb), intent(out), dimension(config%n_g_sw, istartcol:iendcol) & + & :: sw_albedo_direct, sw_albedo_diffuse + + ! Temporary storage of albedo in ecRad bands + real(jprb) :: sw_albedo_band(istartcol:iendcol, config%n_bands_sw) + real(jprb) :: lw_albedo_band(istartcol:iendcol, config%n_bands_lw) + + ! Number of albedo bands + integer :: nalbedoband + + ! Loop indices for ecRad bands and albedo bands + integer :: jband, jalbedoband, jg, jcol + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_single_level:get_albedos',0,hook_handle) + + !$ACC DATA CREATE(sw_albedo_band, lw_albedo_band) & + !$ACC PRESENT(this, config, sw_albedo_direct, sw_albedo_diffuse, & + !$ACC lw_albedo) + + if (config%do_sw) then + ! Albedos/emissivities are stored in single_level in their own + ! spectral intervals and with column as the first dimension + if (config%use_canopy_full_spectrum_sw) then + ! Albedos provided in each g point + if (size(this%sw_albedo,2) /= config%n_g_sw) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo does not have the expected ', & + & config%n_g_sw, ' spectral intervals' + call radiation_abort() + end if + sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol,:)) + if (allocated(this%sw_albedo_direct)) then + sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol,:)) + end if + else if (.not. config%do_nearest_spectral_sw_albedo) then + ! Albedos averaged accurately to ecRad spectral bands + nalbedoband = size(config%sw_albedo_weights,1) + if (size(this%sw_albedo,2) /= nalbedoband) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo does not have the expected ', & + & nalbedoband, ' bands' + call radiation_abort() + end if + + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP SEQ + do jband = 1,config%n_bands_sw + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + sw_albedo_band(jcol,jband) = 0.0_jprb + end do + end do + + !$ACC LOOP SEQ + do jband = 1,config%n_bands_sw + !$ACC LOOP SEQ + do jalbedoband = 1,nalbedoband +#ifndef _OPENACC + if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then +#endif + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + sw_albedo_band(jcol,jband) & + & = sw_albedo_band(jcol,jband) & + & + config%sw_albedo_weights(jalbedoband,jband) & + & * this%sw_albedo(jcol, jalbedoband) + end do +#ifndef _OPENACC + end if +#endif + end do + end do + +#ifndef _OPENACC + sw_albedo_diffuse = transpose(sw_albedo_band(istartcol:iendcol, & + & config%i_band_from_reordered_g_sw)) +#else + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + !$ACC LOOP SEQ + do jg = 1,config%n_g_sw + sw_albedo_diffuse(jg,jcol) = sw_albedo_band(jcol, & + & config%i_band_from_reordered_g_sw(jg)) + end do + end do +#endif + if (allocated(this%sw_albedo_direct)) then + !$ACC LOOP SEQ + do jband = 1,config%n_bands_sw + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + sw_albedo_band(jcol,jband) = 0.0_jprb + end do + end do + + !$ACC LOOP SEQ + do jband = 1,config%n_bands_sw + !$ACC LOOP SEQ + do jalbedoband = 1,nalbedoband +#ifndef _OPENACC + if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then +#endif + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + sw_albedo_band(jcol,jband) & + & = sw_albedo_band(jcol,jband) & + & + config%sw_albedo_weights(jalbedoband,jband) & + & * this%sw_albedo_direct(jcol, jalbedoband) + end do +#ifndef _OPENACC + end if +#endif + end do + end do +#ifndef _OPENACC + sw_albedo_direct = transpose(sw_albedo_band(istartcol:iendcol, & + & config%i_band_from_reordered_g_sw)) +#else + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + !$ACC LOOP SEQ + do jg = 1,config%n_g_sw + sw_albedo_direct(jg,jcol) = sw_albedo_band(jcol, & + & config%i_band_from_reordered_g_sw(jg)) + end do + end do +#endif + else + !$ACC LOOP GANG(STATIC:1) VECTOR + do jcol = istartcol,iendcol + !$ACC LOOP SEQ + do jg = 1,config%n_g_sw + sw_albedo_direct(jg,jcol) = sw_albedo_diffuse(jg,jcol) + end do + end do + end if + !$ACC END PARALLEL + else + ! Albedos mapped less accurately to ecRad spectral bands + if (maxval(config%i_albedo_from_band_sw) > size(this%sw_albedo,2)) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo has fewer than required ', & + & maxval(config%i_albedo_from_band_sw), ' bands' + call radiation_abort() + end if + sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol, & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) + if (allocated(this%sw_albedo_direct)) then + sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol, & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) + else + sw_albedo_direct = sw_albedo_diffuse + end if + end if + end if + + if (config%do_lw .and. present(lw_albedo)) then + if (config%use_canopy_full_spectrum_lw) then + if (config%n_g_lw /= size(this%lw_emissivity,2)) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity does not have the expected ', & + & config%n_g_lw, ' spectral intervals' + call radiation_abort() + end if + lw_albedo = 1.0_jprb - transpose(this%lw_emissivity(istartcol:iendcol,:)) + else if (.not. config%do_nearest_spectral_lw_emiss) then + ! Albedos averaged accurately to ecRad spectral bands + nalbedoband = size(config%lw_emiss_weights,1) + if (nalbedoband /= size(this%lw_emissivity,2)) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity does not have the expected ', & + & nalbedoband, ' bands' + call radiation_abort() + end if + + do jband = 1,config%n_bands_lw + do jcol = istartcol,iendcol + lw_albedo_band(jcol,jband) = 0.0_jprb + end do + end do + + do jband = 1,config%n_bands_lw + do jalbedoband = 1,nalbedoband + if (config%lw_emiss_weights(jalbedoband,jband) /= 0.0_jprb) then + do jcol = istartcol,iendcol + lw_albedo_band(jcol,jband) & + & = lw_albedo_band(jcol,jband) & + & + config%lw_emiss_weights(jalbedoband,jband) & + & * (1.0_jprb-this%lw_emissivity(jcol, jalbedoband)) + end do + end if + end do + end do + + lw_albedo = transpose(lw_albedo_band(istartcol:iendcol, & + & config%i_band_from_reordered_g_lw)) + else + if (maxval(config%i_emiss_from_band_lw) > size(this%lw_emissivity,2)) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity has fewer than required ', & + & maxval(config%i_emiss_from_band_lw), ' bands' + call radiation_abort() + end if +#ifndef _OPENACC + lw_albedo = 1.0_jprb - transpose(this%lw_emissivity(istartcol:iendcol, & + & config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw))) +#else + !$ACC PARALLEL DEFAULT(NONE) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) + do jcol = istartcol,iendcol + do jg = 1,config%n_g_lw + lw_albedo(jg,jcol) = 1.0_jprb - this%lw_emissivity(jcol, & + & config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw(jg))) + end do + end do + !$ACC END PARALLEL +#endif + end if + end if + + !$ACC WAIT + !$ACC END DATA + + if (lhook) call dr_hook('radiation_single_level:get_albedos',1,hook_handle) + + end subroutine get_albedos + + + !--------------------------------------------------------------------- + ! Return .true. if the contents of a single_level structure are out + ! of a physically sensible range, optionally only considering only + ! columns between istartcol and iendcol + function out_of_physical_bounds(this, istartcol, iendcol, do_fix) result(is_bad) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_check, only : out_of_bounds_1d, out_of_bounds_2d + + class(single_level_type), intent(inout) :: this + integer, optional,intent(in) :: istartcol, iendcol + logical, optional,intent(in) :: do_fix + logical :: is_bad + + logical :: do_fix_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_single_level:out_of_physical_bounds',0,hook_handle) + + if (present(do_fix)) then + do_fix_local = do_fix + else + do_fix_local = .false. + end if + + is_bad = out_of_bounds_1d(this%cos_sza, "cos_sza", -1.0_jprb, 1.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_1d(this%skin_temperature, "skin_temperature", 173.0_jprb, 373.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%sw_albedo, "sw_albedo", 0.0_jprb, 1.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%sw_albedo_direct, "sw_albedo", 0.0_jprb, 1.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%lw_emissivity, "lw_emissivity", 0.0_jprb, 1.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) + + if (lhook) call dr_hook('radiation_single_level:out_of_physical_bounds',1,hook_handle) + + end function out_of_physical_bounds + +#ifdef _OPENACC + !--------------------------------------------------------------------- + ! updates fields on host + subroutine update_host(this) + + class(single_level_type), intent(inout) :: this + + !$ACC UPDATE HOST(this%cos_sza) & + !$ACC IF(allocated(this%cos_sza)) + + !$ACC UPDATE HOST(this%skin_temperature) & + !$ACC IF(allocated(this%skin_temperature)) + + !$ACC UPDATE HOST(this%sw_albedo) & + !$ACC IF(allocated(this%sw_albedo)) + + !$ACC UPDATE HOST(this%sw_albedo_direct) & + !$ACC IF(allocated(this%sw_albedo_direct)) + + !$ACC UPDATE HOST(this%lw_emissivity) & + !$ACC IF(allocated(this%lw_emissivity)) + + !$ACC UPDATE HOST(this%lw_emission) & + !$ACC IF(allocated(this%lw_emission)) + + !$ACC UPDATE HOST(this%spectral_solar_scaling) & + !$ACC IF(allocated(this%spectral_solar_scaling)) + + !$ACC UPDATE HOST(this%iseed) & + !$ACC IF(allocated(this%iseed)) + + end subroutine update_host + + !--------------------------------------------------------------------- + ! updates fields on device + subroutine update_device(this) + + class(single_level_type), intent(inout) :: this + + !$ACC UPDATE DEVICE(this%cos_sza) & + !$ACC IF(allocated(this%cos_sza)) + + !$ACC UPDATE DEVICE(this%skin_temperature) & + !$ACC IF(allocated(this%skin_temperature)) + + !$ACC UPDATE DEVICE(this%sw_albedo) & + !$ACC IF(allocated(this%sw_albedo)) + + !$ACC UPDATE DEVICE(this%sw_albedo_direct) & + !$ACC IF(allocated(this%sw_albedo_direct)) + + !$ACC UPDATE DEVICE(this%lw_emissivity) & + !$ACC IF(allocated(this%lw_emissivity)) + + !$ACC UPDATE DEVICE(this%lw_emission) & + !$ACC IF(allocated(this%lw_emission)) + + !$ACC UPDATE DEVICE(this%spectral_solar_scaling) & + !$ACC IF( allocated(this%spectral_solar_scaling)) + + !$ACC UPDATE DEVICE(this%iseed) & + !$ACC IF(allocated(this%iseed)) + + end subroutine update_device +#endif + +end module radiation_single_level Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spartacus_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spartacus_lw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spartacus_lw.F90 (revision 6016) @@ -0,0 +1,1085 @@ +! radiation_spartacus_lw.F90 - SPARTACUS longwave solver +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive emission/albedo rather than planck/emissivity +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2018-09-03 R. Hogan Security via min_cloud_effective_size +! 2018-10-08 R. Hogan Call calc_region_properties +! 2019-01-12 R. Hogan Use inv_inhom_effective_size if allocated + +module radiation_spartacus_lw + + public + +contains + + ! Small routine for scaling cloud optical depth in the cloudy + ! regions +#include "radiation_optical_depth_scaling.h" + + ! This module contains just one subroutine, the longwave solver + ! using the Speedy Algorithm for Radiative Transfer through Cloud + ! Sides (SPARTACUS), which can represent 3D effects using a matrix + ! form of the two-stream equations. + ! + ! Sections: + ! 1: Prepare general variables and arrays + ! 2: Prepare column-specific variables and arrays + ! 3: First loop over layers + ! 3.1: Layer-specific initialization + ! 3.2: Compute gamma variables + ! 3.2a: Clear-sky case + ! 3.2b: Cloudy case + ! 3.3: Compute reflection, transmission and emission + ! 3.3a: g-points with 3D effects + ! 3.3b: g-points without 3D effects + ! 4: Compute total sources and albedos + ! 5: Compute fluxes + subroutine solver_spartacus_lw(nlev,istartcol,iendcol, & + & config, thermodynamics, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, planck_hl, & + & emission, albedo, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulout + use radiation_config, only : config_type, IPdfShapeGamma + use radiation_thermodynamics, only : thermodynamics_type + use radiation_cloud, only : cloud_type + use radiation_regions, only : calc_region_properties + use radiation_overlap, only : calc_overlap_matrices + use radiation_flux, only : flux_type, indexed_sum + use radiation_matrix + use radiation_two_stream, only : calc_two_stream_gammas_lw, & + calc_reflectance_transmittance_lw, LwDiffusivityWP + use radiation_lw_derivatives, only : calc_lw_derivatives_matrix + use radiation_constants, only : Pi, GasConstantDryAir, & + AccelDueToGravity + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(thermodynamics_type),intent(in) :: thermodynamics + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth of each layer at each longwave + ! g-point + real(jprb), intent(in), dimension(config%n_g_lw,nlev,istartcol:iendcol) :: od + + ! Gas and aerosol single-scattering albedo and asymmetry factor, + ! only if longwave scattering by aerosols is to be represented + real(jprb), intent(in), & + & dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol) :: ssa, g + + ! Cloud and precipitation optical depth of each layer in each + ! longwave band + real(jprb), intent(in) :: od_cloud(config%n_bands_lw,nlev,istartcol:iendcol) + + ! Cloud and precipitation single-scattering albedo and asymmetry + ! factor, only if longwave scattering by clouds is to be + ! represented + real(jprb), intent(in), dimension(config%n_bands_lw_if_scattering, & + & nlev,istartcol:iendcol) :: ssa_cloud, g_cloud + + ! Planck function (emitted flux from a black body) at half levels + real(jprb), intent(in), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) & + & :: planck_hl + + ! Emission (Planck*emissivity) and albedo (1-emissivity) at the + ! surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, istartcol:iendcol) & + & :: emission, albedo + + ! Output + type(flux_type), intent(inout):: flux + + integer :: nreg, ng + integer :: nregActive ! =1 in clear layer, =nreg in a cloudy layer + integer :: jcol, jlev, jg, jreg, iband, jreg2 + integer :: ng3D ! Number of g-points with small enough gas optical + ! depth that 3D effects need to be represented + + ! Ratio of gas constant for dry air to acceleration due to gravity + real(jprb), parameter & + & :: R_over_g = GasConstantDryAir / AccelDueToGravity + + ! Used in computing rates of lateral radiation transfer + real(jprb), parameter :: four_over_pi = 4.0_jprb / Pi + + ! The tangent of the effective zenith angle for diffuse radiation + ! that is appropriate for 3D transport + real(jprb), parameter :: tan_diffuse_angle_3d = Pi * 0.5_jprb + ! Incorrect value of tand(53) used by Hogan & Shonk (2013) + ! real(jprb), parameter :: tan_diffuse_angle_3d = 1.32704482162041 + + ! Optical depth, single scattering albedo and asymmetry factor in + ! each region at each g-point + real(jprb), dimension(config%n_g_lw, config%nregions) & + & :: od_region, ssa_region, g_region + + ! Scattering optical depths of gases and clouds + real(jprb) :: scat_od, scat_od_cloud + + ! The area fractions of each region + real(jprb) :: region_fracs(1:config%nregions,nlev,istartcol:iendcol) + + ! The scaling used for the optical depth in the cloudy regions + real(jprb) :: od_scaling(2:config%nregions,nlev,istartcol:iendcol) + + ! The length of the interface between regions per unit area of + ! gridbox, equal to L_diff^ab in Hogan and Shonk (2013). This is + ! actually the effective length oriented to a photon with random + ! azimuth angle. The three values are the edge length between + ! regions a-b, b-c and a-c. + real(jprb) :: edge_length(3) + + ! Element i,j gives the rate of 3D transfer of diffuse + ! radiation from region i to region j, multiplied by the thickness + ! of the layer in m + real(jprb) :: transfer_rate(config%nregions,config%nregions) + + ! Directional overlap matrices defined at all layer interfaces + ! including top-of-atmosphere and the surface + real(jprb), dimension(config%nregions,config%nregions,nlev+1,istartcol:iendcol) & + & :: u_matrix, v_matrix + + ! Two-stream variables + real(jprb), dimension(config%n_g_lw, config%nregions) & + & :: gamma1, gamma2 + + ! Matrix Gamma multiplied by the layer thickness z1, so units + ! metres. After calling expm, this array contains the matrix + ! exponential of the original. + real(jprb), dimension(config%n_g_lw, 2*config%nregions, & + & 2*config%nregions) :: Gamma_z1 + + ! Diffuse reflection and transmission matrices of each layer + real(jprb), dimension(config%n_g_lw, config%nregions, & + & config%nregions, nlev) :: reflectance, transmittance + + ! Clear-sky diffuse reflection and transmission matrices of each + ! layer + real(jprb), dimension(config%n_g_lw, nlev) :: ref_clear, trans_clear + + ! If the Planck term at the top of a layer in each region is the + ! vector b0 then the following is vector [-b0; b0]*dz + real(jprb), dimension(config%n_g_lw,2*config%nregions) :: planck_top + + ! The difference between the Planck terms at the bottom and top of + ! a layer, doubled as with planck_top; in terms of b' in the + ! paper, planck_diff is [-b'; b']*dz*dz + real(jprb), dimension(config%n_g_lw,2*config%nregions) :: planck_diff + + ! Parts of the particular solution associated with the + ! inhomogeneous ODE. In terms of quantities from the paper, + ! solution0 is [c0;d0] and solution_diff is [c';d']*dz. + real(jprb), dimension(config%n_g_lw,2*config%nregions) & + & :: solution0, solution_diff + + ! Used for computing the Planck emission per layer + real(jprb), dimension(config%n_g_lw,config%nregions) & + & :: tmp_vectors + + ! The fluxes upwelling from the top of a layer (source_up) and + ! downwelling from the bottom of the layer (source_dn) due to + ! emission + real(jprb), dimension(config%n_g_lw, config%nregions, nlev) & + & :: source_up, source_dn + ! ...clear-sky equivalents + real(jprb), dimension(config%n_g_lw, nlev) & + & :: source_up_clear, source_dn_clear + + ! Upwelling radiation just above a layer interface due to emission + ! below that interface, where level index = 1 corresponds to the + ! top-of-atmosphere + real(jprb), dimension(config%n_g_lw, config%nregions, nlev+1) & + & :: total_source + ! ...clear-sky equivalent + real(jprb), dimension(config%n_g_lw, nlev+1) :: total_source_clear + + ! As total_source, but just below a layer interface + real(jprb), dimension(config%n_g_lw, config%nregions) & + & :: total_source_below + + ! Total albedo of the atmosphere/surface just above a layer + ! interface with respect to downwelling diffuse radiation at that + ! interface, where level index = 1 corresponds to the + ! top-of-atmosphere + real(jprb), dimension(config%n_g_lw, config%nregions, & + & config%nregions, nlev+1) :: total_albedo + ! ...clear-sky equivalent + real(jprb), dimension(config%n_g_lw, nlev+1) :: total_albedo_clear + + ! As total_albedo, but just below a layer interface + real(jprb), dimension(config%n_g_lw, config%nregions, config%nregions) & + & :: total_albedo_below + + ! The following is used to store matrices of the form I-A*B that + ! are used on the denominator of some expressions + real(jprb), dimension(config%n_g_lw, config%nregions, config%nregions) & + & :: denominator + ! Clear-sky equivalent, but actually its reciprocal to replace + ! some divisions by multiplications + real(jprb), dimension(config%n_g_lw) :: inv_denom_scalar + + ! Layer depth (m) + real(jprb) :: dz + + ! Upwelling and downwelling fluxes above/below layer interfaces + real(jprb), dimension(config%n_g_lw, config%nregions) & + & :: flux_up_above, flux_dn_above, flux_dn_below + ! Clear-sky upwelling and downwelling fluxes (which don't + ! distinguish between whether they are above/below a layer + ! interface) + real(jprb), dimension(config%n_g_lw) :: flux_up_clear, flux_dn_clear + + ! Parameterization of internal flux distribution in a cloud that + ! can lead to the flux just about to exit a cloud being different + ! from the mean in-cloud value. "lateral_od" is the typical + ! absorption optical depth through the cloud in a horizontal + ! direction. + real(jprb), dimension(config%n_g_lw) :: lateral_od, sqrt_1_minus_ssa + real(jprb), dimension(config%n_g_lw) :: side_emiss_thick, side_emiss + + ! In the optically thin limit, the flux near the edge is greater + ! than that in the interior + real(jprb), parameter :: side_emiss_thin = 1.4107 + + real(jprb) :: aspect_ratio + + ! Keep a count of the number of calls to the two ways of computing + ! reflectance/transmittance matrices + integer :: n_calls_expm, n_calls_meador_weaver + + ! Identify clear-sky layers, with pseudo layers for outer space + ! and below the ground, both treated as single-region clear skies + logical :: is_clear_sky_layer(0:nlev+1) + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_spartacus_lw:solver_spartacus_lw',0,hook_handle) + + ! -------------------------------------------------------- + ! Section 1: Prepare general variables and arrays + ! -------------------------------------------------------- + + ! Copy array dimensions to local variables for convenience + nreg = config%nregions + ng = config%n_g_lw + + ! Reset count of number of calls to the two ways to compute + ! reflectance/transmission matrices + n_calls_expm = 0 + n_calls_meador_weaver = 0 + + ! Initialize dz to avoid compiler warning + dz = 1.0_jprb + + ! Compute the wavelength-independent region fractions and + ! optical-depth scalings + call calc_region_properties(nlev,nreg,istartcol,iendcol, & + & config%i_cloud_pdf_shape == IPdfShapeGamma, & + & cloud%fraction, cloud%fractional_std, region_fracs, & + & od_scaling, config%cloud_fraction_threshold) + + ! Compute wavelength-independent overlap matrices u_matrix and v_matrix + call calc_overlap_matrices(nlev, nreg, istartcol, iendcol, & + & region_fracs, cloud%overlap_param, & + & u_matrix, v_matrix, decorrelation_scaling=config%cloud_inhom_decorr_scaling, & + & cloud_fraction_threshold=config%cloud_fraction_threshold, & + & use_beta_overlap=config%use_beta_overlap, & + & cloud_cover=flux%cloud_cover_lw) + + if (config%iverbose >= 3) then + write(nulout,'(a)',advance='no') ' Processing columns' + end if + + ! Main loop over columns + do jcol = istartcol, iendcol + ! -------------------------------------------------------- + ! Section 2: Prepare column-specific variables and arrays + ! -------------------------------------------------------- + + if (config%iverbose >= 3) then + write(nulout,'(a)',advance='no') '.' + end if + + ! Define which layers contain cloud; assume that + ! cloud%crop_cloud_fraction has already been called + is_clear_sky_layer = .true. + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + is_clear_sky_layer(jlev) = .false. + end if + end do + + ! -------------------------------------------------------- + ! Section 3: First loop over layers + ! -------------------------------------------------------- + ! In this section the reflectance, transmittance and sources + ! are computed for each layer + do jlev = 1,nlev ! Start at top-of-atmosphere + ! -------------------------------------------------------- + ! Section 3.1: Layer-specific initialization + ! -------------------------------------------------------- + ! Array-wise assignments + gamma1 = 0.0_jprb + gamma2 = 0.0_jprb + Gamma_z1= 0.0_jprb + planck_top = 0.0_jprb + planck_diff = 0.0_jprb + transfer_rate(:,:) = 0.0_jprb + solution0 = 0.0_jprb + solution_diff = 0.0_jprb + + ! Reset clear-sky absorption/scattering properties in each + ! region + od_region = 0.0_jprb + ssa_region = 0.0_jprb ! No Rayleigh scattering in longwave by default + g_region = 0.0_jprb + + ! Set optical depth of clear-sky region (region 1) to the + ! gas/aerosol optical depth + od_region(1:ng,1) = od(1:ng, jlev, jcol) + + ! Can't deal with zero gas optical depths, but this is now + ! dealt with in radiation_ifsrrtm + ! where (od_region(:,1) < 1.0e-15_jprb) od_region(:,1) = 1.0e-15_jprb + + ! Set clear-sky single-scattering albedo and asymmetry + ! factor, if non-zero + if (config%do_lw_aerosol_scattering) then + ssa_region(1:ng,1) = ssa(1:ng, jlev, jcol) + g_region(1:ng,1) = g(1:ng, jlev, jcol) + end if + + ! -------------------------------------------------------- + ! Section 3.2: Compute gamma variables + ! -------------------------------------------------------- + if (is_clear_sky_layer(jlev)) then + ! --- Section 3.2a: Clear-sky case -------------------- + + nregActive = 1 ! Only region 1 (clear-sky) is active + + ! Compute two-stream variables gamma1 and gamma2 + call calc_two_stream_gammas_lw(ng, & + & ssa_region(1:ng,1), g_region(1:ng,1), & + & gamma1(1:ng,1), gamma2(1:ng,1)) + + if (config%use_expm_everywhere) then + ! Treat cloud-free layer as 3D: the matrix exponential + ! "expm" is used as much as possible (provided the + ! optical depth is not too high). ng3D is initially + ! set to the total number of g-points, then the + ! clear-sky optical depths are searched until a value + ! exceeds the threshold for treating 3D effects, and + ! if found it is reset to that. Note that we are + ! assuming that the g-points have been reordered in + ! approximate order of gas optical depth. + ng3D = ng + do jg = 1, ng + if (od_region(jg,1) > config%max_gas_od_3D) then + ng3D = jg-1 + exit + end if + end do + else + ! Otherwise treat cloud-free layer using the classical + ! Meador & Weaver formulae for all g-points + ng3D = 0 + end if + + else + ! --- Section 3.2b: Cloudy case ----------------------- + + ! Default number of g-points to treat with + ! matrix-exponential scheme + if (config%use_expm_everywhere) then + ng3D = ng ! All g-points + else + ng3D = 0 ! No g-points + end if + + ! Do we compute 3D effects; note that if we only have one + ! region and the sky is overcast then 3D calculations must + ! be turned off as there will be only one region + if (config%do_3d_effects .and. & + & allocated(cloud%inv_cloud_effective_size) .and. & + & .not. (nreg == 2 .and. cloud%fraction(jcol,jlev) & + & > 1.0_jprb-config%cloud_fraction_threshold)) then + if (cloud%inv_cloud_effective_size(jcol,jlev) & + & > 0.0_jprb) then + ! 3D effects are only simulated if + ! inv_cloud_effective_size is defined and greater + ! than zero + ng3D = ng + + ! The following is from the hydrostatic equation + ! and ideal gas law: dz = dp * R * T / (p * g) + dz = R_over_g & + & * (thermodynamics%pressure_hl(jcol,jlev+1) & + & - thermodynamics%pressure_hl(jcol,jlev)) & + & * (thermodynamics%temperature_hl(jcol,jlev) & + & + thermodynamics%temperature_hl(jcol,jlev+1)) & + & / (thermodynamics%pressure_hl(jcol,jlev) & + & + thermodynamics%pressure_hl(jcol,jlev+1)) + + ! Compute cloud edge length per unit area of gridbox + ! from rearranging Hogan & Shonk (2013) Eq. 45, but + ! adding a factor of (1-frac) so that a region that + ! fully occupies the gridbox (frac=1) has an edge of + ! zero. We can therefore use the fraction of clear sky, + ! region_fracs(1,jlev,jcol) for convenience instead. The + ! pi on the denominator means that this is actually edge + ! length with respect to a light ray with a random + ! azimuthal direction. + edge_length(1) = four_over_pi & + & * region_fracs(1,jlev,jcol)*(1.0_jprb-region_fracs(1,jlev,jcol)) & + & * min(cloud%inv_cloud_effective_size(jcol,jlev), & + & 1.0_jprb / config%min_cloud_effective_size) + if (nreg > 2) then + ! The corresponding edge length between the two cloudy + ! regions is computed in the same way but treating the + ! optically denser of the two regions (region 3) as + ! the cloud; note that the fraction of this region may + ! be less than that of the optically less dense of the + ! two regions (region 2). For increased flexibility, + ! the user may specify the effective size of + ! inhomogeneities separately from the cloud effective + ! size. + if (allocated(cloud%inv_inhom_effective_size)) then + edge_length(2) = four_over_pi & + & * region_fracs(3,jlev,jcol)*(1.0_jprb-region_fracs(3,jlev,jcol)) & + & * min(cloud%inv_inhom_effective_size(jcol,jlev), & + & 1.0_jprb / config%min_cloud_effective_size) + else + edge_length(2) = four_over_pi & + & * region_fracs(3,jlev,jcol)*(1.0_jprb-region_fracs(3,jlev,jcol)) & + & * min(cloud%inv_cloud_effective_size(jcol,jlev), & + & 1.0_jprb / config%min_cloud_effective_size) + end if + ! In the case of three regions, some of the cloud + ! boundary may go directly to the "thick" region + if (config%clear_to_thick_fraction > 0.0_jprb) then + edge_length(3) = config%clear_to_thick_fraction & + & * min(edge_length(1), edge_length(2)) + edge_length(1) = edge_length(1) - edge_length(3) + edge_length(2) = edge_length(2) - edge_length(3) + else + edge_length(3) = 0.0_jprb + end if + end if + + do jreg = 1, nreg-1 + ! Compute lateral transfer rate from region jreg to + ! jreg+1 following Hogan & Shonk (2013) Eq. 47, but + ! multiplied by dz because the transfer rate is + ! vertically integrated across the depth of the layer + if (region_fracs(jreg,jlev,jcol) > epsilon(1.0_jprb)) then + transfer_rate(jreg,jreg+1) = dz & + & * edge_length(jreg) & + & * tan_diffuse_angle_3d / region_fracs(jreg,jlev,jcol) + end if + ! Compute transfer rate from region jreg+1 to jreg + if (region_fracs(jreg+1,jlev,jcol) > epsilon(1.0_jprb)) then + transfer_rate(jreg+1,jreg) = dz & + & * edge_length(jreg) & + & * tan_diffuse_angle_3d / region_fracs(jreg+1,jlev,jcol) + end if + end do + + ! Compute transfer rates directly between regions 1 and + ! 3 + if (edge_length(3) > 0.0_jprb) then + if (region_fracs(1,jlev,jcol) > epsilon(1.0_jprb)) then + transfer_rate(1,3) = dz & + & * edge_length(3) & + & * tan_diffuse_angle_3d / region_fracs(1,jlev,jcol) + end if + if (region_fracs(3,jlev,jcol) > epsilon(1.0_jprb)) then + transfer_rate(3,1) = dz & + & * edge_length(3) & + & * tan_diffuse_angle_3d / region_fracs(3,jlev,jcol) + end if + end if + + ! Don't allow the transfer rate out of a region to be + ! equivalent to a loss of exp(-10) through the layer + where (transfer_rate > config%max_3d_transfer_rate) + transfer_rate = config%max_3d_transfer_rate + end where + end if ! Cloud has edge length required for 3D effects + end if ! Include 3D effects + + ! In a cloudy layer the number of active regions equals + ! the number of regions + nregActive = nreg + + ! Compute scattering properties of the regions at each + ! g-point, mapping from the cloud properties + ! defined in each band. + do jg = 1,ng + ! Mapping from g-point to band + iband = config%i_band_from_reordered_g_lw(jg) + + ! Scattering optical depth of clear-sky region + scat_od = od_region(jg,1)*ssa_region(jg,1) + + ! Loop over cloudy regions + do jreg = 2,nreg + ! Add scaled cloud optical depth to clear-sky value + od_region(jg,jreg) = od_region(jg,1) & + & + od_cloud(iband,jlev,jcol)*od_scaling(jreg,jlev,jcol) + if (config%do_lw_cloud_scattering) then + ! Compute single-scattering albedo of gas-cloud + ! combination + scat_od_cloud = od_cloud(iband,jlev,jcol) & + & * ssa_cloud(iband,jlev,jcol)*od_scaling(jreg,jlev,jcol) + ssa_region(jg,jreg) = (scat_od+scat_od_cloud) & + & / od_region(jg,jreg) + if (scat_od + scat_od_cloud > 0.0_jprb) then + ! Compute asymmetry factor of gas-cloud + ! combination + g_region(jg,jreg) & + & = (scat_od*g_region(jg,1) & + & + scat_od_cloud*g_cloud(iband,jlev,jcol)) & + & / (scat_od + scat_od_cloud) + ! else g_region is already set to zero + end if + ! else ssa_region is already set to zero + end if + + ! Apply maximum cloud optical depth for stability in the + ! 3D case + if (od_region(jg,jreg) > config%max_cloud_od) then + od_region(jg,jreg) = config%max_cloud_od + end if + + end do + + ! Calculate two-stream variables gamma1 and gamma2 of + ! all regions at once + call calc_two_stream_gammas_lw(nreg, & + & ssa_region(jg,:), g_region(jg,:), & + & gamma1(jg,:), gamma2(jg,:)) + + ! Loop is in order of g-points with typically + ! increasing optical depth: if optical depth of + ! clear-sky region exceeds a threshold then turn off + ! 3D effects for any further g-points + if (ng3D == ng & + & .and. od_region(jg,1) > config%max_gas_od_3D) then + ng3D = jg-1 + end if + end do ! Loop over g points + end if ! Cloudy level + + ! -------------------------------------------------------- + ! Section 3.3: Compute reflection, transmission and emission + ! -------------------------------------------------------- + if (ng3D > 0) then + ! --- Section 3.3a: g-points with 3D effects ---------- + + ! 3D effects need to be represented in "ng3D" of the g + ! points. This is done by creating ng3D square matrices + ! each of dimension 2*nreg by 2*nreg, computing the matrix + ! exponential, then computing the various + ! transmission/reflectance matrices from that. + do jreg = 1,nregActive + ! Write the diagonal elements of -Gamma1*z1 + Gamma_z1(1:ng3D,jreg,jreg) & + & = od_region(1:ng3D,jreg)*gamma1(1:ng3D,jreg) + ! Write the diagonal elements of +Gamma2*z1 + Gamma_z1(1:ng3D,jreg+nreg,jreg) & + & = od_region(1:ng3D,jreg)*gamma2(1:ng3D,jreg) + + ! Write the vectors corresponding to the inhomogeneous + ! parts of the matrix ODE + planck_top(1:ng3D,nreg+jreg) = od_region(1:ng3D,jreg) & + & *(1.0_jprb-ssa_region(1:ng3D,jreg))*region_fracs(jreg,jlev,jcol) & + & *planck_hl(1:ng3D,jlev,jcol)*LwDiffusivityWP + planck_top(1:ng3D,jreg) = -planck_top(1:ng3D,nreg+jreg) + planck_diff(1:ng3D,nreg+jreg) = od_region(1:ng3D,jreg) & + & * (1.0_jprb-ssa_region(1:ng3D,jreg))*region_fracs(jreg,jlev,jcol) & + & * (planck_hl(1:ng3D,jlev+1,jcol) & + & -planck_hl(1:ng3D,jlev,jcol))*LwDiffusivityWP + planck_diff(1:ng3D,jreg) = -planck_diff(1:ng3D,nreg+jreg) + end do + + if (nregActive < nreg) then + ! To avoid NaNs in some situations we need to put + ! non-zeros in the cloudy-sky regions even if the cloud + ! fraction is zero + do jreg = nregActive+1,nreg + Gamma_z1(1:ng3D,jreg,jreg) = Gamma_z1(1:ng3D,1,1) + Gamma_z1(1:ng3D,nreg+jreg,jreg) = Gamma_z1(1:ng3D,nreg+1,1) + end do + end if + + ! Parameterization for the effective emissivity of the side + ! of the cloud + if (config%do_lw_side_emissivity & + & .and. region_fracs(1,jlev,jcol) > 0.0_jprb .and. region_fracs(2,jlev,jcol) > 0.0_jprb & + & .and. config%do_3d_effects & + & .and. cloud%inv_cloud_effective_size(jcol,jlev) > 0.0_jprb) then + aspect_ratio = 1.0_jprb / (min(cloud%inv_cloud_effective_size(jcol,jlev), & + & 1.0_jprb / config%min_cloud_effective_size) & + & * region_fracs(1,jlev,jcol) * dz) + lateral_od(1:ng3D) = (aspect_ratio / (nreg-1.0_jprb)) & + & * sum(od_region(1:ng3D,2:nreg)*(1.0_jprb-ssa_region(1:ng3D,2:nreg)),2) + sqrt_1_minus_ssa(1:ng3D) = sqrt(1.0_jprb - ssa_region(1:ng3D,2)) + side_emiss_thick(1:ng3D) = 2.0_jprb * sqrt_1_minus_ssa(1:ng3D) / & + & (sqrt_1_minus_ssa(1:ng3D) & + & + sqrt(1.0_jprb-ssa_region(1:ng3D,2)*g_region(1:ng3D,2))) + side_emiss(1:ng3D) = (side_emiss_thin - side_emiss_thick(1:ng3D)) & + & / (lateral_od(1:ng3D) + 1.0_jprb) & + & + side_emiss_thick(1:ng3D) + else + side_emiss(1:ng3D) = 1.0_jprb + end if + + do jreg = 1,nregActive-1 + ! Add the terms assocated with 3D transport to Gamma1*z1. + ! First the rate from region jreg to jreg+1 + Gamma_z1(1:ng3D,jreg,jreg) = Gamma_z1(1:ng3D,jreg,jreg) & + & + transfer_rate(jreg,jreg+1) + Gamma_z1(1:ng3D,jreg+1,jreg) = -transfer_rate(jreg,jreg+1) + + ! Next the rate from region jreg+1 to jreg + if (jreg > 1) then + ! Flow between one cloudy region and another + Gamma_z1(1:ng3D,jreg+1,jreg+1) = Gamma_z1(1:ng3D,jreg+1,jreg+1) & + & + transfer_rate(jreg+1,jreg) + Gamma_z1(1:ng3D,jreg,jreg+1) = -transfer_rate(jreg+1,jreg) + else + ! Only for the lateral transfer between cloud and clear + ! skies do we account for the effective emissivity of + ! the side of the cloud + Gamma_z1(1:ng3D,jreg+1,jreg+1) = Gamma_z1(1:ng3D,jreg+1,jreg+1) & + & + side_emiss(1:ng3D) * transfer_rate(jreg+1,jreg) + Gamma_z1(1:ng3D,jreg,jreg+1) = -side_emiss(1:ng3D)*transfer_rate(jreg+1,jreg) + end if + end do + + ! Possible flow between regions a and c + if (edge_length(3) > 0.0_jprb) then + Gamma_z1(1:ng3D,1,1) = Gamma_z1(1:ng3D,1,1) & + & + transfer_rate(1,3) + Gamma_z1(1:ng3D,3,1) = -transfer_rate(1,3) + Gamma_z1(1:ng3D,3,3) = Gamma_z1(1:ng3D,3,3) & + & + side_emiss(1:ng3D) * transfer_rate(3,1) + Gamma_z1(1:ng3D,1,3) = -side_emiss(1:ng3D)*transfer_rate(3,1) + end if + + ! Copy Gamma1*z1 + Gamma_z1(1:ng3D,nreg+1:2*nreg,nreg+1:2*nreg) & + & = -Gamma_z1(1:ng3D,1:nreg,1:nreg) + ! Copy Gamma2*z1 + Gamma_z1(1:ng3D,1:nreg,nreg+1:2*nreg) & + & = -Gamma_z1(1:ng3D,nreg+1:2*nreg,1:nreg) + + ! Compute the parts of the particular solution + solution_diff(1:ng3D,1:2*nreg) & + & = solve_vec(ng,ng3D,2*nreg,Gamma_z1,planck_diff) + solution_diff(1:ng3D,1:2*nreg) = - solution_diff(1:ng3D,1:2*nreg) + solution0(1:ng3D,1:2*nreg) = solve_vec(ng,ng3D,2*nreg,Gamma_z1, & + & solution_diff-planck_top) + + ! Compute the matrix exponential of Gamma_z1, returning the + ! result in-place + call expm(ng, ng3D, 2*nreg, Gamma_z1, IMatrixPatternDense) + + ! Update count of expm calls + n_calls_expm = n_calls_expm + ng3D + + ! Diffuse reflectance matrix + reflectance(1:ng3D,:,:,jlev) = -solve_mat(ng,ng3D,nreg, & + & Gamma_z1(1:ng3D,1:nreg,1:nreg), & + & Gamma_z1(1:ng3D,1:nreg,nreg+1:2*nreg)) + ! Diffuse transmission matrix + transmittance(1:ng3D,:,:,jlev) = mat_x_mat(ng,ng3D,nreg, & + & Gamma_z1(1:ng3D,nreg+1:2*nreg,1:nreg), & + & reflectance(1:ng3D,:,:,jlev)) & + & + Gamma_z1(1:ng3D,nreg+1:2*nreg,nreg+1:2*nreg) + + ! Upward and downward sources due to emission within the + ! layer + tmp_vectors(1:ng3D,:) = solution0(1:ng3D,1:nreg) & + & + solution_diff(1:ng3D,1:nreg) & + & - mat_x_vec(ng,ng3D,nreg,Gamma_z1(:,1:nreg,nreg+1:2*nreg), & + & solution0(:,nreg+1:2*nreg)) + source_up(1:ng3D,:,jlev) = solution0(1:ng3D,1:nreg) & + & - solve_vec(ng,ng3D,nreg,Gamma_z1(:,1:nreg,1:nreg), & + & tmp_vectors) + tmp_vectors(1:ng3D,:) = source_up(1:ng3D,:,jlev) & + & - solution0(1:ng3D,1:nreg) + source_dn(1:ng3D,:,jlev) = mat_x_vec(ng,ng3D,nreg,& + & Gamma_z1(:,nreg+1:2*nreg,1:nreg),tmp_vectors) & + & + solution0(1:ng3D,nreg+1:2*nreg) & + & - mat_x_vec(ng,ng3D,nreg, & + & Gamma_z1(:,nreg+1:2*nreg,nreg+1:2*nreg), & + & solution0(:,nreg+1:2*nreg)) & + & + solution_diff(1:ng3D,nreg+1:2*nreg) + end if ! we are treating 3D effects for some g points + + ! --- Section 3.3b: g-points without 3D effects ---------- + + ! Compute reflectance, transmittance and upward and downward + ! sources for clear skies, using the Meador-Weaver formulas + ! for reflectance and transmittance, and equivalent solutions + ! to the coupled ODEs for the sources. + call calc_reflectance_transmittance_lw(ng, & + & od_region(1:ng,1), & + & gamma1(1:ng,1), gamma2(1:ng,1), & + & planck_hl(1:ng,jlev,jcol), planck_hl(1:ng,jlev+1,jcol), & + & ref_clear(1:ng,jlev), trans_clear(1:ng,jlev), & + & source_up_clear(1:ng,jlev), source_dn_clear(1:ng,jlev)) + + n_calls_meador_weaver = n_calls_meador_weaver + ng + + if (ng3D < ng) then + ! Some of the g points are to be treated using the + ! conventional plane-parallel method. First zero the + ! relevant parts of the arrays + reflectance (ng3D+1:ng,:,:,jlev) = 0.0_jprb + transmittance(ng3D+1:ng,:,:,jlev) = 0.0_jprb + source_up (ng3D+1:ng,:,jlev) = 0.0_jprb + source_dn (ng3D+1:ng,:,jlev) = 0.0_jprb + + ! Since there is no lateral transport, the clear-sky parts + ! of the arrays can be copied from the clear-sky arrays + reflectance(ng3D+1:ng,1,1,jlev) = ref_clear(ng3D+1:ng,jlev) + transmittance(ng3D+1:ng,1,1,jlev) = trans_clear(ng3D+1:ng,jlev) + source_up(ng3D+1:ng,1,jlev) = region_fracs(1,jlev,jcol)*source_up_clear(ng3D+1:ng,jlev) + source_dn(ng3D+1:ng,1,jlev) = region_fracs(1,jlev,jcol)*source_dn_clear(ng3D+1:ng,jlev) + + ! Compute reflectance, transmittance and upward and downward + ! sources, for each cloudy region, using the Meador-Weaver + ! formulas for reflectance and transmittance, and equivalent + ! solutions to the coupled ODEs for the sources. + do jreg = 2, nregActive + call calc_reflectance_transmittance_lw(ng-ng3D, & + & od_region(ng3D+1:ng,jreg), & + & gamma1(ng3D+1:ng,jreg), gamma2(ng3D+1:ng,jreg), & + & region_fracs(jreg,jlev,jcol)*planck_hl(ng3D+1:ng,jlev,jcol), & + & region_fracs(jreg,jlev,jcol)*planck_hl(ng3D+1:ng,jlev+1,jcol), & + & reflectance(ng3D+1:ng,jreg,jreg,jlev), & + & transmittance(ng3D+1:ng,jreg,jreg,jlev), & + & source_up(ng3D+1:ng,jreg,jlev), & + & source_dn(ng3D+1:ng,jreg,jlev)) + end do + n_calls_meador_weaver & + & = n_calls_meador_weaver + (ng-ng3D)*(nregActive-1) + end if + + end do ! Loop over levels + + ! -------------------------------------------------------- + ! Section 4: Compute total sources and albedos + ! -------------------------------------------------------- + + total_albedo(:,:,:,:) = 0.0_jprb + total_source(:,:,:) = 0.0_jprb + + if (config%do_clear) then + total_albedo_clear(:,:) = 0.0_jprb + total_source_clear(:,:) = 0.0_jprb + end if + + ! Calculate the upwelling radiation emitted by the surface, and + ! copy the surface albedo into total_albedo + do jreg = 1,nreg + do jg = 1,ng + ! region_fracs(jreg,nlev,jcol) is the fraction of each + ! region in the lowest model level + total_source(jg,jreg,nlev+1) = region_fracs(jreg,nlev,jcol)*emission(jg,jcol) + total_albedo(jg,jreg,jreg,nlev+1) = albedo(jg,jcol) + end do + end do + ! Equivalent surface values for computing clear-sky fluxes + if (config%do_clear) then + do jg = 1,ng + total_source_clear(jg,nlev+1) = emission(jg,jcol) + end do + ! In the case of surface albedo there is no dependence on + ! cloud fraction so we can copy the all-sky value + total_albedo_clear(1:ng,nlev+1) = total_albedo(1:ng,1,1,nlev+1) + end if + + ! Loop back up through the atmosphere computing the total albedo + ! and the total upwelling due to emission below each level + do jlev = nlev,1,-1 + if (config%do_clear) then + ! Use adding method for clear-sky arrays; note that there + ! is no need to consider "above" and "below" quantities + ! since with no cloud overlap to worry about, these are + ! the same + inv_denom_scalar(:) = 1.0_jprb & + & / (1.0_jprb - total_albedo_clear(:,jlev+1)*ref_clear(:,jlev)) + total_albedo_clear(:,jlev) = ref_clear(:,jlev) & + & + trans_clear(:,jlev)*trans_clear(:,jlev)*total_albedo_clear(:,jlev+1) & + & * inv_denom_scalar(:) + total_source_clear(:,jlev) = source_up_clear(:,jlev) & + & + trans_clear(:,jlev)*(total_source_clear(:,jlev+1) & + & + total_albedo_clear(:,jlev+1)*source_dn_clear(:,jlev)) & + & * inv_denom_scalar(:) + end if + + if (is_clear_sky_layer(jlev)) then + ! Clear-sky layer: use scalar adding method + inv_denom_scalar(:) = 1.0_jprb & + & / (1.0_jprb - total_albedo(:,1,1,jlev+1)*reflectance(:,1,1,jlev)) + total_albedo_below = 0.0_jprb + total_albedo_below(:,1,1) = reflectance(:,1,1,jlev) & + & + transmittance(:,1,1,jlev) * transmittance(:,1,1,jlev) & + & * total_albedo(:,1,1,jlev+1) * inv_denom_scalar(:) + total_source_below = 0.0_jprb + total_source_below(:,1) = source_up(:,1,jlev) & + & + transmittance(:,1,1,jlev)*(total_source(:,1,jlev+1) & + & + total_albedo(:,1,1,jlev+1)*source_dn(:,1,jlev)) & + & * inv_denom_scalar(:) + else if (config%do_3d_effects .or. & + & config%do_3d_lw_multilayer_effects) then + ! Cloudy layer: use matrix adding method + denominator = identity_minus_mat_x_mat(ng,ng,nreg,& + & total_albedo(:,:,:,jlev+1), reflectance(:,:,:,jlev)) + total_albedo_below = reflectance(:,:,:,jlev) & + & + mat_x_mat(ng,ng,nreg,transmittance(:,:,:,jlev), & + & solve_mat(ng,ng,nreg,denominator, & + & mat_x_mat(ng,ng,nreg,total_albedo(:,:,:,jlev+1), & + & transmittance(:,:,:,jlev)))) + total_source_below = source_up(:,:,jlev) & + & + mat_x_vec(ng,ng,nreg,transmittance(:,:,:,jlev), & + & solve_vec(ng,ng,nreg,denominator, & + & total_source(:,:,jlev+1) + mat_x_vec(ng,ng,nreg, & + & total_albedo(:,:,:,jlev+1),source_dn(:,:,jlev)))) + else + ! Cloudy layer for which reflectance, transmittance and + ! total_albedo matrices are diagonal + total_albedo_below = 0.0_jprb + total_source_below = 0.0_jprb + do jreg = 1,nreg + inv_denom_scalar(:) = 1.0_jprb / (1.0_jprb & + & - total_albedo(:,jreg,jreg,jlev+1)*reflectance(:,jreg,jreg,jlev)) + total_albedo_below(:,jreg,jreg) = reflectance(:,jreg,jreg,jlev) & + & + transmittance(:,jreg,jreg,jlev)*transmittance(:,jreg,jreg,jlev) & + & * total_albedo(:,jreg,jreg,jlev+1) & + & * inv_denom_scalar(:) + total_source_below(:,jreg) = source_up(:,jreg,jlev) & + & + transmittance(:,jreg,jreg,jlev)*(total_source(:,jreg,jlev+1) & + & + total_albedo(:,jreg,jreg,jlev+1)*source_dn(:,jreg,jlev)) & + & * inv_denom_scalar(:) + end do + + end if + + ! Account for cloud overlap when converting albedo and + ! source below a layer interface to the equivalent values + ! just above + if (is_clear_sky_layer(jlev) .and. is_clear_sky_layer(jlev-1)) then + ! If both layers are cloud free, this is trivial... + total_albedo(:,:,:,jlev) = 0.0_jprb + total_albedo(:,1,1,jlev) = total_albedo_below(:,1,1) + total_source(:,:,jlev) = 0.0_jprb + total_source(:,1,jlev) = total_source_below(:,1) + else + total_source(:,:,jlev) = singlemat_x_vec(ng,ng,nreg,& + & u_matrix(:,:,jlev,jcol), total_source_below) + +! if (config%do_3d_effects .or. config%do_3d_lw_multilayer_effects) then + if (config%do_3d_lw_multilayer_effects) then + ! Use the overlap matrices u_matrix and v_matrix + total_albedo(:,:,:,jlev) = singlemat_x_mat(ng,ng,nreg,& + & u_matrix(:,:,jlev,jcol), & + & mat_x_singlemat(ng,ng,nreg,total_albedo_below,& + & v_matrix(:,:,jlev,jcol))) + else + total_albedo(:,:,:,jlev) = 0.0_jprb + ! "total_albedo" is diagonal and we wish to exclude + ! anomalous horizontal transport described by Shonk & + ! Hogan (2008). Therefore, the operation we perform is + ! essentially diag(total_albedo) = matmul(transpose(v_matrix), + ! diag(total_albedo_below)). + do jreg = 1,nreg + do jreg2 = 1,nreg + total_albedo(:,jreg,jreg,jlev) & + & = total_albedo(:,jreg,jreg,jlev) & + & + total_albedo_below(:,jreg2,jreg2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + end do + end do + end if + end if + + end do ! Reverse loop over levels + + ! -------------------------------------------------------- + ! Section 5: Compute fluxes + ! -------------------------------------------------------- + + ! Top-of-atmosphere fluxes into the regions of the top-most + ! layer: zero since we assume no extraterrestrial longwave + ! radiation (the shortwave scheme accounts for solar radiation + ! in the "longwave" part of the spectrum) + flux_dn_below = 0.0_jprb + flux%lw_dn(jcol,1) = 0.0_jprb + if (config%do_clear) then + flux_dn_clear = 0.0_jprb + flux%lw_dn_clear(jcol,1) = 0.0_jprb + end if + + ! Store the outgoing longwave radiation at top-of-atmosphere + flux%lw_up(jcol,1) = sum(sum(total_source(:,:,1),1)) + if (config%do_clear) then + flux%lw_up_clear(jcol,1) = sum(total_source_clear(:,1)) + end if + + if (config%do_save_spectral_flux) then + call indexed_sum(sum(total_source(:,:,1),2), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,1)) + flux%lw_dn_band(:,jcol,1) = 0.0_jprb + if (config%do_clear) then + call indexed_sum(total_source_clear(:,1), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_clear_band(:,jcol,1)) + flux%lw_dn_clear_band(:,jcol,1) = 0.0_jprb + end if + end if + + ! Final loop back down through the atmosphere to compute fluxes + do jlev = 1,nlev + if (config%do_clear) then + ! Scalar operations for clear-sky fluxes + flux_dn_clear(:) = (trans_clear(:,jlev)*flux_dn_clear(:) & + + ref_clear(:,jlev)*total_source_clear(:,jlev+1) & + + source_dn_clear(:,jlev)) & + / (1.0_jprb - ref_clear(:,jlev)*total_albedo_clear(:,jlev+1)) + flux_up_clear(:) = total_source_clear(:,jlev+1) & + + total_albedo_clear(:,jlev+1)*flux_dn_clear(:) + end if + + if (is_clear_sky_layer(jlev)) then + ! Scalar operations for clear-sky layer + flux_dn_above(:,1) = (transmittance(:,1,1,jlev)*flux_dn_below(:,1) & + & + reflectance(:,1,1,jlev)*total_source(:,1,jlev+1) & + & + source_dn(:,1,jlev)) & + & / (1.0_jprb - reflectance(:,1,1,jlev)*total_albedo(:,1,1,jlev+1)) + flux_dn_above(:,2:nreg) = 0.0_jprb + flux_up_above(:,1) = total_source(:,1,jlev+1) & + & + total_albedo(:,1,1,jlev+1)*flux_dn_above(:,1) + flux_up_above(:,2:nreg) = 0.0_jprb + else if (config%do_3d_effects .or. config%do_3d_lw_multilayer_effects) then + ! Matrix operations for cloudy layer + denominator = identity_minus_mat_x_mat(ng,ng,nreg,reflectance(:,:,:,jlev), & + & total_albedo(:,:,:,jlev+1)) + flux_dn_above = solve_vec(ng,ng,nreg,denominator, & + & mat_x_vec(ng,ng,nreg,transmittance(:,:,:,jlev),flux_dn_below) & + & + mat_x_vec(ng,ng,nreg,reflectance(:,:,:,jlev), & + & total_source(:,:,jlev+1)) & + & + source_dn(:,:,jlev)) + flux_up_above = mat_x_vec(ng,ng,nreg,total_albedo(:,:,:,jlev+1), & + & flux_dn_above) + total_source(:,:,jlev+1) + else + do jreg = 1,nreg + ! Scalar operations for all regions, requiring that + ! reflectance, transmittance and total_albedo are diagonal + flux_dn_above(:,jreg) = (transmittance(:,jreg,jreg,jlev)*flux_dn_below(:,jreg) & + & + reflectance(:,jreg,jreg,jlev)*total_source(:,jreg,jlev+1) & + & + source_dn(:,jreg,jlev)) & + & / (1.0_jprb - reflectance(:,jreg,jreg,jlev) & + & * total_albedo(:,jreg,jreg,jlev+1)) + flux_up_above(:,jreg) = total_source(:,jreg,jlev+1) & + & + total_albedo(:,jreg,jreg,jlev+1)*flux_dn_above(:,jreg) + end do + end if + + ! Account for overlap rules in translating fluxes just above + ! a layer interface to the values just below + if (is_clear_sky_layer(jlev) .and. is_clear_sky_layer(jlev+1)) then + flux_dn_below = flux_dn_above + else + flux_dn_below = singlemat_x_vec(ng,ng,nreg,v_matrix(:,:,jlev+1,jcol), & + & flux_dn_above) + end if + + ! Store the broadband fluxes + flux%lw_up(jcol,jlev+1) = sum(sum(flux_up_above,1)) + flux%lw_dn(jcol,jlev+1) = sum(sum(flux_dn_above,1)) + if (config%do_clear) then + flux%lw_up_clear(jcol,jlev+1) = sum(flux_up_clear) + flux%lw_dn_clear(jcol,jlev+1) = sum(flux_dn_clear) + end if + + if (config%do_save_spectral_flux) then + call indexed_sum(sum(flux_up_above,2), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,jlev+1)) + call indexed_sum(sum(flux_dn_above,2), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_band(:,jcol,jlev+1)) + if (config%do_clear) then + call indexed_sum(flux_up_clear, & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_clear_band(:,jcol,jlev+1)) + call indexed_sum(flux_dn_clear, & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_clear_band(:,jcol,jlev+1)) + end if + end if + + end do ! Final loop over levels + + ! Store surface spectral downwelling fluxes, which at this point + ! are at the surface + flux%lw_dn_surf_g(:,jcol) = sum(flux_dn_above,2) + if (config%do_clear) then + flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear + end if + + ! Compute the longwave derivatives needed by Hogan and Bozzo + ! (2015) approximate radiation update scheme + if (config%do_lw_derivatives) then + ! Note that at this point flux_up_above contains the spectral + ! fluxes into the regions of the lowest layer; we sum over + ! regions first to provide a simple spectral flux upwelling + ! from the surface + call calc_lw_derivatives_matrix(ng, nlev, nreg, jcol, transmittance, & + & u_matrix(:,:,:,jcol), sum(flux_up_above,2), flux%lw_derivatives) + end if + + end do ! Loop over columns + + if (config%iverbose >= 3) then + write(nulout,*) + end if + + ! Report number of calls to each method of solving single-layer + ! two-stream equations + if (config%iverbose >= 4) then + write(nulout,'(a,i0)') ' Matrix-exponential calls: ', n_calls_expm + write(nulout,'(a,i0)') ' Meador-Weaver calls: ', n_calls_meador_weaver + end if + + if (lhook) call dr_hook('radiation_spartacus_lw:solver_spartacus_lw',1,hook_handle) + + end subroutine solver_spartacus_lw + +end module radiation_spartacus_lw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spartacus_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spartacus_sw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spartacus_sw.F90 (revision 6016) @@ -0,0 +1,1719 @@ +! radiation_spartacus_sw.F90 - SPARTACUS shortwave solver +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive albedos at g-points +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-06-30 R. Hogan Reformulate to use total_albedo_direct not total_source +! 2017-07-03 R. Hogan Explicit calculation of encroachment +! 2017-10-23 R. Hogan Renamed single-character variables +! 2018-02-20 R. Hogan Corrected "computed" encroachment +! 2018-03-09 R. Hogan Security on computed encroachment, transmittance and reflectance +! 2018-08-29 R. Hogan Reformulate horizontal migration distances in step_migrations +! 2018-09-02 R. Hogan Bug fix in x_direct in step_migrations +! 2018-09-03 R. Hogan Security via min_cloud_effective_size +! 2018-09-04 R. Hogan Use encroachment_scaling and read encroachment edge_length from upper layer +! 2018-09-13 R. Hogan Added "Fractal" encroachment option +! 2018-09-14 R. Hogan Added "Zero" encroachment option +! 2018-10-08 R. Hogan Call calc_region_properties +! 2018-10-15 R. Hogan Added call to fast_expm_exchange instead of expm +! 2019-01-12 R. Hogan Use inv_inhom_effective_size if allocated +! 2019-02-10 R. Hogan Renamed "encroachment" to "entrapment" + +module radiation_spartacus_sw + + public + +contains + + ! Small routine for scaling cloud optical depth in the cloudy + ! regions +#include "radiation_optical_depth_scaling.h" + + ! This module contains just one exported subroutine, the shortwave + ! solver using the Speedy Algorithm for Radiative Transfer through + ! Cloud Sides (SPARTACUS), which can represent 3D effects using a + ! matrix form of the two-stream equations. + ! + ! Sections: + ! 1: Prepare general variables and arrays + ! 2: Prepare column-specific variables and arrays + ! 3: First loop over layers + ! 3.1: Layer-specific initialization + ! 3.2: Compute gamma variables + ! 3.2a: Clear-sky case + ! 3.2b: Cloudy case + ! 3.3: Compute reflection, transmission and sources + ! 3.3a: g-points with 3D effects + ! 3.3b: g-points without 3D effects + ! 4: Compute total albedos + ! 4.1: Adding method + ! 4.2: Overlap and entrapment + ! 5: Compute fluxes + subroutine solver_spartacus_sw(nlev,istartcol,iendcol, & + & config, single_level, thermodynamics, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, & + & albedo_direct, albedo_diffuse, incoming_sw, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + + use radiation_io, only : nulout + use radiation_config, only : config_type, IPdfShapeGamma, & + & IEntrapmentZero, IEntrapmentEdgeOnly, IEntrapmentExplicit, & + & IEntrapmentExplicitNonFractal, IEntrapmentMaximum + use radiation_single_level, only : single_level_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_cloud, only : cloud_type + use radiation_regions, only : calc_region_properties + use radiation_overlap, only : calc_overlap_matrices + use radiation_flux, only : flux_type, & + & indexed_sum, add_indexed_sum + use radiation_matrix + use radiation_two_stream, only : calc_two_stream_gammas_sw, & + & calc_reflectance_transmittance_sw, calc_frac_scattered_diffuse_sw + use radiation_constants, only : Pi, GasConstantDryAir, & + & AccelDueToGravity + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type),intent(in) :: thermodynamics + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each shortwave g-point + real(jprb), intent(in), dimension(config%n_g_sw,nlev,istartcol:iendcol) :: & + & od, ssa, g + + ! Cloud and precipitation optical depth, single-scattering albedo and + ! asymmetry factor in each shortwave band + real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: & + & od_cloud, ssa_cloud, g_cloud + + ! Direct and diffuse surface albedos, and the incoming shortwave + ! flux into a plane perpendicular to the incoming radiation at + ! top-of-atmosphere in each of the shortwave g points + real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) :: & + & albedo_direct, albedo_diffuse, incoming_sw + + ! Output + type(flux_type), intent(inout):: flux + + integer :: nreg, ng + integer :: nregactive ! =1 in clear layer, =nreg in a cloudy layer + integer :: jcol, jlev, jg, jreg, iband, jreg2,jreg3 +#ifdef EXPLICIT_EDGE_ENTRAPMENT + integer :: jreg4 +#endif + integer :: ng3D ! Number of g-points with small enough gas optical + ! depth that 3D effects need to be represented + + ! Ratio of gas constant for dry air to acceleration due to gravity + real(jprb), parameter :: R_over_g = GasConstantDryAir / AccelDueToGravity + + real(jprb) :: mu0, one_over_mu0, tan_sza, transfer_scaling + + ! The tangent of the effective zenith angle for diffuse radiation + ! that is appropriate for 3D transport + real(jprb), parameter :: tan_diffuse_angle_3d = Pi * 0.5_jprb + + ! The minimum cosine of solar zenith angle to consider for 3D + ! effects, equivalent to one solar radius (0.2615 degrees) + real(jprb), parameter :: min_mu0_3d = 0.004625_jprb + + ! Optical depth, single scattering albedo and asymmetry factor in + ! each region and (except for asymmetry) at each g-point + real(jprb), dimension(config%n_g_sw, config%nregions) & + & :: od_region, ssa_region + real(jprb), dimension(config%nregions) :: g_region + + ! Scattering optical depths of gases and clouds + real(jprb) :: scat_od, scat_od_cloud + + ! The area fractions of each region + real(jprb) :: region_fracs(1:config%nregions,nlev,istartcol:iendcol) + + ! The scaling used for the optical depth in the cloudy regions + real(jprb) :: od_scaling(2:config%nregions,nlev,istartcol:iendcol) + + ! The length of the interface between regions jreg and jreg+1 per + ! unit area of gridbox, equal to L_diff^ab in Hogan and Shonk + ! (2013). When the first index is 3, this is the length of the + ! interface between regions 3 and 1. This is actually the + ! effective length oriented to a photon with random azimuth angle, + ! so is the true edge length divided by pi. + real(jprb) :: edge_length(3,nlev) + + ! Element i,j gives the rate of 3D transfer of diffuse/direct + ! radiation from region i to region j, multiplied by the thickness + ! of the layer in m + real(jprb) :: transfer_rate_diffuse(config%nregions,config%nregions) + real(jprb) :: transfer_rate_direct(config%nregions,config%nregions) + + ! Directional overlap matrices defined at all layer interfaces + ! including top-of-atmosphere and the surface + real(jprb), dimension(config%nregions,config%nregions,nlev+1, & + & istartcol:iendcol) :: u_matrix, v_matrix + + ! Two-stream variables + real(jprb), dimension(config%n_g_sw, config%nregions) & + & :: gamma1, gamma2, gamma3 + + ! Matrix Gamma multiplied by the layer thickness z1, so units + ! metres. After calling expm, this array contains the matrix + ! exponential of the original. + real(jprb) :: Gamma_z1(config%n_g_sw,3*config%nregions,3*config%nregions) + + ! Diffuse reflection and transmission matrices of each layer + real(jprb), dimension(config%n_g_sw, config%nregions, & + & config%nregions, nlev) :: reflectance, transmittance + + ! Clear-sky diffuse reflection and transmission matrices of each + ! layer + real(jprb), dimension(config%n_g_sw, nlev) :: ref_clear, trans_clear + + ! Matrices translating the direct flux entering the layer from + ! above to the reflected radiation exiting upwards (ref_dir) and + ! the scattered radiation exiting downwards (trans_dir_diff), + ! along with the direct unscattered transmission matrix + ! (trans_dir_dir). + real(jprb), dimension(config%n_g_sw, config%nregions, config%nregions, nlev) & + & :: ref_dir, trans_dir_diff, trans_dir_dir + ! ...clear-sky equivalents + real(jprb), dimension(config%n_g_sw, nlev) & + & :: ref_dir_clear, trans_dir_diff_clear, trans_dir_dir_clear + + ! The fluxes downwelling from the bottom of the layer due to + ! scattering by the direct beam within the layer + real(jprb), dimension(config%n_g_sw, config%nregions) :: source_dn + ! ...clear-sky equivalent + real(jprb), dimension(config%n_g_sw) :: source_dn_clear + + ! The fluxes upwelling just above the base of a layer due to + ! reflection of the direct downwelling beam; this is just used as + ! a temporary variable + real(jprb), dimension(config%n_g_sw, config%nregions) :: total_source + + ! Direct downwelling flux below and above an interface between + ! layers into a plane perpendicular to the direction of the sun + real(jprb), dimension(config%n_g_sw, config%nregions) & + & :: direct_dn_below, direct_dn_above + ! ...clear-sky equivalent (no distinction between "above/below") + real(jprb), dimension(config%n_g_sw) :: direct_dn_clear + + ! Total albedo of the atmosphere/surface just above a layer + ! interface with respect to downwelling diffuse and direct + ! radiation at that interface, where level index = 1 corresponds + ! to the top-of-atmosphere + real(jprb), dimension(config%n_g_sw, config%nregions, & + & config%nregions, nlev+1) :: total_albedo, total_albedo_direct + ! ...clear-sky equivalent + real(jprb), dimension(config%n_g_sw, nlev+1) & + & :: total_albedo_clear, total_albedo_clear_direct + + ! As total_albedo, but just below a layer interface + real(jprb), dimension(config%n_g_sw, config%nregions, config%nregions) & + & :: total_albedo_below, total_albedo_below_direct + + ! Temporary array for applying adding method with entrapment to + ! albedo matrices + real(jprb), dimension(config%n_g_sw, config%nregions, config%nregions) & + & :: albedo_part + + ! Horizontal migration distance (m) of reflected light + real(jprb), dimension(config%n_g_sw, config%nregions) & + & :: x_diffuse, x_direct + ! Temporary variables when applying overlap rules + real(jprb), dimension(config%n_g_sw, config%nregions) & + & :: x_diffuse_above, x_direct_above + + real(jprb), dimension(config%n_g_sw, config%nregions, config%nregions) & + & :: entrapment + + ! The following is used to store matrices of the form I-A*B that + ! are used on the denominator of some expressions + real(jprb) :: denominator(config%n_g_sw,config%nregions,config%nregions) + + ! Clear-sky equivalent, but actually its reciprocal to replace + ! some divisions by multiplications + real(jprb), dimension(config%n_g_sw) :: inv_denom_scalar + + ! Final step in working out how much transport between regions + ! above occurs + real(jprb), dimension(config%n_g_sw) :: fractal_factor + + ! Inverse of cloud effective size (m^-1) + real(jprb) :: inv_effective_size + + ! Layer depth (m) + real(jprb) :: dz, layer_depth(nlev) + + ! Upwelling and downwelling fluxes above/below layer interfaces + real(jprb), dimension(config%n_g_sw, config%nregions) & + & :: flux_up_above, flux_dn_above, flux_dn_below + ! Clear-sky upwelling and downwelling fluxes (which don't + ! distinguish between whether they are above/below a layer + ! interface) + real(jprb), dimension(config%n_g_sw) :: flux_up_clear, flux_dn_clear + + ! Index of top-most cloudy layer, or nlev+1 if no cloud + integer :: i_cloud_top + + ! Keep a count of the number of calls to the two ways of computing + ! reflectance/transmittance matrices + integer :: n_calls_expm, n_calls_meador_weaver + + ! Identify clear-sky layers, with pseudo layers for outer space + ! and below the ground, both treated as single-region clear skies + logical :: is_clear_sky_layer(0:nlev+1) + + ! Used in computing rates of lateral radiation transfer + real(jprb), parameter :: four_over_pi = 4.0_jprb / Pi + + ! Maximum entrapment coefficient + real(jprb) :: max_entr + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_spartacus_sw:solver_spartacus_sw',0,hook_handle) + + ! -------------------------------------------------------- + ! Section 1: Prepare general variables and arrays + ! -------------------------------------------------------- + + ! Copy array dimensions to local variables for convenience + nreg = config%nregions + ng = config%n_g_sw + + ! Reset count of number of calls to the two ways to compute + ! reflectance/transmission matrices + n_calls_expm = 0 + n_calls_meador_weaver = 0 + + ! Compute the wavelength-independent region fractions and + ! optical-depth scalings + call calc_region_properties(nlev,nreg,istartcol,iendcol, & + & config%i_cloud_pdf_shape == IPdfShapeGamma, & + & cloud%fraction, cloud%fractional_std, region_fracs, & + & od_scaling, config%cloud_fraction_threshold) + + ! Compute wavelength-independent overlap matrices u_matrix and v_matrix + call calc_overlap_matrices(nlev,nreg,istartcol,iendcol, & + & region_fracs, cloud%overlap_param, & + & u_matrix, v_matrix, decorrelation_scaling=config%cloud_inhom_decorr_scaling, & + & cloud_fraction_threshold=config%cloud_fraction_threshold, & + & use_beta_overlap=config%use_beta_overlap, & + & cloud_cover=flux%cloud_cover_sw) + + if (config%iverbose >= 3) then + write(nulout,'(a)',advance='no') ' Processing columns' + end if + + ! Main loop over columns + do jcol = istartcol, iendcol + ! -------------------------------------------------------- + ! Section 2: Prepare column-specific variables and arrays + ! -------------------------------------------------------- + + if (config%iverbose >= 3) then + write(nulout,'(a)',advance='no') '.' + end if + + ! Copy local cosine of the solar zenith angle + mu0 = single_level%cos_sza(jcol) + + ! Skip profile if sun is too low in the sky + if (mu0 < 1.0e-10_jprb) then + flux%sw_dn(jcol,:) = 0.0_jprb + flux%sw_up(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = 0.0_jprb + end if + if (config%do_clear) then + flux%sw_dn_clear(jcol,:) = 0.0_jprb + flux%sw_up_clear(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,:) = 0.0_jprb + end if + end if + + if (config%do_save_spectral_flux) then + flux%sw_dn_band(:,jcol,:) = 0.0_jprb + flux%sw_up_band(:,jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,:) = 0.0_jprb + end if + if (config%do_clear) then + flux%sw_dn_clear_band(:,jcol,:) = 0.0_jprb + flux%sw_up_clear_band(:,jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,:) = 0.0_jprb + end if + end if + end if + + flux%sw_dn_diffuse_surf_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_g(:,jcol) = 0.0_jprb + if (config%do_clear) then + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_clear_g(:,jcol) = 0.0_jprb + end if + + cycle + end if ! sun is below the horizon + + ! At this point mu0 >= 1.0e-10 + + ! Used to compute rate of attenuation of direct solar beam + ! through the atmosphere + one_over_mu0 = 1.0_jprb / mu0 + + ! The rate at which direct radiation enters cloud sides is + ! proportional to the tangent of the solar zenith angle, but + ! this gets very large when the sun is low in the sky, in which + ! case we limit it to one solar radius above the horizon + if (mu0 < min_mu0_3d) then + tan_sza = sqrt(1.0_jprb/(min_mu0_3d*min_mu0_3d) - 1.0_jprb) + else if (one_over_mu0 > 1.0_jprb) then + tan_sza = sqrt(one_over_mu0*one_over_mu0 - 1.0_jprb & + & + config%overhead_sun_factor) + else + ! Just in case we get mu0 > 1... + tan_sza = sqrt(config%overhead_sun_factor) + end if + + ! Define which layers contain cloud; assume that + ! cloud%crop_cloud_fraction has already been called + is_clear_sky_layer = .true. + i_cloud_top = nlev+1 + do jlev = nlev,1,-1 + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + is_clear_sky_layer(jlev) = .false. + i_cloud_top = jlev + end if + end do + + ! -------------------------------------------------------- + ! Section 3: First loop over layers + ! -------------------------------------------------------- + ! In this section the reflectance, transmittance and sources + ! are computed for each layer + do jlev = 1,nlev ! Start at top-of-atmosphere + ! -------------------------------------------------------- + ! Section 3.1: Layer-specific initialization + ! -------------------------------------------------------- + + ! Array-wise assignments + gamma1 = 0.0_jprb + gamma2 = 0.0_jprb + gamma3 = 0.0_jprb + Gamma_z1= 0.0_jprb + transfer_rate_direct(:,:) = 0.0_jprb + transfer_rate_diffuse(:,:) = 0.0_jprb + edge_length(:,jlev) = 0.0_jprb + + ! The following is from the hydrostatic equation + ! and ideal gas law: dz = dp * R * T / (p * g) + layer_depth(jlev) = R_over_g & + & * (thermodynamics%pressure_hl(jcol,jlev+1) & + & - thermodynamics%pressure_hl(jcol,jlev)) & + & * (thermodynamics%temperature_hl(jcol,jlev) & + & + thermodynamics%temperature_hl(jcol,jlev+1)) & + & / (thermodynamics%pressure_hl(jcol,jlev) & + & + thermodynamics%pressure_hl(jcol,jlev+1)) + + ! -------------------------------------------------------- + ! Section 3.2: Compute gamma variables + ! -------------------------------------------------------- + if (is_clear_sky_layer(jlev)) then + ! --- Section 3.2a: Clear-sky case -------------------- + + nregactive = 1 ! Only region 1 (clear-sky) is active + + ! Copy optical depth and single-scattering albedo of + ! clear-sky region + od_region(1:ng,1) = od(1:ng,jlev,jcol) + ssa_region(1:ng,1) = ssa(1:ng,jlev,jcol) + + ! Compute two-stream variables gamma1-gamma3 (gamma4=1-gamma3) + call calc_two_stream_gammas_sw(ng, & + & mu0, ssa(1:ng,jlev,jcol), g(1:ng,jlev,jcol), & + & gamma1(1:ng,1), gamma2(1:ng,1), gamma3(1:ng,1)) + + if (config%use_expm_everywhere) then + ! Treat cloud-free layer as 3D: the matrix exponential + ! "expm" is used as much as possible (provided the + ! optical depth is not too high). ng3D is initially + ! set to the total number of g-points, then the + ! clear-sky optical depths are searched until a value + ! exceeds the threshold for treating 3D effects, and + ! if found it is reset to that. Note that we are + ! assuming that the g-points have been reordered in + ! approximate order of gas optical depth. + ng3D = ng + do jg = 1, ng + if (od_region(jg,1) > config%max_gas_od_3D) then + ng3D = jg-1 + exit + end if + end do + else + ! Otherwise treat cloud-free layer using the classical + ! Meador & Weaver formulae for all g-points + ng3D = 0 + end if + + + else + ! --- Section 3.2b: Cloudy case ----------------------- + + ! Default number of g-points to treat with + ! matrix-exponential scheme + if (config%use_expm_everywhere) then + ng3D = ng ! All g-points + else + ng3D = 0 ! No g-points + end if + + if (config%do_3d_effects .and. & + & allocated(cloud%inv_cloud_effective_size) .and. & + & .not. (nreg == 2 .and. cloud%fraction(jcol,jlev) & + & > 1.0-config%cloud_fraction_threshold)) then + if (cloud%inv_cloud_effective_size(jcol,jlev) > 0.0_jprb) then + ! 3D effects are only simulated if + ! inv_cloud_effective_size is defined and greater + ! than zero + ng3D = ng + + ! Depth of current layer + dz = layer_depth(jlev) + + ! Compute cloud edge length per unit area of gridbox + ! from rearranging Hogan & Shonk (2013) Eq. 45, but + ! adding a factor of (1-frac) so that a region that + ! fully occupies the gridbox (frac=1) has an edge of + ! zero. We can therefore use the fraction of clear sky, + ! region_fracs(1,jlev,jcol) for convenience instead. The + ! pi on the denominator means that this is actually edge + ! length with respect to a light ray with a random + ! azimuthal direction. + edge_length(1,jlev) = four_over_pi & + & * region_fracs(1,jlev,jcol)*(1.0_jprb-region_fracs(1,jlev,jcol)) & + & * min(cloud%inv_cloud_effective_size(jcol,jlev), & + & 1.0_jprb / config%min_cloud_effective_size) + if (nreg > 2) then + ! The corresponding edge length between the two cloudy + ! regions is computed in the same way but treating the + ! optically denser of the two regions (region 3) as + ! the cloud; note that the fraction of this region may + ! be less than that of the optically less dense of the + ! two regions (region 2). For increased flexibility, + ! the user may specify the effective size of + ! inhomogeneities separately from the cloud effective + ! size. + if (allocated(cloud%inv_inhom_effective_size)) then + edge_length(2,jlev) = four_over_pi & + & * region_fracs(3,jlev,jcol)*(1.0_jprb-region_fracs(3,jlev,jcol)) & + & * min(cloud%inv_inhom_effective_size(jcol,jlev), & + & 1.0_jprb / config%min_cloud_effective_size) + else + edge_length(2,jlev) = four_over_pi & + & * region_fracs(3,jlev,jcol)*(1.0_jprb-region_fracs(3,jlev,jcol)) & + & * min(cloud%inv_cloud_effective_size(jcol,jlev), & + & 1.0_jprb / config%min_cloud_effective_size) + end if + + ! In the case of three regions, some of the cloud + ! boundary may go directly to the "thick" region + if (config%clear_to_thick_fraction > 0.0_jprb) then + edge_length(3,jlev) = config%clear_to_thick_fraction & + & * min(edge_length(1,jlev), edge_length(2,jlev)) + edge_length(1,jlev) = edge_length(1,jlev) - edge_length(3,jlev) + edge_length(2,jlev) = edge_length(2,jlev) - edge_length(3,jlev) + else + edge_length(3,jlev) = 0.0_jprb + end if + end if + + do jreg = 1, nreg-1 + ! Compute lateral transfer rates from region jreg to + ! jreg+1 following Hogan & Shonk (2013) Eq. 47, but + ! multiplied by dz because the transfer rate is + ! vertically integrated across the depth of the layer + if (region_fracs(jreg,jlev,jcol) > epsilon(1.0_jprb)) then + transfer_rate_direct(jreg,jreg+1) = dz & + & * edge_length(jreg,jlev) * tan_sza / region_fracs(jreg,jlev,jcol) + transfer_rate_diffuse(jreg,jreg+1) = dz & + & * edge_length(jreg,jlev) & + & * tan_diffuse_angle_3d / region_fracs(jreg,jlev,jcol) + end if + ! Compute transfer rates from region jreg+1 to + ! jreg + if (region_fracs(jreg+1,jlev,jcol) > epsilon(1.0_jprb)) then + transfer_rate_direct(jreg+1,jreg) = dz & + & * edge_length(jreg,jlev) & + & * tan_sza / region_fracs(jreg+1,jlev,jcol) + transfer_rate_diffuse(jreg+1,jreg) = dz & + & * edge_length(jreg,jlev) & + & * tan_diffuse_angle_3d / region_fracs(jreg+1,jlev,jcol) + end if + end do + + ! Compute transfer rates directly between regions 1 and + ! 3 + if (edge_length(3,jlev) > 0.0_jprb) then + if (region_fracs(1,jlev,jcol) > epsilon(1.0_jprb)) then + transfer_rate_direct(1,3) = dz & + & * edge_length(3,jlev) * tan_sza / region_fracs(1,jlev,jcol) + transfer_rate_diffuse(1,3) = dz & + & * edge_length(3,jlev) & + & * tan_diffuse_angle_3d / region_fracs(1,jlev,jcol) + end if + if (region_fracs(3,jlev,jcol) > epsilon(1.0_jprb)) then + transfer_rate_direct(3,1) = dz & + & * edge_length(3,jlev) * tan_sza / region_fracs(3,jlev,jcol) + transfer_rate_diffuse(3,1) = dz & + & * edge_length(3,jlev) & + & * tan_diffuse_angle_3d / region_fracs(3,jlev,jcol) + end if + end if + + ! Don't allow the transfer rate out of a region to be + ! equivalent to a loss of exp(-10) through the layer + where (transfer_rate_direct > config%max_3d_transfer_rate) + transfer_rate_direct = config%max_3d_transfer_rate + end where + where (transfer_rate_diffuse > config%max_3d_transfer_rate) + transfer_rate_diffuse = config%max_3d_transfer_rate + end where + + end if ! Cloud has edge length required for 3D effects + end if ! Include 3D effects + + ! In a cloudy layer the number of active regions equals + ! the number of regions + nregactive = nreg + + ! Compute scattering properties of the regions at each + ! g-point, mapping from the cloud properties + ! defined in each band. + do jg = 1,ng + ! Mapping from g-point to band + iband = config%i_band_from_reordered_g_sw(jg) + + ! Scattering optical depth of clear-sky region + scat_od = od(jg,jlev,jcol)*ssa(jg,jlev,jcol) + + ! Scattering properties of clear-sky regions copied + ! over + od_region(jg,1) = od(jg, jlev, jcol) + ssa_region(jg,1) = ssa(jg, jlev, jcol) + g_region(1) = g(jg, jlev, jcol) + + ! Loop over cloudy regions + do jreg = 2,nreg + scat_od_cloud = od_cloud(iband,jlev,jcol) & + & * ssa_cloud(iband,jlev,jcol)*od_scaling(jreg,jlev,jcol) + ! Add scaled cloud optical depth to clear-sky value + od_region(jg,jreg) = od(jg,jlev,jcol) & + & + od_cloud(iband,jlev,jcol)*od_scaling(jreg,jlev,jcol) + ! Compute single-scattering albedo and asymmetry + ! factor of gas-cloud combination + ssa_region(jg,jreg) = (scat_od+scat_od_cloud) & + & / od_region(jg,jreg) + g_region(jreg) = (scat_od*g(jg,jlev,jcol) & + & + scat_od_cloud * g_cloud(iband,jlev,jcol)) & + & / (scat_od + scat_od_cloud) + + ! Apply maximum cloud optical depth for stability in the + ! 3D case + if (od_region(jg,jreg) > config%max_cloud_od) then + od_region(jg,jreg) = config%max_cloud_od + end if + + end do + + ! Calculate two-stream variables gamma1-gamma3 of all + ! regions at once + call calc_two_stream_gammas_sw(nreg, & + & mu0, ssa_region(jg,:), g_region, & + & gamma1(jg,:), gamma2(jg,:), gamma3(jg,:)) + + ! Loop is in order of g-points with typically + ! increasing optical depth: if optical depth of + ! clear-sky region exceeds a threshold then turn off + ! 3D effects for any further g-points + if (ng3D == ng & + & .and. od_region(jg,1) > config%max_gas_od_3D) then + ng3D = jg-1 + end if + end do ! Loop over g points + end if ! Cloudy level + + ! -------------------------------------------------------- + ! Section 3.3: Compute reflection, transmission and emission + ! -------------------------------------------------------- + if (ng3D > 0) then + ! --- Section 3.3a: g-points with 3D effects ---------- + + ! 3D effects need to be represented in "ng3D" of the g + ! points. This is done by creating ng3D square matrices + ! each of dimension 3*nreg by 3*nreg, computing the matrix + ! exponential, then computing the various + ! transmission/reflectance matrices from that. + do jreg = 1,nregactive + ! Write the diagonal elements of -Gamma1*z1 + Gamma_z1(1:ng3D,jreg,jreg) & + & = od_region(1:ng3D,jreg)*gamma1(1:ng3D,jreg) + ! Write the diagonal elements of +Gamma2*z1 + Gamma_z1(1:ng3D,jreg+nreg,jreg) & + & = od_region(1:ng3D,jreg)*gamma2(1:ng3D,jreg) + ! Write the diagonal elements of -Gamma3*z1 + Gamma_z1(1:ng3D,jreg,jreg+2*nreg) & + & = -od_region(1:ng3D,jreg)*ssa_region(1:ng3D,jreg) & + & * gamma3(1:ng3D,jreg) + + ! Write the diagonal elements of +Gamma4*z1 + Gamma_z1(1:ng3D,jreg+nreg,jreg+2*nreg) & + & = od_region(1:ng3D,jreg)*ssa_region(1:ng3D,jreg) & + & * (1.0_jprb - gamma3(1:ng3D,jreg)) + + ! Write the diagonal elements of +Gamma0*z1 + Gamma_z1(1:ng3D,jreg+2*nreg,jreg+2*nreg) & + & = -od_region(1:ng3D,jreg)*one_over_mu0 + end do + + do jreg = 1,nregactive-1 + ! Write the elements of -Gamma1*z1 concerned with 3D + ! transport + Gamma_z1(1:ng3D,jreg,jreg) = Gamma_z1(1:ng3D,jreg,jreg) & + & + transfer_rate_diffuse(jreg,jreg+1) + Gamma_z1(1:ng3D,jreg+1,jreg+1) = Gamma_z1(1:ng3D,jreg+1,jreg+1) & + & + transfer_rate_diffuse(jreg+1,jreg) + Gamma_z1(1:ng3D,jreg+1,jreg) = -transfer_rate_diffuse(jreg,jreg+1) + Gamma_z1(1:ng3D,jreg,jreg+1) = -transfer_rate_diffuse(jreg+1,jreg) + ! Write the elements of +Gamma0*z1 concerned with 3D + ! transport + Gamma_z1(1:ng3D,jreg+2*nreg,jreg+2*nreg) & + & = Gamma_z1(1:ng3D,jreg+2*nreg,jreg+2*nreg) & + & - transfer_rate_direct(jreg,jreg+1) + Gamma_z1(1:ng3D,jreg+2*nreg+1,jreg+2*nreg+1) & + & = Gamma_z1(1:ng3D,jreg+2*nreg+1,jreg+2*nreg+1) & + & - transfer_rate_direct(jreg+1,jreg) + Gamma_z1(1:ng3D,jreg+2*nreg+1,jreg+2*nreg) & + & = transfer_rate_direct(jreg,jreg+1) + Gamma_z1(1:ng3D,jreg+2*nreg,jreg+2*nreg+1) & + & = transfer_rate_direct(jreg+1,jreg) + end do + + ! Possible flow between regions a and c + if (edge_length(3,jlev) > 0.0_jprb) then + ! Diffuse transport + Gamma_z1(1:ng3D,1,1) = Gamma_z1(1:ng3D,1,1) & + & + transfer_rate_diffuse(1,3) + Gamma_z1(1:ng3D,3,3) = Gamma_z1(1:ng3D,3,3) & + & + transfer_rate_diffuse(3,1) + Gamma_z1(1:ng3D,3,1) = -transfer_rate_diffuse(1,3) + Gamma_z1(1:ng3D,1,3) = -transfer_rate_diffuse(3,1) + ! Direct transport + Gamma_z1(1:ng3D,1+2*nreg,1+2*nreg) = Gamma_z1(1:ng3D,1+2*nreg,1+2*nreg) & + & - transfer_rate_direct(1,3) + Gamma_z1(1:ng3D,3+2*nreg,3+2*nreg) = Gamma_z1(1:ng3D,3+2*nreg,3+2*nreg) & + & - transfer_rate_direct(3,1) + Gamma_z1(1:ng3D,3+2*nreg,1+2*nreg) = transfer_rate_direct(1,3) + Gamma_z1(1:ng3D,1+2*nreg,3+2*nreg) = transfer_rate_direct(3,1) + end if + + ! Copy Gamma1*z1 + Gamma_z1(1:ng3D,nreg+1:nreg+nregactive,nreg+1:nreg+nregactive) & + & = -Gamma_z1(1:ng3D,1:nregactive,1:nregactive) + ! Copy Gamma2*z1 + Gamma_z1(1:ng3D,1:nregactive,nreg+1:nreg+nregactive) & + & = -Gamma_z1(1:ng3D,nreg+1:nreg+nregactive,1:nregactive) + + ! Compute the matrix exponential of Gamma_z1, returning the + ! result in-place + call expm(ng, ng3D, 3*nreg, Gamma_z1, IMatrixPatternShortwave) + + ! Update count of expm calls + n_calls_expm = n_calls_expm + ng3D + + ! Direct transmission matrix + trans_dir_dir(1:ng3D,:,:,jlev) = min(1.0_jprb,max(0.0_jprb, & + & Gamma_z1(1:ng3D,2*nreg+1:3*nreg, 2*nreg+1:3*nreg))) + ! Diffuse reflectance matrix; security on negative values + ! necessary occasionally for very low cloud fraction and very high + ! in-cloud optical depth + reflectance(1:ng3D,:,:,jlev) = min(1.0_jprb,max(0.0_jprb, & + & -solve_mat(ng,ng3D,nreg,Gamma_z1(1:ng3D,1:nreg,1:nreg), & + & Gamma_z1(1:ng3D,1:nreg,nreg+1:2*nreg)))) + ! Diffuse transmission matrix + transmittance(1:ng3D,:,:,jlev) = min(1.0_jprb,max(0.0_jprb, & + & mat_x_mat(ng,ng3D,nreg,Gamma_z1(1:ng3D,nreg+1:2*nreg,1:nreg), & + & reflectance(1:ng3D,:,:,jlev)) & + & + Gamma_z1(1:ng3D,nreg+1:2*nreg,nreg+1:2*nreg))) + ! Transfer matrix between downward direct and upward + ! diffuse + ref_dir(1:ng3D,:,:,jlev) = min(mu0,max(0.0_jprb, & + & -solve_mat(ng,ng3D,nreg,Gamma_z1(1:ng3D,1:nreg,1:nreg), & + & Gamma_z1(1:ng3D,1:nreg,2*nreg+1:3*nreg)))) + ! Transfer matrix between downward direct and downward + ! diffuse in layer interface below. Include correction for + ! trans_dir_diff out of plausible bounds (note that Meador & + ! Weaver has the same correction in radiation_two_stream.F90 + ! - this is not just an expm thing) + trans_dir_diff(1:ng3D,:,:,jlev) = min(mu0,max(0.0_jprb, & + & mat_x_mat(ng,ng3D,nreg,Gamma_z1(1:ng3D,nreg+1:2*nreg,1:nreg), & + & ref_dir(1:ng3D,:,:,jlev)) & + & + Gamma_z1(1:ng3D,nreg+1:2*nreg,2*nreg+1:3*nreg))) + + end if ! we are treating 3D effects for some g points + + ! --- Section 3.3b: g-points without 3D effects ---------- + + ! Compute reflectance, transmittance and associated terms for + ! clear skies, using the Meador-Weaver formulas + call calc_reflectance_transmittance_sw(ng, & + & mu0, od_region(1:ng,1), ssa_region(1:ng,1), & + & gamma1(1:ng,1), gamma2(1:ng,1), gamma3(1:ng,1), & + & ref_clear(1:ng,jlev), trans_clear(1:ng,jlev), & + & ref_dir_clear(1:ng,jlev), trans_dir_diff_clear(1:ng,jlev), & + & trans_dir_dir_clear(1:ng,jlev) ) + + n_calls_meador_weaver = n_calls_meador_weaver + ng + + if (ng3D < ng) then + ! Some of the g points are to be treated using the + ! conventional plane-parallel method. First zero the + ! relevant parts of the matrices + trans_dir_dir (ng3D+1:ng,:,:,jlev) = 0.0_jprb + reflectance (ng3D+1:ng,:,:,jlev) = 0.0_jprb + transmittance (ng3D+1:ng,:,:,jlev) = 0.0_jprb + ref_dir (ng3D+1:ng,:,:,jlev) = 0.0_jprb + trans_dir_diff(ng3D+1:ng,:,:,jlev) = 0.0_jprb + + ! Since there is no lateral transport, the clear-sky parts + ! of the arrays can be copied from the clear-sky arrays + trans_dir_dir (ng3D+1:ng,1,1,jlev) = trans_dir_dir_clear (ng3D+1:ng,jlev) + reflectance (ng3D+1:ng,1,1,jlev) = ref_clear (ng3D+1:ng,jlev) + transmittance (ng3D+1:ng,1,1,jlev) = trans_clear (ng3D+1:ng,jlev) + ref_dir (ng3D+1:ng,1,1,jlev) = ref_dir_clear (ng3D+1:ng,jlev) + trans_dir_diff(ng3D+1:ng,1,1,jlev) = trans_dir_diff_clear(ng3D+1:ng,jlev) + + ! Compute reflectance, transmittance and associated terms + ! for each cloudy region, using the Meador-Weaver formulas + do jreg = 2, nregactive + call calc_reflectance_transmittance_sw(ng-ng3D, & + & mu0, & + & od_region(ng3D+1:ng,jreg), ssa_region(ng3D+1:ng,jreg), & + & gamma1(ng3D+1:ng,jreg), gamma2(ng3D+1:ng,jreg), & + & gamma3(ng3D+1:ng,jreg), & + & reflectance(ng3D+1:ng,jreg,jreg,jlev), & + & transmittance(ng3D+1:ng,jreg,jreg,jlev), & + & ref_dir(ng3D+1:ng,jreg,jreg,jlev), & + & trans_dir_diff(ng3D+1:ng,jreg,jreg,jlev), & + & trans_dir_dir(ng3D+1:ng,jreg,jreg,jlev) ) + end do + n_calls_meador_weaver & + & = n_calls_meador_weaver + (ng-ng3D)*(nregactive-1) + end if + + end do ! Loop over levels + + ! -------------------------------------------------------- + ! Section 4: Compute total albedos + ! -------------------------------------------------------- + + total_albedo(:,:,:,:) = 0.0_jprb + total_albedo_direct(:,:,:,:) = 0.0_jprb + + if (config%do_clear) then + total_albedo_clear(:,:) = 0.0_jprb + total_albedo_clear_direct(:,:) = 0.0_jprb + end if + + ! Calculate the upwelling radiation scattered from the direct + ! beam incident on the surface, and copy the surface albedo + ! into total_albedo + do jreg = 1,nreg + do jg = 1,ng + total_albedo(jg,jreg,jreg,nlev+1) = albedo_diffuse(jg,jcol) + total_albedo_direct(jg,jreg,jreg,nlev+1) & + & = mu0 * albedo_direct(jg,jcol) + end do + end do + + if (config%do_clear) then + ! Surface albedo is the same + total_albedo_clear(1:ng,nlev+1) = total_albedo(1:ng,1,1,nlev+1) + total_albedo_clear_direct(1:ng,nlev+1) & + & = total_albedo_direct(1:ng,1,1,nlev+1) + end if + + ! Horizontal migration distances of reflected radiation at the + ! surface are zero + x_diffuse = 0.0_jprb + x_direct = 0.0_jprb + + ! Work back up through the atmosphere computing the total albedo + ! of the atmosphere below that point using the adding method + do jlev = nlev,1,-1 + + ! -------------------------------------------------------- + ! Section 4.1: Adding method + ! -------------------------------------------------------- + + if (config%do_clear) then + ! Use adding method for clear-sky arrays; note that there + ! is no need to consider "above" and "below" quantities + ! since with no cloud overlap to worry about, these are + ! the same + inv_denom_scalar(:) = 1.0_jprb & + & / (1.0_jprb - total_albedo_clear(:,jlev+1)*ref_clear(:,jlev)) + total_albedo_clear(:,jlev) = ref_clear(:,jlev) & + & + trans_clear(:,jlev)*trans_clear(:,jlev)*total_albedo_clear(:,jlev+1) & + & * inv_denom_scalar(:) + total_albedo_clear_direct(:,jlev) = ref_dir_clear(:,jlev) & + & + (trans_dir_dir_clear(:,jlev) * total_albedo_clear_direct(:,jlev+1) & + & +trans_dir_diff_clear(:,jlev) * total_albedo_clear(:,jlev+1)) & + & * trans_clear(:,jlev) * inv_denom_scalar(:) + end if + + if (is_clear_sky_layer(jlev)) then + ! Clear-sky layer: use scalar adding method + inv_denom_scalar(:) = 1.0_jprb & + & / (1.0_jprb - total_albedo(:,1,1,jlev+1)*reflectance(:,1,1,jlev)) + total_albedo_below = 0.0_jprb + total_albedo_below(:,1,1) = reflectance(:,1,1,jlev) & + & + transmittance(:,1,1,jlev) * transmittance(:,1,1,jlev) & + & * total_albedo(:,1,1,jlev+1) * inv_denom_scalar(:) + total_albedo_below_direct = 0.0_jprb + total_albedo_below_direct(:,1,1) = ref_dir(:,1,1,jlev) & + & + (trans_dir_dir(:,1,1,jlev)*total_albedo_direct(:,1,1,jlev+1) & + & +trans_dir_diff(:,1,1,jlev)*total_albedo(:,1,1,jlev+1)) & + & * transmittance(:,1,1,jlev) * inv_denom_scalar(:) + else + ! Cloudy layer: use matrix adding method + denominator = identity_minus_mat_x_mat(ng,ng,nreg, & + & total_albedo(:,:,:,jlev+1), reflectance(:,:,:,jlev)) + total_albedo_below = reflectance(:,:,:,jlev) & + & + mat_x_mat(ng,ng,nreg,transmittance(:,:,:,jlev), & + & solve_mat(ng,ng,nreg,denominator, & + & mat_x_mat(ng,ng,nreg,total_albedo(:,:,:,jlev+1), & + & transmittance(:,:,:,jlev)))) + total_albedo_below_direct = ref_dir(:,:,:,jlev) & + & + mat_x_mat(ng,ng,nreg,transmittance(:,:,:,jlev), & + & solve_mat(ng,ng,nreg,denominator, & + & mat_x_mat(ng,ng,nreg,total_albedo_direct(:,:,:,jlev+1), & + & trans_dir_dir(:,:,:,jlev)) & + & +mat_x_mat(ng,ng,nreg,total_albedo(:,:,:,jlev+1), & + & trans_dir_diff(:,:,:,jlev)))) + end if + + ! -------------------------------------------------------- + ! Section 4.2: Overlap and entrapment + ! -------------------------------------------------------- + +#ifndef PRINT_ENTRAPMENT_DATA + if ((config%i_3d_sw_entrapment == IEntrapmentExplicitNonFractal & + & .or. config%i_3d_sw_entrapment == IEntrapmentExplicit) & + & .and. jlev >= i_cloud_top) then +#else + if (config%i_3d_sw_entrapment == IEntrapmentExplicitNonFractal & + & .or. config%i_3d_sw_entrapment == IEntrapmentExplicit) then +#endif + ! "Explicit entrapment": we have the horizontal migration + ! distances just above the base of the layer, and need to + ! step them to just below the top of the same layer + call step_migrations(ng, nreg, cloud%fraction(jcol,jlev), & + & layer_depth(jlev), tan_diffuse_angle_3d, tan_sza, & + & reflectance(:,:,:,jlev), transmittance(:,:,:,jlev), & + & ref_dir(:,:,:,jlev), trans_dir_dir(:,:,:,jlev), & + & trans_dir_diff(:,:,:,jlev), total_albedo(:,:,:,jlev+1), & + & total_albedo_direct(:,:,:,jlev+1), & + & x_diffuse, x_direct) + +#ifdef PRINT_ENTRAPMENT_DATA + ! Write out for later analysis: these are the entrapment + ! statistics at the top of layer "jlev" + ! Note that number of scattering events is now not computed, + ! so print "1.0" + if (nreg == 2) then + write(101,'(i4,i4,6e14.6)') jcol, jlev, & + & x_direct(1,:), x_diffuse(1,:), x_direct(1,:)*0.0_jprb+1.0_jprb + else + write(101,'(i4,i4,9e14.6)') jcol, jlev, & + & x_direct(1,1:3), x_diffuse(1,1:3), 1.0_jprb,1.0_jprb,1.0_jprb + end if +#endif + + end if + + ! Account for cloud overlap when converting albedo and source + ! below a layer interface to the equivalent values just above + if (is_clear_sky_layer(jlev) .and. is_clear_sky_layer(jlev-1)) then + ! If both layers are cloud free, this is trivial... + total_albedo(:,:,:,jlev) = 0.0_jprb + total_albedo(:,1,1,jlev) = total_albedo_below(:,1,1) + total_albedo_direct(:,:,:,jlev) = 0.0_jprb + total_albedo_direct(:,1,1,jlev) = total_albedo_below_direct(:,1,1) + + else if (config%i_3d_sw_entrapment == IEntrapmentMaximum & + & .or. is_clear_sky_layer(jlev-1)) then + ! "Maximum entrapment": use the overlap matrices u_matrix and v_matrix + ! (this is the original SPARTACUS method) + total_albedo(:,:,:,jlev) = singlemat_x_mat(ng,ng,nreg,& + & u_matrix(:,:,jlev,jcol), & + & mat_x_singlemat(ng,ng,nreg,total_albedo_below,& + & v_matrix(:,:,jlev,jcol))) + total_albedo_direct(:,:,:,jlev) = singlemat_x_mat(ng,ng,nreg,& + & u_matrix(:,:,jlev,jcol), & + & mat_x_singlemat(ng,ng,nreg,total_albedo_below_direct,& + & v_matrix(:,:,jlev,jcol))) + + else if (config%i_3d_sw_entrapment == IEntrapmentZero) then + ! "Zero entrapment": even radiation transported + ! laterally between regions in the layers below is + ! reflected back up into the same region. First diffuse + ! radiation: + total_albedo(:,:,:,jlev) = 0.0_jprb + do jreg = 1,nreg ! Target layer (jlev-1) + do jreg2 = 1,nreg ! Current layer (jlev) + total_albedo(:,jreg,jreg,jlev) = total_albedo(:,jreg,jreg,jlev) & + & + sum(total_albedo_below(:,:,jreg2),2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + end do + end do + ! ...then direct radiation: + total_albedo_direct(:,:,:,jlev) = 0.0_jprb + do jreg = 1,nreg ! Target layer (jlev-1) + do jreg2 = 1,nreg ! Current layer (jlev) + total_albedo_direct(:,jreg,jreg,jlev) = total_albedo_direct(:,jreg,jreg,jlev) & + & + sum(total_albedo_below_direct(:,:,jreg2),2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + end do + end do + + else + ! Controlled entrapment + +#ifdef EXPLICIT_EDGE_ENTRAPMENT + ! If "EXPLICIT_EDGE_ENTRAPMENT" is defined then we use the + ! explicit entrapment approach for both horizontal transport + ! within regions, and horizontal transport between regions + ! (otherwise, horizontal transport between regions is + ! automatically treated using maximum entrapment). This is + ! experimental, which is why it is not a run-time option. + + if (config%i_3d_sw_entrapment == IEntrapmentEdgeOnly) then +#endif + ! Add the contribution from off-diagonal elements of the + ! albedo matrix in the lower layer, i.e. radiation that + ! flows between regions... + + ! First diffuse radiation: + albedo_part = total_albedo_below + do jreg = 1,nreg + albedo_part(:,jreg,jreg) = 0.0_jprb + end do + total_albedo(:,:,:,jlev) = singlemat_x_mat(ng,ng,nreg,& + & u_matrix(:,:,jlev,jcol), & + & mat_x_singlemat(ng,ng,nreg,albedo_part,& + & v_matrix(:,:,jlev,jcol))) + ! ...then direct radiation: + albedo_part = total_albedo_below_direct + do jreg = 1,nreg + albedo_part(:,jreg,jreg) = 0.0_jprb + end do + total_albedo_direct(:,:,:,jlev) = singlemat_x_mat(ng,ng,nreg,& + & u_matrix(:,:,jlev,jcol), & + & mat_x_singlemat(ng,ng,nreg,albedo_part,& + & v_matrix(:,:,jlev,jcol))) + +#ifdef EXPLICIT_EDGE_ENTRAPMENT +end if +#endif + + ! Now the contribution from the diagonals of the albedo + ! matrix in the lower layer + if (config%i_3d_sw_entrapment == IEntrapmentEdgeOnly & + & .or. (.not. config%do_3d_effects)) then + ! "Edge-only entrapment": the operation we perform is + ! essentially diag(total_albedo) += matmul(transpose(v_matrix), + ! diag(total_albedo_below)). + do jreg = 1,nreg + do jreg2 = 1,nreg + total_albedo(:,jreg,jreg,jlev) & + & = total_albedo(:,jreg,jreg,jlev) & + & + total_albedo_below(:,jreg2,jreg2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + total_albedo_direct(:,jreg,jreg,jlev) & + & = total_albedo_direct(:,jreg,jreg,jlev) & + & + total_albedo_below_direct(:,jreg2,jreg2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + end do + end do + + else + ! "Explicit entrapment" + + do jreg2 = 1,nreg + ! Loop through each region in the lower layer. For one + ! of the regions in the lower layer, we are imagining it + ! to be divided into "nreg" subregions that map onto the + ! regions in the upper layer. The rate of exchange + ! between these subregions is computed via a coupled + ! differential equation written in terms of a singular + ! exchange matrix (there are only terms for the exchange + ! between subregions, but no propagation effects since + ! we already know the albedo of this region). This is + ! solved using the matrix-exponential method. + + ! Use the following array for the transfer of either + ! diffuse or direct radiation (despite the name), per + ! unit horizontal distance travelled + transfer_rate_diffuse = 0.0_jprb + + ! As we need to reference the layer above the interface, + ! don't do the following on the highest layer + if (jlev > 1) then + + ! Given a horizontal migration distance, there is + ! still uncertainty about how much entrapment occurs + ! associated with how one assumes cloud boundaries + ! line up in adjacent layers. "overhang_factor" + ! can be varied between 0.0 (the boundaries line up to + ! the greatest extent possible given the overlap + ! parameter) and 1.0 (the boundaries line up to the + ! minimum extent possible); here this is used to + ! produce a scaling factor for the transfer rate. + transfer_scaling = 1.0_jprb - (1.0_jprb - config%overhang_factor) & + & * cloud%overlap_param(jcol,jlev-1) & + & * min(region_fracs(jreg2,jlev,jcol),region_fracs(jreg2,jlev-1,jcol)) & + & / max(config%cloud_fraction_threshold, region_fracs(jreg2,jlev,jcol)) + + do jreg = 1, nreg-1 + ! Compute lateral transfer rates from region jreg to + ! jreg+1 as before, but without length scale which + ! is wavelength dependent. + + ! Recall that overlap indexing is + ! u_matrix(upper_region, lower_region, level, + ! column). + transfer_rate_diffuse(jreg,jreg+1) = transfer_scaling & + & * edge_length(jreg,jlev-1) / max(u_matrix(jreg,jreg2,jlev,jcol),1.0e-5_jprb) + ! Compute transfer rates from region jreg+1 to jreg + transfer_rate_diffuse(jreg+1,jreg) = transfer_scaling & + & * edge_length(jreg,jlev-1) / max(u_matrix(jreg+1,jreg2,jlev,jcol),1.0e-5_jprb) + end do + + ! Compute transfer rates directly between regions 1 + ! and 3 (not used below) + if (edge_length(3,jlev) > 0.0_jprb) then + transfer_rate_diffuse(1,3) = transfer_scaling & + & * edge_length(3,jlev-1) / max(u_matrix(1,jreg2,jlev,jcol),1.0e-5_jprb) + transfer_rate_diffuse(3,1) = transfer_scaling & + & * edge_length(3,jlev-1) / max(u_matrix(3,jreg2,jlev,jcol),1.0e-5_jprb) + end if + end if + + ! Compute matrix of exchange coefficients + entrapment = 0.0_jprb + inv_effective_size = min(cloud%inv_cloud_effective_size(jcol,jlev-1), & + & 1.0_jprb/config%min_cloud_effective_size) + do jreg = 1,nreg-1 + ! Diffuse transport down and up with one random + ! scattering event + if (config%i_3d_sw_entrapment == IEntrapmentExplicit) then + fractal_factor = 1.0_jprb / sqrt(max(1.0_jprb, 2.5_jprb*x_diffuse(:,jreg2) & + & * inv_effective_size)) + entrapment(:,jreg+1,jreg) = entrapment(:,jreg+1,jreg) & + & + transfer_rate_diffuse(jreg,jreg+1)*x_diffuse(:,jreg2) & + & * fractal_factor + entrapment(:,jreg,jreg+1) = entrapment(:,jreg,jreg+1) & + & + transfer_rate_diffuse(jreg+1,jreg)*x_diffuse(:,jreg2) & + & * fractal_factor + else + entrapment(:,jreg+1,jreg) = entrapment(:,jreg+1,jreg) & + & + transfer_rate_diffuse(jreg,jreg+1)*x_diffuse(:,jreg2) + entrapment(:,jreg,jreg+1) = entrapment(:,jreg,jreg+1) & + & + transfer_rate_diffuse(jreg+1,jreg)*x_diffuse(:,jreg2) + end if + entrapment(:,jreg,jreg) = entrapment(:,jreg,jreg) & + & - entrapment(:,jreg+1,jreg) + entrapment(:,jreg+1,jreg+1) = entrapment(:,jreg+1,jreg+1) & + & - entrapment(:,jreg,jreg+1) + end do + + ! If rate of exchange is excessive the expm can throw a + ! floating point exception, even if it tends towards a + ! trival limit, so we cap the maximum input to expm by + ! scaling down if necessary + do jg = 1,ng + max_entr = -min(entrapment(jg,1,1),entrapment(jg,2,2)) + if (max_entr > config%max_cloud_od) then + ! Scale down all inputs for this g point + entrapment(jg,:,:) = entrapment(jg,:,:) * (config%max_cloud_od/max_entr) + end if + end do + + ! Since the matrix to be exponentiated has a simple + ! structure we may use a faster method described in the + ! appendix of Hogan et al. (GMD 2018) +#define USE_FAST_EXPM_EXCHANGE 1 +#ifdef USE_FAST_EXPM_EXCHANGE + if (nreg == 2) then + call fast_expm_exchange(ng, ng, entrapment(:,2,1), entrapment(:,1,2), & + & albedo_part) + else + call fast_expm_exchange(ng, ng, entrapment(:,2,1), entrapment(:,1,2), & + & entrapment(:,3,2), entrapment(:,2,3), & + & albedo_part) + end if +#else + ! Use matrix exponential to compute rate of exchange + albedo_part = entrapment + call expm(ng, ng, nreg, albedo_part, IMatrixPatternDense) + n_calls_expm = n_calls_expm + ng +#endif + +#ifndef EXPLICIT_EDGE_ENTRAPMENT + ! Scale to get the contribution to the diffuse albedo + do jreg3 = 1,nreg + do jreg = 1,nreg + albedo_part(:,jreg3,jreg) = albedo_part(:,jreg3,jreg) & + & * v_matrix(jreg2,jreg,jlev,jcol) * total_albedo_below(:,jreg2,jreg2) + end do + end do +#else + ! The following is an experimental treatment that tries + ! to explicitly account for the horizontal distance + ! traveled by radiation that passes through cloud sides + entrapment = albedo_part + albedo_part = 0.0_jprb + ! Scale to get the contribution to the diffuse albedo + do jreg3 = 1,nreg ! TO upper region + do jreg = 1,nreg ! FROM upper region + transfer_scaling = 1.0_jprb - (1.0_jprb - config%overhang_factor) & + & * cloud%overlap_param(jcol,jlev-1) & + & * min(region_fracs(jreg,jlev,jcol), region_fracs(jreg,jlev,jcol)) & + & / max(config%cloud_fraction_threshold, region_fracs(jreg,jlev,jcol)) + do jreg4 = 1,nreg ! VIA first lower region (jreg2 is second lower region) + if (.not. (jreg4 == jreg .and. jreg4 /= jreg2)) then + albedo_part(:,jreg3,jreg) = albedo_part(:,jreg3,jreg) + entrapment(:,jreg3,jreg) & + & * v_matrix(jreg4,jreg,jlev,jcol) * total_albedo_below(:,jreg2,jreg4) + else + albedo_part(:,jreg3,jreg) = albedo_part(:,jreg3,jreg) & + & + v_matrix(jreg4,jreg,jlev,jcol) * total_albedo_below(:,jreg2,jreg4) & + & * (transfer_scaling * entrapment(:,jreg3,jreg) & + & +((1.0_jprb-transfer_scaling) * entrapment(:,jreg3,jreg2))) + end if + end do + end do + end do +#endif + + ! Increment diffuse albedo + total_albedo(:,:,:,jlev) = total_albedo(:,:,:,jlev) + albedo_part + + ! Now do the same for the direct albedo + entrapment = 0.0_jprb + do jreg = 1,nreg-1 + ! Direct transport down and diffuse up with one random + ! scattering event + if (config%i_3d_sw_entrapment == IEntrapmentExplicit) then + fractal_factor = 1.0_jprb / sqrt(max(1.0_jprb, 2.5_jprb*x_direct(:,jreg2) & + & * inv_effective_size)) + entrapment(:,jreg+1,jreg) = entrapment(:,jreg+1,jreg) & + & + transfer_rate_diffuse(jreg,jreg+1)*x_direct(:,jreg2) & + & * fractal_factor + entrapment(:,jreg,jreg+1) = entrapment(:,jreg,jreg+1) & + & + transfer_rate_diffuse(jreg+1,jreg)*x_direct(:,jreg2) & + & * fractal_factor + else + entrapment(:,jreg+1,jreg) = entrapment(:,jreg+1,jreg) & + & + transfer_rate_diffuse(jreg,jreg+1)*x_direct(:,jreg2) + entrapment(:,jreg,jreg+1) = entrapment(:,jreg,jreg+1) & + & + transfer_rate_diffuse(jreg+1,jreg)*x_direct(:,jreg2) + end if + entrapment(:,jreg,jreg) = entrapment(:,jreg,jreg) & + & - entrapment(:,jreg+1,jreg) + entrapment(:,jreg+1,jreg+1) = entrapment(:,jreg+1,jreg+1) & + & - entrapment(:,jreg,jreg+1) + end do + + ! If rate of exchange is excessive the expm can throw a + ! floating point exception, even if it tends towards a + ! trival limit, so we cap the maximum input to expm by + ! scaling down if necessary + do jg = 1,ng + max_entr = -min(entrapment(jg,1,1),entrapment(jg,2,2)) + if (max_entr > config%max_cloud_od) then + ! Scale down all inputs for this g point + entrapment(jg,:,:) = entrapment(jg,:,:) * (config%max_cloud_od/max_entr) + end if + end do + + +#ifdef USE_FAST_EXPM_EXCHANGE + if (nreg == 2) then + call fast_expm_exchange(ng, ng, entrapment(:,2,1), entrapment(:,1,2), & + & albedo_part) + else + call fast_expm_exchange(ng, ng, entrapment(:,2,1), entrapment(:,1,2), & + & entrapment(:,3,2), entrapment(:,2,3), & + & albedo_part) + end if +#else + albedo_part = entrapment + call expm(ng, ng, nreg, albedo_part, IMatrixPatternDense) + n_calls_expm = n_calls_expm + ng +#endif + +#ifndef EXPLICIT_EDGE_ENTRAPMENT + do jreg3 = 1,nreg + do jreg = 1,nreg + albedo_part(:,jreg3,jreg) = albedo_part(:,jreg3,jreg) & + & * v_matrix(jreg2,jreg,jlev,jcol) * total_albedo_below_direct(:,jreg2,jreg2) + end do + end do +#else + entrapment = albedo_part + albedo_part = 0.0_jprb + do jreg3 = 1,nreg + do jreg = 1,nreg + transfer_scaling = 1.0_jprb - (1.0_jprb - config%overhang_factor) & + & * cloud%overlap_param(jcol,jlev-1) & + & * min(region_fracs(jreg,jlev,jcol), region_fracs(jreg,jlev-1,jcol)) & + & / max(config%cloud_fraction_threshold, region_fracs(jreg,jlev,jcol)) + do jreg4 = 1,nreg + if (.not. (jreg4 == jreg .and. jreg4 /= jreg2)) then + albedo_part(:,jreg3,jreg) = albedo_part(:,jreg3,jreg) + entrapment(:,jreg3,jreg) & + & * v_matrix(jreg4,jreg,jlev,jcol) * total_albedo_below_direct(:,jreg2,jreg4) + else + albedo_part(:,jreg3,jreg) = albedo_part(:,jreg3,jreg) & + & + v_matrix(jreg4,jreg,jlev,jcol) * total_albedo_below_direct(:,jreg2,jreg4) & + & * (transfer_scaling * entrapment(:,jreg3,jreg) & + & +((1.0_jprb-transfer_scaling) * entrapment(:,jreg3,jreg2))) + end if + end do + end do + end do + +#endif + ! Increment direct albedo + total_albedo_direct(:,:,:,jlev) = total_albedo_direct(:,:,:,jlev) + albedo_part + + end do + + end if + end if + + if ((config%i_3d_sw_entrapment == IEntrapmentExplicitNonFractal & + & .or. config%i_3d_sw_entrapment == IEntrapmentExplicit) & + & .and. .not. (is_clear_sky_layer(jlev) .and. is_clear_sky_layer(jlev-1))) then + ! Horizontal migration distances are averaged when + ! applying overlap rules, so equation is + ! x_above=matmul(transpose(v_matrix),x_below) + + ! We do this into temporary arrays... + x_direct_above = 0.0_jprb + x_diffuse_above = 0.0_jprb + + nregactive = nreg + if (is_clear_sky_layer(jlev)) then + nregactive = 1 + end if + + do jreg = 1,nreg ! Target layer (jlev-1) + do jreg2 = 1,nregactive ! Current layer (jlev) + x_direct_above(:,jreg) = x_direct_above(:,jreg) & + & + x_direct(:,jreg2) * v_matrix(jreg2,jreg,jlev,jcol) + x_diffuse_above(:,jreg) = x_diffuse_above(:,jreg) & + & + x_diffuse(:,jreg2) * v_matrix(jreg2,jreg,jlev,jcol) + end do + end do + + !... then copy out of the temporary arrays + x_direct = x_direct_above + x_diffuse = x_diffuse_above + end if + + end do ! Reverse loop over levels + + ! -------------------------------------------------------- + ! Section 5: Compute fluxes + ! -------------------------------------------------------- + + ! Top-of-atmosphere fluxes into the regions of the top-most + ! layer, zero since we assume no diffuse downwelling + flux_dn_below = 0.0_jprb + ! Direct downwelling flux (into a plane perpendicular to the + ! sun) entering the top of each region in the top-most layer + do jreg = 1,nreg + direct_dn_below(:,jreg) = incoming_sw(:,jcol)*region_fracs(jreg,1,jcol) + end do + ! We're using flux_up_above as a container; actually its + ! interpretation at top of atmosphere here is just 'below' the + ! TOA interface, so using the regions of the first model layer + flux_up_above = mat_x_vec(ng,ng,nreg,total_albedo_direct(:,:,:,1),direct_dn_below) + + if (config%do_clear) then + flux_dn_clear = 0.0_jprb + direct_dn_clear(:) = incoming_sw(:,jcol) + flux_up_clear = direct_dn_clear*total_albedo_clear_direct(:,1) + end if + + ! Store the TOA broadband fluxes + flux%sw_up(jcol,1) = sum(sum(flux_up_above,1)) + flux%sw_dn(jcol,1) = mu0 * sum(direct_dn_clear(:)) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,1) = flux%sw_dn(jcol,1) + end if + if (config%do_clear) then + flux%sw_up_clear(jcol,1) = sum(flux_up_clear) + flux%sw_dn_clear(jcol,1) = flux%sw_dn(jcol,1) + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,1) = flux%sw_dn_clear(jcol,1) + end if + end if + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum(sum(flux_up_above(:,:),2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_up_band(:,jcol,1)) + call indexed_sum(sum(direct_dn_below(:,:),2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,1)) + flux%sw_dn_band(:,jcol,1) = mu0 * flux%sw_dn_band(:,jcol,1) + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,1) = flux%sw_dn_band(:,jcol,1) + end if + if (config%do_clear) then + flux%sw_dn_clear_band(:,jcol,1) = flux%sw_dn_band(:,jcol,1) + call indexed_sum(flux_up_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_up_clear_band(:,jcol,1)) + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,1) & + & = flux%sw_dn_clear_band(:,jcol,1) + end if + end if + end if + + ! Final loop back down through the atmosphere to compute fluxes + do jlev = 1,nlev + +#ifdef PRINT_ENTRAPMENT_DATA + if (config%i_3d_sw_entrapment == IEntrapmentExplicitNonFractal & + & .or. config%i_3d_sw_entrapment == IEntrapmentExplicit) then + ! Save downwelling direct and diffuse fluxes at the top of + ! layer "jlev" in each of the regions of layer "jlev" + if (nreg == 2) then + write(102,'(i4,i4,4e14.6)') jcol, jlev, direct_dn_below(1,:), flux_dn_below(1,:) + else + write(102,'(i4,i4,6e14.6)') jcol, jlev, direct_dn_below(1,1:3), flux_dn_below(1,1:3) + end if + end if +#endif + + ! Compute the solar downwelling "source" at the base of the + ! layer due to scattering of the direct beam within it + if (config%do_clear) then + source_dn_clear = trans_dir_diff_clear(:,jlev)*direct_dn_clear + end if + source_dn(:,:) = mat_x_vec(ng,ng,nreg,trans_dir_diff(:,:,:,jlev),direct_dn_below, & + & is_clear_sky_layer(jlev)) + + ! Compute direct downwelling flux in each region at base of + ! current layer + if (config%do_clear) then + direct_dn_clear = trans_dir_dir_clear(:,jlev)*direct_dn_clear + end if + direct_dn_above = mat_x_vec(ng,ng,nreg,trans_dir_dir(:,:,:,jlev),direct_dn_below, & + & is_clear_sky_layer(jlev)) + + ! Integrate downwelling direct flux across spectrum and + ! regions, and store (the diffuse part will be added later) + flux%sw_dn(jcol,jlev+1) = mu0 * sum(sum(direct_dn_above,1)) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,jlev+1) = flux%sw_dn(jcol,jlev+1) + end if + if (config%do_clear) then + flux%sw_dn_clear(jcol,jlev+1) = mu0 * sum(direct_dn_clear) + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,jlev+1) & + & = flux%sw_dn_clear(jcol,jlev+1) + end if + end if + + if (config%do_save_spectral_flux) then + call indexed_sum(sum(direct_dn_above,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,jlev+1)) + flux%sw_dn_band(:,jcol,jlev+1) = mu0 * flux%sw_dn_band(:,jcol,jlev+1) + + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,jlev+1) & + & = flux%sw_dn_band(:,jcol,jlev+1) + end if + if (config%do_clear) then + call indexed_sum(direct_dn_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_clear_band(:,jcol,jlev+1)) + flux%sw_dn_clear_band(:,jcol,jlev+1) = mu0 & + & * flux%sw_dn_clear_band(:,jcol,jlev+1) + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,jlev+1) & + & = flux%sw_dn_clear_band(:,jcol,jlev+1) + end if + end if + end if + + if (config%do_clear) then + ! Scalar operations for clear-sky fluxes + flux_dn_clear(:) = (trans_clear(:,jlev)*flux_dn_clear(:) & + & + ref_clear(:,jlev)*total_albedo_clear_direct(:,jlev+1)*direct_dn_clear & + & + source_dn_clear) & + & / (1.0_jprb - ref_clear(:,jlev)*total_albedo_clear(:,jlev+1)) + flux_up_clear(:) = total_albedo_clear_direct(:,jlev+1)*direct_dn_clear & + & + total_albedo_clear(:,jlev+1)*flux_dn_clear + end if + + if (is_clear_sky_layer(jlev)) then + ! Scalar operations for clear-sky layer + flux_dn_above(:,1) = (transmittance(:,1,1,jlev)*flux_dn_below(:,1) & + & + reflectance(:,1,1,jlev)*total_albedo_direct(:,1,1,jlev+1)*direct_dn_above(:,1) & + & + source_dn(:,1)) & + & / (1.0_jprb - reflectance(:,1,1,jlev)*total_albedo(:,1,1,jlev+1)) + flux_dn_above(:,2:nreg) = 0.0_jprb + flux_up_above(:,1) = total_albedo_direct(:,1,1,jlev+1)*direct_dn_above(:,1) & + & + total_albedo(:,1,1,jlev+1)*flux_dn_above(:,1) + flux_up_above(:,2:nreg) = 0.0_jprb + else + ! Matrix operations for cloudy layer + denominator = identity_minus_mat_x_mat(ng,ng,nreg,reflectance(:,:,:,jlev), & + & total_albedo(:,:,:,jlev+1)) + total_source = mat_x_vec(ng,ng,nreg,total_albedo_direct(:,:,:,jlev+1),direct_dn_above) + + flux_dn_above = solve_vec(ng,ng,nreg,denominator, & + & mat_x_vec(ng,ng,nreg,transmittance(:,:,:,jlev),flux_dn_below) & + & + mat_x_vec(ng,ng,nreg,reflectance(:,:,:,jlev), total_source(:,:)) & + & + source_dn(:,:)) + flux_up_above = mat_x_vec(ng,ng,nreg,total_albedo(:,:,:,jlev+1), & + & flux_dn_above) + total_source(:,:) + end if + + ! Account for overlap rules in translating fluxes just above + ! a layer interface to the values just below + if (is_clear_sky_layer(jlev) .and. is_clear_sky_layer(jlev+1)) then + ! Regions in current layer map directly on to regions in + ! layer below + flux_dn_below = flux_dn_above + direct_dn_below = direct_dn_above + else + ! Apply downward overlap matrix to compute direct + ! downwelling flux entering the top of each region in the + ! layer below + flux_dn_below = singlemat_x_vec(ng,ng,nreg,v_matrix(:,:,jlev+1,jcol), & + & flux_dn_above) + direct_dn_below = singlemat_x_vec(ng,ng,nreg,v_matrix(:,:,jlev+1,jcol), & + & direct_dn_above) + end if + + ! Store the broadband fluxes + flux%sw_up(jcol,jlev+1) = sum(sum(flux_up_above,1)) + flux%sw_dn(jcol,jlev+1) & + & = flux%sw_dn(jcol,jlev+1) + sum(sum(flux_dn_above,1)) + if (config%do_clear) then + flux%sw_up_clear(jcol,jlev+1) = sum(flux_up_clear) + flux%sw_dn_clear(jcol,jlev+1) & + & = flux%sw_dn_clear(jcol,jlev+1) + sum(flux_dn_clear) + end if + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum(sum(flux_up_above,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_up_band(:,jcol,jlev+1)) + call add_indexed_sum(sum(flux_dn_above,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,jlev+1)) + if (config%do_clear) then + call indexed_sum(flux_up_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_up_clear_band(:,jcol,jlev+1)) + call add_indexed_sum(flux_dn_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_clear_band(:,jcol,jlev+1)) + end if + end if + + end do ! Final loop over levels + + ! Store surface spectral fluxes, if required (after the end of + ! the final loop over levels, the current values of these arrays + ! will be the surface values) + flux%sw_dn_diffuse_surf_g(:,jcol) = sum(flux_dn_above,2) + flux%sw_dn_direct_surf_g(:,jcol) = mu0 * sum(direct_dn_above,2) + if (config%do_clear) then + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = flux_dn_clear + flux%sw_dn_direct_surf_clear_g(:,jcol) = mu0 * direct_dn_clear + end if + + end do ! Loop over columns + if (config%iverbose >= 3) then + write(nulout,*) + end if + + ! Report number of calls to each method of solving single-layer + ! two-stream equations + if (config%iverbose >= 4) then + write(nulout,'(a,i0)') ' Matrix-exponential calls: ', n_calls_expm + write(nulout,'(a,i0)') ' Meador-Weaver calls: ', n_calls_meador_weaver + end if + + if (lhook) call dr_hook('radiation_spartacus_sw:solver_spartacus_sw',1,hook_handle) + + end subroutine solver_spartacus_sw + + + ! Step the horizontal migration distances from the base of a layer + ! to the top, accounting for the extra distance travelled within the + ! layer + subroutine step_migrations(ng, nreg, cloud_frac, & + & layer_depth, tan_diffuse_angle_3d, tan_sza, & + & reflectance, transmittance, ref_dir, trans_dir_dir, & + & trans_dir_diff, total_albedo_diff, total_albedo_dir, & + & x_diffuse, x_direct) + + use parkind1, only : jprb + + implicit none + + ! Inputs + + ! Number of g points and regions + integer, intent(in) :: ng, nreg + ! Cloud fraction + real(jprb), intent(in) :: cloud_frac + ! Layer depth (m), tangent of diffuse zenith angle and tangent of + ! solar zenith angle + real(jprb), intent(in) :: layer_depth, tan_diffuse_angle_3d, tan_sza + ! Reflectance and transmittance to diffuse downwelling radiation + real(jprb), intent(in), dimension(ng, nreg, nreg) :: reflectance, transmittance + ! Reflectance and transmittance to direct downwelling radiation + real(jprb), intent(in), dimension(ng, nreg, nreg) :: ref_dir, trans_dir_dir + ! Transmittance involving direct entering a layer from the top and + ! diffuse leaving from the bottom + real(jprb), intent(in), dimension(ng, nreg, nreg) :: trans_dir_diff + + ! Total albedo of direct and diffuse radiation of the atmosphere + ! below the layer in question + real(jprb), intent(in), dimension(ng, nreg, nreg) & + & :: total_albedo_diff, total_albedo_dir + + ! Inputs/outputs + + ! Horizontal migration distance (m) of reflected light + real(jprb), intent(inout), dimension(ng, nreg) :: x_diffuse, x_direct + + ! Local variables + + ! Top albedo, i.e. the albedo of the top of the layer assuming no + ! lateral transport + real(jprb), dimension(ng) :: top_albedo + + ! Multiple-scattering amplitude enhancement + real(jprb), dimension(ng) :: ms_enhancement + + ! Multiple-scattering distance enhancement + real(jprb), dimension(ng) :: x_enhancement + + + real(jprb) :: x_layer_diffuse, x_layer_direct + integer :: jreg, istartreg, iendreg + + istartreg = 1 + iendreg = nreg + + if (cloud_frac <= 0.0_jprb) then + ! Clear-sky layer: don't waste time on cloudy regions + iendreg = 1 + else if (cloud_frac >= 1.0_jprb) then + ! Overcast layer: don't waste time on clear region + istartreg = 2 + end if + + ! This is the mean horizontal distance travelled by diffuse + ! radiation that travels from the top of a layer to the centre and + ! is then scattered back up and out + x_layer_diffuse = layer_depth * tan_diffuse_angle_3d/sqrt(2.0_jprb) + + ! This is the mean horizontal distance travelled by direct + ! radiation that travels from the top of a layer to the centre and + ! is then scattered back up and out + x_layer_direct = layer_depth * sqrt(tan_sza*tan_sza & + & + tan_diffuse_angle_3d*tan_diffuse_angle_3d) * 0.5_jprb + + do jreg = istartreg,iendreg + ! Geometric series enhancement due to multiple scattering: the + ! amplitude enhancement is equal to the limit of + ! T*[1+RA+(RA)^2+(RA)^3+...] + ms_enhancement = transmittance(:,jreg,jreg) & + & / (1.0_jprb - reflectance(:,jreg,jreg)*total_albedo_diff(:,jreg,jreg)) + ! ...and the distance enhancement is approximately equal to the + ! limit of T*[1+sqrt(2)*RA+sqrt(3)*(RA)^2+sqrt(4)*(RA)^3+...] + x_enhancement = (1.0_jprb - reflectance(:,jreg,jreg)*total_albedo_diff(:,jreg,jreg))**(-1.5_jprb) + + ! Horizontal migration of direct downwelling radiation + top_albedo = max(1.0e-8_jprb, ref_dir(:,jreg,jreg) + ms_enhancement & + & * (trans_dir_diff(:,jreg,jreg)*total_albedo_diff(:,jreg,jreg) & + & +trans_dir_dir(:,jreg,jreg)*total_albedo_dir(:,jreg,jreg))) + ! The following is approximate and has been found to + ! occasionally go negative + x_direct(:,jreg) = max(0.0_jprb, x_layer_direct & + & + ((trans_dir_diff(:,jreg,jreg)*total_albedo_diff(:,jreg,jreg)*x_enhancement & + & +trans_dir_dir(:,jreg,jreg)*total_albedo_dir(:,jreg,jreg)*(x_enhancement-1.0_jprb)) & + & *(x_diffuse(:,jreg)+x_layer_diffuse) & + & +trans_dir_dir(:,jreg,jreg)*total_albedo_dir(:,jreg,jreg) & + & *(x_direct(:,jreg)+x_layer_direct)) & + & * transmittance(:,jreg,jreg) / top_albedo) + + ! Horizontal migration of diffuse downwelling radiation + top_albedo = max(1.0e-8_jprb, reflectance(:,jreg,jreg) & + & + ms_enhancement*transmittance(:,jreg,jreg)*total_albedo_diff(:,jreg,jreg)) + x_diffuse(:,jreg) = x_layer_diffuse + x_enhancement*total_albedo_diff(:,jreg,jreg) & + & *(transmittance(:,jreg,jreg)*transmittance(:,jreg,jreg)) & + & * (x_diffuse(:,jreg) + x_layer_diffuse) / top_albedo + + end do + if (iendreg < nreg) then + x_diffuse(:,iendreg+1:nreg) = 0.0_jprb + x_direct(:,iendreg+1:nreg) = 0.0_jprb + else if (istartreg == 2) then + x_diffuse(:,1) = 0.0_jprb + x_direct(:,1) = 0.0_jprb + end if + + end subroutine step_migrations + +end module radiation_spartacus_sw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spectral_definition.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spectral_definition.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_spectral_definition.F90 (revision 6016) @@ -0,0 +1,993 @@ +! radiation_spectral_definition.F90 - Derived type to describe a spectral definition +! +! (C) Copyright 2020- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +#include "ecrad_config.h" + +module radiation_spectral_definition + + use parkind1, only : jprb + + implicit none + + public + + real(jprb), parameter :: SolarReferenceTemperature = 5777.0_jprb ! K + real(jprb), parameter :: TerrestrialReferenceTemperature = 273.15_jprb ! K + + !--------------------------------------------------------------------- + ! A derived type describing the contribution of the g points of a + ! correlated k-distribution gas-optics model from each part of the + ! spectrum. This is used primarily to map the cloud and aerosol + ! optical properties on to the gas g points. + type spectral_definition_type + + ! Spectral mapping of g points + + ! Number of wavenumber intervals + integer :: nwav = 0 + ! Number of k terms / g points + integer :: ng = 0 + ! Start and end wavenumber (cm-1), dimensioned (nwav) + real(jprb), allocatable :: wavenumber1(:) + real(jprb), allocatable :: wavenumber2(:) + ! Fraction of each g point in each wavenumber interval, + ! dimensioned (nwav, ng) + real(jprb), allocatable :: gpoint_fraction(:,:) + + ! Spectral weighting information for generating mappings to/from + ! different spectral grids: this can be in terms of a reference + ! temperature (K) to generate a Planck function, or the + ! solar_spectral_irradiance (W m-2) if available in the gas-optics + ! file. + real(jprb) :: reference_temperature = -1.0_jprb + real(jprb), allocatable :: solar_spectral_irradiance(:) + + ! Band information + + ! Number of bands + integer :: nband = 0 + ! Lower and upper bounds of wavenumber bands (cm-1), dimensioned + ! (nband) + real(jprb), allocatable :: wavenumber1_band(:) + real(jprb), allocatable :: wavenumber2_band(:) + ! Band (one based) to which each g point belongs + integer, allocatable :: i_band_number(:) + + contains + procedure :: read => read_spectral_definition + procedure :: allocate_bands_only + procedure :: deallocate + procedure :: find => find_wavenumber + procedure :: calc_mapping + procedure :: calc_mapping_from_bands + procedure :: calc_mapping_from_wavenumber_bands + procedure :: print_mapping_from_bands + procedure :: min_wavenumber, max_wavenumber + + end type spectral_definition_type + +contains + + !--------------------------------------------------------------------- + ! Read the description of a spectral definition from a NetCDF + ! file of the type used to describe an ecCKD model + subroutine read_spectral_definition(this, file) + +#ifdef EASY_NETCDF_READ_MPI + use easy_netcdf_read_mpi, only : netcdf_file +#else + use easy_netcdf, only : netcdf_file +#endif + use yomhook, only : lhook, dr_hook, jphook + + class(spectral_definition_type), intent(inout) :: this + type(netcdf_file), intent(inout) :: file + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:read',0,hook_handle) + + ! Read spectral mapping of g points + call file%get('wavenumber1', this%wavenumber1) + call file%get('wavenumber2', this%wavenumber2) + call file%get('gpoint_fraction', this%gpoint_fraction) + + ! Read band information + call file%get('wavenumber1_band', this%wavenumber1_band) + call file%get('wavenumber2_band', this%wavenumber2_band) + call file%get('band_number', this%i_band_number) + + ! Read spectral weighting information + if (file%exists('solar_spectral_irradiance')) then + ! This is on the same grid as wavenumber1,2 + call file%get('solar_spectral_irradiance', & + & this%solar_spectral_irradiance) + end if + if (file%exists('solar_irradiance')) then + ! Shortwave default temperature + this%reference_temperature = SolarReferenceTemperature + else + ! Longwave reference temperature + this%reference_temperature = TerrestrialReferenceTemperature + end if + + ! Band number is 0-based: add 1 + this%i_band_number = this%i_band_number + 1 + + this%nwav = size(this%wavenumber1) + this%ng = size(this%gpoint_fraction, 2); + this%nband = size(this%wavenumber1_band) + + if (lhook) call dr_hook('radiation_spectral_definition:read',1,hook_handle) + + end subroutine read_spectral_definition + + + !--------------------------------------------------------------------- + ! Store a simple band description by copying over the reference + ! temperature and the lower and upper wavenumbers of each band + subroutine allocate_bands_only(this, reference_temperature, wavenumber1, wavenumber2) + + use yomhook, only : lhook, dr_hook, jphook + + class(spectral_definition_type), intent(inout) :: this + real(jprb), intent(in) :: reference_temperature ! K + real(jprb), dimension(:), intent(in) :: wavenumber1, wavenumber2 ! cm-1 + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:allocate_bands_only',0,hook_handle) + + call this%deallocate() + + this%nband = size(wavenumber1) + allocate(this%wavenumber1_band(this%nband)) + allocate(this%wavenumber2_band(this%nband)) + this%wavenumber1_band = wavenumber1 + this%wavenumber2_band = wavenumber2 + this%reference_temperature = reference_temperature + + if (lhook) call dr_hook('radiation_spectral_definition:allocate_bands_only',1,hook_handle) + + end subroutine allocate_bands_only + + + !--------------------------------------------------------------------- + ! Deallocate memory inside a spectral definition object + subroutine deallocate(this) + + class(spectral_definition_type), intent(inout) :: this + + this%nwav = 0 + this%ng = 0 + this%nband = 0 + this%reference_temperature = -1.0_jprb + + if (allocated(this%wavenumber1)) deallocate(this%wavenumber1) + if (allocated(this%wavenumber2)) deallocate(this%wavenumber2) + if (allocated(this%wavenumber1_band)) deallocate(this%wavenumber1_band) + if (allocated(this%wavenumber2_band)) deallocate(this%wavenumber2_band) + if (allocated(this%gpoint_fraction)) deallocate(this%gpoint_fraction) + if (allocated(this%i_band_number)) deallocate(this%i_band_number) + + end subroutine deallocate + + + !--------------------------------------------------------------------- + ! Find the index to the highest wavenumber in the spectral + ! definition that is lower than or equal to "wavenumber", used for + ! implementing look-up tables + pure function find_wavenumber(this, wavenumber) + class(spectral_definition_type), intent(in) :: this + real(jprb), intent(in) :: wavenumber ! cm-1 + integer :: find_wavenumber + + if (wavenumber < this%wavenumber1(1) .or. wavenumber > this%wavenumber2(this%nwav)) then + ! Wavenumber not present + find_wavenumber = 0 + else + find_wavenumber = 1 + do while (wavenumber > this%wavenumber2(find_wavenumber) & + & .and. find_wavenumber < this%nwav) + find_wavenumber = find_wavenumber + 1 + end do + end if + end function find_wavenumber + + + !--------------------------------------------------------------------- + ! Compute a mapping matrix "mapping" that can be used in an + ! expression y=matmul(mapping,x) where x is a variable containing + ! optical properties at each input "wavenumber", and y is this + ! variable mapped on to the spectral intervals in the spectral + ! definition "this". + subroutine calc_mapping(this, wavenumber, mapping, weighting_temperature, use_bands) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + + class(spectral_definition_type), intent(in) :: this + real(jprb), intent(in) :: wavenumber(:) ! cm-1 + real(jprb), allocatable, intent(inout) :: mapping(:,:) + real(jprb), optional, intent(in) :: weighting_temperature ! K + logical, optional, intent(in) :: use_bands + + ! Spectral weights to apply, same length as wavenumber above + real(jprb), dimension(:), allocatable :: weight, planck_weight + + ! Wavenumbers (cm-1) marking triangle of influence of a cloud + ! spectral point + real(jprb) :: wavenum0, wavenum1, wavenum2 + + integer :: nwav ! Number of wavenumbers describing cloud + + ! Indices to wavenumber intervals in spectral definition structure + integer :: isd, isd0, isd1, isd2 + + ! Wavenumber index + integer :: iwav + + ! Loop indices + integer :: jg, jwav, jband + + logical :: use_bands_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping',0,hook_handle) + + if (present(use_bands)) then + use_bands_local = use_bands + else + use_bands_local = .false. + end if + + nwav = size(wavenumber) + + if (allocated(mapping)) then + deallocate(mapping) + end if + + ! Define the mapping matrix + if (use_bands_local) then + ! Cloud properties per band + + allocate(mapping(this%nband, nwav)) + allocate(weight(nwav)) + + ! Planck weight uses the wavenumbers of the cloud points + allocate(planck_weight(nwav)) + if (present(weighting_temperature)) then + if (weighting_temperature > 0.0_jprb) then + planck_weight = calc_planck_function_wavenumber(wavenumber, & + & weighting_temperature) + else + ! Legacy mode: unweighted average + planck_weight = 1.0_jprb + end if + else + planck_weight = calc_planck_function_wavenumber(wavenumber, & + & this%reference_temperature) + end if + + do jband = 1,this%nband + weight = 0.0_jprb + do jwav = 1,nwav + ! Work out wavenumber range for which this cloud wavenumber + ! will be applicable + if (wavenumber(jwav) >= this%wavenumber1_band(jband) & + & .and. wavenumber(jwav) <= this%wavenumber2_band(jband)) then + if (jwav > 1) then + wavenum1 = max(this%wavenumber1_band(jband), & + & 0.5_jprb*(wavenumber(jwav-1)+wavenumber(jwav))) + else + wavenum1 = this%wavenumber1_band(jband) + end if + if (jwav < nwav) then + wavenum2 = min(this%wavenumber2_band(jband), & + & 0.5_jprb*(wavenumber(jwav)+wavenumber(jwav+1))) + else + wavenum2 = this%wavenumber2_band(jband) + end if + ! This cloud wavenumber is weighted by the wavenumber + ! range of its applicability multiplied by the Planck + ! function at an appropriate temperature + weight(jwav) = (wavenum2-wavenum1) * planck_weight(jwav) + end if + end do + if (sum(weight) <= 0.0_jprb) then + ! No cloud wavenumbers lie in the band; interpolate to + ! central wavenumber of band instead + if (wavenumber(1) >= this%wavenumber2_band(jband)) then + ! Band is entirely below first cloudy wavenumber + weight(1) = 1.0_jprb + else if (wavenumber(nwav) <= this%wavenumber1_band(jband)) then + ! Band is entirely above last cloudy wavenumber + weight(nwav) = 1.0_jprb + else + ! Find interpolating points + iwav = 2 + do while (wavenumber(iwav) < this%wavenumber2_band(jband)) + iwav = iwav+1 + end do + weight(iwav-1) = planck_weight(iwav-1) * (wavenumber(iwav) & + & - 0.5_jprb*(this%wavenumber2_band(jband)+this%wavenumber1_band(jband))) + weight(iwav) = planck_weight(iwav) * (-wavenumber(iwav-1) & + & + 0.5_jprb*(this%wavenumber2_band(jband)+this%wavenumber1_band(jband))) + end if + end if + mapping(jband,:) = weight / sum(weight) + end do + + deallocate(weight) + deallocate(planck_weight) + + else + ! Cloud properties per g-point + + if (this%ng == 0) then + write(nulerr,'(a)') '*** Error: requested cloud/aerosol mapping per g-point but only available per band' + call radiation_abort('Radiation configuration error') + end if + + allocate(mapping(this%ng, nwav)) + allocate(weight(this%nwav)) + allocate(planck_weight(this%nwav)) + + if (allocated(this%solar_spectral_irradiance)) then + planck_weight = this%solar_spectral_irradiance + else + planck_weight = calc_planck_function_wavenumber(0.5_jprb & + & * (this%wavenumber1 + this%wavenumber2), & + & this%reference_temperature) + end if + + mapping = 0.0_jprb + ! Loop over wavenumbers representing cloud + do jwav = 1,nwav + ! Clear the weights. The weight says for one wavenumber in the + ! cloud file, what is its fractional contribution to each of + ! the spectral-definition intervals + weight = 0.0_jprb + + ! Cloud properties are linearly interpolated between each of + ! the nwav cloud points; therefore, the influence of a + ! particular cloud point extends as a triangle between + ! wavenum0 and wavenum2, peaking at wavenum1 + wavenum1 = wavenumber(jwav) + isd1 = this%find(wavenum1) + if (isd1 < 1) then + cycle + end if + if (jwav > 1) then + wavenum0 = wavenumber(jwav-1) + + ! Map triangle under (wavenum0,0) to (wavenum1,1) to the + ! wavenumbers in this%gpoint_fraction + isd0 = this%find(wavenum0) + if (isd0 == isd1) then + ! Triangle completely within the range + ! this%wavenumber1(isd0)-this%wavenumber2(isd0) + weight(isd0) = 0.5_jprb*(wavenum1-wavenum0) & + & / (this%wavenumber2(isd0)-this%wavenumber1(isd0)) + else + if (isd0 >= 1) then + ! Left part of triangle + weight(isd0) = 0.5_jprb * (this%wavenumber2(isd0)-wavenum0)**2 & + & / ((this%wavenumber2(isd0)-this%wavenumber1(isd0)) & + & *(wavenum1-wavenum0)) + end if + ! Right part of triangle (trapezium) +! weight(isd1) = 0.5_jprb * (wavenum1-this%wavenumber1(isd1)) & +! & * (wavenum1 + this%wavenumber1(isd1) - 2.0_jprb*wavenum0) & +! & / (wavenum1-wavenum0) + weight(isd1) = 0.5_jprb * (1.0_jprb & + & + (this%wavenumber1(isd1)-wavenum1)/(wavenum1-wavenum0)) & + & * (wavenum1-this%wavenumber1(isd1)) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + if (isd1-isd0 > 1) then + do isd = isd0+1,isd1-1 + ! Intermediate trapezia + weight(isd) = 0.5_jprb * (this%wavenumber1(isd)+this%wavenumber2(isd) & + & - 2.0_jprb*wavenum0) & + & / (wavenum1-wavenum0) + end do + end if + end if + + else + ! First cloud wavenumber: all wavenumbers in the spectral + ! definition below this will use the first one + if (isd1 >= 1) then + weight(1:isd1-1) = 1.0_jprb + weight(isd1) = (wavenum1-this%wavenumber1(isd1)) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + end if + end if + + if (jwav < nwav) then + wavenum2 = wavenumber(jwav+1) + + ! Map triangle under (wavenum1,1) to (wavenum2,0) to the + ! wavenumbers in this%gpoint_fraction + isd2 = this%find(wavenum2) + + if (isd1 == isd2) then + ! Triangle completely within the range + ! this%wavenumber1(isd1)-this%wavenumber2(isd1) + weight(isd1) = weight(isd1) + 0.5_jprb*(wavenum2-wavenum1) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + else + if (isd2 >= 1 .and. isd2 <= this%nwav) then + ! Right part of triangle + weight(isd2) = weight(isd2) + 0.5_jprb * (wavenum2-this%wavenumber1(isd2))**2 & + & / ((this%wavenumber2(isd2)-this%wavenumber1(isd2)) & + & *(wavenum2-wavenum1)) + end if + ! Left part of triangle (trapezium) +! weight(isd1) = weight(isd1) + 0.5_jprb * (this%wavenumber2(isd1)-wavenum1) & +! & * (wavenum1 + this%wavenumber2(isd1) - 2.0_jprb*wavenum2) & +! & / (wavenum2-wavenum1) + weight(isd1) = weight(isd1) + 0.5_jprb * (1.0_jprb & + & + (wavenum2-this%wavenumber2(isd1)) / (wavenum2-wavenum1)) & + & * (this%wavenumber2(isd1)-wavenum1) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + if (isd2-isd1 > 1) then + do isd = isd1+1,isd2-1 + ! Intermediate trapezia + weight(isd) = weight(isd) + 0.5_jprb * (2.0_jprb*wavenum2 & + & - this%wavenumber1(isd) - this%wavenumber2(isd)) & + & / (wavenum2-wavenum1) + end do + end if + end if + + else + ! Last cloud wavenumber: all wavenumbers in the spectral + ! definition above this will use the last one + if (isd1 <= this%nwav) then + weight(isd1+1:this%nwav) = 1.0_jprb + weight(isd1) = (this%wavenumber2(isd1)-wavenum1) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + end if + end if + + weight = weight * planck_weight + + do jg = 1,this%ng + mapping(jg, jwav) = sum(weight * this%gpoint_fraction(:,jg)) + end do + + end do + + deallocate(weight) + deallocate(planck_weight) + + ! Normalize mapping matrix + do jg = 1,this%ng + mapping(jg,:) = mapping(jg,:) * (1.0_jprb/sum(mapping(jg,:))) + end do + + end if + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping',1,hook_handle) + + end subroutine calc_mapping + + + !--------------------------------------------------------------------- + ! Under normal operation (if use_fluxes is .false. or not present), + ! compute a mapping matrix "mapping" that can be used in an + ! expression y=matmul(mapping^T,x) where x is a variable containing + ! optical properties in input bands (e.g. albedo in shortwave albedo + ! bands), and y is this variable mapped on to the spectral intervals + ! in the spectral definition "this". Note that "mapping" is here + ! transposed from the convention in the calc_mapping routine. Under + ! the alternative operation (if use_fluxes is present and .true.), + ! the mapping works in the reverse sense: if y contains fluxes in + ! each ecRad band or g-point, then x=matmul(mapping,y) would return + ! fluxes in x averaged to user-supplied "input" bands. In this + ! version, the bands are described by their wavelength bounds + ! (wavelength_bound, which must be increasing and exclude the end + ! points) and the index of the mapping matrix that each band + ! corresponds to (i_intervals, which has one more element than + ! wavelength_bound and can have duplicated values if an + ! albedo/emissivity value is to be associated with more than one + ! discontinuous ranges of the spectrum). + subroutine calc_mapping_from_bands(this, & + & wavelength_bound, i_intervals, mapping, use_bands, use_fluxes) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_io, only : nulerr, radiation_abort + + class(spectral_definition_type), intent(in) :: this + ! Monotonically increasing wavelength bounds (m) between + ! intervals, not including the outer bounds (which are assumed to + ! be zero and infinity) + real(jprb), intent(in) :: wavelength_bound(:) + ! The albedo band indices corresponding to each interval + integer, intent(in) :: i_intervals(:) + real(jprb), allocatable, intent(inout) :: mapping(:,:) + logical, optional, intent(in) :: use_bands + logical, optional, intent(in) :: use_fluxes + + ! Planck function and central wavenumber of each wavenumber + ! interval of the spectral definition + real(jprb) :: planck(this%nwav) ! W m-2 (cm-1)-1 + real(jprb) :: wavenumber_mid(this%nwav) ! cm-1 + + real(jprb), allocatable :: mapping_denom(:,:) + + real(jprb) :: wavenumber1_bound, wavenumber2_bound + + ! To work out weights we sample the Planck function at five points + ! in the interception between an input interval and a band, and + ! use the Trapezium Rule + integer, parameter :: nsample = 5 + integer :: isamp + real(jprb), dimension(nsample) :: wavenumber_sample, planck_sample + real(jprb), parameter :: weight_sample(nsample) & + & = [0.5_jprb, 1.0_jprb, 1.0_jprb, 1.0_jprb, 0.5_jprb] + + ! Index of input value corresponding to each wavenumber interval + integer :: i_input(this%nwav) + + ! Number of albedo/emissivity values that will be provided, some + ! of which may span discontinuous intervals in wavelength space + integer :: ninput + + ! Number of albedo/emissivity intervals represented, where some + ! may be grouped to have the same value of albedo/emissivity (an + ! example is in the thermal infrared where classically the IFS has + ! ninput=2 and ninterval=3, since only two emissivities are + ! provided representing (1) the infrared window, and (2) the + ! intervals to each side of the infrared window. + integer :: ninterval + + logical :: use_bands_local, use_fluxes_local + + ! Loop indices + integer :: jg, jband, jin, jint, jwav + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping_from_bands',0,hook_handle) + + if (present(use_bands)) then + use_bands_local = use_bands + else + use_bands_local = .false. + end if + + if (present(use_fluxes)) then + use_fluxes_local = use_fluxes + else + use_fluxes_local = .false. + end if + + ! Count the number of input intervals + ninterval = size(i_intervals) + ninput = maxval(i_intervals) + + if (allocated(mapping)) then + deallocate(mapping) + end if + + ! Check wavelength is monotonically increasing + if (ninterval > 2) then + do jint = 2,ninterval-1 + if (wavelength_bound(jint) <= wavelength_bound(jint-1)) then + write(nulerr, '(a)') '*** Error: wavelength bounds must be monotonically increasing' + call radiation_abort() + end if + end do + end if + + ! Define the mapping matrix + if (use_bands_local) then + ! Require properties per band + + allocate(mapping(ninput, this%nband)) + mapping = 0.0_jprb + + if (use_fluxes_local) then + allocate(mapping_denom(ninput, this%nband)) + mapping_denom = 0.0_jprb + end if + + do jband = 1,this%nband + do jint = 1,ninterval + if (jint == 1) then + ! First input interval in wavelength space: lower + ! wavelength bound is 0 m, so infinity cm-1 + wavenumber2_bound = this%wavenumber2_band(jband) + else + wavenumber2_bound = min(this%wavenumber2_band(jband), & + & 0.01_jprb/wavelength_bound(jint-1)) + end if + + if (jint == ninterval) then + ! Final input interval in wavelength space: upper + ! wavelength bound is infinity m, so 0 cm-1 + wavenumber1_bound = this%wavenumber1_band(jband) + else + wavenumber1_bound = max(this%wavenumber1_band(jband), & + & 0.01_jprb/wavelength_bound(jint)) + + end if + + if (wavenumber2_bound > wavenumber1_bound) then + ! Current input interval contributes to current band; + ! compute the weight of the contribution in proportion to + ! an approximate calculation of the integral of the Planck + ! function over the relevant part of the spectrum + wavenumber_sample = wavenumber1_bound + [(isamp,isamp=0,nsample-1)] & + & * (wavenumber2_bound-wavenumber1_bound) / real(nsample-1,jprb) + planck_sample = calc_planck_function_wavenumber(wavenumber_sample, & + & this%reference_temperature) + mapping(i_intervals(jint),jband) = mapping(i_intervals(jint),jband) & + & + sum(planck_sample*weight_sample) * (wavenumber2_bound-wavenumber1_bound) + if (use_fluxes_local) then + ! Compute an equivalent sample containing the entire ecRad band + wavenumber_sample = this%wavenumber1_band(jband) + [(isamp,isamp=0,nsample-1)] & + & * (this%wavenumber2_band(jband)-this%wavenumber1_band(jband)) & + & / real(nsample-1,jprb) + planck_sample = calc_planck_function_wavenumber(wavenumber_sample, & + & this%reference_temperature) + mapping_denom(i_intervals(jint),jband) = mapping_denom(i_intervals(jint),jband) & + & + sum(planck_sample*weight_sample) * (this%wavenumber2_band(jband)-this%wavenumber1_band(jband)) + end if + end if + + end do + end do + + if (use_fluxes_local) then + mapping = mapping / max(1.0e-12_jprb, mapping_denom) + deallocate(mapping_denom) + end if + + else + ! Require properties per g-point + + if (this%ng == 0) then + write(nulerr,'(a)') '*** Error: requested surface mapping per g-point but only available per band' + call radiation_abort('Radiation configuration error') + end if + + allocate(mapping(ninput,this%ng)) + mapping = 0.0_jprb + + wavenumber_mid = 0.5_jprb * (this%wavenumber1 + this%wavenumber2) + if (allocated(this%solar_spectral_irradiance)) then + planck = this%solar_spectral_irradiance + else + planck = calc_planck_function_wavenumber(wavenumber_mid, & + & this%reference_temperature) + end if + +#ifdef USE_COARSE_MAPPING + ! In the processing that follows, we assume that the wavenumber + ! grid on which the g-points are defined in the spectral + ! definition is much finer than the albedo/emissivity intervals + ! that the user will provide. This means that each wavenumber + ! is assigned to only one of the albedo/emissivity intervals. + + ! By default set all wavenumbers to use first input + ! albedo/emissivity + i_input = 1 + + ! All bounded intervals + do jint = 2,ninterval-1 + wavenumber1_bound = 0.01_jprb / wavelength_bound(jint) + wavenumber2_bound = 0.01_jprb / wavelength_bound(jint-1) + where (wavenumber_mid > wavenumber1_bound & + & .and. wavenumber_mid <= wavenumber2_bound) + i_input = i_intervals(jint) + end where + end do + + ! Final interval in wavelength space goes up to wavelength of + ! infinity (wavenumber of zero) + if (ninterval > 1) then + wavenumber2_bound = 0.01_jprb / wavelength_bound(ninterval-1) + where (wavenumber_mid <= wavenumber2_bound) + i_input = i_intervals(ninterval) + end where + end if + + do jg = 1,this%ng + do jin = 1,ninput + mapping(jin,jg) = sum(this%gpoint_fraction(:,jg) * planck, & + & mask=(i_input==jin)) + if (use_fluxes_local) then + mapping(jin,jg) = mapping(jin,jg) / sum(this%gpoint_fraction(:,jg) * planck) + end if + end do + end do + +#else + + ! Loop through all intervals + do jint = 1,ninterval + ! Loop through the wavenumbers for gpoint_fraction + do jwav = 1,this%nwav + if (jint == 1) then + ! First input interval in wavelength space: lower + ! wavelength bound is 0 m, so infinity cm-1 + wavenumber2_bound = this%wavenumber2(jwav) + else + wavenumber2_bound = min(this%wavenumber2(jwav), & + & 0.01_jprb/wavelength_bound(jint-1)) + end if + + if (jint == ninterval) then + ! Final input interval in wavelength space: upper + ! wavelength bound is infinity m, so 0 cm-1 + wavenumber1_bound = this%wavenumber1(jwav) + else + wavenumber1_bound = max(this%wavenumber1(jwav), & + & 0.01_jprb/wavelength_bound(jint)) + + end if + + if (wavenumber2_bound > wavenumber1_bound) then + ! Overlap between input interval and gpoint_fraction + ! interval: compute the weight of the contribution in + ! proportion to an approximate calculation of the integral + ! of the Planck function over the relevant part of the + ! spectrum + mapping(i_intervals(jint),:) = mapping(i_intervals(jint),:) + this%gpoint_fraction(jwav,:) & + & * (planck(jwav) * (wavenumber2_bound - wavenumber1_bound) & + & / (this%wavenumber2(jwav)-this%wavenumber1(jwav))) + end if + end do + end do + if (use_fluxes_local) then + do jg = 1,this%ng + mapping(:,jg) = mapping(:,jg) / sum(this%gpoint_fraction(:,jg) * planck) + end do + end if + +#endif + + end if + + if (.not. use_fluxes_local) then + ! Normalize mapping matrix + do jg = 1,size(mapping,dim=2) + mapping(:,jg) = mapping(:,jg) * (1.0_jprb/sum(mapping(:,jg))) + end do + end if + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping_from_bands',1,hook_handle) + + end subroutine calc_mapping_from_bands + + + !--------------------------------------------------------------------- + ! As calc_mapping_from_bands but in terms of wavenumber bounds from + ! wavenumber1 to wavenumber2 + subroutine calc_mapping_from_wavenumber_bands(this, & + & wavenumber1, wavenumber2, mapping, use_bands, use_fluxes) + + use yomhook, only : lhook, dr_hook, jphook + + class(spectral_definition_type), intent(in) :: this + real(jprb), intent(in) :: wavenumber1(:), wavenumber2(:) + real(jprb), allocatable, intent(inout) :: mapping(:,:) + logical, optional, intent(in) :: use_bands + logical, optional, intent(in) :: use_fluxes + + ! Monotonically increasing wavelength bounds (m) between + ! intervals, not including the outer bounds (which are assumed to + ! be zero and infinity) + real(jprb) :: wavelength_bound(size(wavenumber1)-1) + ! The albedo band indices corresponding to each interval + integer :: i_intervals(size(wavenumber1)) + + ! Lower wavelength bound (m) of each band + real(jprb) :: wavelength1(size(wavenumber1)) + + logical :: is_band_unassigned(size(wavenumber1)) + + ! Number of albedo/emissivity intervals represented, where some + ! may be grouped to have the same value of albedo/emissivity (an + ! example is in the thermal infrared where classically the IFS has + ! ninput=2 and ninterval=3, since only two emissivities are + ! provided representing (1) the infrared window, and (2) the + ! intervals to each side of the infrared window. + integer :: ninterval + + ! Index to next band in order of increasing wavelength + integer :: inext + + ! Loop indices + integer :: jint + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping_from_wavenumber_bands',0,hook_handle) + + wavelength1 = 0.01_jprb / wavenumber2 + ninterval = size(wavelength1) + + is_band_unassigned = .true. + + do jint = 1,ninterval + inext = minloc(wavelength1, dim=1, mask=is_band_unassigned) + if (jint > 1) then + wavelength_bound(jint-1) = wavelength1(inext) + end if + is_band_unassigned(inext) = .false. + i_intervals(jint) = inext + end do + + call calc_mapping_from_bands(this, wavelength_bound, i_intervals, mapping, use_bands, use_fluxes) + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping_from_wavenumber_bands',1,hook_handle) + + end subroutine calc_mapping_from_wavenumber_bands + + + !--------------------------------------------------------------------- + ! Print out the mapping computed by calc_mapping_from_bands + subroutine print_mapping_from_bands(this, mapping, use_bands) + + use radiation_io, only : nulout + + class(spectral_definition_type), intent(in) :: this + real(jprb), allocatable, intent(in) :: mapping(:,:) ! (ninput,nband/ng) + logical, optional, intent(in) :: use_bands + + logical :: use_bands_local + + integer :: nin, nout + integer :: jin, jout + + if (present(use_bands)) then + use_bands_local = use_bands + else + use_bands_local = .false. + end if + + nin = size(mapping,1) + nout = size(mapping,2) + + if (nin <= 1) then + write(nulout, '(a)') ' All spectral intervals will use the same albedo/emissivity' + else if (use_bands_local) then + write(nulout, '(a,i0,a,i0,a)') ' Mapping from ', nin, ' values to ', nout, ' bands (wavenumber ranges in cm-1)' + if (nout <= 40) then + do jout = 1,nout + write(nulout,'(i6,a,i6,a)',advance='no') nint(this%wavenumber1_band(jout)), ' to', & + & nint(this%wavenumber2_band(jout)), ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,jout) + end do + write(nulout, '()') + end do + else + do jout = 1,30 + write(nulout,'(i6,a,i6,a)',advance='no') nint(this%wavenumber1_band(jout)), ' to', & + & nint(this%wavenumber2_band(jout)), ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,jout) + end do + write(nulout, '()') + end do + write(nulout,'(a)') ' ...' + write(nulout,'(i6,a,i6,a)',advance='no') nint(this%wavenumber1_band(nout)), ' to', & + & nint(this%wavenumber2_band(nout)), ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,nout) + end do + write(nulout, '()') + end if + else + write(nulout, '(a,i0,a,i0,a)') ' Mapping from ', nin, ' values to ', nout, ' g-points' + if (nout <= 40) then + do jout = 1,nout + write(nulout,'(i3,a)',advance='no') jout, ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,jout) + end do + write(nulout, '()') + end do + else + do jout = 1,30 + write(nulout,'(i3,a)',advance='no') jout, ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,jout) + end do + write(nulout, '()') + end do + write(nulout,'(a)') ' ...' + write(nulout,'(i3,a)',advance='no') nout, ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,nout) + end do + write(nulout, '()') + end if + end if + + end subroutine print_mapping_from_bands + + + !--------------------------------------------------------------------- + ! Return the minimum wavenumber of this object in cm-1 + pure function min_wavenumber(this) + + class(spectral_definition_type), intent(in) :: this + real(jprb) :: min_wavenumber + + if (this%nwav > 0) then + min_wavenumber = this%wavenumber1(1) + else + min_wavenumber = minval(this%wavenumber1_band) + end if + + end function min_wavenumber + + + !--------------------------------------------------------------------- + ! Return the maximum wavenumber of this object in cm-1 + pure function max_wavenumber(this) + + class(spectral_definition_type), intent(in) :: this + real(jprb) :: max_wavenumber + + if (this%nwav > 0) then + max_wavenumber = this%wavenumber1(this%nwav) + else + max_wavenumber = maxval(this%wavenumber2_band) + end if + + end function max_wavenumber + + + !--------------------------------------------------------------------- + ! Return the Planck function (in W m-2 (cm-1)-1) for a given + ! wavenumber (cm-1) and temperature (K), ensuring double precision + ! for internal calculation. If temperature is 0 or less then unity + ! is returned; since this function is primarily used to weight an + ! integral by the Planck function, a temperature of 0 or less means + ! no weighting is to be applied. + elemental function calc_planck_function_wavenumber(wavenumber, temperature) + + use parkind1, only : jprb, jprd + use radiation_constants, only : SpeedOfLight, BoltzmannConstant, PlanckConstant + + real(jprb), intent(in) :: wavenumber ! cm-1 + real(jprb), intent(in) :: temperature ! K + real(jprb) :: calc_planck_function_wavenumber + + real(jprd) :: freq ! Hz + real(jprd) :: planck_fn_freq ! W m-2 Hz-1 + + if (temperature > 0.0_jprd) then + freq = 100.0_jprd * real(SpeedOfLight,jprd) * real(wavenumber,jprd) + planck_fn_freq = 2.0_jprd * real(PlanckConstant,jprd) * freq**3 & + & / (real(SpeedOfLight,jprd)**2 * (exp(real(PlanckConstant,jprd)*freq & + & /(real(BoltzmannConstant,jprd)*real(temperature,jprd))) - 1.0_jprd)) + calc_planck_function_wavenumber = real(planck_fn_freq * 100.0_jprd * real(SpeedOfLight,jprd), jprb) + else + calc_planck_function_wavenumber = 1.0_jprb + end if + + end function calc_planck_function_wavenumber + +end module radiation_spectral_definition Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_thermodynamics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_thermodynamics.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_thermodynamics.F90 (revision 6016) @@ -0,0 +1,426 @@ +! This file has been modified for the use in ICON + +! radiation_thermodynamics.F90 - Derived type for pressure & temperature +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-05-11 R. Hogan Fix startcol/endcol for get_layer_mass +! 2019-01-14 R. Hogan Added out_of_physical_bounds routine +! 2019-01-14 R. Hogan Capped h2o_sat_liq at 1 + +module radiation_thermodynamics + + use parkind1, only : jprb + + implicit none + public + + !--------------------------------------------------------------------- + ! Derived type for storing pressure and temperature at half and full levels + type thermodynamics_type + real(jprb), allocatable, dimension(:,:) :: & + & pressure_hl, & ! (ncol,nlev+1) pressure (Pa) + & temperature_hl, & ! (ncol,nlev+1) temperature (K) + & pressure_fl, & ! (ncol,nlev) pressure (Pa) + & temperature_fl ! (ncol,nlev) temperature (K) + + ! The following is a function of pressure and temperature: you + ! can calculate it according to your favourite formula, or the + ! calc_saturation_wrt_liquid subroutine can be used to do this + ! approximately + real(jprb), allocatable, dimension(:,:) :: & + & h2o_sat_liq ! (ncol,nlev) specific humidity at liquid + ! saturation (kg/kg) + + ! Using the interpolation method for temperature and pressure from half levels + ! to full levels that is used in the subroutine gas_optics in radiation_ifs_rrtm + ! can result in values for ind1 that exceed the bounds of absa within + ! srtm_taumol16 for ecRad inside ICON. This can be avoided by directly + ! passing pressure_fl and temperature_fl from ICON to ecRad. With + ! rrtm_pass_temppres_fl = .TRUE., the fields pressure_fl and temperature_fl + ! are allocated and used within gas_optics in radiation_ifs_rrtm. + logical :: & + & rrtm_pass_temppres_fl + contains + procedure :: allocate => allocate_thermodynamics_arrays + procedure :: deallocate => deallocate_thermodynamics_arrays + procedure :: calc_saturation_wrt_liquid + procedure :: get_layer_mass + procedure :: get_layer_mass_column + procedure :: out_of_physical_bounds +#ifdef _OPENACC + procedure :: update_host + procedure :: update_device +#endif + + end type thermodynamics_type + +contains + + + !--------------------------------------------------------------------- + ! Allocate variables with specified dimensions + subroutine allocate_thermodynamics_arrays(this, ncol, nlev, & + & use_h2o_sat, rrtm_pass_temppres_fl) + + use yomhook, only : lhook, dr_hook, jphook + + class(thermodynamics_type), intent(inout) :: this + integer, intent(in) :: ncol ! Number of columns + integer, intent(in) :: nlev ! Number of levels + logical, intent(in), optional :: use_h2o_sat ! Allocate h2o_sat_liq? + logical, intent(in), optional :: rrtm_pass_temppres_fl ! Directly pass temperature + ! and pressure on full levels + + logical :: use_h2o_sat_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_thermodynamics:allocate',0,hook_handle) + + allocate(this%pressure_hl(ncol,nlev+1)) + allocate(this%temperature_hl(ncol,nlev+1)) + !$ACC ENTER DATA CREATE(this%pressure_hl, this%temperature_hl) ASYNC(1) + + use_h2o_sat_local = .false. + if (present(use_h2o_sat)) then + use_h2o_sat_local = use_h2o_sat + end if + + this%rrtm_pass_temppres_fl = .false. + if (present(rrtm_pass_temppres_fl)) then + this%rrtm_pass_temppres_fl = rrtm_pass_temppres_fl + end if + + if (this%rrtm_pass_temppres_fl) then + allocate(this%pressure_fl(ncol,nlev)) + allocate(this%temperature_fl(ncol,nlev)) + !$ACC ENTER DATA CREATE(this%pressure_fl, this%temperature_fl) ASYNC(1) + end if + + if (use_h2o_sat_local) then + allocate(this%h2o_sat_liq(ncol,nlev)) + !$ACC ENTER DATA CREATE(this%h2o_sat_liq) ASYNC(1) + end if + + if (lhook) call dr_hook('radiation_thermodynamics:allocate',1,hook_handle) + + end subroutine allocate_thermodynamics_arrays + + + !--------------------------------------------------------------------- + ! Deallocate variables + subroutine deallocate_thermodynamics_arrays(this) + + use yomhook, only : lhook, dr_hook, jphook + + class(thermodynamics_type), intent(inout) :: this + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_thermodynamics:deallocate',0,hook_handle) + + if (allocated(this%pressure_hl)) then + !$ACC EXIT DATA DELETE(this%pressure_hl) WAIT(1) + deallocate(this%pressure_hl) + end if + if (allocated(this%temperature_hl)) then + !$ACC EXIT DATA DELETE(this%temperature_hl) WAIT(1) + deallocate(this%temperature_hl) + end if + if (allocated(this%pressure_fl)) then + !$ACC EXIT DATA DELETE(this%pressure_fl) WAIT(1) + deallocate(this%pressure_fl) + end if + if (allocated(this%temperature_fl)) then + !$ACC EXIT DATA DELETE(this%temperature_fl) WAIT(1) + deallocate(this%temperature_fl) + end if + if (allocated(this%h2o_sat_liq)) then + !$ACC EXIT DATA DELETE(this%h2o_sat_liq) WAIT(1) + deallocate(this%h2o_sat_liq) + end if + + if (lhook) call dr_hook('radiation_thermodynamics:deallocate',1,hook_handle) + + end subroutine deallocate_thermodynamics_arrays + + + !--------------------------------------------------------------------- + ! Calculate approximate saturation with respect to liquid + subroutine calc_saturation_wrt_liquid(this,istartcol,iendcol) + + use yomhook, only : lhook, dr_hook, jphook + + class(thermodynamics_type), intent(inout) :: this + integer, intent(in) :: istartcol, iendcol + + ! Pressure and temperature at full levels + real(jprb) :: pressure, temperature + + ! Vapour pressure (Pa) + real(jprb) :: e_sat + + integer :: ncol, nlev ! Dimension sizes + integer :: jcol, jlev ! Loop indices for column and level + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_thermodynamics:calc_saturation_wrt_liquid',0,hook_handle) + + ncol = size(this%pressure_hl,1) + nlev = size(this%pressure_hl,2) - 1 + + if (.not. allocated(this%h2o_sat_liq)) then + allocate(this%h2o_sat_liq(ncol,nlev)) + !$ACC ENTER DATA CREATE(this%h2o_sat_liq) ASYNC(1) + end if + + !$ACC PARALLEL DEFAULT(NONE) PRESENT(this) ASYNC(1) + !$ACC LOOP GANG VECTOR COLLAPSE(2) PRIVATE(pressure, temperature, e_sat) + do jlev = 1,nlev + do jcol = istartcol,iendcol + pressure = 0.5 * (this%pressure_hl(jcol,jlev)+this%pressure_hl(jcol,jlev+1)) + temperature = 0.5 * (this%temperature_hl(jcol,jlev)+this%temperature_hl(jcol,jlev+1)) + e_sat = 6.11e2_jprb * exp( 17.269_jprb * (temperature-273.16_jprb) / (temperature-35.86_jprb) ) + ! This formula can go above 1 at low pressure so needs to be + ! capped + this%h2o_sat_liq(jcol,jlev) = min(1.0_jprb, 0.622_jprb * e_sat / pressure) + end do + end do + !$ACC END PARALLEL + + if (lhook) call dr_hook('radiation_thermodynamics:calc_saturation_wrt_liquid',1,hook_handle) + + end subroutine calc_saturation_wrt_liquid + + + !--------------------------------------------------------------------- + ! Calculate the dry mass of each layer, neglecting humidity effects. + ! The first version is for all columns. + subroutine get_layer_mass(this,istartcol,iendcol,layer_mass) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_constants, only : AccelDueToGravity + + class(thermodynamics_type), intent(in) :: this + integer, intent(in) :: istartcol, iendcol + real(jprb), intent(out) :: layer_mass(:,:) + + integer :: nlev + real(jprb) :: inv_g + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_thermodynamics:get_layer_mass',0,hook_handle) + + nlev = ubound(this%pressure_hl,2) - 1 + inv_g = 1.0_jprb / AccelDueToGravity + + layer_mass(istartcol:iendcol,1:nlev) & + & = ( this%pressure_hl(istartcol:iendcol,2:nlev+1) & + & -this%pressure_hl(istartcol:iendcol,1:nlev ) ) & + & * inv_g + + if (lhook) call dr_hook('radiation_thermodynamics:get_layer_mass',1,hook_handle) + + end subroutine get_layer_mass + + !--------------------------------------------------------------------- + ! Calculate the dry mass of each layer, neglecting humidity effects. + ! The second version is for one column, the one numbered "icol". + subroutine get_layer_mass_column(this, icol, layer_mass) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_constants, only : AccelDueToGravity + + class(thermodynamics_type), intent(in) :: this + integer, intent(in) :: icol + real(jprb), intent(out) :: layer_mass(:) + + integer :: nlev + real(jprb) :: inv_g + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_thermodynamics:get_layer_mass_column',0,hook_handle) + + nlev = ubound(this%pressure_hl,2) - 1 + inv_g = 1.0_jprb / AccelDueToGravity + + layer_mass = ( this%pressure_hl(icol,2:nlev+1) & + & -this%pressure_hl(icol,1:nlev ) ) & + & * inv_g + + if (lhook) call dr_hook('radiation_thermodynamics:get_layer_mass_column',1,hook_handle) + + end subroutine get_layer_mass_column + + + !--------------------------------------------------------------------- + ! Estimate the separation between the mid-points of model layers + ! given the half-level pressure and temperature. This is not in + ! terms of the "thermodynamics" type as it is useful for computing + ! overlap decorrelation lengths and hence cloud cover outside the + ! radiation scheme. + subroutine get_layer_separation(pressure_hl, temperature_hl, layer_separation) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_constants, only : GasConstantDryAir, AccelDueToGravity + + ! Pressure (Pa) and temperature (K) at half-levels, dimensioned + ! (ncol,nlev+1) where ncol is the number of columns and nlev is + ! the number of model levels + real(jprb), dimension(:,:), intent(in) :: pressure_hl, temperature_hl + + ! Layer separation in metres, dimensioned (ncol,nlev-1) + real(jprb), dimension(:,:), intent(out) :: layer_separation + + ! Ratio of gas constant for dry air to acceleration due to gravity + real(jprb), parameter :: R_over_g = GasConstantDryAir / AccelDueToGravity + + ! Loop indices and array bounds + integer :: jlev + integer :: i1, i2, nlev + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_thermodynamics:get_layer_separation',0,hook_handle) + + i1 = lbound(pressure_hl,1) + i2 = ubound(pressure_hl,1) + nlev = size(pressure_hl,2)-1 + + if (pressure_hl(i1,2) > pressure_hl(i1,1)) then + ! Pressure is increasing with index (order of layers is + ! top-of-atmosphere to surface). In case pressure_hl(:,1)=0, we + ! don't take the logarithm of the first pressure in each column. + layer_separation(i1:i2,1) = R_over_g * temperature_hl(i1:i2,2) & + & * log(pressure_hl(i1:i2,3)/pressure_hl(i1:i2,2)) + + ! For other layers we take the separation between midpoints to + ! be half the separation between the half-levels at the edge of + ! the two adjacent layers + do jlev = 2,nlev-1 + layer_separation(i1:i2,jlev) = (0.5_jprb * R_over_g) * temperature_hl(i1:i2,jlev+1) & + & * log(pressure_hl(i1:i2,jlev+2)/pressure_hl(i1:i2,jlev)) + + end do + + else + ! Pressure is decreasing with index (order of layers is surface + ! to top-of-atmosphere). In case pressure_hl(:,nlev+1)=0, we + ! don't take the logarithm of the last pressure in each column. + + do jlev = 1,nlev-2 + layer_separation(i1:i2,jlev) = (0.5_jprb * R_over_g) * temperature_hl(i1:i2,jlev+1) & + & * log(pressure_hl(i1:i2,jlev)/pressure_hl(i1:i2,jlev+2)) + + end do + layer_separation(i1:i2,nlev-1) = R_over_g * temperature_hl(i1:i2,nlev) & + & * log(pressure_hl(i1:i2,nlev-1)/pressure_hl(i1:i2,nlev)) + + end if + + if (lhook) call dr_hook('radiation_thermodynamics:get_layer_separation',1,hook_handle) + + end subroutine get_layer_separation + + + !--------------------------------------------------------------------- + ! Return .true. if variables are out of a physically sensible range, + ! optionally only considering columns between istartcol and iendcol + function out_of_physical_bounds(this, istartcol, iendcol, do_fix) result(is_bad) + + use yomhook, only : lhook, dr_hook, jphook + use radiation_check, only : out_of_bounds_2d + + class(thermodynamics_type), intent(inout) :: this + integer, optional,intent(in) :: istartcol, iendcol + logical, optional,intent(in) :: do_fix + logical :: is_bad + + logical :: do_fix_local + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_thermodynamics:out_of_physical_bounds',0,hook_handle) + + if (present(do_fix)) then + do_fix_local = do_fix + else + do_fix_local = .false. + end if + + ! Dangerous to cap pressure_hl as then the pressure difference across a layer could be zero + is_bad = out_of_bounds_2d(this%pressure_hl, 'pressure_hl', 0.0_jprb, 110000.0_jprb, & + & .false., i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%temperature_hl, 'temperature_hl', 100.0_jprb, 400.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) & + & .or. out_of_bounds_2d(this%h2o_sat_liq, 'h2o_sat_liq', 0.0_jprb, 1.0_jprb, & + & do_fix_local, i1=istartcol, i2=iendcol) + + if (lhook) call dr_hook('radiation_thermodynamics:out_of_physical_bounds',1,hook_handle) + + end function out_of_physical_bounds + +#ifdef _OPENACC + !--------------------------------------------------------------------- + ! updates fields on host + subroutine update_host(this) + + class(thermodynamics_type), intent(inout) :: this + + !$ACC UPDATE HOST(this%pressure_hl) & + !$ACC IF(allocated(this%pressure_hl)) + + !$ACC UPDATE HOST(this%temperature_hl) & + !$ACC IF(allocated(this%temperature_hl)) + + !$ACC UPDATE HOST(this%pressure_fl) & + !$ACC IF(allocated(this%pressure_fl)) + + !$ACC UPDATE HOST(this%temperature_fl) & + !$ACC IF(allocated(this%temperature_fl)) + + !$ACC UPDATE HOST(this%h2o_sat_liq) & + !$ACC IF(allocated(this%h2o_sat_liq)) + + end subroutine update_host + + !--------------------------------------------------------------------- + ! updates fields on device + subroutine update_device(this) + + class(thermodynamics_type), intent(inout) :: this + + !$ACC UPDATE DEVICE(this%pressure_hl) & + !$ACC IF(allocated(this%pressure_hl)) + + !$ACC UPDATE DEVICE(this%temperature_hl) & + !$ACC IF(allocated(this%temperature_hl)) + + !$ACC UPDATE DEVICE(this%pressure_fl) & + !$ACC IF(allocated(this%pressure_fl)) + + !$ACC UPDATE DEVICE(this%temperature_fl) & + !$ACC IF(allocated(this%temperature_fl)) + + !$ACC UPDATE DEVICE(this%h2o_sat_liq) & + !$ACC IF(allocated(this%h2o_sat_liq)) + + end subroutine update_device +#endif + +end module radiation_thermodynamics Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_lw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_lw.F90 (revision 6016) @@ -0,0 +1,567 @@ +! radiation_tripleclouds_lw.F90 - Longwave "Tripleclouds" solver +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-28 R. Hogan Receive emission/albedo rather than planck/emissivity +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-10-23 R. Hogan Renamed single-character variables +! 2018-10-08 R. Hogan Call calc_region_properties +! 2020-09-18 R. Hogan Replaced some array expressions with loops +! 2020-09-19 R. Hogan Implement the cloud-only-scattering optimization + +module radiation_tripleclouds_lw + + public + +contains + ! Small routine for scaling cloud optical depth in the cloudy + ! regions +#include "radiation_optical_depth_scaling.h" + + !--------------------------------------------------------------------- + ! This module contains just one subroutine, the longwave + ! "Tripleclouds" solver in which cloud inhomogeneity is treated by + ! dividing each model level into three regions, one clear and two + ! cloudy (with differing optical depth). This approach was described + ! by Shonk and Hogan (2008). + subroutine solver_tripleclouds_lw(nlev,istartcol,iendcol, & + & config, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, planck_hl, & + & emission, albedo, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + +! use radiation_io, only : nulout + use radiation_config, only : config_type, IPdfShapeGamma + use radiation_cloud, only : cloud_type + use radiation_regions, only : calc_region_properties + use radiation_overlap, only : calc_overlap_matrices + use radiation_flux, only : flux_type, indexed_sum + use radiation_matrix, only : singlemat_x_vec + use radiation_two_stream, only : calc_ref_trans_lw, & + & calc_no_scattering_transmittance_lw + use radiation_adding_ica_lw, only : adding_ica_lw, calc_fluxes_no_scattering_lw + use radiation_lw_derivatives, only : calc_lw_derivatives_region + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth of each layer at each longwave + ! g-point + real(jprb), intent(in), dimension(config%n_g_lw,nlev,istartcol:iendcol) :: od + + ! Gas and aerosol single-scattering albedo and asymmetry factor, + ! only if longwave scattering by aerosols is to be represented + real(jprb), intent(in), & + & dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol) :: ssa, g + + ! Cloud and precipitation optical depth of each layer in each + ! longwave band + real(jprb), intent(in) :: od_cloud(config%n_bands_lw,nlev,istartcol:iendcol) + + ! Cloud and precipitation single-scattering albedo and asymmetry + ! factor, only if longwave scattering by clouds is to be + ! represented + real(jprb), intent(in), dimension(config%n_bands_lw_if_scattering, & + & nlev,istartcol:iendcol) :: ssa_cloud, g_cloud + + ! Planck function (emitted flux from a black body) at half levels + ! and at the surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: planck_hl + + ! Emission (Planck*emissivity) and albedo (1-emissivity) at the + ! surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, istartcol:iendcol) :: emission, albedo + + ! Optical depth, single scattering albedo and asymmetry factor in + ! each g-point including gas, aerosol and clouds + real(jprb), dimension(config%n_g_lw) :: od_total, ssa_total, g_total + + ! Modified optical depth after Tripleclouds scaling to represent + ! cloud inhomogeneity + real(jprb), dimension(config%n_g_lw) :: od_cloud_new + + ! Output + type(flux_type), intent(inout):: flux + + ! Local constants + integer, parameter :: nregions = 3 + + ! In a clear-sky layer this will be 1, otherwise equal to nregions + integer :: nreg + + ! Local variables + + ! The area fractions of each region + real(jprb) :: region_fracs(1:nregions,nlev,istartcol:iendcol) + + ! The scaling used for the optical depth in the cloudy regions + real(jprb) :: od_scaling(2:nregions,nlev,istartcol:iendcol) + + ! Directional overlap matrices defined at all layer interfaces + ! including top-of-atmosphere and the surface + real(jprb), dimension(nregions,nregions,nlev+1, & + & istartcol:iendcol) :: u_matrix, v_matrix + + ! Diffuse reflection and transmission matrices of each layer + real(jprb), dimension(config%n_g_lw, nregions, nlev) :: reflectance, transmittance + + ! Emission by a layer into the upwelling or downwelling diffuse + ! streams + real(jprb), dimension(config%n_g_lw, nregions, nlev) & + & :: source_up, source_dn + + ! Clear-sky reflectance and transmittance + real(jprb), dimension(config%n_g_lw, nlev) & + & :: ref_clear, trans_clear + + ! ...clear-sky equivalent + real(jprb), dimension(config%n_g_lw, nlev) & + & :: source_up_clear, source_dn_clear + + ! Total albedo of the atmosphere/surface just above a layer + ! interface with respect to downwelling diffuse radiation at that + ! interface, where level index = 1 corresponds to the + ! top-of-atmosphere + real(jprb), dimension(config%n_g_lw, nregions, nlev+1) :: total_albedo + + ! Upwelling radiation just above a layer interface due to emission + ! below that interface, where level index = 1 corresponds to the + ! top-of-atmosphere + real(jprb), dimension(config%n_g_lw, nregions, nlev+1) :: total_source + + ! Total albedo and source of the atmosphere just below a layer interface + real(jprb), dimension(config%n_g_lw, nregions) & + & :: total_albedo_below, total_source_below + + ! Downwelling flux below and above an interface between + ! layers into a plane perpendicular to the direction of the sun + real(jprb), dimension(config%n_g_lw, nregions) & + & :: flux_dn, flux_dn_below, flux_up + + ! ...clear-sky equivalent (no distinction between "above/below") + real(jprb), dimension(config%n_g_lw, nlev+1) & + & :: flux_dn_clear, flux_up_clear + + ! Clear-sky equivalent, but actually its reciprocal to replace + ! some divisions by multiplications + real(jprb), dimension(config%n_g_lw, nregions) :: inv_denom + + ! Identify clear-sky layers, with pseudo layers for outer space + ! and below the ground, both treated as single-region clear skies + logical :: is_clear_sky_layer(0:nlev+1) + + ! Index of the highest cloudy layer + integer :: i_cloud_top + + integer :: jcol, jlev, jg, jreg, jreg2, ng + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_tripleclouds_lw:solver_tripleclouds_lw',0,hook_handle) + + ! -------------------------------------------------------- + ! Section 1: Prepare general variables and arrays + ! -------------------------------------------------------- + ! Copy array dimensions to local variables for convenience + ng = config%n_g_lw + + ! Compute the wavelength-independent region fractions and + ! optical-depth scalings + call calc_region_properties(nlev,nregions,istartcol,iendcol, & + & config%i_cloud_pdf_shape == IPdfShapeGamma, & + & cloud%fraction, cloud%fractional_std, region_fracs, & + & od_scaling, config%cloud_fraction_threshold) + + ! Compute wavelength-independent overlap matrices u_matrix and v_matrix + call calc_overlap_matrices(nlev,nregions,istartcol,iendcol, & + & region_fracs, cloud%overlap_param, & + & u_matrix, v_matrix, & + & decorrelation_scaling=config%cloud_inhom_decorr_scaling, & + & cloud_fraction_threshold=config%cloud_fraction_threshold, & + & use_beta_overlap=config%use_beta_overlap, & + & cloud_cover=flux%cloud_cover_lw) + + ! Main loop over columns + do jcol = istartcol, iendcol + ! -------------------------------------------------------- + ! Section 2: Prepare column-specific variables and arrays + ! -------------------------------------------------------- + + ! Define which layers contain cloud; assume that + ! cloud%crop_cloud_fraction has already been called + is_clear_sky_layer = .true. + i_cloud_top = nlev+1 + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + is_clear_sky_layer(jlev) = .false. + ! Get index to the first cloudy layer from the top + if (i_cloud_top > jlev) then + i_cloud_top = jlev + end if + end if + end do + if (config%do_lw_aerosol_scattering) then + ! This is actually the first layer in which we need to + ! consider scattering + i_cloud_top = 1 + end if + + ! -------------------------------------------------------- + ! Section 3: Clear-sky calculation + ! -------------------------------------------------------- + + if (.not. config%use_aerosols & + .or. .not. config%do_lw_aerosol_scattering) then + ! No scattering in clear-sky flux calculation; note that here + ! the first two dimensions of the input arrays are unpacked + ! into vectors inside the routine + call calc_no_scattering_transmittance_lw(ng*nlev, od(:,:,jcol), & + & planck_hl(:,1:nlev,jcol), planck_hl(:,2:nlev+1, jcol), & + & trans_clear, source_up_clear, source_dn_clear) + ! Ensure that clear-sky reflectance is zero since it may be + ! used in cloudy-sky case + ref_clear = 0.0_jprb + ! Simple down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear, flux_dn_clear) + else + ! Scattering in clear-sky flux calculation + call calc_ref_trans_lw(ng*nlev, & + & od(:,:,jcol), ssa(:,:,jcol), g(:,:,jcol), & + & planck_hl(:,1:nlev,jcol), planck_hl(:,2:nlev+1,jcol), & + & ref_clear, trans_clear, & + & source_up_clear, source_dn_clear) + ! Use adding method to compute fluxes + call adding_ica_lw(ng, nlev, & + & ref_clear, trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear, flux_dn_clear) + end if + + if (config%do_clear) then + ! Sum over g-points to compute broadband fluxes + flux%lw_up_clear(jcol,:) = sum(flux_up_clear,1) + flux%lw_dn_clear(jcol,:) = sum(flux_dn_clear,1) + ! Store surface spectral downwelling fluxes / TOA upwelling + flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear(:,nlev+1) + flux%lw_up_toa_clear_g (:,jcol) = flux_up_clear(:,1) + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + do jlev = 1,nlev+1 + call indexed_sum(flux_up_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_clear_band(:,jcol,jlev)) + call indexed_sum(flux_dn_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_clear_band(:,jcol,jlev)) + end do + end if + end if + + ! -------------------------------------------------------- + ! Section 4: Loop over cloudy layers to compute reflectance and transmittance + ! -------------------------------------------------------- + ! In this section the reflectance, transmittance and sources + ! are computed for each layer + + ! Firstly, ensure clear-sky transmittance is valid for whole + ! depth of the atmosphere, because even above cloud it is used + ! by the LW derivatives + transmittance(:,1,:) = trans_clear(:,:) + ! Dummy values in cloudy regions above cloud top + if (i_cloud_top > 0) then + transmittance(:,2:,1:min(i_cloud_top,nlev)) = 1.0_jprb + end if + + do jlev = i_cloud_top,nlev ! Start at cloud top and work down + + ! Copy over clear-sky properties + reflectance(:,1,jlev) = ref_clear(:,jlev) + source_up(:,1,jlev) = source_up_clear(:,jlev) ! Scaled later by region size + source_dn(:,1,jlev) = source_dn_clear(:,jlev) ! Scaled later by region size + nreg = nregions + if (is_clear_sky_layer(jlev)) then + nreg = 1 + reflectance(:,2:,jlev) = 0.0_jprb + transmittance(:,2:,jlev) = 1.0_jprb + source_up(:,2:,jlev) = 0.0_jprb + source_dn(:,2:,jlev) = 0.0_jprb + else + do jreg = 2,nreg + ! Cloudy sky + ! Add scaled cloud optical depth to clear-sky value + od_cloud_new = od_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_scaling(jreg,jlev,jcol) + od_total = od(:,jlev,jcol) + od_cloud_new + + if (config%do_lw_cloud_scattering) then + ssa_total = 0.0_jprb + g_total = 0.0_jprb + if (config%do_lw_aerosol_scattering) then + where (od_total > 0.0_jprb) + ssa_total = (ssa(:,jlev,jcol)*od(:,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_new) & + & / od_total + end where + where (ssa_total > 0.0_jprb .and. od_total > 0.0_jprb) + g_total = (g(:,jlev,jcol)*ssa(:,jlev,jcol)*od(:,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_new) & + & / (ssa_total*od_total) + end where + else + where (od_total > 0.0_jprb) + ssa_total = ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_new / od_total + end where + where (ssa_total > 0.0_jprb .and. od_total > 0.0_jprb) + g_total = g_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_new / (ssa_total*od_total) + end where + end if + call calc_ref_trans_lw(ng, & + & od_total, ssa_total, g_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & + & reflectance(:,jreg,jlev), transmittance(:,jreg,jlev), & + & source_up(:,jreg,jlev), source_dn(:,jreg,jlev)) + else + ! No-scattering case: use simpler functions for + ! transmission and emission + call calc_no_scattering_transmittance_lw(ng, od_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & transmittance(:,jreg,jlev), source_up(:,jreg,jlev), source_dn(:,jreg,jlev)) + reflectance(:,jreg,jlev) = 0.0_jprb + end if + end do + ! Emission is scaled by the size of each region + do jreg = 1,nregions + source_up(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * source_up(:,jreg,jlev) + source_dn(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * source_dn(:,jreg,jlev) + end do + end if + + end do ! Loop over levels + + ! -------------------------------------------------------- + ! Section 5: Compute total sources and albedos at each half level + ! -------------------------------------------------------- + + total_albedo(:,:,:) = 0.0_jprb + total_source(:,:,:) = 0.0_jprb + + ! Calculate the upwelling radiation emitted by the surface, and + ! copy the surface albedo into total_albedo + do jreg = 1,nregions + do jg = 1,ng + ! region_fracs(jreg,nlev,jcol) is the fraction of each region in the + ! lowest model level + total_source(jg,jreg,nlev+1) = region_fracs(jreg,nlev,jcol)*emission(jg,jcol) + total_albedo(jg,jreg,nlev+1) = albedo(jg,jcol) + end do + end do + + ! Work up from the surface computing the total albedo of the + ! atmosphere and the total upwelling due to emission below each + ! level below using the adding method + do jlev = nlev,i_cloud_top,-1 + + total_albedo_below = 0.0_jprb + + if (is_clear_sky_layer(jlev)) then + total_albedo_below = 0.0_jprb + total_source_below = 0.0_jprb + do jg = 1,ng + inv_denom(jg,1) = 1.0_jprb & + & / (1.0_jprb - total_albedo(jg,1,jlev+1)*reflectance(jg,1,jlev)) + total_albedo_below(jg,1) = reflectance(jg,1,jlev) & + & + transmittance(jg,1,jlev)*transmittance(jg,1,jlev)*total_albedo(jg,1,jlev+1) & + & * inv_denom(jg,1) + total_source_below(jg,1) = source_up(jg,1,jlev) & + & + transmittance(jg,1,jlev)*(total_source(jg,1,jlev+1) & + & + total_albedo(jg,1,jlev+1)*source_dn(jg,1,jlev)) & + & * inv_denom(jg,1) + end do + else + inv_denom = 1.0_jprb / (1.0_jprb - total_albedo(:,:,jlev+1)*reflectance(:,:,jlev)) + total_albedo_below = reflectance(:,:,jlev) & + & + transmittance(:,:,jlev)*transmittance(:,:,jlev)*total_albedo(:,:,jlev+1) & + & * inv_denom + total_source_below = source_up(:,:,jlev) & + & + transmittance(:,:,jlev)*(total_source(:,:,jlev+1) & + & + total_albedo(:,:,jlev+1)*source_dn(:,:,jlev)) & + & * inv_denom + end if + + ! Account for cloud overlap when converting albedo below a + ! layer interface to the equivalent values just above + if (is_clear_sky_layer(jlev) .and. is_clear_sky_layer(jlev-1)) then + total_albedo(:,:,jlev) = total_albedo_below(:,:) + total_source(:,:,jlev) = total_source_below(:,:) + else + total_source(:,:,jlev) = singlemat_x_vec(ng,ng,nregions,& + & u_matrix(:,:,jlev,jcol), total_source_below) + ! Use overlap matrix and exclude "anomalous" horizontal + ! transport described by Shonk & Hogan (2008). Therefore, + ! the operation we perform is essentially diag(total_albedo) + ! = matmul(transpose(v_matrix), diag(total_albedo_below)). + do jreg = 1,nregions + do jreg2 = 1,nregions + total_albedo(:,jreg,jlev) & + & = total_albedo(:,jreg,jlev) & + & + total_albedo_below(:,jreg2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + + end do + end do + + end if + + end do ! Reverse loop over levels + + ! -------------------------------------------------------- + ! Section 6: Copy over downwelling fluxes above cloud top + ! -------------------------------------------------------- + do jlev = 1,i_cloud_top + if (config%do_clear) then + ! Clear-sky fluxes have already been averaged: use these + flux%lw_dn(jcol,jlev) = flux%lw_dn_clear(jcol,jlev) + if (config%do_save_spectral_flux) then + flux%lw_dn_band(:,jcol,jlev) = flux%lw_dn_clear_band(:,jcol,jlev) + end if + else + flux%lw_dn(jcol,:) = sum(flux_dn_clear(:,jlev)) + if (config%do_save_spectral_flux) then + call indexed_sum(flux_dn_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_band(:,jcol,jlev)) + end if + end if + end do + + ! -------------------------------------------------------- + ! Section 7: Compute fluxes up to top-of-atmosphere + ! -------------------------------------------------------- + + ! Compute the fluxes just above the highest cloud + flux_up(:,1) = total_source(:,1,i_cloud_top) & + & + total_albedo(:,1,i_cloud_top)*flux_dn_clear(:,i_cloud_top) + flux_up(:,2:) = 0.0_jprb + flux%lw_up(jcol,i_cloud_top) = sum(flux_up(:,1)) + if (config%do_save_spectral_flux) then + call indexed_sum(flux_up(:,1), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,i_cloud_top)) + end if + do jlev = i_cloud_top-1,1,-1 + flux_up(:,1) = trans_clear(:,jlev)*flux_up(:,1) + source_up_clear(:,jlev) + flux%lw_up(jcol,jlev) = sum(flux_up(:,1)) + if (config%do_save_spectral_flux) then + call indexed_sum(flux_up(:,1), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,jlev)) + end if + end do + flux%lw_up_toa_g(:,jcol) = sum(flux_up,2) + + ! -------------------------------------------------------- + ! Section 8: Compute fluxes down to surface + ! -------------------------------------------------------- + + ! Copy over downwelling spectral fluxes at top of first + ! scattering layer, using overlap matrix to translate to the + ! regions of the first layer of cloud + do jreg = 1,nregions + flux_dn(:,jreg) = v_matrix(jreg,1,i_cloud_top,jcol)*flux_dn_clear(:,i_cloud_top) + end do + + ! Final loop back down through the atmosphere to compute fluxes + do jlev = i_cloud_top,nlev + + if (is_clear_sky_layer(jlev)) then + do jg = 1,ng + flux_dn(jg,1) = (transmittance(jg,1,jlev)*flux_dn(jg,1) & + & + reflectance(jg,1,jlev)*total_source(jg,1,jlev+1) + source_dn(jg,1,jlev) ) & + & / (1.0_jprb - reflectance(jg,1,jlev)*total_albedo(jg,1,jlev+1)) + flux_up(jg,1) = total_source(jg,1,jlev+1) + flux_dn(jg,1)*total_albedo(jg,1,jlev+1) + end do + flux_dn(:,2:) = 0.0_jprb + flux_up(:,2:) = 0.0_jprb + else + flux_dn = (transmittance(:,:,jlev)*flux_dn & + & + reflectance(:,:,jlev)*total_source(:,:,jlev+1) + source_dn(:,:,jlev) ) & + & / (1.0_jprb - reflectance(:,:,jlev)*total_albedo(:,:,jlev+1)) + flux_up = total_source(:,:,jlev+1) + flux_dn*total_albedo(:,:,jlev+1) + end if + + if (.not. (is_clear_sky_layer(jlev) & + & .and. is_clear_sky_layer(jlev+1))) then + ! Account for overlap rules in translating fluxes just above + ! a layer interface to the values just below + flux_dn_below = singlemat_x_vec(ng,ng,nregions, & + & v_matrix(:,:,jlev+1,jcol), flux_dn) + flux_dn = flux_dn_below + end if ! Otherwise the fluxes in each region are the same so + ! nothing to do + + ! Store the broadband fluxes + flux%lw_up(jcol,jlev+1) = sum(sum(flux_up,1)) + flux%lw_dn(jcol,jlev+1) = sum(sum(flux_dn,1)) + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum(sum(flux_up,2), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,jlev+1)) + call indexed_sum(sum(flux_dn,2), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_band(:,jcol,jlev+1)) + end if + + end do ! Final loop over levels + + ! Store surface spectral downwelling fluxes, which at this point + ! are at the surface + flux%lw_dn_surf_g(:,jcol) = sum(flux_dn,2) + + ! Compute the longwave derivatives needed by Hogan and Bozzo + ! (2015) approximate radiation update scheme + if (config%do_lw_derivatives) then + ! Note that at this point flux_up contains the spectral + ! fluxes into the regions of the lowest layer; we sum over + ! regions first to provide a simple spectral flux upwelling + ! from the surface + call calc_lw_derivatives_region(ng, nlev, nregions, jcol, transmittance, & + & u_matrix(:,:,:,jcol), sum(flux_up,2), flux%lw_derivatives) + end if + + end do ! Loop over columns + + if (lhook) call dr_hook('radiation_tripleclouds_lw:solver_tripleclouds_lw',1,hook_handle) + + end subroutine solver_tripleclouds_lw + +end module radiation_tripleclouds_lw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_lw.F90.or =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_lw.F90.or (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_lw.F90.or (revision 6016) @@ -0,0 +1,607 @@ +! radiation_tripleclouds_lw.F90 - Longwave "Tripleclouds" solver +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-28 R. Hogan Receive emission/albedo rather than planck/emissivity +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-10-23 R. Hogan Renamed single-character variables +! 2018-10-08 R. Hogan Call calc_region_properties +! 2020-09-18 R. Hogan Replaced some array expressions with loops +! 2020-09-19 R. Hogan Implement the cloud-only-scattering optimization + +module radiation_tripleclouds_lw + + public + +contains + ! Small routine for scaling cloud optical depth in the cloudy + ! regions +#include "radiation_optical_depth_scaling.h" + + !--------------------------------------------------------------------- + ! This module contains just one subroutine, the longwave + ! "Tripleclouds" solver in which cloud inhomogeneity is treated by + ! dividing each model level into three regions, one clear and two + ! cloudy (with differing optical depth). This approach was described + ! by Shonk and Hogan (2008). + subroutine solver_tripleclouds_lw(nlev,istartcol,iendcol, & + & config, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, planck_hl, & + & emission, albedo, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + +! use radiation_io, only : nulout + use radiation_config, only : config_type, IPdfShapeGamma + use radiation_cloud, only : cloud_type + use radiation_regions, only : calc_region_properties + use radiation_overlap, only : calc_overlap_matrices + use radiation_flux, only : flux_type, indexed_sum + use radiation_matrix, only : singlemat_x_vec + use radiation_two_stream, only : calc_ref_trans_lw, & + & calc_no_scattering_transmittance_lw + use radiation_adding_ica_lw, only : adding_ica_lw, calc_fluxes_no_scattering_lw + use radiation_lw_derivatives, only : calc_lw_derivatives_region + + implicit none + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth of each layer at each longwave + ! g-point + real(jprb), intent(in), dimension(config%n_g_lw,nlev,istartcol:iendcol) :: od + + ! Gas and aerosol single-scattering albedo and asymmetry factor, + ! only if longwave scattering by aerosols is to be represented + real(jprb), intent(in), & + & dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol) :: ssa, g + + ! Cloud and precipitation optical depth of each layer in each + ! longwave band + real(jprb), intent(in) :: od_cloud(config%n_bands_lw,nlev,istartcol:iendcol) + + ! Cloud and precipitation single-scattering albedo and asymmetry + ! factor, only if longwave scattering by clouds is to be + ! represented + real(jprb), intent(in), dimension(config%n_bands_lw_if_scattering, & + & nlev,istartcol:iendcol) :: ssa_cloud, g_cloud + + ! Planck function (emitted flux from a black body) at half levels + ! and at the surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: planck_hl + + ! Emission (Planck*emissivity) and albedo (1-emissivity) at the + ! surface at each longwave g-point + real(jprb), intent(in), dimension(config%n_g_lw, istartcol:iendcol) :: emission, albedo + + ! Optical depth, single scattering albedo and asymmetry factor in + ! each g-point including gas, aerosol and clouds + real(jprb), dimension(config%n_g_lw) :: od_total, ssa_total, g_total + + ! Modified optical depth after Tripleclouds scaling to represent + ! cloud inhomogeneity + real(jprb), dimension(config%n_g_lw) :: od_cloud_new + + ! Output + type(flux_type), intent(inout):: flux + + ! Local constants + integer, parameter :: nregions = 3 + + ! In a clear-sky layer this will be 1, otherwise equal to nregions + integer :: nreg + + ! Local variables + + ! The area fractions of each region + real(jprb) :: region_fracs(1:nregions,nlev,istartcol:iendcol) + + ! The scaling used for the optical depth in the cloudy regions + real(jprb) :: od_scaling(2:nregions,nlev,istartcol:iendcol) + + ! Directional overlap matrices defined at all layer interfaces + ! including top-of-atmosphere and the surface + real(jprb), dimension(nregions,nregions,nlev+1, & + & istartcol:iendcol) :: u_matrix, v_matrix + + ! Diffuse reflection and transmission matrices of each layer + real(jprb), dimension(config%n_g_lw, nregions, nlev) :: reflectance, transmittance + + ! Emission by a layer into the upwelling or downwelling diffuse + ! streams + real(jprb), dimension(config%n_g_lw, nregions, nlev) & + & :: source_up, source_dn + + ! Clear-sky reflectance and transmittance + real(jprb), dimension(config%n_g_lw, nlev) & + & :: ref_clear, trans_clear + + ! ...clear-sky equivalent + real(jprb), dimension(config%n_g_lw, nlev) & + & :: source_up_clear, source_dn_clear + + ! Total albedo of the atmosphere/surface just above a layer + ! interface with respect to downwelling diffuse radiation at that + ! interface, where level index = 1 corresponds to the + ! top-of-atmosphere + real(jprb), dimension(config%n_g_lw, nregions, nlev+1) :: total_albedo + + ! Upwelling radiation just above a layer interface due to emission + ! below that interface, where level index = 1 corresponds to the + ! top-of-atmosphere + real(jprb), dimension(config%n_g_lw, nregions, nlev+1) :: total_source + + ! Total albedo and source of the atmosphere just below a layer interface + real(jprb), dimension(config%n_g_lw, nregions) & + & :: total_albedo_below, total_source_below + + ! Downwelling flux below and above an interface between + ! layers into a plane perpendicular to the direction of the sun + real(jprb), dimension(config%n_g_lw, nregions) & + & :: flux_dn, flux_dn_below, flux_up + + ! ...clear-sky equivalent (no distinction between "above/below") + real(jprb), dimension(config%n_g_lw, nlev+1) & + & :: flux_dn_clear, flux_up_clear + + ! Clear-sky equivalent, but actually its reciprocal to replace + ! some divisions by multiplications + real(jprb), dimension(config%n_g_lw, nregions) :: inv_denom + + ! Identify clear-sky layers, with pseudo layers for outer space + ! and below the ground, both treated as single-region clear skies + logical :: is_clear_sky_layer(0:nlev+1) + + ! Temporaries to speed up summations + real(jprb) :: sum_dn, sum_up + + ! Index of the highest cloudy layer + integer :: i_cloud_top + + integer :: jcol, jlev, jg, jreg, jreg2, ng + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_tripleclouds_lw:solver_tripleclouds_lw',0,hook_handle) + + ! -------------------------------------------------------- + ! Section 1: Prepare general variables and arrays + ! -------------------------------------------------------- + ! Copy array dimensions to local variables for convenience + ng = config%n_g_lw + + ! Compute the wavelength-independent region fractions and + ! optical-depth scalings + call calc_region_properties(nlev,nregions,istartcol,iendcol, & + & config%i_cloud_pdf_shape == IPdfShapeGamma, & + & cloud%fraction, cloud%fractional_std, region_fracs, & + & od_scaling, config%cloud_fraction_threshold) + + ! Compute wavelength-independent overlap matrices u_matrix and v_matrix + call calc_overlap_matrices(nlev,nregions,istartcol,iendcol, & + & region_fracs, cloud%overlap_param, & + & u_matrix, v_matrix, & + & decorrelation_scaling=config%cloud_inhom_decorr_scaling, & + & cloud_fraction_threshold=config%cloud_fraction_threshold, & + & use_beta_overlap=config%use_beta_overlap, & + & cloud_cover=flux%cloud_cover_lw) + + ! Main loop over columns + do jcol = istartcol, iendcol + ! -------------------------------------------------------- + ! Section 2: Prepare column-specific variables and arrays + ! -------------------------------------------------------- + + ! Define which layers contain cloud; assume that + ! cloud%crop_cloud_fraction has already been called + is_clear_sky_layer = .true. + i_cloud_top = nlev+1 + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + is_clear_sky_layer(jlev) = .false. + ! Get index to the first cloudy layer from the top + if (i_cloud_top > jlev) then + i_cloud_top = jlev + end if + end if + end do + if (config%do_lw_aerosol_scattering) then + ! This is actually the first layer in which we need to + ! consider scattering + i_cloud_top = 1 + end if + + ! -------------------------------------------------------- + ! Section 3: Clear-sky calculation + ! -------------------------------------------------------- + + if (.not. config%do_lw_aerosol_scattering) then + ! No scattering in clear-sky flux calculation; note that here + ! the first two dimensions of the input arrays are unpacked + ! into vectors inside the routine + call calc_no_scattering_transmittance_lw(ng*nlev, od(:,:,jcol), & + & planck_hl(:,1:nlev,jcol), planck_hl(:,2:nlev+1, jcol), & + & trans_clear, source_up_clear, source_dn_clear) + ! Ensure that clear-sky reflectance is zero since it may be + ! used in cloudy-sky case + ref_clear = 0.0_jprb + ! Simple down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear, flux_dn_clear) + else + ! Scattering in clear-sky flux calculation + call calc_ref_trans_lw(ng*nlev, & + & od(:,:,jcol), ssa(:,:,jcol), g(:,:,jcol), & + & planck_hl(:,1:nlev,jcol), planck_hl(:,2:nlev+1,jcol), & + & ref_clear, trans_clear, & + & source_up_clear, source_dn_clear) + ! Use adding method to compute fluxes + call adding_ica_lw(ng, nlev, & + & ref_clear, trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear, flux_dn_clear) + end if + + if (config%do_clear) then + ! Sum over g-points to compute broadband fluxes + do jlev = 1,nlev+1 + sum_up = 0.0_jprb + sum_dn = 0.0_jprb + !$omp simd reduction(+:sum_up, sum_dn) + do jg = 1,ng + sum_up = sum_up + flux_up_clear(jg,jlev) + sum_dn = sum_dn + flux_dn_clear(jg,jlev) + end do + flux%lw_up_clear(jcol,jlev) = sum_up + flux%lw_dn_clear(jcol,jlev) = sum_dn + end do + + ! Store surface spectral downwelling fluxes / TOA upwelling + do jg = 1,ng + flux%lw_dn_surf_clear_g(jg,jcol) = flux_dn_clear(jg,nlev+1) + flux%lw_up_toa_clear_g (jg,jcol) = flux_up_clear(jg,1) + end do + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + do jlev = 1,nlev+1 + call indexed_sum(flux_up_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_clear_band(:,jcol,jlev)) + call indexed_sum(flux_dn_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_clear_band(:,jcol,jlev)) + end do + end if + end if + + ! -------------------------------------------------------- + ! Section 4: Loop over cloudy layers to compute reflectance and transmittance + ! -------------------------------------------------------- + ! In this section the reflectance, transmittance and sources + ! are computed for each layer + + ! Firstly, ensure clear-sky transmittance is valid for whole + ! depth of the atmosphere, because even above cloud it is used + ! by the LW derivatives + transmittance(:,1,:) = trans_clear(:,:) + ! Dummy values in cloudy regions above cloud top + if (i_cloud_top > 0) then + transmittance(:,2:,1:min(i_cloud_top,nlev)) = 1.0_jprb + end if + + do jlev = i_cloud_top,nlev ! Start at cloud top and work down + + ! Copy over clear-sky properties + reflectance(:,1,jlev) = ref_clear(:,jlev) + source_up(:,1,jlev) = source_up_clear(:,jlev) ! Scaled later by region size + source_dn(:,1,jlev) = source_dn_clear(:,jlev) ! Scaled later by region size + nreg = nregions + if (is_clear_sky_layer(jlev)) then + nreg = 1 + reflectance(:,2:,jlev) = 0.0_jprb + transmittance(:,2:,jlev) = 1.0_jprb + source_up(:,2:,jlev) = 0.0_jprb + source_dn(:,2:,jlev) = 0.0_jprb + else + do jreg = 2,nreg + ! Cloudy sky + ! Add scaled cloud optical depth to clear-sky value + od_cloud_new = od_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_scaling(jreg,jlev,jcol) + od_total = od(:,jlev,jcol) + od_cloud_new + + if (config%do_lw_cloud_scattering) then + ssa_total = 0.0_jprb + g_total = 0.0_jprb + if (config%do_lw_aerosol_scattering) then + where (od_total > 0.0_jprb) + ssa_total = (ssa(:,jlev,jcol)*od(:,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_new) & + & / od_total + end where + where (ssa_total > 0.0_jprb .and. od_total > 0.0_jprb) + g_total = (g(:,jlev,jcol)*ssa(:,jlev,jcol)*od(:,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_new) & + & / (ssa_total*od_total) + end where + else + where (od_total > 0.0_jprb) + ssa_total = ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_new / od_total + end where + where (ssa_total > 0.0_jprb .and. od_total > 0.0_jprb) + g_total = g_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & + & * od_cloud_new / (ssa_total*od_total) + end where + end if + call calc_ref_trans_lw(ng, & + & od_total, ssa_total, g_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & + & reflectance(:,jreg,jlev), transmittance(:,jreg,jlev), & + & source_up(:,jreg,jlev), source_dn(:,jreg,jlev)) + else + ! No-scattering case: use simpler functions for + ! transmission and emission + call calc_no_scattering_transmittance_lw(ng, od_total, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & transmittance(:,jreg,jlev), source_up(:,jreg,jlev), source_dn(:,jreg,jlev)) + reflectance(:,jreg,jlev) = 0.0_jprb + end if + end do + ! Emission is scaled by the size of each region + do jreg = 1,nregions + source_up(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * source_up(:,jreg,jlev) + source_dn(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * source_dn(:,jreg,jlev) + end do + end if + + end do ! Loop over levels + + ! -------------------------------------------------------- + ! Section 5: Compute total sources and albedos at each half level + ! -------------------------------------------------------- + + total_albedo(:,:,:) = 0.0_jprb + total_source(:,:,:) = 0.0_jprb + + ! Calculate the upwelling radiation emitted by the surface, and + ! copy the surface albedo into total_albedo + do jreg = 1,nregions + do jg = 1,ng + ! region_fracs(jreg,nlev,jcol) is the fraction of each region in the + ! lowest model level + total_source(jg,jreg,nlev+1) = region_fracs(jreg,nlev,jcol)*emission(jg,jcol) + total_albedo(jg,jreg,nlev+1) = albedo(jg,jcol) + end do + end do + + ! Work up from the surface computing the total albedo of the + ! atmosphere and the total upwelling due to emission below each + ! level below using the adding method + do jlev = nlev,i_cloud_top,-1 + + total_albedo_below = 0.0_jprb + + if (is_clear_sky_layer(jlev)) then + total_albedo_below = 0.0_jprb + total_source_below = 0.0_jprb + do jg = 1,ng + inv_denom(jg,1) = 1.0_jprb & + & / (1.0_jprb - total_albedo(jg,1,jlev+1)*reflectance(jg,1,jlev)) + total_albedo_below(jg,1) = reflectance(jg,1,jlev) & + & + transmittance(jg,1,jlev)*transmittance(jg,1,jlev)*total_albedo(jg,1,jlev+1) & + & * inv_denom(jg,1) + total_source_below(jg,1) = source_up(jg,1,jlev) & + & + transmittance(jg,1,jlev)*(total_source(jg,1,jlev+1) & + & + total_albedo(jg,1,jlev+1)*source_dn(jg,1,jlev)) & + & * inv_denom(jg,1) + end do + else + inv_denom = 1.0_jprb / (1.0_jprb - total_albedo(:,:,jlev+1)*reflectance(:,:,jlev)) + total_albedo_below = reflectance(:,:,jlev) & + & + transmittance(:,:,jlev)*transmittance(:,:,jlev)*total_albedo(:,:,jlev+1) & + & * inv_denom + total_source_below = source_up(:,:,jlev) & + & + transmittance(:,:,jlev)*(total_source(:,:,jlev+1) & + & + total_albedo(:,:,jlev+1)*source_dn(:,:,jlev)) & + & * inv_denom + end if + + ! Account for cloud overlap when converting albedo below a + ! layer interface to the equivalent values just above + if (is_clear_sky_layer(jlev) .and. is_clear_sky_layer(jlev-1)) then + total_albedo(:,:,jlev) = total_albedo_below(:,:) + total_source(:,:,jlev) = total_source_below(:,:) + else + total_source(:,:,jlev) = singlemat_x_vec(ng,ng,nregions,& + & u_matrix(:,:,jlev,jcol), total_source_below) + ! Use overlap matrix and exclude "anomalous" horizontal + ! transport described by Shonk & Hogan (2008). Therefore, + ! the operation we perform is essentially diag(total_albedo) + ! = matmul(transpose(v_matrix), diag(total_albedo_below)). + do jreg = 1,nregions + do jreg2 = 1,nregions + total_albedo(:,jreg,jlev) & + & = total_albedo(:,jreg,jlev) & + & + total_albedo_below(:,jreg2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + + end do + end do + + end if + + end do ! Reverse loop over levels + + ! -------------------------------------------------------- + ! Section 6: Copy over downwelling fluxes above cloud top + ! -------------------------------------------------------- + do jlev = 1,i_cloud_top + if (config%do_clear) then + ! Clear-sky fluxes have already been averaged: use these + flux%lw_dn(jcol,jlev) = flux%lw_dn_clear(jcol,jlev) + if (config%do_save_spectral_flux) then + flux%lw_dn_band(:,jcol,jlev) = flux%lw_dn_clear_band(:,jcol,jlev) + end if + else + sum_dn = 0.0_jprb + !$omp simd reduction(+:sum_dn) + do jg = 1,ng + sum_dn = sum_dn + flux_dn_clear(jg,jlev) + end do + flux%lw_dn(jcol,jlev) = sum_dn + if (config%do_save_spectral_flux) then + call indexed_sum(flux_dn_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_band(:,jcol,jlev)) + end if + end if + end do + + ! -------------------------------------------------------- + ! Section 7: Compute fluxes up to top-of-atmosphere + ! -------------------------------------------------------- + + ! Compute the fluxes just above the highest cloud + flux_up(:,1) = total_source(:,1,i_cloud_top) & + & + total_albedo(:,1,i_cloud_top)*flux_dn_clear(:,i_cloud_top) + flux_up(:,2:) = 0.0_jprb + + sum_up = 0.0_jprb + !$omp simd reduction(+:sum_up) + do jg = 1,ng + sum_up = sum_up + flux_up(jg,1) + end do + flux%lw_up(jcol,i_cloud_top) = sum_up + + if (config%do_save_spectral_flux) then + call indexed_sum(flux_up(:,1), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,i_cloud_top)) + end if + do jlev = i_cloud_top-1,1,-1 + flux_up(:,1) = trans_clear(:,jlev)*flux_up(:,1) + source_up_clear(:,jlev) + sum_up = 0.0_jprb + !$omp simd reduction(+:sum_up) + do jg = 1,ng + sum_up = sum_up + flux_up(jg,1) + end do + flux%lw_up(jcol,jlev) = sum_up + if (config%do_save_spectral_flux) then + call indexed_sum(flux_up(:,1), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,jlev)) + end if + end do + flux%lw_up_toa_g(:,jcol) = sum(flux_up,2) + + ! -------------------------------------------------------- + ! Section 8: Compute fluxes down to surface + ! -------------------------------------------------------- + + ! Copy over downwelling spectral fluxes at top of first + ! scattering layer, using overlap matrix to translate to the + ! regions of the first layer of cloud + do jreg = 1,nregions + flux_dn(:,jreg) = v_matrix(jreg,1,i_cloud_top,jcol)*flux_dn_clear(:,i_cloud_top) + end do + + ! Final loop back down through the atmosphere to compute fluxes + do jlev = i_cloud_top,nlev + + if (is_clear_sky_layer(jlev)) then + do jg = 1,ng + flux_dn(jg,1) = (transmittance(jg,1,jlev)*flux_dn(jg,1) & + & + reflectance(jg,1,jlev)*total_source(jg,1,jlev+1) + source_dn(jg,1,jlev) ) & + & / (1.0_jprb - reflectance(jg,1,jlev)*total_albedo(jg,1,jlev+1)) + flux_up(jg,1) = total_source(jg,1,jlev+1) + flux_dn(jg,1)*total_albedo(jg,1,jlev+1) + end do + flux_dn(:,2:) = 0.0_jprb + flux_up(:,2:) = 0.0_jprb + else + flux_dn = (transmittance(:,:,jlev)*flux_dn & + & + reflectance(:,:,jlev)*total_source(:,:,jlev+1) + source_dn(:,:,jlev) ) & + & / (1.0_jprb - reflectance(:,:,jlev)*total_albedo(:,:,jlev+1)) + flux_up = total_source(:,:,jlev+1) + flux_dn*total_albedo(:,:,jlev+1) + end if + + if (.not. (is_clear_sky_layer(jlev) & + & .and. is_clear_sky_layer(jlev+1))) then + ! Account for overlap rules in translating fluxes just above + ! a layer interface to the values just below + flux_dn_below = singlemat_x_vec(ng,ng,nregions, & + & v_matrix(:,:,jlev+1,jcol), flux_dn) + flux_dn = flux_dn_below + end if ! Otherwise the fluxes in each region are the same so + ! nothing to do + + ! Store the broadband fluxes + sum_up = 0.0_jprb + sum_dn = 0.0_jprb + do jreg = 1,nregions + !$omp simd reduction(+:sum_up, sum_dn) + do jg = 1,ng + sum_up = sum_up + flux_up(jg,jreg) + sum_dn = sum_dn + flux_dn(jg,jreg) + end do + end do + flux%lw_up(jcol,jlev+1) = sum_up + flux%lw_dn(jcol,jlev+1) = sum_dn + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum(sum(flux_up,2), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,jlev+1)) + call indexed_sum(sum(flux_dn,2), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_band(:,jcol,jlev+1)) + end if + + end do ! Final loop over levels + + ! Store surface spectral downwelling fluxes, which at this point + ! are at the surface + flux%lw_dn_surf_g(:,jcol) = sum(flux_dn,2) + + ! Compute the longwave derivatives needed by Hogan and Bozzo + ! (2015) approximate radiation update scheme + if (config%do_lw_derivatives) then + ! Note that at this point flux_up contains the spectral + ! fluxes into the regions of the lowest layer; we sum over + ! regions first to provide a simple spectral flux upwelling + ! from the surface + call calc_lw_derivatives_region(ng, nlev, nregions, jcol, transmittance, & + & u_matrix(:,:,:,jcol), sum(flux_up,2), flux%lw_derivatives) + end if + + end do ! Loop over columns + + if (lhook) call dr_hook('radiation_tripleclouds_lw:solver_tripleclouds_lw',1,hook_handle) + + end subroutine solver_tripleclouds_lw + +end module radiation_tripleclouds_lw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_sw.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_tripleclouds_sw.F90 (revision 6016) @@ -0,0 +1,626 @@ +! radiation_tripleclouds_sw.F90 - Shortwave "Tripleclouds" solver +! +! (C) Copyright 2016- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-11 R. Hogan Receive albedos at g-points +! 2017-04-22 R. Hogan Store surface fluxes at all g-points +! 2017-10-23 R. Hogan Renamed single-character variables +! 2018-10-08 R. Hogan Call calc_region_properties +! 2019-01-02 R. Hogan Fixed problem of do_save_spectral_flux .and. .not. do_sw_direct +! 2020-09-18 R. Hogan Replaced some array expressions with loops for speed +! 2021-10-01 P. Ukkonen Performance optimizations: batched computations + +module radiation_tripleclouds_sw + + public + +contains + ! Provides elemental function "delta_eddington" +#include "radiation_delta_eddington.h" + + ! Small routine for scaling cloud optical depth in the cloudy + ! regions +#include "radiation_optical_depth_scaling.h" + + !--------------------------------------------------------------------- + ! This module contains just one subroutine, the shortwave + ! "Tripleclouds" solver in which cloud inhomogeneity is treated by + ! dividing each model level into three regions, one clear and two + ! cloudy (with differing optical depth). This approach was described + ! by Shonk and Hogan (2008). + subroutine solver_tripleclouds_sw(nlev,istartcol,iendcol, & + & config, single_level, cloud, & + & od, ssa, g, od_cloud, ssa_cloud, g_cloud, & + & albedo_direct, albedo_diffuse, incoming_sw, & + & flux) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook, jphook + +! use radiation_io, only : nulout + use radiation_config, only : config_type, IPdfShapeGamma + use radiation_single_level, only : single_level_type + use radiation_cloud, only : cloud_type + use radiation_regions, only : calc_region_properties + use radiation_overlap, only : calc_overlap_matrices + use radiation_flux, only : flux_type, & + & indexed_sum, add_indexed_sum + use radiation_matrix, only : singlemat_x_vec + use radiation_two_stream, only : calc_ref_trans_sw + + implicit none + + ! Number of regions + integer, parameter :: nregions = 3 + + ! Inputs + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(cloud_type), intent(in) :: cloud + + ! Gas and aerosol optical depth, single-scattering albedo and + ! asymmetry factor at each shortwave g-point +! real(jprb), intent(in), dimension(istartcol:iendcol,nlev,config%n_g_sw) :: & + real(jprb), intent(in), dimension(config%n_g_sw,nlev,istartcol:iendcol) :: & + & od, ssa, g + + ! Cloud and precipitation optical depth, single-scattering albedo and + ! asymmetry factor in each shortwave band + real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: & + & od_cloud, ssa_cloud, g_cloud + + ! Optical depth, single scattering albedo and asymmetry factor in + ! each g-point of each cloudy region including gas, aerosol and + ! clouds + real(jprb), dimension(config%n_g_sw,2:nregions) & + & :: od_total, ssa_total, g_total + + ! Direct and diffuse surface albedos, and the incoming shortwave + ! flux into a plane perpendicular to the incoming radiation at + ! top-of-atmosphere in each of the shortwave g points + real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) :: & + & albedo_direct, albedo_diffuse, incoming_sw + + ! Output + type(flux_type), intent(inout):: flux + + ! Local variables + + ! The area fractions of each region + real(jprb) :: region_fracs(1:nregions,nlev,istartcol:iendcol) + + ! The scaling used for the optical depth in the cloudy regions + real(jprb) :: od_scaling(2:nregions,nlev,istartcol:iendcol) + + ! Directional overlap matrices defined at all layer interfaces + ! including top-of-atmosphere and the surface + real(jprb), dimension(nregions,nregions,nlev+1, & + & istartcol:iendcol) :: u_matrix, v_matrix + + ! Diffuse reflection and transmission matrices in the cloudy + ! regions of each layer + real(jprb), dimension(config%n_g_sw, 2:nregions, nlev) & + & :: reflectance, transmittance + + ! Terms translating the direct flux entering the layer from above + ! to the reflected radiation exiting upwards (ref_dir) and the + ! scattered radiation exiting downwards (trans_dir_diff), along with the + ! direct unscattered transmission matrix (trans_dir_dir). + real(jprb), dimension(config%n_g_sw, 2:nregions, nlev) & + & :: ref_dir, trans_dir_diff, trans_dir_dir + + ! As above but for the clear regions; clear and cloudy layers are + ! separated out so that calc_ref_trans_sw can be called on the + ! entire clear-sky atmosphere at once + real(jprb), dimension(config%n_g_sw, nlev) & + & :: reflectance_clear, transmittance_clear, & + & ref_dir_clear, trans_dir_diff_clear, trans_dir_dir_clear + + ! Total albedo of the atmosphere/surface just above a layer + ! interface with respect to downwelling diffuse and direct + ! (respectively) radiation at that interface, where level index = + ! 1 corresponds to the top-of-atmosphere + real(jprb), dimension(config%n_g_sw, nregions, nlev+1) & + & :: total_albedo, total_albedo_direct + + ! ...equivalent values for clear-skies + real(jprb), dimension(config%n_g_sw, nlev+1) & + & :: total_albedo_clear, total_albedo_clear_direct + + ! Total albedo of the atmosphere just below a layer interface + real(jprb), dimension(config%n_g_sw, nregions) & + & :: total_albedo_below, total_albedo_below_direct + + ! Direct downwelling flux below and above an interface between + ! layers into a plane perpendicular to the direction of the sun + real(jprb), dimension(config%n_g_sw, nregions) :: direct_dn + ! Diffuse equivalents + real(jprb), dimension(config%n_g_sw, nregions) :: flux_dn, flux_up + + ! ...clear-sky equivalent (no distinction between "above/below") + real(jprb), dimension(config%n_g_sw) & + & :: direct_dn_clear, flux_dn_clear, flux_up_clear + + ! Clear-sky equivalent, but actually its reciprocal to replace + ! some divisions by multiplications + real(jprb), dimension(config%n_g_sw, nregions) :: inv_denom + + ! Identify clear-sky layers, with pseudo layers for outer space + ! and below the ground, both treated as single-region clear skies + logical :: is_clear_sky_layer(0:nlev+1) + + ! Scattering optical depth of gas+aerosol and of cloud + real(jprb) :: scat_od, scat_od_cloud + + real(jprb) :: mu0 + + integer :: jcol, jlev, jg, jreg, iband, jreg2, ng + + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_tripleclouds_sw:solver_tripleclouds_sw',0,hook_handle) + + ! -------------------------------------------------------- + ! Section 1: Prepare general variables and arrays + ! -------------------------------------------------------- + ! Copy array dimensions to local variables for convenience + ng = config%n_g_sw + + ! Compute the wavelength-independent region fractions and + ! optical-depth scalings + call calc_region_properties(nlev,nregions,istartcol,iendcol, & + & config%i_cloud_pdf_shape == IPdfShapeGamma, & + & cloud%fraction, cloud%fractional_std, region_fracs, & + & od_scaling, config%cloud_fraction_threshold) + + ! Compute wavelength-independent overlap matrices u_matrix and + ! v_matrix + call calc_overlap_matrices(nlev,nregions,istartcol,iendcol, & + & region_fracs, cloud%overlap_param, & + & u_matrix, v_matrix, & + & decorrelation_scaling=config%cloud_inhom_decorr_scaling, & + & cloud_fraction_threshold=config%cloud_fraction_threshold, & + & use_beta_overlap=config%use_beta_overlap, & + & cloud_cover=flux%cloud_cover_sw) + + ! Main loop over columns + do jcol = istartcol, iendcol + ! -------------------------------------------------------- + ! Section 2: Prepare column-specific variables and arrays + ! -------------------------------------------------------- + + ! Copy local cosine of the solar zenith angle + mu0 = single_level%cos_sza(jcol) + + ! Skip profile if sun is too low in the sky + if (mu0 < 1.0e-10_jprb) then + flux%sw_dn(jcol,:) = 0.0_jprb + flux%sw_up(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,:) = 0.0_jprb + end if + if (config%do_clear) then + flux%sw_dn_clear(jcol,:) = 0.0_jprb + flux%sw_up_clear(jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,:) = 0.0_jprb + end if + end if + + if (config%do_save_spectral_flux) then + flux%sw_dn_band(:,jcol,:) = 0.0_jprb + flux%sw_up_band(:,jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,:) = 0.0_jprb + end if + if (config%do_clear) then + flux%sw_dn_clear_band(:,jcol,:) = 0.0_jprb + flux%sw_up_clear_band(:,jcol,:) = 0.0_jprb + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,:) = 0.0_jprb + end if + end if + end if + + flux%sw_dn_diffuse_surf_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_g(:,jcol) = 0.0_jprb + if (config%do_clear) then + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = 0.0_jprb + flux%sw_dn_direct_surf_clear_g(:,jcol) = 0.0_jprb + end if + + cycle + end if ! sun is below the horizon + + ! At this point mu0 >= 1.0e-10 + + ! Define which layers contain cloud; assume that + ! cloud%crop_cloud_fraction has already been called + is_clear_sky_layer = .true. + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + is_clear_sky_layer(jlev) = .false. + end if + end do + + ! -------------------------------------------------------- + ! Section 3: Loop over layers to compute reflectance and transmittance + ! -------------------------------------------------------- + ! In this section the reflectance, transmittance and sources + ! are computed for each layer + + ! Clear-sky quantities for all layers at once + call calc_ref_trans_sw(ng*nlev, & + & mu0, od(:,:,jcol), ssa(:,:,jcol), g(:,:,jcol), & + & reflectance_clear, transmittance_clear, & + & ref_dir_clear, trans_dir_diff_clear, & + & trans_dir_dir_clear) + + ! Cloudy layers + do jlev = 1,nlev ! Start at top-of-atmosphere + if (.not. is_clear_sky_layer(jlev)) then + do jreg = 2,nregions + do jg = 1,ng + ! Mapping from g-point to band + iband = config%i_band_from_reordered_g_sw(jg) + scat_od = od(jg,jlev,jcol)*ssa(jg,jlev,jcol) + scat_od_cloud = od_cloud(iband,jlev,jcol) & + & * ssa_cloud(iband,jlev,jcol) * od_scaling(jreg,jlev,jcol) + ! Add scaled cloud optical depth to clear-sky value + od_total(jg,jreg) = od(jg,jlev,jcol) & + & + od_cloud(iband,jlev,jcol)*od_scaling(jreg,jlev,jcol) + ! Compute single-scattering albedo and asymmetry + ! factor of gas-cloud combination + ssa_total(jg,jreg) = (scat_od+scat_od_cloud) & + & / od_total(jg,jreg) + g_total(jg,jreg) = (scat_od*g(jg,jlev,jcol) & + & + scat_od_cloud * g_cloud(iband,jlev,jcol)) & + & / (scat_od + scat_od_cloud) + end do + end do + + if (config%do_sw_delta_scaling_with_gases) then + ! Apply delta-Eddington scaling to the aerosol-gas(-cloud) + ! mixture + call delta_eddington(od_total, ssa_total, g_total) + end if + ! Both cloudy regions at once + call calc_ref_trans_sw(ng*(nregions-1), & + & mu0, od_total, ssa_total, g_total, & + & reflectance(:,:,jlev), transmittance(:,:,jlev), & + & ref_dir(:,:,jlev), trans_dir_diff(:,:,jlev), & + & trans_dir_dir(:,:,jlev)) + end if + end do + + ! -------------------------------------------------------- + ! Section 4: Compute total albedos + ! -------------------------------------------------------- + + total_albedo(:,:,:) = 0.0_jprb + total_albedo_direct(:,:,:) = 0.0_jprb + + ! Copy surface albedos in clear-sky region + do jg = 1,ng + total_albedo(jg,1,nlev+1) = albedo_diffuse(jg,jcol) + total_albedo_direct(jg,1,nlev+1) & + & = mu0 * albedo_direct(jg,jcol) + end do + + ! If there is cloud in the lowest layer then we need the albedos + ! underneath + if (.not. is_clear_sky_layer(nlev)) then + do jreg = 2,nregions + total_albedo(:,jreg,nlev+1) = total_albedo(:,1,nlev+1) + total_albedo_direct(:,jreg,nlev+1) = total_albedo_direct(:,1,nlev+1) + end do + end if + + if (config%do_clear) then + total_albedo_clear(:,nlev+1) = total_albedo(:,1,nlev+1) + total_albedo_clear_direct(:,nlev+1) = total_albedo_direct(:,1,nlev+1) + end if + + ! Work up from the surface computing the total albedo of the + ! atmosphere below that point using the adding method + do jlev = nlev,1,-1 + + total_albedo_below = 0.0_jprb + total_albedo_below_direct = 0.0_jprb + + if (config%do_clear) then + ! For clear-skies there is no need to consider "above" and + ! "below" quantities since with no cloud overlap to worry + ! about, these are the same + do jg = 1,ng + inv_denom(jg,1) = 1.0_jprb & + & / (1.0_jprb - total_albedo_clear(jg,jlev+1)*reflectance_clear(jg,jlev)) + total_albedo_clear(jg,jlev) = reflectance_clear(jg,jlev) & + & + transmittance_clear(jg,jlev) * transmittance_clear(jg,jlev) & + & * total_albedo_clear(jg,jlev+1) * inv_denom(jg,1) + + total_albedo_clear_direct(jg,jlev) = ref_dir_clear(jg,jlev) & + & + (trans_dir_dir_clear(jg,jlev)*total_albedo_clear_direct(jg,jlev+1) & + & +trans_dir_diff_clear(jg,jlev)*total_albedo_clear(jg,jlev+1)) & + & * transmittance_clear(jg,jlev) * inv_denom(jg,1) + end do + end if + + ! All-sky fluxes: first the clear region + do jg = 1,ng + inv_denom(jg,1) = 1.0_jprb & + & / (1.0_jprb - total_albedo(jg,1,jlev+1)*reflectance_clear(jg,jlev)) + total_albedo_below(jg,1) = reflectance_clear(jg,jlev) & + & + transmittance_clear(jg,jlev) * transmittance_clear(jg,jlev) & + & * total_albedo(jg,1,jlev+1) * inv_denom(jg,1) + total_albedo_below_direct(jg,1) = ref_dir_clear(jg,jlev) & + & + (trans_dir_dir_clear(jg,jlev)*total_albedo_direct(jg,1,jlev+1) & + & +trans_dir_diff_clear(jg,jlev)*total_albedo(jg,1,jlev+1)) & + & * transmittance_clear(jg,jlev) * inv_denom(jg,1) + end do + + ! Then the cloudy regions if any cloud is present in this layer + if (.not. is_clear_sky_layer(jlev)) then + do jreg = 2,nregions + do jg = 1,ng + inv_denom(jg,jreg) = 1.0_jprb / (1.0_jprb & + & - total_albedo(jg,jreg,jlev+1)*reflectance(jg,jreg,jlev)) + total_albedo_below(jg,jreg) = reflectance(jg,jreg,jlev) & + & + transmittance(jg,jreg,jlev) * transmittance(jg,jreg,jlev) & + & * total_albedo(jg,jreg,jlev+1) * inv_denom(jg,jreg) + total_albedo_below_direct(jg,jreg) = ref_dir(jg,jreg,jlev) & + & + (trans_dir_dir(jg,jreg,jlev)*total_albedo_direct(jg,jreg,jlev+1) & + & +trans_dir_diff(jg,jreg,jlev)*total_albedo(jg,jreg,jlev+1)) & + & * transmittance(jg,jreg,jlev) * inv_denom(jg,jreg) + end do + end do + end if + + ! Account for cloud overlap when converting albedo below a + ! layer interface to the equivalent values just above + if (is_clear_sky_layer(jlev) .and. is_clear_sky_layer(jlev-1)) then + total_albedo(:,:,jlev) = total_albedo_below(:,:) + total_albedo_direct(:,:,jlev) = total_albedo_below_direct(:,:) + else + ! Use overlap matrix and exclude "anomalous" horizontal + ! transport described by Shonk & Hogan (2008). Therefore, + ! the operation we perform is essentially diag(total_albedo) + ! = matmul(transpose(v_matrix)), diag(total_albedo_below)). + do jreg = 1,nregions + do jreg2 = 1,nregions + total_albedo(:,jreg,jlev) & + & = total_albedo(:,jreg,jlev) & + & + total_albedo_below(:,jreg2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + total_albedo_direct(:,jreg,jlev) & + & = total_albedo_direct(:,jreg,jlev) & + & + total_albedo_below_direct(:,jreg2) & + & * v_matrix(jreg2,jreg,jlev,jcol) + end do + end do + + end if + + end do ! Reverse loop over levels + + ! -------------------------------------------------------- + ! Section 5: Compute fluxes + ! -------------------------------------------------------- + + ! Top-of-atmosphere fluxes into the regions of the top-most + ! layer, zero since we assume no diffuse downwelling + flux_dn = 0.0_jprb + ! Direct downwelling flux (into a plane perpendicular to the + ! sun) entering the top of each region in the top-most layer + do jreg = 1,nregions + direct_dn(:,jreg) = incoming_sw(:,jcol)*region_fracs(jreg,1,jcol) + end do + flux_up = direct_dn*total_albedo_direct(:,:,1) + + if (config%do_clear) then + flux_dn_clear = 0.0_jprb + direct_dn_clear(:) = incoming_sw(:,jcol) + flux_up_clear = direct_dn_clear*total_albedo_clear_direct(:,1) + end if + + ! Store TOA spectral fluxes + flux%sw_up_toa_g(:,jcol) = sum(flux_up,2) + flux%sw_dn_toa_g(:,jcol) = incoming_sw(:,jcol)*mu0 + if (config%do_clear) then + flux%sw_up_toa_clear_g(:,jcol) = flux_up_clear + end if + + ! Store the TOA broadband fluxes + flux%sw_up(jcol,1) = sum(sum(flux_up,1)) + flux%sw_dn(jcol,1) = mu0 * sum(sum(direct_dn,1)) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,1) = flux%sw_dn(jcol,1) + end if + if (config%do_clear) then + flux%sw_up_clear(jcol,1) = sum(flux_up_clear) + flux%sw_dn_clear(jcol,1) = mu0 * sum(direct_dn_clear) + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,1) = flux%sw_dn_clear(jcol,1) + end if + end if + + ! Save the spectral fluxes if required; some redundancy here as + ! the TOA downwelling flux is the same in clear and cloudy skies + if (config%do_save_spectral_flux) then + call indexed_sum(sum(flux_up,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_up_band(:,jcol,1)) + call indexed_sum(sum(direct_dn,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,1)) + flux%sw_dn_band(:,jcol,1) = & + & mu0 * flux%sw_dn_band(:,jcol,1) + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,1) = flux%sw_dn_band(:,jcol,1) + end if + call add_indexed_sum(sum(flux_dn,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,1)) + if (config%do_clear) then + call indexed_sum(flux_up_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_up_clear_band(:,jcol,1)) + call indexed_sum(direct_dn_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_clear_band(:,jcol,1)) + flux%sw_dn_clear_band(:,jcol,1) & + & = mu0 * flux%sw_dn_clear_band(:,jcol,1) + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,1) & + & = flux%sw_dn_clear_band(:,jcol,1) + end if + call add_indexed_sum(flux_dn_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_clear_band(:,jcol,1)) + end if + end if + + ! Final loop back down through the atmosphere to compute fluxes + do jlev = 1,nlev + if (config%do_clear) then + do jg = 1,ng + flux_dn_clear(jg) = (transmittance_clear(jg,jlev)*flux_dn_clear(jg) + direct_dn_clear(jg) & + & * (trans_dir_dir_clear(jg,jlev)*total_albedo_clear_direct(jg,jlev+1)*reflectance_clear(jg,jlev) & + & + trans_dir_diff_clear(jg,jlev) )) & + & / (1.0_jprb - reflectance_clear(jg,jlev)*total_albedo_clear(jg,jlev+1)) + direct_dn_clear(jg) = trans_dir_dir_clear(jg,jlev)*direct_dn_clear(jg) + flux_up_clear(jg) = direct_dn_clear(jg)*total_albedo_clear_direct(jg,jlev+1) & + & + flux_dn_clear(jg)*total_albedo_clear(jg,jlev+1) + end do + end if + + ! All-sky fluxes: first the clear region... + do jg = 1,ng + flux_dn(jg,1) = (transmittance_clear(jg,jlev)*flux_dn(jg,1) + direct_dn(jg,1) & + & * (trans_dir_dir_clear(jg,jlev)*total_albedo_direct(jg,1,jlev+1)*reflectance_clear(jg,jlev) & + & + trans_dir_diff_clear(jg,jlev) )) & + & / (1.0_jprb - reflectance_clear(jg,jlev)*total_albedo(jg,1,jlev+1)) + direct_dn(jg,1) = trans_dir_dir_clear(jg,jlev)*direct_dn(jg,1) + flux_up(jg,1) = direct_dn(jg,1)*total_albedo_direct(jg,1,jlev+1) & + & + flux_dn(jg,1)*total_albedo(jg,1,jlev+1) + end do + + ! ...then the cloudy regions if there are any + if (is_clear_sky_layer(jlev)) then + flux_dn(:,2:nregions) = 0.0_jprb + flux_up(:,2:nregions) = 0.0_jprb + direct_dn(:,2:nregions)= 0.0_jprb + else + do jreg = 2,nregions + do jg = 1,ng + flux_dn(jg,jreg) = (transmittance(jg,jreg,jlev)*flux_dn(jg,jreg) + direct_dn(jg,jreg) & + & * (trans_dir_dir(jg,jreg,jlev)*total_albedo_direct(jg,jreg,jlev+1)*reflectance(jg,jreg,jlev) & + & + trans_dir_diff(jg,jreg,jlev) )) & + & / (1.0_jprb - reflectance(jg,jreg,jlev)*total_albedo(jg,jreg,jlev+1)) + direct_dn(jg,jreg) = trans_dir_dir(jg,jreg,jlev)*direct_dn(jg,jreg) + flux_up(jg,jreg) = direct_dn(jg,jreg)*total_albedo_direct(jg,jreg,jlev+1) & + & + flux_dn(jg,jreg)*total_albedo(jg,jreg,jlev+1) + end do + end do + end if + + if (.not. (is_clear_sky_layer(jlev) & + & .and. is_clear_sky_layer(jlev+1))) then + ! Account for overlap rules in translating fluxes just above + ! a layer interface to the values just below + flux_dn = singlemat_x_vec(ng,ng,nregions, & + & v_matrix(:,:,jlev+1,jcol), flux_dn) + direct_dn = singlemat_x_vec(ng,ng,nregions, & + & v_matrix(:,:,jlev+1,jcol), direct_dn) + end if ! Otherwise the fluxes in each region are the same so + ! nothing to do + + ! Store the broadband fluxes + flux%sw_up(jcol,jlev+1) = sum(sum(flux_up,1)) + if (allocated(flux%sw_dn_direct)) then + flux%sw_dn_direct(jcol,jlev+1) = mu0 * sum(sum(direct_dn,1)) + flux%sw_dn(jcol,jlev+1) & + & = flux%sw_dn_direct(jcol,jlev+1) + sum(sum(flux_dn,1)) + else + flux%sw_dn(jcol,jlev+1) = mu0 * sum(sum(direct_dn,1)) + sum(sum(flux_dn,1)) + end if + if (config%do_clear) then + flux%sw_up_clear(jcol,jlev+1) = sum(flux_up_clear) + if (allocated(flux%sw_dn_direct_clear)) then + flux%sw_dn_direct_clear(jcol,jlev+1) = mu0 * sum(direct_dn_clear) + flux%sw_dn_clear(jcol,jlev+1) & + & = flux%sw_dn_direct_clear(jcol,jlev+1) + sum(flux_dn_clear) + else + flux%sw_dn_clear(jcol,jlev+1) = mu0 * sum(direct_dn_clear) & + & + sum(flux_dn_clear) + end if + end if + + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + call indexed_sum(sum(flux_up,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_up_band(:,jcol,jlev+1)) + call indexed_sum(sum(direct_dn,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,jlev+1)) + flux%sw_dn_band(:,jcol,jlev+1) = & + & mu0 * flux%sw_dn_band(:,jcol,jlev+1) + if (allocated(flux%sw_dn_direct_band)) then + flux%sw_dn_direct_band(:,jcol,jlev+1) & + & = flux%sw_dn_band(:,jcol,jlev+1) + end if + call add_indexed_sum(sum(flux_dn,2), & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_band(:,jcol,jlev+1)) + if (config%do_clear) then + call indexed_sum(flux_up_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_up_clear_band(:,jcol,jlev+1)) + call indexed_sum(direct_dn_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_clear_band(:,jcol,jlev+1)) + flux%sw_dn_clear_band(:,jcol,jlev+1) = & + & mu0 * flux%sw_dn_clear_band(:,jcol,jlev+1) + if (allocated(flux%sw_dn_direct_clear_band)) then + flux%sw_dn_direct_clear_band(:,jcol,jlev+1) & + & = flux%sw_dn_clear_band(:,jcol,jlev+1) + end if + call add_indexed_sum(flux_dn_clear, & + & config%i_spec_from_reordered_g_sw, & + & flux%sw_dn_clear_band(:,jcol,jlev+1)) + end if + end if + + end do ! Final loop over levels + + ! Store surface spectral fluxes, if required (after the end of + ! the final loop over levels, the current values of these arrays + ! will be the surface values) + flux%sw_dn_diffuse_surf_g(:,jcol) = sum(flux_dn,2) + flux%sw_dn_direct_surf_g(:,jcol) = mu0 * sum(direct_dn,2) + if (config%do_clear) then + flux%sw_dn_diffuse_surf_clear_g(:,jcol) = flux_dn_clear + flux%sw_dn_direct_surf_clear_g(:,jcol) = mu0 * direct_dn_clear + end if + + end do ! Loop over columns + + if (lhook) call dr_hook('radiation_tripleclouds_sw:solver_tripleclouds_sw',1,hook_handle) + + end subroutine solver_tripleclouds_sw + +end module radiation_tripleclouds_sw Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_two_stream.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_two_stream.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/radiation/radiation_two_stream.F90 (revision 6016) @@ -0,0 +1,872 @@ +! This file has been modified for the use in ICON + +! radiation_two_stream.F90 - Compute two-stream coefficients +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-05-04 P Dueben/R Hogan Use JPRD where double precision essential +! 2017-07-12 R Hogan Optimized LW coeffs in low optical depth case +! 2017-07-26 R Hogan Added calc_frac_scattered_diffuse_sw routine +! 2017-10-23 R Hogan Renamed single-character variables +! 2021-02-19 R Hogan Security for shortwave singularity +! 2022-11-22 P Ukkonen/R Hogan Single precision uses no double precision +! 2023-09-28 R Hogan Increased security for single-precision SW "k" + +#include "ecrad_config.h" + +module radiation_two_stream + + use parkind1, only : jprb, jprd + + implicit none + public + + ! Elsasser's factor: the effective factor by which the zenith + ! optical depth needs to be multiplied to account for longwave + ! transmission at all angles through the atmosphere. Alternatively + ! think of acos(1/lw_diffusivity) to be the effective zenith angle + ! of longwave radiation. + real(jprd), parameter :: LwDiffusivity = 1.66_jprd + real(jprb), parameter :: LwDiffusivityWP = 1.66_jprb ! Working precision version + + ! The routines in this module can be called millions of times, so + ! calling Dr Hook for each one may be a significant overhead. + ! Uncomment the following to turn Dr Hook on. +!#define DO_DR_HOOK_TWO_STREAM + +contains + + !--------------------------------------------------------------------- + ! Calculate the two-stream coefficients gamma1 and gamma2 for the + ! longwave + subroutine calc_two_stream_gammas_lw(ng, ssa, g, & + & gamma1, gamma2) + +#ifdef DO_DR_HOOK_TWO_STREAM + use yomhook, only : lhook, dr_hook, jphook +#endif + + integer, intent(in) :: ng + ! Sngle scattering albedo and asymmetry factor: + real(jprb), intent(in), dimension(:) :: ssa, g + real(jprb), intent(out), dimension(:) :: gamma1, gamma2 + + real(jprb) :: factor + + integer :: jg + + !$ACC ROUTINE WORKER + +#ifdef DO_DR_HOOK_TWO_STREAM + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_two_stream:calc_two_stream_gammas_lw',0,hook_handle) +#endif + +!$ACC LOOP WORKER VECTOR +! Added for DWD (2020) +!NEC$ shortloop + do jg = 1, ng + ! Fu et al. (1997), Eq 2.9 and 2.10: + ! gamma1(jg) = LwDiffusivity * (1.0_jprb - 0.5_jprb*ssa(jg) & + ! & * (1.0_jprb + g(jg))) + ! gamma2(jg) = LwDiffusivity * 0.5_jprb * ssa(jg) & + ! & * (1.0_jprb - g(jg)) + ! Reduce number of multiplications + factor = (LwDiffusivity * 0.5_jprb) * ssa(jg) + gamma1(jg) = LwDiffusivity - factor*(1.0_jprb + g(jg)) + gamma2(jg) = factor * (1.0_jprb - g(jg)) + end do + +#ifdef DO_DR_HOOK_TWO_STREAM + if (lhook) call dr_hook('radiation_two_stream:calc_two_stream_gammas_lw',1,hook_handle) +#endif + + end subroutine calc_two_stream_gammas_lw + + + !--------------------------------------------------------------------- + ! Calculate the two-stream coefficients gamma1-gamma4 in the + ! shortwave + subroutine calc_two_stream_gammas_sw(ng, mu0, ssa, g, & + & gamma1, gamma2, gamma3) + +#ifdef DO_DR_HOOK_TWO_STREAM + use yomhook, only : lhook, dr_hook, jphook +#endif + + integer, intent(in) :: ng + ! Cosine of solar zenith angle, single scattering albedo and + ! asymmetry factor: + real(jprb), intent(in) :: mu0 + real(jprb), intent(in), dimension(:) :: ssa, g + real(jprb), intent(out), dimension(:) :: gamma1, gamma2, gamma3 + + real(jprb) :: factor + + integer :: jg + +#ifdef DO_DR_HOOK_TWO_STREAM + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_two_stream:calc_two_stream_gammas_sw',0,hook_handle) +#endif + + !$ACC ROUTINE WORKER + + ! Zdunkowski "PIFM" (Zdunkowski et al., 1980; Contributions to + ! Atmospheric Physics 53, 147-66) +!$ACC LOOP WORKER VECTOR PRIVATE(factor) +! Added for DWD (2020) +!NEC$ shortloop + do jg = 1, ng + ! gamma1(jg) = 2.0_jprb - ssa(jg) * (1.25_jprb + 0.75_jprb*g(jg)) + ! gamma2(jg) = 0.75_jprb *(ssa(jg) * (1.0_jprb - g(jg))) + ! gamma3(jg) = 0.5_jprb - (0.75_jprb*mu0)*g(jg) + ! Optimized version: + factor = 0.75_jprb*g(jg) + gamma1(jg) = 2.0_jprb - ssa(jg) * (1.25_jprb + factor) + gamma2(jg) = ssa(jg) * (0.75_jprb - factor) + gamma3(jg) = 0.5_jprb - mu0*factor + end do + +#ifdef DO_DR_HOOK_TWO_STREAM + if (lhook) call dr_hook('radiation_two_stream:calc_two_stream_gammas_sw',1,hook_handle) +#endif + + end subroutine calc_two_stream_gammas_sw + + + !--------------------------------------------------------------------- + ! Compute the longwave reflectance and transmittance to diffuse + ! radiation using the Meador & Weaver formulas, as well as the + ! upward flux at the top and the downward flux at the base of the + ! layer due to emission from within the layer assuming a linear + ! variation of Planck function within the layer. + subroutine calc_reflectance_transmittance_lw(ng, & + & od, gamma1, gamma2, planck_top, planck_bot, & + & reflectance, transmittance, source_up, source_dn) + +#ifdef DO_DR_HOOK_TWO_STREAM + use yomhook, only : lhook, dr_hook, jphook +#endif + + implicit none + + integer, intent(in) :: ng + + ! Optical depth and single scattering albedo + real(jprb), intent(in), dimension(ng) :: od + + ! The two transfer coefficients from the two-stream + ! differentiatial equations (computed by + ! calc_two_stream_gammas_lw) + real(jprb), intent(in), dimension(ng) :: gamma1, gamma2 + + ! The Planck terms (functions of temperature) at the top and + ! bottom of the layer + real(jprb), intent(in), dimension(ng) :: planck_top, planck_bot + + ! The diffuse reflectance and transmittance, i.e. the fraction of + ! diffuse radiation incident on a layer from either top or bottom + ! that is reflected back or transmitted through + real(jprb), intent(out), dimension(ng) :: reflectance, transmittance + + ! The upward emission at the top of the layer and the downward + ! emission at its base, due to emission from within the layer + real(jprb), intent(out), dimension(ng) :: source_up, source_dn + + real(jprd) :: k_exponent, reftrans_factor + real(jprd) :: exponential ! = exp(-k_exponent*od) + real(jprd) :: exponential2 ! = exp(-2*k_exponent*od) + + real(jprd) :: coeff, coeff_up_top, coeff_up_bot, coeff_dn_top, coeff_dn_bot + + integer :: jg + +#ifdef DO_DR_HOOK_TWO_STREAM + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_two_stream:calc_reflectance_transmittance_lw',0,hook_handle) +#endif + + !$ACC ROUTINE WORKER + + +!$ACC LOOP WORKER VECTOR +! Added for DWD (2020) +!NEC$ shortloop + do jg = 1, ng + if (od(jg) > 1.0e-3_jprd) then + k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & + 1.0e-12_jprd)) ! Eq 18 of Meador & Weaver (1980) + exponential = exp(-k_exponent*od(jg)) + exponential2 = exponential*exponential + reftrans_factor = 1.0 / (k_exponent + gamma1(jg) + (k_exponent - gamma1(jg))*exponential2) + ! Meador & Weaver (1980) Eq. 25 + reflectance(jg) = gamma2(jg) * (1.0_jprd - exponential2) * reftrans_factor + ! Meador & Weaver (1980) Eq. 26 + transmittance(jg) = 2.0_jprd * k_exponent * exponential * reftrans_factor + + ! Compute upward and downward emission assuming the Planck + ! function to vary linearly with optical depth within the layer + ! (e.g. Wiscombe , JQSRT 1976). + + ! Stackhouse and Stephens (JAS 1991) Eqs 5 & 12 + coeff = (planck_bot(jg)-planck_top(jg)) / (od(jg)*(gamma1(jg)+gamma2(jg))) + coeff_up_top = coeff + planck_top(jg) + coeff_up_bot = coeff + planck_bot(jg) + coeff_dn_top = -coeff + planck_top(jg) + coeff_dn_bot = -coeff + planck_bot(jg) + source_up(jg) = coeff_up_top - reflectance(jg) * coeff_dn_top - transmittance(jg) * coeff_up_bot + source_dn(jg) = coeff_dn_bot - reflectance(jg) * coeff_up_bot - transmittance(jg) * coeff_dn_top + else + k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & + 1.0e-12_jprd)) ! Eq 18 of Meador & Weaver (1980) + reflectance(jg) = gamma2(jg) * od(jg) + transmittance(jg) = (1.0_jprb - k_exponent*od(jg)) / (1.0_jprb + od(jg)*(gamma1(jg)-k_exponent)) + source_up(jg) = (1.0_jprb - reflectance(jg) - transmittance(jg)) & + & * 0.5 * (planck_top(jg) + planck_bot(jg)) + source_dn(jg) = source_up(jg) + end if + end do + +#ifdef DO_DR_HOOK_TWO_STREAM + if (lhook) call dr_hook('radiation_two_stream:calc_reflectance_transmittance_lw',1,hook_handle) +#endif + + end subroutine calc_reflectance_transmittance_lw + + + !--------------------------------------------------------------------- + ! Compute the longwave reflectance and transmittance to diffuse + ! radiation using the Meador & Weaver formulas, as well as the + ! upward flux at the top and the downward flux at the base of the + ! layer due to emission from within the layer assuming a linear + ! variation of Planck function within the layer; this version + ! computes gamma1 and gamma2 within the same routine. + subroutine calc_ref_trans_lw(ng, & + & od, ssa, asymmetry, planck_top, planck_bot, & + & reflectance, transmittance, source_up, source_dn) + +#ifdef DO_DR_HOOK_TWO_STREAM + use yomhook, only : lhook, dr_hook, jphook +#endif + + integer, intent(in) :: ng + + ! Optical depth and single scattering albedo + real(jprb), intent(in), dimension(ng) :: od + + ! Single scattering albedo and asymmetry factor + real(jprb), intent(in), dimension(ng) :: ssa, asymmetry + + ! The Planck terms (functions of temperature) at the top and + ! bottom of the layer + real(jprb), intent(in), dimension(ng) :: planck_top, planck_bot + + ! The diffuse reflectance and transmittance, i.e. the fraction of + ! diffuse radiation incident on a layer from either top or bottom + ! that is reflected back or transmitted through + real(jprb), intent(out), dimension(ng) :: reflectance, transmittance + + ! The upward emission at the top of the layer and the downward + ! emission at its base, due to emission from within the layer + real(jprb), intent(out), dimension(ng) :: source_up, source_dn + + ! The two transfer coefficients from the two-stream + ! differentiatial equations + real(jprb) :: gamma1, gamma2 + + real(jprb) :: k_exponent, reftrans_factor, factor + real(jprb) :: exponential ! = exp(-k_exponent*od) + real(jprb) :: exponential2 ! = exp(-2*k_exponent*od) + + real(jprb) :: coeff, coeff_up_top, coeff_up_bot, coeff_dn_top, coeff_dn_bot + + integer :: jg + +#ifdef DO_DR_HOOK_TWO_STREAM + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_two_stream:calc_ref_trans_lw',0,hook_handle) +#endif + + !$ACC ROUTINE WORKER + + !$ACC LOOP WORKER VECTOR PRIVATE(factor, gamma1, gamma2, k_exponent, & + !$ACC reftrans_factor, exponential, exponential2, & + !$ACC coeff, coeff_up_top, coeff_up_bot, coeff_dn_top, coeff_dn_bot) + do jg = 1, ng + factor = (LwDiffusivityWP * 0.5_jprb) * ssa(jg) + gamma1 = LwDiffusivityWP - factor*(1.0_jprb + asymmetry(jg)) + gamma2 = factor * (1.0_jprb - asymmetry(jg)) + k_exponent = sqrt(max((gamma1 - gamma2) * (gamma1 + gamma2), & + 1.0e-12_jprb)) ! Eq 18 of Meador & Weaver (1980) + if (od(jg) > 1.0e-3_jprb) then + exponential = exp(-k_exponent*od(jg)) + exponential2 = exponential*exponential + reftrans_factor = 1.0_jprb / (k_exponent + gamma1 + (k_exponent - gamma1)*exponential2) + ! Meador & Weaver (1980) Eq. 25 + reflectance(jg) = gamma2 * (1.0_jprb - exponential2) * reftrans_factor + ! Meador & Weaver (1980) Eq. 26 + transmittance(jg) = 2.0_jprb * k_exponent * exponential * reftrans_factor + + ! Compute upward and downward emission assuming the Planck + ! function to vary linearly with optical depth within the layer + ! (e.g. Wiscombe , JQSRT 1976). + + ! Stackhouse and Stephens (JAS 1991) Eqs 5 & 12 + coeff = (planck_bot(jg)-planck_top(jg)) / (od(jg)*(gamma1+gamma2)) + coeff_up_top = coeff + planck_top(jg) + coeff_up_bot = coeff + planck_bot(jg) + coeff_dn_top = -coeff + planck_top(jg) + coeff_dn_bot = -coeff + planck_bot(jg) + source_up(jg) = coeff_up_top - reflectance(jg) * coeff_dn_top - transmittance(jg) * coeff_up_bot + source_dn(jg) = coeff_dn_bot - reflectance(jg) * coeff_up_bot - transmittance(jg) * coeff_dn_top + else + reflectance(jg) = gamma2 * od(jg) + transmittance(jg) = (1.0_jprb - k_exponent*od(jg)) / (1.0_jprb + od(jg)*(gamma1-k_exponent)) + source_up(jg) = (1.0_jprb - reflectance(jg) - transmittance(jg)) & + & * 0.5 * (planck_top(jg) + planck_bot(jg)) + source_dn(jg) = source_up(jg) + end if + end do + +#ifdef DO_DR_HOOK_TWO_STREAM + if (lhook) call dr_hook('radiation_two_stream:calc_ref_trans_lw',1,hook_handle) +#endif + + end subroutine calc_ref_trans_lw + + + !--------------------------------------------------------------------- + ! Compute the longwave transmittance to diffuse radiation in the + ! no-scattering case, as well as the upward flux at the top and the + ! downward flux at the base of the layer due to emission from within + ! the layer assuming a linear variation of Planck function within + ! the layer. + subroutine calc_no_scattering_transmittance_lw(ng, & + & od, planck_top, planck_bot, transmittance, source_up, source_dn) + +#ifdef DO_DR_HOOK_TWO_STREAM + use yomhook, only : lhook, dr_hook, jphook +#endif + + integer, intent(in) :: ng + + ! Optical depth and single scattering albedo + real(jprb), intent(in), dimension(ng) :: od + + ! The Planck terms (functions of temperature) at the top and + ! bottom of the layer + real(jprb), intent(in), dimension(ng) :: planck_top, planck_bot + + ! The diffuse transmittance, i.e. the fraction of diffuse + ! radiation incident on a layer from either top or bottom that is + ! reflected back or transmitted through + real(jprb), intent(out), dimension(ng) :: transmittance + + ! The upward emission at the top of the layer and the downward + ! emission at its base, due to emission from within the layer + real(jprb), intent(out), dimension(ng) :: source_up, source_dn + + real(jprb) :: coeff, coeff_up_top, coeff_up_bot, coeff_dn_top, coeff_dn_bot !, planck_mean + + integer :: jg + + !$ACC ROUTINE WORKER + +#ifdef DO_DR_HOOK_TWO_STREAM + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_two_stream:calc_no_scattering_transmittance_lw',0,hook_handle) +#endif + +#ifndef DWD_TWO_STREAM_OPTIMIZATIONS + transmittance = exp(-LwDiffusivityWP*od) +#endif + +!$ACC LOOP WORKER VECTOR + do jg = 1, ng + ! Compute upward and downward emission assuming the Planck + ! function to vary linearly with optical depth within the layer + ! (e.g. Wiscombe , JQSRT 1976). + coeff = LwDiffusivityWP*od(jg) +#ifdef DWD_TWO_STREAM_OPTIMIZATIONS + transmittance(jg) = exp(-coeff) +#endif + if (od(jg) > 1.0e-3_jprb) then + ! Simplified from calc_reflectance_transmittance_lw above + coeff = (planck_bot(jg)-planck_top(jg)) / coeff + coeff_up_top = coeff + planck_top(jg) + coeff_up_bot = coeff + planck_bot(jg) + coeff_dn_top = -coeff + planck_top(jg) + coeff_dn_bot = -coeff + planck_bot(jg) + source_up(jg) = coeff_up_top - transmittance(jg) * coeff_up_bot + source_dn(jg) = coeff_dn_bot - transmittance(jg) * coeff_dn_top + else + ! Linear limit at low optical depth + source_up(jg) = coeff * 0.5_jprb * (planck_top(jg)+planck_bot(jg)) + source_dn(jg) = source_up(jg) + end if + end do + +#ifdef DO_DR_HOOK_TWO_STREAM + if (lhook) call dr_hook('radiation_two_stream:calc_no_scattering_transmittance_lw',1,hook_handle) +#endif + + end subroutine calc_no_scattering_transmittance_lw + + + !--------------------------------------------------------------------- + ! Compute the shortwave reflectance and transmittance to diffuse + ! radiation using the Meador & Weaver formulas, as well as the + ! "direct" reflection and transmission, which really means the rate + ! of transfer of direct solar radiation (into a plane perpendicular + ! to the direct beam) into diffuse upward and downward streams at + ! the top and bottom of the layer, respectively. Finally, + ! trans_dir_dir is the transmittance of the atmosphere to direct + ! radiation with no scattering. + subroutine calc_reflectance_transmittance_sw(ng, mu0, od, ssa, & + & gamma1, gamma2, gamma3, ref_diff, trans_diff, & + & ref_dir, trans_dir_diff, trans_dir_dir) + +#ifdef DO_DR_HOOK_TWO_STREAM + use yomhook, only : lhook, dr_hook, jphook +#endif + + integer, intent(in) :: ng + + ! Cosine of solar zenith angle + real(jprb), intent(in) :: mu0 + + ! Optical depth and single scattering albedo + real(jprb), intent(in), dimension(ng) :: od, ssa + + ! The three transfer coefficients from the two-stream + ! differentiatial equations (computed by calc_two_stream_gammas) + real(jprb), intent(in), dimension(ng) :: gamma1, gamma2, gamma3 + + ! The direct reflectance and transmittance, i.e. the fraction of + ! incoming direct solar radiation incident at the top of a layer + ! that is either reflected back (ref_dir) or scattered but + ! transmitted through the layer to the base (trans_dir_diff) + real(jprb), intent(out), dimension(ng) :: ref_dir, trans_dir_diff + + ! The diffuse reflectance and transmittance, i.e. the fraction of + ! diffuse radiation incident on a layer from either top or bottom + ! that is reflected back or transmitted through + real(jprb), intent(out), dimension(ng) :: ref_diff, trans_diff + + ! Transmittance of the direct been with no scattering + real(jprb), intent(out), dimension(ng) :: trans_dir_dir + + real(jprd) :: gamma4, alpha1, alpha2, k_exponent, reftrans_factor + real(jprb) :: exponential0 ! = exp(-od/mu0) + real(jprd) :: exponential ! = exp(-k_exponent*od) + real(jprd) :: exponential2 ! = exp(-2*k_exponent*od) + real(jprd) :: k_mu0, k_gamma3, k_gamma4 + real(jprd) :: k_2_exponential, od_over_mu0 + integer :: jg + + ! Local value of cosine of solar zenith angle, in case it needs to be + ! tweaked to avoid near division by zero. This is intentionally in working + ! precision (jprb) rather than fixing at double precision (jprd). + real(jprb) :: mu0_local + +#ifdef DO_DR_HOOK_TWO_STREAM + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_two_stream:calc_reflectance_transmittance_sw',0,hook_handle) +#endif + + !$ACC ROUTINE WORKER + +!$ACC LOOP WORKER VECTOR PRIVATE(gamma4, alpha1, alpha2, k_exponent, & +!$ACC reftrans_factor, exponential0, exponential, exponential2, k_mu0, & +!$ACC k_gamma3, k_gamma4, k_2_exponential, od_over_mu0) +! Added for DWD (2020) +!NEC$ shortloop + do jg = 1, ng + + gamma4 = 1.0_jprd - gamma3(jg) + alpha1 = gamma1(jg)*gamma4 + gamma2(jg)*gamma3(jg) ! Eq. 16 + alpha2 = gamma1(jg)*gamma3(jg) + gamma2(jg)*gamma4 ! Eq. 17 + + k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & + & 1.0e-12_jprd)) ! Eq 18 + + ! We had a rare crash where k*mu0 was within around 1e-13 of 1, + ! leading to ref_dir and trans_dir_diff being well outside the range + ! 0-1. The following approach is appropriate when k_exponent is double + ! precision and mu0_local is single precision, although work is needed + ! to make this entire routine secure in single precision. + mu0_local = mu0 + if (abs(1.0_jprd - k_exponent*mu0) < 1000.0_jprd * epsilon(1.0_jprd)) then + mu0_local = mu0 * (1.0_jprb + SIGN(1._jprd,k_exponent*mu0-1._jprd)*10.0_jprb*epsilon(1.0_jprb)) + end if + + od_over_mu0 = max(od(jg) / mu0_local, 0.0_jprd) + + ! Note that if the minimum value is reduced (e.g. to 1.0e-24) + ! then noise starts to appear as a function of solar zenith + ! angle + k_mu0 = k_exponent*mu0_local + k_gamma3 = k_exponent*gamma3(jg) + k_gamma4 = k_exponent*gamma4 + ! Check for mu0 <= 0! + exponential0 = exp(-od_over_mu0) + trans_dir_dir(jg) = exponential0 + exponential = exp(-k_exponent*od(jg)) + + exponential2 = exponential*exponential + k_2_exponential = 2.0_jprd * k_exponent * exponential + + reftrans_factor = 1.0_jprd / (k_exponent + gamma1(jg) + (k_exponent - gamma1(jg))*exponential2) + + ! Meador & Weaver (1980) Eq. 25 + ref_diff(jg) = gamma2(jg) * (1.0_jprd - exponential2) * reftrans_factor + + ! Meador & Weaver (1980) Eq. 26 + trans_diff(jg) = k_2_exponential * reftrans_factor + + ! Here we need mu0 even though it wasn't in Meador and Weaver + ! because we are assuming the incoming direct flux is defined + ! to be the flux into a plane perpendicular to the direction of + ! the sun, not into a horizontal plane + reftrans_factor = mu0_local * ssa(jg) * reftrans_factor / (1.0_jprd - k_mu0*k_mu0) + + ! Meador & Weaver (1980) Eq. 14, multiplying top & bottom by + ! exp(-k_exponent*od) in case of very high optical depths + ref_dir(jg) = reftrans_factor & + & * ( (1.0_jprd - k_mu0) * (alpha2 + k_gamma3) & + & -(1.0_jprd + k_mu0) * (alpha2 - k_gamma3)*exponential2 & + & -k_2_exponential*(gamma3(jg) - alpha2*mu0_local)*exponential0) + + ! Meador & Weaver (1980) Eq. 15, multiplying top & bottom by + ! exp(-k_exponent*od), minus the 1*exp(-od/mu0) term representing direct + ! unscattered transmittance. + trans_dir_diff(jg) = reftrans_factor * ( k_2_exponential*(gamma4 + alpha1*mu0_local) & + & - exponential0 & + & * ( (1.0_jprd + k_mu0) * (alpha1 + k_gamma4) & + & -(1.0_jprd - k_mu0) * (alpha1 - k_gamma4) * exponential2) ) + + ! Final check that ref_dir + trans_dir_diff <= 1 + ref_dir(jg) = max(0.0_jprb, min(ref_dir(jg), 1.0_jprb)) + trans_dir_diff(jg) = max(0.0_jprb, min(trans_dir_diff(jg), 1.0_jprb-ref_dir(jg))) + + end do + +#ifdef DO_DR_HOOK_TWO_STREAM + if (lhook) call dr_hook('radiation_two_stream:calc_reflectance_transmittance_sw',1,hook_handle) +#endif + + end subroutine calc_reflectance_transmittance_sw + + + !--------------------------------------------------------------------- + ! Compute the shortwave reflectance and transmittance to diffuse + ! radiation using the Meador & Weaver formulas, as well as the + ! "direct" reflection and transmission, which really means the rate + ! of transfer of direct solar radiation (into a plane perpendicular + ! to the direct beam) into diffuse upward and downward streams at + ! the top and bottom of the layer, respectively. Finally, + ! trans_dir_dir is the transmittance of the atmosphere to direct + ! radiation with no scattering. This version incorporates the + ! calculation of the gamma terms. + subroutine calc_ref_trans_sw(ng, mu0, od, ssa, & + & asymmetry, ref_diff, trans_diff, & + & ref_dir, trans_dir_diff, trans_dir_dir) + +#ifdef DO_DR_HOOK_TWO_STREAM + use yomhook, only : lhook, dr_hook, jphook +#endif + + implicit none + + integer, intent(in) :: ng + + ! Cosine of solar zenith angle + real(jprb), intent(in) :: mu0 + + ! Optical depth and single scattering albedo + real(jprb), intent(in), dimension(ng) :: od, ssa, asymmetry + + ! The direct reflectance and transmittance, i.e. the fraction of + ! incoming direct solar radiation incident at the top of a layer + ! that is either reflected back (ref_dir) or scattered but + ! transmitted through the layer to the base (trans_dir_diff) + real(jprb), intent(out), dimension(ng) :: ref_dir, trans_dir_diff + + ! The diffuse reflectance and transmittance, i.e. the fraction of + ! diffuse radiation incident on a layer from either top or bottom + ! that is reflected back or transmitted through + real(jprb), intent(out), dimension(ng) :: ref_diff, trans_diff + + ! Transmittance of the direct been with no scattering + real(jprb), intent(out), dimension(ng) :: trans_dir_dir + + ! The three transfer coefficients from the two-stream + ! differentiatial equations +#ifndef DWD_TWO_STREAM_OPTIMIZATIONS + real(jprb), dimension(ng) :: gamma1, gamma2, gamma3, gamma4 + real(jprb), dimension(ng) :: alpha1, alpha2, k_exponent + real(jprb), dimension(ng) :: exponential ! = exp(-k_exponent*od) +#else + real(jprb) :: gamma1, gamma2, gamma3, gamma4 + real(jprb) :: alpha1, alpha2, k_exponent + real(jprb) :: exponential ! = exp(-k_exponent*od) +#endif + + real(jprb) :: reftrans_factor, factor + real(jprb) :: exponential2 ! = exp(-2*k_exponent*od) + real(jprb) :: k_mu0, k_gamma3, k_gamma4 + real(jprb) :: k_2_exponential, one_minus_kmu0_sqr + integer :: jg + +#ifdef DO_DR_HOOK_TWO_STREAM + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_two_stream:calc_ref_trans_sw',0,hook_handle) +#endif + +#ifndef DWD_TWO_STREAM_OPTIMIZATIONS + ! GCC 9.3 strange error: intermediate values of ~ -8000 cause a + ! FPE when vectorizing exp(), but not in non-vectorized loop, nor + ! with larger negative values! + trans_dir_dir = max(-max(od * (1.0_jprb/mu0), 0.0_jprb),-1000.0_jprb) + trans_dir_dir = exp(trans_dir_dir) + + do jg = 1, ng + + ! Zdunkowski "PIFM" (Zdunkowski et al., 1980; Contributions to + ! Atmospheric Physics 53, 147-66) + factor = 0.75_jprb*asymmetry(jg) + + gamma1(jg) = 2.0_jprb - ssa(jg) * (1.25_jprb + factor) + gamma2(jg) = ssa(jg) * (0.75_jprb - factor) + gamma3(jg) = 0.5_jprb - mu0*factor + gamma4(jg) = 1.0_jprb - gamma3(jg) + + alpha1(jg) = gamma1(jg)*gamma4(jg) + gamma2(jg)*gamma3(jg) ! Eq. 16 + alpha2(jg) = gamma1(jg)*gamma3(jg) + gamma2(jg)*gamma4(jg) ! Eq. 17 + ! The following line crashes inexplicably with gfortran 8.5.0 in + ! single precision - try a later version. Note that the minimum + ! value is needed to produce correct results for single + ! scattering albedos very close to or equal to one. +#ifdef PARKIND1_SINGLE + k_exponent(jg) = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & + & 1.0e-6_jprb)) ! Eq 18 +#else + k_exponent(jg) = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & + & 1.0e-12_jprb)) ! Eq 18 +#endif + end do + + exponential = exp(-k_exponent*od) + + do jg = 1, ng + k_mu0 = k_exponent(jg)*mu0 + one_minus_kmu0_sqr = 1.0_jprb - k_mu0*k_mu0 + k_gamma3 = k_exponent(jg)*gamma3(jg) + k_gamma4 = k_exponent(jg)*gamma4(jg) + exponential2 = exponential(jg)*exponential(jg) + k_2_exponential = 2.0_jprb * k_exponent(jg) * exponential(jg) + reftrans_factor = 1.0_jprb / (k_exponent(jg) + gamma1(jg) + (k_exponent(jg) - gamma1(jg))*exponential2) + + ! Meador & Weaver (1980) Eq. 25 + ref_diff(jg) = gamma2(jg) * (1.0_jprb - exponential2) * reftrans_factor + !ref_diff(jg) = max(0.0_jprb, min(ref_diff(jg)), 1.0_jprb) + + ! Meador & Weaver (1980) Eq. 26, with security (which is + ! sometimes needed, but apparently not on ref_diff) + trans_diff(jg) = max(0.0_jprb, min(k_2_exponential * reftrans_factor, 1.0_jprb-ref_diff(jg))) + + ! Here we need mu0 even though it wasn't in Meador and Weaver + ! because we are assuming the incoming direct flux is defined to + ! be the flux into a plane perpendicular to the direction of the + ! sun, not into a horizontal plane + reftrans_factor = mu0 * ssa(jg) * reftrans_factor & + & / merge(one_minus_kmu0_sqr, epsilon(1.0_jprb), abs(one_minus_kmu0_sqr) > epsilon(1.0_jprb)) + + ! Meador & Weaver (1980) Eq. 14, multiplying top & bottom by + ! exp(-k_exponent*od) in case of very high optical depths + ref_dir(jg) = reftrans_factor & + & * ( (1.0_jprb - k_mu0) * (alpha2(jg) + k_gamma3) & + & -(1.0_jprb + k_mu0) * (alpha2(jg) - k_gamma3)*exponential2 & + & -k_2_exponential*(gamma3(jg) - alpha2(jg)*mu0)*trans_dir_dir(jg) ) + + ! Meador & Weaver (1980) Eq. 15, multiplying top & bottom by + ! exp(-k_exponent*od), minus the 1*exp(-od/mu0) term + ! representing direct unscattered transmittance. + trans_dir_diff(jg) = reftrans_factor * ( k_2_exponential*(gamma4(jg) + alpha1(jg)*mu0) & + & - trans_dir_dir(jg) & + & * ( (1.0_jprb + k_mu0) * (alpha1(jg) + k_gamma4) & + & -(1.0_jprb - k_mu0) * (alpha1(jg) - k_gamma4) * exponential2) ) + + ! Final check that ref_dir + trans_dir_diff <= 1 + ref_dir(jg) = max(0.0_jprb, min(ref_dir(jg), mu0*(1.0_jprb-trans_dir_dir(jg)))) + trans_dir_diff(jg) = max(0.0_jprb, min(trans_dir_diff(jg), mu0*(1.0_jprb-trans_dir_dir(jg))-ref_dir(jg))) + end do + +#else + ! GPU-capable and vector-optimized version for ICON + !$ACC ROUTINE WORKER + + !$ACC LOOP WORKER VECTOR PRIVATE(gamma1, gamma2, gamma3, gamma4, & + !$ACC alpha1, alpha2, k_exponent, & + !$ACC reftrans_factor, exponential, k_mu0, & + !$ACC k_gamma3, k_gamma4, k_2_exponential, one_minus_kmu0_sqr) + do jg = 1, ng + + trans_dir_dir(jg) = max(-max(od(jg) * (1.0_jprb/mu0),0.0_jprb),-1000.0_jprb) + trans_dir_dir(jg) = exp(trans_dir_dir(jg)) + + ! Zdunkowski "PIFM" (Zdunkowski et al., 1980; Contributions to + ! Atmospheric Physics 53, 147-66) + factor = 0.75_jprb*asymmetry(jg) + + gamma1 = 2.0_jprb - ssa(jg) * (1.25_jprb + factor) + gamma2 = ssa(jg) * (0.75_jprb - factor) + gamma3 = 0.5_jprb - mu0*factor + gamma4 = 1.0_jprb - gamma3 + + alpha1 = gamma1*gamma4 + gamma2*gamma3 ! Eq. 16 + alpha2 = gamma1*gamma3 + gamma2*gamma4 ! Eq. 17 +#ifdef PARKIND1_SINGLE + k_exponent = sqrt(max((gamma1 - gamma2) * (gamma1 + gamma2), 1.0e-6_jprb)) ! Eq 18 +#else + k_exponent = sqrt(max((gamma1 - gamma2) * (gamma1 + gamma2), 1.0e-12_jprb)) ! Eq 18 +#endif + + exponential = exp(-k_exponent*od(jg)) + + k_mu0 = k_exponent*mu0 + one_minus_kmu0_sqr = 1.0_jprb - k_mu0*k_mu0 + k_gamma3 = k_exponent*gamma3 + k_gamma4 = k_exponent*gamma4 + exponential2 = exponential*exponential + k_2_exponential = 2.0_jprb * k_exponent * exponential + reftrans_factor = 1.0_jprb / (k_exponent + gamma1 + (k_exponent - gamma1)*exponential2) + + ! Meador & Weaver (1980) Eq. 25 + ref_diff(jg) = gamma2 * (1.0_jprb - exponential2) * reftrans_factor + + ! Meador & Weaver (1980) Eq. 26 + trans_diff(jg) = k_2_exponential * reftrans_factor + + ! Here we need mu0 even though it wasn't in Meador and Weaver + ! because we are assuming the incoming direct flux is defined to + ! be the flux into a plane perpendicular to the direction of the + ! sun, not into a horizontal plane + reftrans_factor = mu0 * ssa(jg) * reftrans_factor & + & / merge(one_minus_kmu0_sqr, epsilon(1.0_jprb), abs(one_minus_kmu0_sqr) > epsilon(1.0_jprb)) + + ! Meador & Weaver (1980) Eq. 14, multiplying top & bottom by + ! exp(-k_exponent*od) in case of very high optical depths + ref_dir(jg) = reftrans_factor & + & * ( (1.0_jprb - k_mu0) * (alpha2 + k_gamma3) & + & -(1.0_jprb + k_mu0) * (alpha2 - k_gamma3)*exponential2 & + & -k_2_exponential*(gamma3 - alpha2*mu0)*trans_dir_dir(jg) ) + + ! Meador & Weaver (1980) Eq. 15, multiplying top & bottom by + ! exp(-k_exponent*od), minus the 1*exp(-od/mu0) term + ! representing direct unscattered transmittance. + trans_dir_diff(jg) = reftrans_factor * ( k_2_exponential*(gamma4 + alpha1*mu0) & + & - trans_dir_dir(jg) & + & * ( (1.0_jprb + k_mu0) * (alpha1 + k_gamma4) & + & -(1.0_jprb - k_mu0) * (alpha1 - k_gamma4) * exponential2) ) + + ! Final check that ref_dir + trans_dir_diff <= 1 + ref_dir(jg) = max(0.0_jprb, min(ref_dir(jg), mu0*(1.0_jprb-trans_dir_dir(jg)))) + trans_dir_diff(jg) = max(0.0_jprb, min(trans_dir_diff(jg), mu0*(1.0_jprb-trans_dir_dir(jg))-ref_dir(jg))) + + end do +#endif + +#ifdef DO_DR_HOOK_TWO_STREAM + if (lhook) call dr_hook('radiation_two_stream:calc_ref_trans_sw',1,hook_handle) +#endif + + end subroutine calc_ref_trans_sw + + + !--------------------------------------------------------------------- + ! Compute the fraction of shortwave transmitted diffuse radiation + ! that is scattered during its transmission, used to compute + ! entrapment in SPARTACUS + subroutine calc_frac_scattered_diffuse_sw(ng, od, & + & gamma1, gamma2, frac_scat_diffuse) + +#ifdef DO_DR_HOOK_TWO_STREAM + use yomhook, only : lhook, dr_hook, jphook +#endif + + integer, intent(in) :: ng + + ! Optical depth + real(jprb), intent(in), dimension(ng) :: od + + ! The first two transfer coefficients from the two-stream + ! differentiatial equations (computed by calc_two_stream_gammas) + real(jprb), intent(in), dimension(ng) :: gamma1, gamma2 + + ! The fraction of shortwave transmitted diffuse radiation that is + ! scattered during its transmission + real(jprb), intent(out), dimension(ng) :: frac_scat_diffuse + + real(jprd) :: k_exponent, reftrans_factor + real(jprd) :: exponential ! = exp(-k_exponent*od) + real(jprd) :: exponential2 ! = exp(-2*k_exponent*od) + real(jprd) :: k_2_exponential + integer :: jg + +#ifdef DO_DR_HOOK_TWO_STREAM + real(jphook) :: hook_handle + + if (lhook) call dr_hook('radiation_two_stream:calc_frac_scattered_diffuse_sw',0,hook_handle) +#endif + +! Added for DWD (2020) +!NEC$ shortloop + do jg = 1, ng + ! Note that if the minimum value is reduced (e.g. to 1.0e-24) + ! then noise starts to appear as a function of solar zenith + ! angle + k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & + & 1.0e-12_jprd)) ! Eq 18 + exponential = exp(-k_exponent*od(jg)) + exponential2 = exponential*exponential + k_2_exponential = 2.0_jprd * k_exponent * exponential + + reftrans_factor = 1.0_jprd / (k_exponent + gamma1(jg) + (k_exponent - gamma1(jg))*exponential2) + + ! Meador & Weaver (1980) Eq. 26. + ! Until 1.1.8, used LwDiffusivity instead of 2.0, although the + ! effect is very small + ! frac_scat_diffuse(jg) = 1.0_jprb - min(1.0_jprb,exp(-LwDiffusivity*od(jg)) & + ! & / max(1.0e-8_jprb, k_2_exponential * reftrans_factor)) + frac_scat_diffuse(jg) = 1.0_jprb & + & - min(1.0_jprb,exp(-2.0_jprb*od(jg)) & + & / max(1.0e-8_jprb, k_2_exponential * reftrans_factor)) + end do + +#ifdef DO_DR_HOOK_TWO_STREAM + if (lhook) call dr_hook('radiation_two_stream:calc_frac_scattered_diffuse_sw',1,hook_handle) +#endif + + end subroutine calc_frac_scattered_diffuse_sw + +end module radiation_two_stream Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/Makefile (revision 6016) @@ -0,0 +1,150 @@ +# Makefile for running ecRad on clear-sky CKDMIP profiles. The basic +# test uses the single input file INPUT below. You can also run ecRad +# on CKDMIP scenarios (see lower in file). You need the NCO tools +# ncap2, ncrcat and ncpdq. + +# --- BASIC TEST --- + +# Type "make" to use the default ecckd gas-optics models, or "make +# GASMODEL=rrtmg" for the RRTMG gas-optics model. + +INPUT = ckdmip_evaluation1_concentrations_present_reduced.nc +DRIVER = ../../bin/ecrad +CHANGENAM = ../common/change_namelist.sh +GASMODEL = ecckd +CONFIG = config-$(GASMODEL).nam + +all: test + +# By default run the sw and lw tests +test: sw lw + +# Longwave ecRad calculation: simply run ecRad with an appropriate +# config file +lw: config-$(GASMODEL)_lw.nam + $(DRIVER) config-$(GASMODEL)_lw.nam $(INPUT) ckdmip_evaluation1_lw_out.nc + +# Shortwave ecRad calculation: run the five solar zenith angles then +# concatenate the NetCDF files. This uses the GNU make feature "call", +# here applied to CALCSWSZA which takes two arguments, the input and +# output files +sw: config_sw_all + $(call CALCSWSZA,$(INPUT),ckdmip_evaluation1_sw_out.nc) + +# Create a longwave config file (basically turn of the shortwave) +config-$(GASMODEL)_lw.nam: $(CONFIG) + $(CHANGENAM) $(CONFIG) config-$(GASMODEL)_lw.nam do_sw=false + +# Create the namelist files for a particular solar zenith angle, +# e.g. "make config-rrtmg_sw_0.5.nam" creates a namelist file for the +# RRTMG gas optics model and a solar zenith angle of 60 degrees. +config-$(GASMODEL)_sw_%.nam: $(CONFIG) + $(CHANGENAM) $(CONFIG) $@ do_lw=false cos_solar_zenith_angle=$* + +# Produce config files for each of the five solar zenith angles +config_sw_all: config-$(GASMODEL)_sw_0.1.nam config-$(GASMODEL)_sw_0.3.nam \ + config-$(GASMODEL)_sw_0.5.nam config-$(GASMODEL)_sw_0.7.nam config-$(GASMODEL)_sw_0.9.nam + + +# --- HELPER FUNCTIONS --- + +# Function to run ecRad shortwave-only on the 50 evaluation profiles +# for a single value of the solar zenith angle (works only with GNU +# make), and then to add a mu0 variable storing the cosine of the +# solar zenith angle. The arguments are (1) the input file name and +# (2) the cosine of the solar zenith angle. +CALCSW = \ + $(DRIVER) config-$(GASMODEL)_sw_$(2).nam $(1) tmp_out.nc; \ + ncap2 -O -s 'defdim("mu0",1,0);mu0[mu0]={'$(2)'f};mu0@long_name="Cosine of solar zenith angle";flux_dn_sw[mu0,column,half_level]=flux_dn_sw;flux_up_sw[mu0,column,half_level]=flux_up_sw;flux_dn_direct_sw[mu0,column,half_level]=flux_dn_direct_sw' tmp_out.nc tmp_$(2)_out.nc + +# Function to run ecRad shortwave-only for all five solar zenith +# angles, then to contatenate the results into a single file. The +# arguments are (1) the input file name and (2) the output file name. +CALCSWSZA = \ + $(call CALCSW,$(1),0.1); \ + $(call CALCSW,$(1),0.3); \ + $(call CALCSW,$(1),0.5); \ + $(call CALCSW,$(1),0.7); \ + $(call CALCSW,$(1),0.9); \ + ncrcat -O tmp_0.1_out.nc tmp_0.3_out.nc tmp_0.5_out.nc tmp_0.7_out.nc tmp_0.9_out.nc tmp_out2.nc; \ + ncpdq -O -a column,mu0,half_level tmp_out2.nc $(2) + + +# --- CKDMIP SCENARIOS --- + +# To run the CKDMIP scenarios you first need to copy the concentration +# files from http://aux.ecmwf.int/ecpds/home/ckdmip/concentrations/, +# or ftp from aux.ecmwf.int (username ckdmip, password any non-empty +# string), which you can do with "make download". Then do: +# +# make scenarios +# +# As in the basic test you can add the GASMODEL=rrtmg to use the RRTMG +# gas-optics model instead of ecCKD. To use a different configuration +# of ecCKD than the default, copy config-ecckd.nam to something like +# config-custom.nam, then add the gas_optics_sw_override_file_name and +# gas_optics_lw_override_file_name namelist arguments to specify your +# preferred CKD definition file, and call make with GASMODEL=custom. + +CONCDIR = concentrations +DATASET = evaluation1 +FLUXDIR = fluxes +LBLFLUXDIR = lbl_fluxes + +# Web/FTP location of concentration files (no trailing slash) +#WEBSOURCE = http://aux.ecmwf.int/ecpds/home/ckdmip +WEBSOURCE = ftp://ckdmip:blank@aux.ecmwf.int + +# List of scenarios to run +SCENARIOS = present co2-180 co2-280 co2-560 co2-1120 co2-2240 ch4-350 ch4-700 ch4-1200 ch4-2600 ch4-3500 n2o-190 n2o-270 n2o-405 n2o-540 + +# A longwave and shortwave make rule for each scenario +SCENARIO_RULES = $(addprefix lw_scenario_,$(SCENARIOS)) $(addprefix sw_scenario_,$(SCENARIOS)) +# A download rule for each scenario +DOWNLOAD_RULES = $(addprefix download_,$(SCENARIOS)) + +# Main target of this section runs each scenario longwave and shortwave +scenarios: $(SCENARIO_RULES) + +# Pattern matches a shortwave scenario, invoked by calling the +# CALCSWSZA function. +sw_scenario_%: config_sw_all + mkdir -p $(FLUXDIR) + $(call CALCSWSZA,$(CONCDIR)/ckdmip_$(DATASET)_concentrations_$*.nc,$(FLUXDIR)/ecrad-$(GASMODEL)_$(DATASET)_sw_fluxes_$*.nc) + +# Pattern matches a longwave scenario. +lw_scenario_%: config-$(GASMODEL)_lw.nam + mkdir -p $(FLUXDIR) + $(DRIVER) config-$(GASMODEL)_lw.nam $(CONCDIR)/ckdmip_$(DATASET)_concentrations_$*.nc $(FLUXDIR)/ecrad-$(GASMODEL)_$(DATASET)_lw_fluxes_$*.nc + +# Target to download concentration files from the web to the CONCDIR +# directory +download: $(DOWNLOAD_RULES) + +# Download one scenario, explicitly overwriting if it already +# exists. Note that the "h5" files are NetCDF4/HDF5 format so can be +# read with NetCDF tools +download_%: + mkdir -p $(CONCDIR) + wget -nv -O $(CONCDIR)/ckdmip_$(DATASET)_concentrations_$*.nc \ + $(WEBSOURCE)/concentrations/ckdmip_$(DATASET)_concentrations_$*.nc + mkdir -p $(LBLFLUXDIR) + wget -nv -O $(LBLFLUXDIR)/ckdmip_$(DATASET)_lw_fluxes_$*.nc \ + $(WEBSOURCE)/lw_fluxes/$(DATASET)/ckdmip_$(DATASET)_lw_fluxes_$*.h5 + wget -nv -O $(LBLFLUXDIR)/ckdmip_$(DATASET)_sw_fluxes_$*.nc \ + $(WEBSOURCE)/sw_fluxes/$(DATASET)/ckdmip_$(DATASET)_sw_fluxes_$*.h5 + + +# Clean data files +clean: + rm -f *_out.nc config-*_sw_*.nam config-*_lw.nam tmp*.nc wget-log + +distclean: clean + rm -rf $(CONCDIR)/ckdmip_$(DATASET)_concentrations_present.nc \ + $(CONCDIR)/ckdmip_$(DATASET)_*-*.nc \ + $(FLUXDIR)/ecrad-*_$(DATASET)_lw_fluxes_*.nc \ + $(FLUXDIR)/ecrad-*_$(DATASET)_sw_fluxes_*.nc \ + $(LBLFLUXDIR)/ckdmip_$(DATASET)_lw_fluxes_*.nc \ + $(LBLFLUXDIR)/ckdmip_$(DATASET)_sw_fluxes_*.nc + +.PHONY: config_sw_all scenarios sw lw all test clean distclean Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/README =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/README (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/README (revision 6016) @@ -0,0 +1,47 @@ +*** BASIC TEST *** + +This file contains +"ckdmip_evaluation1_concentrations_present_reduced.nc", the 50 +clear-sky atmospheric profiles of the CKDMIP "Evaluation-1" dataset +described by Hogan and Matricard (GMDD 2020), and the corresponding +line-by-line fluxes in +"ckdmip_evaluation1_lw_fluxes_present_reduced.nc" and +"ckdmip_evaluation1_sw_fluxes_present_reduced.nc". + +Type "make" in this directory to run ecRad on these profiles. You +will need the nco tools, because the shortwave calculation is +performed five times for different solar zenith angles and the results +are concatenated into one file. + +Then run the Matlab script "do_evaluate_ecrad.m" to evaluate the ecRad +calculations against line-by-line, producing plots in the same style +as Figs. 5 and 7 of Hogan and Matricardi (2020). + +By default the ecCKD gas optics is used: to use RRTMG, use instead +"make GASMODEL=rrtmg", which uses the namelist file config-rrtmg.nam +instead of config-ecckd.nam. To use a different spectral +configuration file with ecCKD, edit config-ecckd.nam. + + +*** CKDMIP SCENARIOS *** + +To run ecRad on a wider range of CKDMIP scenarios, first download a +selection of concentration files from the CKDMIP FTP site to the +"concentrations" directory: + + make download + +This also downloads the line-by-line reference fluxes to "lbl_fluxes". +Then run ecRad on them using ecCKD gas optics with: + + make scenarios + +This generates *_lw_fluxes_* and *_sw_fluxes_* files in the "fluxes" +directory. + +Or with the following you can use RRTMG gas optics: + + make GASMODEL=rrtmg scenarios + +You can clean up with "make clean" or delete any downloaded files with +"make distclean". Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/calc_hr.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/calc_hr.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/calc_hr.m (revision 6016) @@ -0,0 +1,13 @@ +function hr = calc_hr(data, band, icol) + +eval(['flux_up = data.flux_up_' band ';']); +eval(['flux_dn = data.flux_dn_' band ';']); +flux_net = flux_dn-flux_up; +g=9.81; +scaling = 3600.*24; +hr_all = -scaling.*(diff(flux_net).*g./diff(data.pressure_hl)./1004)'; +if nargin > 2 + hr = hr_all(icol,:); +else + hr = hr_all; +end Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/calc_hr_error.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/calc_hr_error.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/calc_hr_error.m (revision 6016) @@ -0,0 +1,23 @@ +% Compute RMS error in heating rate, in K d-1, weighting by the +% cube-root of pressure, where pressure arguments are in hPa +function err = calc_hr_error(pressure_hl, hr, hr_ref, pressure_range); + + % If final argument not provided, consider all pressure ranges + if nargin < 4 + pressure_range = [0 Inf]; + end + + mypow = (1./3); + + pressure_fl = 0.5.*(pressure_hl(1:end-1,:) + pressure_hl(2:end,:)); + weight = (pressure_hl(2:end,:)).^mypow - (pressure_hl(1:end-1,:)).^mypow; + + index = find(pressure_fl < pressure_range(1) | pressure_fl >= pressure_range(2)); + if ~isempty(index) + weight(index) = 0; + end + nprof = size(weight,2); + for ii = 1:nprof + weight(:,ii) = weight(:,ii) ./ sum(weight(:,ii)); + end + err = sqrt(sum(weight(:) .* (hr(:)-hr_ref(:)).^2)./nprof); Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/config-ecckd.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/config-ecckd.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/config-ecckd.nam (revision 6016) @@ -0,0 +1,47 @@ +! Configuration namelists for ECRAD radiation code +! This version is for use with the CKDMIP profiles (clear-sky only) +! using the ecCKD gas-optics scheme +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file. +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 1000, ! Number of columns to process per thread +do_save_inputs = false, ! Save inputs in "inputs.nc"? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 3, +istartcol = 0, ! 0 = Use full range of columns by default +iendcol = 0, ! 0 = Use full range of columns by default +nrepeat = 1, +lw_emissivity = 1.0, +vmr_suffix_str = "_mole_fraction_fl", +cos_solar_zenith_angle = 0.5, +sw_albedo = 0.15, +solar_irradiance_override=1361.0, +/ +! +! The following namelist controls the behaviour of the SPARTACUS +! radiation code +! +&radiation +do_sw = true, ! Compute shortwave fluxes? +do_lw = true, ! Compute longwave fluxes? +do_sw_direct = true, ! Compute direct downward shortwave fluxes? +do_clear = false, ! Compute clear-sky fluxes? +directory_name = "../../data", ! Location of configuration files +sw_solver_name = "Cloudless", +lw_solver_name = "Cloudless", +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +! Separate verbosity specified for setup and ordinary execution +iverbose = 5, +iverbosesetup = 3, +use_aerosols = false, ! Include aerosols in radiation calculations? +do_save_spectral_flux = false, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +do_surface_sw_spectral_flux = false, +do_lw_derivatives = false, ! Hogan-Bozzo style derivatives for approx updates +gas_model_name = "ECCKD", ! Gas model +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/config-rrtmg.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/config-rrtmg.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/config-rrtmg.nam (revision 6016) @@ -0,0 +1,47 @@ +! Configuration namelists for ECRAD radiation code +! This version is for use with the CKDMIP profiles (clear-sky only) +! using the RRTMG gas-optics scheme +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file. +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 1000, ! Number of columns to process per thread +do_save_inputs = false, ! Save inputs in "inputs.nc"? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 3, +istartcol = 0, ! 0 = Use full range of columns by default +iendcol = 0, ! 0 = Use full range of columns by default +nrepeat = 1, +lw_emissivity = 1.0, +vmr_suffix_str = "_mole_fraction_fl", +cos_solar_zenith_angle = 0.5, +sw_albedo = 0.15, +solar_irradiance_override=1361.0, +/ +! +! The following namelist controls the behaviour of the SPARTACUS +! radiation code +! +&radiation +do_sw = true, ! Compute shortwave fluxes? +do_lw = true, ! Compute longwave fluxes? +do_sw_direct = true, ! Compute direct downward shortwave fluxes? +do_clear = false, ! Compute clear-sky fluxes? +directory_name = "../../data", ! Location of configuration files +sw_solver_name = "Cloudless", +lw_solver_name = "Cloudless", +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +! Separate verbosity specified for setup and ordinary execution +iverbose = 5, +iverbosesetup = 3, +use_aerosols = false, ! Include aerosols in radiation calculations? +do_save_spectral_flux = false, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +do_surface_sw_spectral_flux = false, +do_lw_derivatives = false, ! Hogan-Bozzo style derivatives for approx updates +gas_model_name = "RRTMG-IFS", ! Gas model +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/do_evaluate_ecrad.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/do_evaluate_ecrad.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/do_evaluate_ecrad.m (revision 6016) @@ -0,0 +1,5 @@ +path(path,'../common'); +figure(1) +evaluate_ckd_lw_fluxes('ckdmip_evaluation1_lw_fluxes_present_reduced.nc','ckdmip_evaluation1_lw_out.nc','ecRad','Present-day') +figure(2) +evaluate_ckd_sw_fluxes('ckdmip_evaluation1_sw_fluxes_present_reduced.nc','ckdmip_evaluation1_sw_out.nc','ecRad','Present-day') Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_ckd_lw_fluxes.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_ckd_lw_fluxes.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_ckd_lw_fluxes.m (revision 6016) @@ -0,0 +1,297 @@ +function stats = evaluate_ckd_lw_fluxes(ref_file, ckd_file_in, model_name, scenario_title) +% Evaluate the fluxes and heating rates from a CKD model with +% line-by-line benchmark calculations for a CKDMIP scenario + +ickd_stats = 1; % Which CKD model do we show the stats for (0=none) + +if iscell(ckd_file_in) + ckd_file = ckd_file_in; +else + ckd_file = {ckd_file_in}; +end + +if iscell(model_name) + titles = model_name; +else + titles = {model_name} +end + +combined_titles = ''; +for ie = 1:length(titles) + combined_titles = [combined_titles titles{ie} '_']; +end +ickd = 1:length(ckd_file); + +col_ref = 'k'; +cols = {'r','b','g','m','c'}; +alpha= [0.2 0.3 0.25 0.25 0.1 0.1]; + +dflux_axis = [-4 4]; +%dfluxscatter_axis = [-8 8]; +dfluxscatter_axis = [-4 4]; +hr_axis = [-1 1]; + +if length(ckd_file) > 1 + do_legend = 1; +else + do_legend = 0; +end + +legfontsize = 7; +error_save = []; + + +[ref,attr_ref] = loadnc(ref_file); +if ~exist('scenario_title','var') + scenario_title = attr_ref.global.scenario; +end + +hr_ref = calc_hr(ref,'lw')'; + +for ie = 1:length(ckd_file) + ckd{ie} = loadnc(ckd_file{ie}); + hr_ckd{ie} = calc_hr(ckd{ie},'lw')'; +end + +% Pressure in hPa at full levels and half levels +p_fl_hPa = 0.01.*0.5.*(ref.pressure_hl(1:end-1,:) + ref.pressure_hl(2:end,:)); +p_hl_hPa = 0.01.*ref.pressure_hl; + +iprof = 1:size(ref.pressure_hl,2); + +xloc = 0.025;yloc = 0.95; + +if nargout == 0 + do_plot = 1; +else + do_plot = 0; +end + +if do_plot +clf +set(gcf,'paperposition',[0.5 0.5 27 25]); +set(gcf,'defaultaxeslayer','top','defaultlinelinewidth',0.5,'defaulttextfontsize',10); + +% Plot reference flux and heating-rate profiles +subplot(3,3,1) +semilogy(ref.flux_up_lw(:,iprof), p_hl_hPa(:,iprof), col_ref); +set(gca,'ydir','reverse'); +ylim([0.01 1000]); +ylabel('Pressure (hPa)'); +xlabel('Upwelling longwave flux (W m^{-2})'); +title('Reference profiles') +text(xloc, yloc, '\bf(a)','units','normalized'); + +subplot(3,3,4) +semilogy(ref.flux_dn_lw(:,iprof), p_hl_hPa, col_ref); +set(gca,'ydir','reverse'); +ylim([0.01 1000]); +ylabel('Pressure (hPa)'); +xlabel('Downwelling longwave flux (W m^{-2})'); +text(xloc, yloc, '\bf(d)','units','normalized'); + +subplot(3,3,7) +semilogy(hr_ref(:,iprof), p_fl_hPa(:,iprof), col_ref); +set(gca,'ydir','reverse'); +ylim([0.01 1000]); +ylabel('Pressure (hPa)'); +xlabel('Heating rate (K d^{-1})'); +xlim([-25 5]); +text(xloc, yloc, '\bf(g)','units','normalized'); + +% Plot random errors and biases in flux and heating-rate profiles +subplot(3,3,8) +end + +ileg = 1; +leg = {}; +for ie = ickd + err = calc_hr_error(p_hl_hPa(:,iprof), hr_ckd{ie}(:,iprof),hr_ref(:,iprof), [0.02 4]); + err4 = calc_hr_error(p_hl_hPa(:,iprof), hr_ckd{ie}(:,iprof),hr_ref(:,iprof), [4 1100]); + leg{ileg} = [titles{ie} ' (RMSE=' num2str(err,'%0.3f') ' K d^{-1})']; + ileg = ileg+1; + error_save(1,ie) = err; + error_save(2,ie) = err4; + + if do_plot + plot(-1,-1,cols{ie},'linewidth',1.5); + hold on + end +end + + +if do_plot +for ie = ickd + hr_error = hr_ckd{ie}(:,iprof) - hr_ref(:,iprof); + hr_bias = mean(hr_error'); + hr_ci = std(hr_error').*1.96; + hr_errmin = min(hr_error,[],2); + hr_errmax = max(hr_error,[],2); + pp = mean(p_fl_hPa'); + h=fill([hr_bias+hr_ci flip(hr_bias-hr_ci)],... + [pp flip(pp)],'r'); + set(h,'facecolor',cols{ie}(1),'edgecolor','none','facealpha',alpha(ie)); + hold on + plot(hr_bias,pp,cols{ie},'linewidth',1.5); +% plot(hr_errmin,pp,[cols{ie}(1) '--']) +% plot(hr_errmax,pp,[cols{ie}(1) '--']) +end +plot(hr_axis,[0.02 0.02],'k:'); +plot(hr_axis,[4 4],'k:'); +set(gca,'ydir','reverse'); +set(gca,'yscale','log'); +ylim([0.01 1000]); +ylabel('Pressure (hPa)'); +xlabel('Heating rate error (K d^{-1})'); +xlim(hr_axis); +plot([0 0],[0.01 1000],'k:'); +%if do_legend +% set(legend(leg,'location','south'),'fontsize',legfontsize','box','on'); + %end +text(xloc, yloc, '\bf(h)','units','normalized'); + +subplot(3,3,2) +for ie = ickd + plot(-1,-1,cols{ie},'linewidth',1.5); + hold on +end +for ie = ickd + flux_error = ckd{ie}.flux_up_lw(:,iprof) - ref.flux_up_lw(:,iprof); + flux_bias = mean(flux_error'); + flux_ci = std(flux_error').*1.96; + flux_errmin = min(flux_error,[],2); + flux_errmax = max(flux_error,[],2); + pp = mean(p_hl_hPa'); + h=fill([flux_bias+flux_ci flip(flux_bias-flux_ci)],... + [pp flip(pp)],'r'); + set(h,'facecolor',cols{ie}(1),'edgecolor','none','facealpha',alpha(ie)); + hold on + plot(flux_bias,pp,cols{ie},'linewidth',1.5); +end +set(gca,'ydir','reverse','yscale','log'); +ylim([0.01 1000]); +plot([0 0],[0.01 1000],'k:'); +ylabel('Pressure (hPa)'); +xlabel('Upwelling flux error (W m^{-2})'); +xlim(dflux_axis); +title('Errors in profiles') +if do_legend + set(legend(titles{ickd},'location','best'),'fontsize',legfontsize','box','on'); +end +text(xloc, yloc, '\bf(b)','units','normalized'); + +subplot(3,3,5) +for ie = ickd + flux_error = ckd{ie}.flux_dn_lw(:,iprof) - ref.flux_dn_lw(:,iprof); + flux_bias = mean(flux_error'); + flux_ci = std(flux_error').*1.96; + flux_errmin = min(flux_error,[],2); + flux_errmax = max(flux_error,[],2); + pp = mean(p_hl_hPa'); + h=fill([flux_bias+flux_ci flip(flux_bias-flux_ci)],... + [pp flip(pp)],'r'); + set(h,'facecolor',cols{ie}(1),'edgecolor','none','facealpha',alpha(ie)); + hold on + plot(flux_bias,pp,cols{ie},'linewidth',1.5); +end +set(gca,'ydir','reverse','yscale','log'); +ylim([0.01 1000]); +plot([0 0],[0.01 1000],'k:'); +ylabel('Pressure (hPa)'); +xlabel('Downwelling flux error (W m^{-2})'); +xlim(dflux_axis); +text(xloc, yloc, '\bf(e)','units','normalized'); + +subplot(3,3,3) +ileg = 1; +leg = {}; +end + +for ie = ickd + mydiff = ckd{ie}.flux_up_lw(1,iprof)-ref.flux_up_lw(1,iprof); + err = sqrt(mean(mydiff.^2)); + leg{ileg} = [titles{ie} ' (RMSE=' num2str(err,'%0.2f') ' W m^{-2})']; + error_save(3,ie) = err; + error_save(4,ie) = mean(mydiff); + %plot(-1,-1,cols{ie},'linewidth',1.5); + ileg = ileg+1; + if do_plot + plot(ref.flux_up_lw(1,iprof), mydiff, ... + [cols{ie}(1) 'o']); + hold on + end +end +if do_plot +if do_legend + set(legend(leg,'location','best'),'fontsize',legfontsize','box','on') +end +xlabel('Reference TOA upwelling (W m^{-2})'); +ylabel('TOA upwelling error (W m^{-2})'); +xlim([0 400]); +plot(xlim,[0 0],'k:','linewidth',0.5); +ylim(dfluxscatter_axis); +title('Errors at surface and TOA'); +text(xloc, yloc, '\bf(c)','units','normalized'); + +subplot(3,3,6) +end +ileg = 1; +leg = {}; +for ie = ickd + mydiff = ckd{ie}.flux_dn_lw(end,iprof)-ref.flux_dn_lw(end,iprof); + err = sqrt(mean(mydiff.^2)); + leg{ileg} = [titles{ie} ' (RMSE=' num2str(err,'%0.2f') ' W m^{-2})']; + error_save(5,ie) = err; + error_save(6,ie) = mean(mydiff); + ileg = ileg+1; + if do_plot + plot(ref.flux_dn_lw(end,iprof), mydiff, ... + [cols{ie}(1) 'o']); + hold on + end +end +if do_plot +if do_legend + set(legend(leg,'location','best'),'fontsize',legfontsize') +end +xlabel('Reference surface downwelling (W m^{-2})'); +ylabel('Surface downwelling error (W m^{-2})'); +plot(xlim,[0 0],'k:','linewidth',0.5); +ylim(dfluxscatter_axis); +text(xloc, yloc, '\bf(f)','units','normalized'); + +h=subplot(3,3,9); +set(h,'visible','off') + +xstart = -0.15; +text(xstart,0.95,['\bfScenario: ' scenario_title],'fontsize',12); + +if ickd_stats > 0 + for ie = ickd_stats + text(xstart,0.85,['\bfCKD model: ' titles{ie}],'fontsize',12); + ystart = 0.75; %-0.4.*(ie-1); + %text(xstart,ystart,['\bfRMS errors in ' titles{ie} ':'],'units','normalized'); + text(xstart,ystart,['Bias TOA upwelling: ' num2str(error_save(4,ie),'%0.2f') ' W m^{-2}'],'units','normalized'); + text(xstart,ystart-0.1,['Bias surface downwelling: ' num2str(error_save(6,ie),'%0.2f') ' W m^{-2}'],'units','normalized'); + text(xstart,ystart-0.2,['RMSE TOA upwelling: ' num2str(error_save(3,ie),'%0.2f') ' W m^{-2}'],'units','normalized'); + text(xstart,ystart-0.3,['RMSE surface downwelling: ' num2str(error_save(5,ie),'%0.2f') ' W m^{-2}'],'units','normalized'); + text(xstart,ystart-0.4,['RMSE heating rate (0.02-4 hPa): ' num2str(error_save(1,ie),'%0.3f') ' K d^{-1}'],'units','normalized'); + text(xstart,ystart-0.5,['RMSE heating rate (4-1100 hPa): ' num2str(error_save(2,ie),'%0.3f') ' K d^{-1}'],'units','normalized'); + + end +end + +drawnow +end +%print('-dpng','-painters','-r100',[combined_titles 'evaluation1_fluxes_' scenario '.png']); +%end + +if nargin > 0 + stats.toa_up_bias = error_save(4,:); + stats.surf_dn_bias= error_save(6,:); + stats.toa_up_rmse = error_save(3,:); + stats.surf_dn_rmse= error_save(5,:); + stats.heating_rate_low_rmse=error_save(1,:); + stats.heating_rate_high_rmse=error_save(2,:); +end + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_ckd_sw_fluxes.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_ckd_sw_fluxes.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_ckd_sw_fluxes.m (revision 6016) @@ -0,0 +1,341 @@ +function evaluate_ckd_sw_fluxes(ref_file, ckd_file_in, model_name, scenario_title,specdef) +% Evaluate the shortwave fluxes and heating rates from a CKD model +% with line-by-line benchmark calculations for the four main CKDMIP +% scenarios + +ickd_stats = 1; % Which CKD model do we show the stats for (0=none) +nsza = 5;isza_list = 1:nsza; +%nsza = 1;isza_list = 5; + + +do_diurnal_average = 0; + +if do_diurnal_average + hr_scaling_factor = 0.5; + warning(['Heating rate error (only) has been scaled by 0.5 to represent a diurnal average']); +else + hr_scaling_factor = 1; +end + +if iscell(ckd_file_in) + ckd_file = ckd_file_in; +else + ckd_file = {ckd_file_in}; +end + +if iscell(model_name) + titles = model_name; +else + titles = {model_name} +end + +if nargin > 4 & ~iscell(ckd_file_in) + ckd_file = {ckd_file_in,ckd_file_in} + do_fix_ssi = [0 1]; + ickd_stats = 2; + titles = {model_name,[model_name ' (fix SSI)']}; +else + do_fix_ssi = zeros(size(ckd_file)); +end + + +combined_titles = ''; +for ie = 1:length(titles) + combined_titles = [combined_titles titles{ie} '_']; +end +ickd = 1:length(ckd_file); + +col_ref = 'k'; +cols = {'r','b','g','m','c'}; +alpha= [0.2 0.3 0.25 0.25 0.1 0.1]; + +ref_cols = {'y','g','c','b','k'}; +%ref_shades = {[0.8 0.8 0.8],[0.6 0.6 0.6],[0.4 0.4 0.4],[0.2 0.2 0.2],[0 0 0]}; +%ref_styles = {'-','-','-','-','-'}; + + +dflux_axis = [-5 5]; +hr_axis = [-3 3]; +%hr_axis = [-15 15]; + +% Debugging ecCKD... +%dflux_axis = [-20 20]; +%hr_axis = [-5 5]; + + +if length(ckd_file) > 1 + cols = {'b','r','g','m','c'}; + do_legend = 1; +else + do_legend = 0; +end +legfontsize = 7; +rmse_save = []; + + [ref_orig, attr_ref] = loadnc(ref_file); + ref = flatten_sza(ref_orig,isza_list); + hr_ref = calc_hr(ref,'sw')'; + if ~exist('scenario_title','var') + scenario_title = attr_ref.global.scenario; + end + + for ie = 1:length(ckd_file) + ckd_tmp = loadnc(ckd_file{ie}); + if do_fix_ssi(ie) + ckd_tmp = correct_ssi(ref_orig, ckd_tmp, specdef); + end + ckd{ie} = flatten_sza(ckd_tmp,isza_list); + hr_ckd{ie} = calc_hr(ckd{ie},'sw')'; + end + + % Pressure in hPa at full levels and half levels + p_fl_hPa = 0.01.*0.5.*(ref.pressure_hl(1:end-1,:) + ref.pressure_hl(2:end,:)); + p_hl_hPa = 0.01.*ref.pressure_hl; + + iprof = 1:size(ref.pressure_hl,2); + iprof_orig = 1:size(ref_orig.pressure_hl,2); + + xloc = 0.025;yloc = 0.95; + + clf + set(gcf,'paperposition',[0.5 0.5 27 25]); + set(gcf,'defaultaxeslayer','top','defaultlinelinewidth',0.5,'defaulttextfontsize',10); + + % Plot reference flux and heating-rate profiles + subplot(3,3,1) + %semilogy(ref.flux_up_sw(:,iprof), p_hl_hPa(:,iprof), col_ref); + for isza = 1:nsza + semilogy(squeeze(ref_orig.flux_up_sw(:,isza,iprof_orig)), p_hl_hPa(:,iprof_orig), ref_cols{isza}); +%... +% ref_styles{isza}, 'color', ref_shades{isza}); + hold on + end + set(gca,'ydir','reverse'); + ylim([0.01 1000]); + ylabel('Pressure (hPa)'); + xlabel('Upwelling shortwave flux (W m^{-2})'); + title('Reference profiles') + text(xloc, yloc, '\bf(a)','units','normalized') + + subplot(3,3,4) + for isza = 1:nsza + semilogy(-1,-1, ref_cols{isza}); + hold on + end + %semilogy(ref.flux_dn_sw(:,iprof), p_hl_hPa, col_ref); + for isza = 1:nsza + semilogy(squeeze(ref_orig.flux_dn_sw(:,isza,iprof_orig)), p_hl_hPa(:,iprof_orig), ref_cols{isza}); + hold on + end + set(gca,'ydir','reverse'); + ylim([0.01 1000]); + ylabel('Pressure (hPa)'); + xlabel('Downwelling shortwave flux (W m^{-2})'); + legend('\mu_0 = 0.1',... + '\mu_0 = 0.3',... + '\mu_0 = 0.5',... + '\mu_0 = 0.7',... + '\mu_0 = 0.9','location','northeast'); + text(xloc, yloc, '\bf(d)','units','normalized') + + subplot(3,3,7) + %semilogy(hr_ref(:,iprof), p_fl_hPa(:,iprof), col_ref); + for isza = 1:nsza + semilogy(-1,-1, ref_cols{isza}); + hold on + end + for isza = 1:nsza + semilogy(hr_ref(:,isza:nsza:end), p_fl_hPa(:,iprof_orig), ref_cols{isza}); + hold on + end + text(xloc, yloc, '\bf(g)','units','normalized') + if 0 + % Extra legend... + legend('\mu_0 = 0.1',... + '\mu_0 = 0.3',... + '\mu_0 = 0.5',... + '\mu_0 = 0.7',... + '\mu_0 = 0.9','location','southeast'); + end + + set(gca,'ydir','reverse'); + ylim([0.01 1000]); + ylabel('Pressure (hPa)'); + xlabel('Heating rate (K d^{-1})'); + xlim([0 40]); + + % Plot random errors and biases in flux and heating-rate profiles + subplot(3,3,8) + + ileg = 1; + leg = {}; + for ie = ickd + err = calc_hr_error(p_hl_hPa(:,iprof), hr_ckd{ie}(:,iprof),hr_ref(:,iprof), [0.02 4]); + err4 = calc_hr_error(p_hl_hPa(:,iprof), hr_ckd{ie}(:,iprof),hr_ref(:,iprof), [4 1100]); + leg{ileg} = [titles{ie} ' (RMSE=' num2str(err,'%0.3f') ' K d^{-1})']; + plot(-1,-1,cols{ie},'linewidth',1.5); + ileg = ileg+1; + rmse_save(1,ie) = err; + rmse_save(2,ie) = err4; + hold on + end + + for ie = ickd + hr_error = hr_scaling_factor .* (hr_ckd{ie}(:,iprof) - hr_ref(:,iprof)); + hr_bias = mean(hr_error'); + hr_ci = std(hr_error').*1.96; + hr_errmin = min(hr_error,[],2); + hr_errmax = max(hr_error,[],2); + pp = mean(p_fl_hPa'); + h=fill([hr_bias+hr_ci flip(hr_bias-hr_ci)],... + [pp flip(pp)],'r'); + set(h,'facecolor',cols{ie}(1),'edgecolor','none','facealpha',alpha(ie)); + hold on + plot(hr_bias,pp,cols{ie},'linewidth',1.5); + % plot(hr_errmin,pp,[cols{ie}(1) '--']) + % plot(hr_errmax,pp,[cols{ie}(1) '--']) + end + plot(hr_axis,[0.02 0.02],'k:'); + plot(hr_axis,[4 4],'k:'); + set(gca,'ydir','reverse'); + set(gca,'yscale','log'); + ylim([0.01 1000]); + ylabel('Pressure (hPa)'); + xlabel('Heating rate error (K d^{-1})'); + xlim(hr_axis); + plot([0 0],[0.01 1000],'k:'); + %if do_legend + % set(legend(leg,'location','south'),'fontsize',legfontsize','box','on'); + %end + text(xloc, yloc, '\bf(h)','units','normalized') + + subplot(3,3,2) + for ie = ickd + plot(-1,-1,cols{ie},'linewidth',1.5); + hold on + end + for ie = ickd + flux_error = ckd{ie}.flux_up_sw(:,iprof) - ref.flux_up_sw(:,iprof); + flux_bias = mean(flux_error'); + flux_ci = std(flux_error').*1.96; + flux_errmin = min(flux_error,[],2); + flux_errmax = max(flux_error,[],2); + pp = mean(p_hl_hPa'); + h=fill([flux_bias+flux_ci flip(flux_bias-flux_ci)],... + [pp flip(pp)],'r'); + set(h,'facecolor',cols{ie}(1),'edgecolor','none','facealpha',alpha(ie)); + hold on + plot(flux_bias,pp,cols{ie},'linewidth',1.5); + end + set(gca,'ydir','reverse','yscale','log'); + ylim([0.01 1000]); + plot([0 0],[0.01 1000],'k:'); + ylabel('Pressure (hPa)'); + xlabel('Upwelling flux error (W m^{-2})'); + xlim(dflux_axis); + title('Errors in profiles') + if do_legend + set(legend(titles{ickd},'location','northeast'),'fontsize',legfontsize','box','on'); + end + text(xloc, yloc, '\bf(b)','units','normalized') + + subplot(3,3,5) + for ie = ickd + flux_error = ckd{ie}.flux_dn_sw(:,iprof) - ref.flux_dn_sw(:,iprof); + flux_bias = mean(flux_error'); + flux_ci = std(flux_error').*1.96; + flux_errmin = min(flux_error,[],2); + flux_errmax = max(flux_error,[],2); + pp = mean(p_hl_hPa'); + h=fill([flux_bias+flux_ci flip(flux_bias-flux_ci)],... + [pp flip(pp)],'r'); + set(h,'facecolor',cols{ie}(1),'edgecolor','none','facealpha',alpha(ie)); + hold on + plot(flux_bias,pp,cols{ie},'linewidth',1.5); + end + set(gca,'ydir','reverse','yscale','log'); + ylim([0.01 1000]); + plot([0 0],[0.01 1000],'k:'); + ylabel('Pressure (hPa)'); + xlabel('Downwelling flux error (W m^{-2})'); + xlim(dflux_axis); + text(xloc, yloc, '\bf(e)','units','normalized') + + subplot(3,3,3) + ileg = 1; + leg = {}; + symsurf = {'+','o'}; + for ie = ickd + mydiff = ckd{ie}.flux_up_sw(1,iprof)-ref.flux_up_sw(1,iprof); + err = sqrt(mean(mydiff.^2)); + leg{ileg} = [titles{ie} ' (RMSE=' num2str(err,'%0.2f') ' W m^{-2})']; + rmse_save(3,ie) = err; + rmse_save(4,ie) = mean(mydiff); + %plot(-1,-1,cols{ie},'linewidth',1.5); + ileg = ileg+1; + plot(ref.flux_up_sw(1,iprof), mydiff, ... + [cols{ie}(1) symsurf{ie}]); + hold on + end + %if do_legend + % set(legend(leg,'location','best'),'fontsize',legfontsize','box','on') + %end + xlabel('Reference TOA upwelling (W m^{-2})'); + ylabel('TOA upwelling error (W m^{-2})'); + xlim([0 250]); + plot(xlim,[0 0],'k:','linewidth',0.5); + ylim(dflux_axis); + title('Errors at surface and TOA'); + text(xloc, yloc, '\bf(c)','units','normalized') + + subplot(3,3,6) + ileg = 1; + leg = {}; + for ie = ickd + mydiff = ckd{ie}.flux_dn_sw(end,iprof)-ref.flux_dn_sw(end,iprof); + err = sqrt(mean(mydiff.^2)); + leg{ileg} = [titles{ie} ' (RMSE=' num2str(err,'%0.2f') ' W m^{-2})']; + rmse_save(5,ie) = err; + rmse_save(6,ie) = mean(mydiff); + ileg = ileg+1; + plot(ref.flux_dn_sw(end,iprof), mydiff, ... + [cols{ie}(1) symsurf{ie}]); + hold on + end + %if do_legend + % set(legend(leg,'location','best'),'fontsize',legfontsize') + %end + xlabel('Reference surface downwelling (W m^{-2})'); + ylabel('Surface downwelling error (W m^{-2})'); + plot(xlim,[0 0],'k:','linewidth',0.5); + ylim(dflux_axis); + xlim([0 1200]) + text(xloc, yloc, '\bf(f)','units','normalized') + + h=subplot(3,3,9); + set(h,'visible','off') + + xstart = -0.15; + text(xstart,0.95,['\bfScenario: ' scenario_title],'fontsize',12); + + if ickd_stats > 0 + for ie = ickd_stats + text(xstart,0.85,['\bfCKD model: ' titles{ie}],'fontsize',12); + ystart = 0.75; %-0.4.*(ie-1); + %text(xstart,ystart,['\bfRMS errors in ' titles{ie} ':'],'units','normalized'); + text(xstart,ystart,['Bias TOA upwelling: ' num2str(rmse_save(4,ie),'%0.2f') ' W m^{-2}'],'units','normalized'); + text(xstart,ystart-0.1,['Bias surface downwelling: ' num2str(rmse_save(6,ie),'%0.2f') ' W m^{-2}'],'units','normalized'); + text(xstart,ystart-0.2,['RMSE TOA upwelling: ' num2str(rmse_save(3,ie),'%0.2f') ' W m^{-2}'],'units','normalized'); + text(xstart,ystart-0.3,['RMSE surface downwelling: ' num2str(rmse_save(5,ie),'%0.2f') ' W m^{-2}'],'units','normalized'); + text(xstart,ystart-0.4,['RMSE heating rate (0.02-4 hPa): ' num2str(rmse_save(1,ie),'%0.3f') ' K d^{-1}'],'units','normalized'); + text(xstart,ystart-0.5,['RMSE heating rate (4-1100 hPa): ' num2str(rmse_save(2,ie),'%0.3f') ' K d^{-1}'],'units','normalized'); + + end + end + + drawnow +% print('-dpng','-painters','-r100',[combined_titles 'evaluation1_fluxes_' scenario '.png']); + + + + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_forcing_ecrad.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_forcing_ecrad.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/evaluate_forcing_ecrad.m (revision 6016) @@ -0,0 +1,69 @@ +% Evaluate the forcing calculated by ecRad for the CKDMIP scenarios +% against line-by-line + +DOMAIN='sw'; +DATASET='evaluation1'; +VAR=['flux_up_' DOMAIN]; +REFDIR='lbl_fluxes'; +EXPDIR='fluxes'; +MODELS={'rrtmg','ecckd'}; +LEGEND={'LBLRTM','RRTMG','ecCKD'}; + +gases={'co2','ch4','n2o'}; +labels={'CO2 concentration (ppmv)','CH4 concentration (ppbv)','N2O concentration (ppbv)'} +concs={[180 280 415 560 1120 2240],[350 700 1200 1921 2600 3500],[190 270 332 405 540]}; +ipresent = [3 4 3]; +if ~exist('ref','var') + for igas = 1:length(gases) + conc = concs{igas}; + for iconc = 1:length(conc) + if iconc == ipresent(igas) + scenario_str = 'present'; + else + scenario_str = [gases{igas} '-' num2str(conc(iconc))]; + end + ref{igas}{iconc} = loadnc([REFDIR '/ckdmip_' DATASET '_' DOMAIN '_fluxes_' scenario_str '.nc']); + data = ref{igas}{iconc}.(VAR)(1,:,:); + ref_mean_toa_up{igas}(iconc) = mean(data(:)); + end + end +end + +if ~exist('expt','var') + for igas = 1:length(gases) + conc = concs{igas}; + for iconc = 1:length(conc) + if iconc == ipresent(igas) + scenario_str = 'present'; + else + scenario_str = [gases{igas} '-' num2str(conc(iconc))]; + end + for iexpt = 1:length(MODELS) + expt{iexpt,igas}{iconc} = loadnc([EXPDIR '/ecrad-' MODELS{iexpt} '_' DATASET '_' DOMAIN '_fluxes_' scenario_str '.nc']); + data = expt{iexpt,igas}{iconc}.(VAR)(1,:,:); + expt_mean_toa_up{iexpt,igas}(iconc) = mean(data(:)); + end + end + end +end + +clf +set(gcf,'defaultlinelinewidth',1,'paperposition',[0.5 0.5 30 10]); +stys = {'b--','r-.'}; +for igas = 1:length(gases) + subplot(1,length(gases),igas) + conc = concs{igas}; + plot(conc, -ref_mean_toa_up{igas}+ref_mean_toa_up{igas}(ipresent(igas)),'k'); + hold on + for iexpt = 1:length(MODELS) + plot(conc, -expt_mean_toa_up{iexpt,igas}+expt_mean_toa_up{iexpt,igas}(ipresent(igas)),stys{iexpt}); + end + if igas == 1 + set(gca,'xscale','log'); + legend(LEGEND,'location','northwest'); + end + xlabel(labels{igas}) + ylabel('Instantaneous radiative forcing (W/m2)') + grid on +end + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/flatten_sza.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/flatten_sza.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/flatten_sza.m (revision 6016) @@ -0,0 +1,37 @@ +function out = flatten_sza(in, isza) +% Flatten the solar-zenith-angle and column dimensions + +if nargin < 2 + isza = 1:length(in.mu0); +end +nsza = length(isza); + +ncol = size(in.pressure_hl,2); +nz = size(in.pressure_hl,1); + +out.pressure_hl = in.pressure_hl(:,ceil([1:nsza*ncol]./nsza)); +if isfield(out,'temperature_hl') + out.temperature_hl = in.temperature_hl(:,ceil([1:nsza*ncol]./nsza)); +end +out.mu0 = repmat(in.mu0(isza), ncol, 1); +%out.reference_surface_mole_fraction = in.reference_surface_mole_fraction; +%out.mole_fraction_fl = in.mole_fraction_fl(:,:,ceil([1:nsza*ncol]./nsza)); +out.flux_up_sw = reshape(in.flux_up_sw(:,isza,:),[nz nsza*ncol]); +out.flux_dn_sw = reshape(in.flux_dn_sw(:,isza,:),[nz nsza*ncol]); +out.flux_dn_direct_sw = reshape(in.flux_dn_direct_sw(:,isza,:),[nz nsza*ncol]); +if isfield(in, 'band_flux_up_sw') + nband = size(in.band_flux_up_sw,1); + out.band_wavenumber1_sw = in.band_wavenumber1_sw; + out.band_wavenumber2_sw = in.band_wavenumber2_sw; + out.band_flux_up_sw = reshape(in.band_flux_up_sw(:,:,isza,:),[nband nz nsza*ncol]); + out.band_flux_dn_sw = reshape(in.band_flux_dn_sw(:,:,isza,:),[nband nz nsza*ncol]); + out.band_flux_dn_direct_sw = reshape(in.band_flux_dn_direct_sw(:,:,isza,:),[nband nz nsza*ncol]); +end +if isfield(in, 'spectral_flux_up_sw') + nspectral = size(in.spectral_flux_up_sw,1); + out.spectral_flux_up_sw = reshape(in.spectral_flux_up_sw(:,:,isza,:),[nspectral nz nsza*ncol]); + out.spectral_flux_dn_sw = reshape(in.spectral_flux_dn_sw(:,:,isza,:),[nspectral nz nsza*ncol]); + out.spectral_flux_dn_direct_sw = reshape(in.spectral_flux_dn_direct_sw(:,:,isza,:),[nspectral nz nsza*ncol]); +end + + Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/permute_sza.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/permute_sza.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ckdmip/permute_sza.m (revision 6016) @@ -0,0 +1,14 @@ +function out = permute_sza(in, sza) +% Permute the implicit solar-zenith-angle and column dimensions + +nsza = length(sza); +ncol = size(in.pressure_hl,2)./nsza; +nz = size(in.pressure_hl,1); + +vars = {'flux_dn_direct_sw','flux_dn_sw','flux_up_sw','pressure_hl'}; + +out = in; + +for ivar = 1:length(vars) + out.(vars{ivar}) = reshape(permute(reshape(in.(vars{ivar}),[nz ncol nsza]), [1 3 2]), [nz ncol*nsza]); +end Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/common/change_namelist.sh =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/common/change_namelist.sh (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/common/change_namelist.sh (revision 6016) @@ -0,0 +1,42 @@ +#!/bin/bash +# +# (C) Copyright 2014- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + +# Change entries in a Fortran namelist file +# Usage: change_namelist.sh infile.nam outfile.nam key1=value1 key2=value2 ... + +INFILE=$1 +OUTFILE=$2 +shift +shift + +SEDLINE="" +while [ "$1" ] +do + FOUND=$(echo $1 | grep '=') + if [ ! "$FOUND" ] + then + echo "Error in $0: argument '$1' not of the form key=value" + exit 1 + fi + KEY=$(echo $1 | awk -F= '{print $1}') + VALUE=$(echo $1 | awk -F= '{print $2}') + FOUND=$(grep $KEY $INFILE) + if [ ! "$FOUND" ] + then + echo "Error: $KEY not found in $INFILE" + exit 1 + fi + + SEDLINE="$SEDLINE -e s|^[[:space:]!]*"$KEY".*|"$KEY"="$VALUE",|" + shift +done +echo sed $SEDLINE $INFILE ">" $OUTFILE +sed $SEDLINE $INFILE > $OUTFILE Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/common/loadnc.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/common/loadnc.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/common/loadnc.m (revision 6016) @@ -0,0 +1,170 @@ +function [data, attribute] = load_nc_struct(nc_file, names); +% load_nc_struct -- Load NetCDF variables and attributes. +% +% [data, attribute] = load_nc_struct('nc_file') loads all variables of +% 'nc_file' into structure 'data' and all attributes into structure +% 'attribute', so variable 'X' could then be accessed using 'data.X' +% and attribute 'long_name' of 'X' could be accessed with +% 'attribute.X.long_name'. + +if nargin < 1, help(mfilename), return, end + +result = []; +if nargout > 0, data = []; attribute = []; end + +ncid = netcdf.open(nc_file, 'nowrite'); +if isempty(ncid), return, end +disp(['Loading ' nc_file]); + +if nargin < 2 + names = var_names(ncid); +end + +allnames = var_names(ncid); + +disp(['Variables:']); +for ii = 1:length(names) + if any(strcmp(names{ii},allnames)) + newname = names{ii}; + newname(find(newname == '-')) = '_'; + newname(find(newname == '.')) = '_'; + newname(find(newname == '@')) = '_'; + varid = netcdf.inqVarID(ncid, names{ii}); + + [varname, xtype,dimids,natts] = netcdf.inqVar(ncid, varid); + + [add_offset, scale_factor] = get_scaling(ncid, varid); + + if xtype == netcdf.getConstant('NC_FLOAT') | ~isempty(add_offset) | ~isempty(scale_factor) + missing_value = double(get_missing_value(ncid, varid)); + data.(newname) = double(netcdf.getVar(ncid, varid)); + else + missing_value = get_missing_value(ncid, varid); + data.(newname) = netcdf.getVar(ncid, varid); + end + + if ~isempty(missing_value) + data.(newname)(find(data.(newname) == missing_value)) = NaN; + end + + if ~isempty(scale_factor) + data.(newname) = data.(newname) .* scale_factor; + else + scale_factor = 1.0; + end + if ~isempty(add_offset) + data.(newname) = data.(newname) + add_offset; + else + add_offset = 0.0; + end + + if nargout > 1 + % Do attributes + for jj = 1:natts + % Check for underscore starting attribute name + attname = netcdf.inqAttName(ncid, varid, jj-1); + attname_mod = attname; + if strcmp(attname,'_FillValue') + attname_mod = 'FillValue_'; + elseif attname(1) == '_' + warning([newname '.' attname ' changed to ' names{ii} ':X' attname]); + attname = ['X' attname]; + end + eval(['attribute.' names{ii} '.' attname_mod ' = netcdf.getAtt(ncid, varid, attname);']); + end + end + + the_size = size(data.(newname)); + if the_size(end) == 1; + the_size = the_size(1:end-1); + end + + long_name = ''; + try + long_name = netcdf.getAtt(ncid, varid, 'long_name'); + long_name = clean_up_string(long_name); + long_name = ['"' long_name '"']; + end + units = ''; + try + units = netcdf.getAtt(ncid, varid, 'units'); + units = clean_up_string(units); + units = [' (' units ')']; + end + + names{ii} = newname; + + + size_str = num2str(the_size(1)); + for ii = 2:length(the_size); + size_str = [size_str ',' num2str(the_size(ii))]; + end + + newname = [newname ' (' size_str ')']; + + namefill = blanks(max(0,30-length(newname))); + + + if add_offset ~= 0.0 | scale_factor ~= 1.0 + scale_str = ' scaled'; + else + scale_str = ''; + end + disp([namefill newname ': ' long_name units scale_str]); + + end +end + +%if nargout > 1 + % Do global attributes +% disp('Global attributes:'); +% attnames = ncnames(att(f)); +%for ii = 1:length(attnames) +% if isempty(find(attnames{ii} == '/' | attnames{ii} == '-' | attnames{ii} == '+' | attnames{ii} == ' ') > 0) +% eval(['attr = f.' attnames{ii} '(:);']); +% if ischar(attr) +% attr = clean_up_string(attr); +% end +% eval(['attribute.global.' attnames{ii} ' = attr;']); +% namefill = blanks(max(0,14-length(attnames{ii}))); +% disp([namefill attnames{ii} ': ' num2str(attr)]); +% else +% disp(['Attribute name ' attnames{ii} ' incompatible with Matlab - not loaded.']) +% end +%end +%end +netcdf.close(ncid) + +function newstr = clean_up_string(oldstr) +newstr = num2str(oldstr); +if length(newstr) > 1 + if newstr(end-1) == '\' & newstr(end) == '0' + newstr = deblank(newstr(1:end-2)); + end +end + +function names = var_names(ncid) + [ndims,nvars,ngatts,unlimdimid] = netcdf.inq(ncid); + for ii = 0:nvars-1 + names{ii+1} = netcdf.inqVar(ncid, ii); + end + +function missing_value = get_missing_value(ncid, varid) + missing_value = []; + try + missing_value = netcdf.getAtt(ncid, varid, 'missing_value'); + catch exception + try + missing_value = netcdf.getAtt(ncid, varid, '_FillValue'); + end + end + +function [add_offset,scale_factor] = get_scaling(ncid, varid) + add_offset = []; + scale_factor = []; + try + add_offset = netcdf.getAtt(ncid, varid, 'add_offset'); + end + try + scale_factor = netcdf.getAtt(ncid, varid, 'scale_factor'); + end Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/Makefile (revision 6016) @@ -0,0 +1,83 @@ +INPUT_PROFILE = i3rc_mls_cumulus + +DRIVER = ../../bin/ecrad +CHANGENAM = ../common/change_namelist.sh +CONFIG = configI3RC.nam + +# Typing "make" will run radiation scheme in all possible ways +all: test + +test: $(INPUT_PROFILE)_sza.nc i3rc_spartacus i3rc_tripleclouds i3rc_mcica + + +# Create netcdf file containing duplicated profile but with varying +# solar zenith angle +$(INPUT_PROFILE)_sza.nc: $(INPUT_PROFILE).nc duplicate_profiles.sh + ./duplicate_profiles.sh $(INPUT_PROFILE).nc $(INPUT_PROFILE)_sza.nc + +i3rc_spartacus: $(INPUT_PROFILE)_sza.nc + $(CHANGENAM) $(CONFIG) config_3reg_3d.nam \ + n_regions=3 do_3d_effects=true do_3d_lw_multilayer_effects=true + $(CHANGENAM) $(CONFIG) config_3reg_1d.nam \ + n_regions=3 do_3d_effects=false do_3d_lw_multilayer_effects=false + $(CHANGENAM) $(CONFIG) config_3reg_3d_clustering.nam \ + n_regions=3 do_3d_effects=true effective_size_scaling=1.449 + $(DRIVER) config_3reg_1d.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_1d_out.nc + $(DRIVER) config_3reg_3d.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_3d_out.nc + $(DRIVER) config_3reg_3d_clustering.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_3d_clustering_out.nc +i3rc_spartacus2: $(INPUT_PROFILE)_sza.nc + $(CHANGENAM) $(CONFIG) config_2reg_3d.nam \ + n_regions=2 do_3d_effects=true do_3d_lw_multilayer_effects=true + $(DRIVER) config_2reg_3d.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_2reg_3d_out.nc +i3rc_spartacus_extra: $(INPUT_PROFILE)_sza.nc + $(CHANGENAM) $(CONFIG) config_3reg_3d_explicit.nam \ + sw_entrapment_name='"Explicit"' + $(CHANGENAM) $(CONFIG) config_3reg_3d_nonfractal.nam \ + sw_entrapment_name='"Non-fractal"' + $(CHANGENAM) $(CONFIG) config_3reg_3d_edgeonly.nam \ + sw_entrapment_name='"Edge-only"' + $(CHANGENAM) $(CONFIG) config_3reg_1d_explicit.nam \ + do_3d_effects=false sw_entrapment_name='"Explicit"' + $(CHANGENAM) $(CONFIG) config_3reg_1d_edgeonly.nam \ + do_3d_effects=false sw_entrapment_name='"Edge-only"' + $(CHANGENAM) $(CONFIG) config_3reg_3d_explicit_ohf1.nam \ + sw_entrapment_name='"Explicit"' overhang_factor=1.0 + $(DRIVER) config_3reg_3d_explicit.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_3d_explicit_out.nc + $(DRIVER) config_3reg_3d_nonfractal.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_3d_nonfractal_out.nc $(DRIVER) config_3reg_3d_edgeonly.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_3d_edgeonly_out.nc + $(DRIVER) config_3reg_1d_explicit.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_1d_explicit_out.nc + $(DRIVER) config_3reg_1d_edgeonly.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_1d_edgeonly_out.nc + $(DRIVER) config_3reg_3d_explicit_ohf1.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_3reg_3d_explicit_ohf1_out.nc + +i3rc_tripleclouds: $(INPUT_PROFILE)_sza.nc + $(CHANGENAM) $(CONFIG) config_tc.nam n_regions=3 \ + do_3d_effects=false sw_solver_name='"Tripleclouds"' lw_solver_name='"Tripleclouds"' + $(DRIVER) config_tc.nam $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_tc_out.nc + +i3rc_mcica: $(INPUT_PROFILE)_sza.nc + $(CHANGENAM) $(CONFIG) config_mcica.nam \ + sw_solver_name='"McICA"' lw_solver_name='"McICA"' + $(DRIVER) config_mcica.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_mcica_out.nc + +i3rc_print_entrapment: $(INPUT_PROFILE)_sza.nc + $(CHANGENAM) $(CONFIG) config_print_entr.nam \ + sw_entrapment_name='"Explicit"' \ + gas_model_name='"Monochromatic"' \ + sw_albedo=0.2 + $(DRIVER) config_print_entr.nam \ + $(INPUT_PROFILE)_sza.nc $(INPUT_PROFILE)_mono_entr_out.nc + +# Clean data files +clean: + rm -f $(INPUT_PROFILE)*_out.nc tmp*.nc radiative_properties*.nc \ + $(INPUT_PROFILE)*_sza.nc inputs.nc config_*.nam gmon.out Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/README =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/README (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/README (revision 6016) @@ -0,0 +1,9 @@ +This directory contains the 1D profile of the I3RC cumulus test case +used by Hogan et al. (2016). Typing "make test" in this directory runs +the various 1D and 3D configurations of ECRAD. The Matlab script +plot_i3rc.m can then be used to visualize the results, reproducing +three of the figures from Hogan et al. (2016). Note that you will need +to ensure that a reasonably up-to-date version of the "nco" tools are +available and in your path. This test involves running the +duplicate_profiles.sh script, which duplicates the single profile in +i3rc_mls_cumulus.nc, each with a different solar zenith angle. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/configI3RC.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/configI3RC.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/configI3RC.nam (revision 6016) @@ -0,0 +1,51 @@ +! Configuration namelists for ECRAD radiation code +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 8, ! Number of columns to process per thread +sw_albedo = 0.08, ! Override shortwave albedo +!lw_emissivity = 1.0, ! Override longwave emissivity +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 2, +solar_irradiance_override= 1366.0,! Total solar irradiance (W m-2) + +! Note that the overlap parameters computed from adjacent cloud +! fractions lead to the total cloud cover being overestimated, so an +! adjustment is used to go half-way to matching the true cloud cover +! of the scene (see Hogan et al. 2016) +overlap_decorr_length_scaling=1.13, +effective_size_scaling = 1.0, +/ +! +! The following namelist controls the behaviour of the ECRAD +! radiation code +! +&radiation +use_general_cloud_optics = false, +use_general_aerosol_optics = false, +do_3d_effects = true, ! Represent 3D effects? +do_lw_side_emissivity = true, +n_regions = 3, ! Number of regions (2=clear+cloudy, 3=clear+2cloudy) +do_3d_lw_multilayer_effects = true, +min_cloud_effective_size= 1.0e-6, ! Minimum cloud effective size, for stability (m) +sw_entrapment_name = "Maximum", ! "Maximum" = old behaviour ("Explicit" is the best) +overhang_factor = 1.0, +directory_name = "../../data", ! Location of configuration files +sw_solver_name = "SPARTACUS", +lw_solver_name = "SPARTACUS", +cloud_pdf_shape_name = "Gamma", +overhead_sun_factor = 0.06, +do_lw_cloud_scattering = true, ! Clouds scatter in the longwave? +cloud_inhom_decorr_scaling = 0.5, +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 1, +use_aerosols = false, ! Include aerosols in radiation calculations? +do_save_spectral_flux = false, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +gas_model_name = "RRTMG-IFS", ! Gas model +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/duplicate_profiles.sh =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/duplicate_profiles.sh (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/duplicate_profiles.sh (revision 6016) @@ -0,0 +1,33 @@ +#!/bin/bash -e +# +# (C) Copyright 2014- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + +# Duplicate profiles with solar zenith angles varying from 0 to 90 degrees +# You need to have the nco netcdf tools in your PATH + +INPUT=$1 +OUTPUT=$2 + +NSZA=46 +COS_SZA='1.0,0.999391,0.997564,0.994522,0.990268,0.984808,0.978148,0.970296,0.961262,0.951057,0.939693,0.927184,0.913545,0.898794,0.882948,0.866025,0.848048,0.829038,0.809017,0.788011,0.766044,0.743145,0.71934,0.694658,0.669131,0.642788,0.615661,0.587785,0.559193,0.529919,0.5,0.469472,0.438371,0.406737,0.374607,0.34202,0.309017,0.275637,0.241922,0.207912,0.173648,0.139173,0.104528,0.0697565,0.0348995,0.01' +#NSZA=2 +#COS_SZA='1,0.1' + +# Check for existence of NCO commands +command -v ncks >/dev/null 2>&1 || { \ + echo "###########################################################" ; \ + echo "### Error: NCO commands (ncks etc) needed but not found ###" ; \ + echo "###########################################################" ; \ + exit 1; } + +ncks -O --mk_rec_dmn column $INPUT tmp0.nc +ncrcat -O -n $NSZA,1,0 tmp0.nc tmp_$OUTPUT +ncap2 -O -s "cos_solar_zenith_angle(:)={$COS_SZA}" tmp_$OUTPUT $OUTPUT +rm tmp0.nc tmp_$OUTPUT Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/herrorbar.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/herrorbar.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/herrorbar.m (revision 6016) @@ -0,0 +1,158 @@ +function hh = herrorbar(x, y, l, u, symbol) +%HERRORBAR Horizontal Error bar plot. +% HERRORBAR(X,Y,L,R) plots the graph of vector X vs. vector Y with +% horizontal error bars specified by the vectors L and R. L and R contain the +% left and right error ranges for each point in X. Each error bar +% is L(i) + R(i) long and is drawn a distance of L(i) to the right and R(i) +% to the right the points in (X,Y). The vectors X,Y,L and R must all be +% the same length. If X,Y,L and R are matrices then each column +% produces a separate line. +% +% HERRORBAR(X,Y,E) or HERRORBAR(Y,E) plots X with error bars [X-E X+E]. +% HERRORBAR(...,'LineSpec') uses the color and linestyle specified by +% the string 'LineSpec'. See PLOT for possibilities. +% +% H = HERRORBAR(...) returns a vector of line handles. +% +% Example: +% x = 1:10; +% y = sin(x); +% e = std(y)*ones(size(x)); +% herrorbar(x,y,e) +% draws symmetric horizontal error bars of unit standard deviation. +% +% This code is based on ERRORBAR provided in MATLAB. +% +% See also ERRORBAR + +% Jos van der Geest +% email: jos@jasen.nl +% +% File history: +% August 2006 (Jos): I have taken back ownership. I like to thank Greg Aloe from +% The MathWorks who originally introduced this piece of code to the +% Matlab File Exchange. +% September 2003 (Greg Aloe): This code was originally provided by Jos +% from the newsgroup comp.soft-sys.matlab: +% http://newsreader.mathworks.com/WebX?50@118.fdnxaJz9btF^1@.eea3ff9 +% After unsuccessfully attempting to contact the orignal author, I +% decided to take ownership so that others could benefit from finding it +% on the MATLAB Central File Exchange. + +if min(size(x))==1, + npt = length(x); + x = x(:); + y = y(:); + if nargin > 2, + if ~isstr(l), + l = l(:); + end + if nargin > 3 + if ~isstr(u) + u = u(:); + end + end + end +else + [npt,n] = size(x); +end + +if nargin == 3 + if ~isstr(l) + u = l; + symbol = '-'; + else + symbol = l; + l = y; + u = y; + y = x; + [m,n] = size(y); + x(:) = (1:npt)'*ones(1,n);; + end +end + +if nargin == 4 + if isstr(u), + symbol = u; + u = l; + else + symbol = '-'; + end +end + +if nargin == 2 + l = y; + u = y; + y = x; + [m,n] = size(y); + x(:) = (1:npt)'*ones(1,n);; + symbol = '-'; +end + +u = abs(u); +l = abs(l); + +if isstr(x) | isstr(y) | isstr(u) | isstr(l) + error('Arguments must be numeric.') +end + +if ~isequal(size(x),size(y)) | ~isequal(size(x),size(l)) | ~isequal(size(x),size(u)), + error('The sizes of X, Y, L and U must be the same.'); +end + +if strcmp(get(gca,'ylimmode'),'manual') + my_ylim = ylim; + index = find(y >= my_ylim(1) & y <= my_ylim(2)); + tee = (max(y(index)) - min(y(index)))/100; +else + tee = (max(y(:))-min(y(:)))/100 % make tee .02 x-distance for error bars +end +% changed from errorbar.m +xl = x - l; +xr = x + u; +ytop = y + tee; +ybot = y - tee; +n = size(y,2); +% end change + +% Plot graph and bars +hold_state = ishold; +cax = newplot; +next = lower(get(cax,'NextPlot')); + +% build up nan-separated vector for bars +% changed from errorbar.m +xb = zeros(npt*9,n); +xb(1:9:end,:) = xl; +xb(2:9:end,:) = xl; +xb(3:9:end,:) = NaN; +xb(4:9:end,:) = xl; +xb(5:9:end,:) = xr; +xb(6:9:end,:) = NaN; +xb(7:9:end,:) = xr; +xb(8:9:end,:) = xr; +xb(9:9:end,:) = NaN; + +yb = zeros(npt*9,n); +yb(1:9:end,:) = ytop; +yb(2:9:end,:) = ybot; +yb(3:9:end,:) = NaN; +yb(4:9:end,:) = y; +yb(5:9:end,:) = y; +yb(6:9:end,:) = NaN; +yb(7:9:end,:) = ytop; +yb(8:9:end,:) = ybot; +yb(9:9:end,:) = NaN; +% end change + + +[ls,col,mark,msg] = colstyle(symbol); if ~isempty(msg), error(msg); end +symbol = [ls mark col]; % Use marker only on data part +esymbol = ['-' col]; % Make sure bars are solid + +h = plot(xb,yb,esymbol); hold on +h = [h;plot(x,y,symbol)]; + +if ~hold_state, hold off; end + +if nargout>0, hh = h; end Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/plot_entrapment.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/plot_entrapment.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/plot_entrapment.m (revision 6016) @@ -0,0 +1,75 @@ +% This script plots horizontal migration distances predicted by +% SPARTACUS's "explicit entrapment" option, but it requires (1) the +% whole code to have been compiled with "make +% PRINT_ENTRAPMENT_DATA=1", and (2) "make i3rc_print_entrapment" to +% have been run in this directory. This produces the fort.10[12] files +% containing the migration distances. + +xdata = load('fort.101'); +fdata = load('fort.102'); +in = loadnc('i3rc_mls_cumulus_sza.nc'); +out= loadnc('i3rc_mls_cumulus_mono_entr_out.nc'); + +z=in.height_hl(1:end-1,1)./1000; +zh=in.height_hl(:,1)./1000; +[nlev,ncol] = size(in.cloud_fraction); + +x_region_direct = flip(reshape(xdata(:,3:5),nlev,ncol,3),1); +x_region_diffuse = flip(reshape(xdata(:,6:8),nlev,ncol,3),1); +n_scat_region = flip(reshape(xdata(:,9:11),nlev,ncol,3),1); + +x_diffuse_scaling = sqrt(2.0 * (n_scat_region+exp(-n_scat_region)-1.0) + 1.0e-16) ./ (n_scat_region+1.0e-8); + +tot_region_diffuse = sqrt(2.0).*x_region_diffuse.*x_diffuse_scaling; +tot_region_direct = sqrt(x_region_direct.^2 + (x_region_diffuse.*x_diffuse_scaling).^2); + +flux_region_direct = reshape(fdata(:,3:5),nlev,ncol,3); +flux_region_dn_diffuse = reshape(fdata(:,6:8),nlev,ncol,3); + +flux_direct = squeeze(sum(flux_region_direct,3)); +flux_dn_diffuse = squeeze(sum(flux_region_dn_diffuse,3)); + +ind = find(flux_region_dn_diffuse(:,1,1) < 1.0e-8); +flux_region_dn_diffuse(ind,:,1) = NaN; + +xdirect = squeeze(sum(flux_region_direct.*tot_region_direct,3) ... + ./sum(flux_region_direct,3)); +xdiffuse = squeeze(sum(flux_region_dn_diffuse.*tot_region_diffuse,3) ... + ./sum(flux_region_dn_diffuse,3)); + +sza = acosd(in.cos_solar_zenith_angle); + +isza = [1 16 31 41]; +isza = [1 23 36]; + +xmax = 12; +zmax = 4; + +figure(2) +clf +for ii = 1:length(isza) +subplot(2,2,ii) +%plot(squeeze(x_region_direct(:,isza(ii),:)),z); +%plot(squeeze(x_region_diffuse(:,isza(ii),:)),z,'--'); + +plot(xdirect(:,isza(ii))./1000,z,'r') +hold on +plot(xdiffuse(:,isza(ii))./1000,z,'b'); +ylim([0 zmax]); +xlim([0 xmax]) +xlabel('Horizontal distance travelled (km)'); +ylabel('Height (km)'); +title(['(' 'a'-1+ii ') SZA=' num2str(sza(isza(ii))) '\circ']) +if ii == 1 + legend('Direct','Diffuse','location','southeast') +end +grid on +end + +subplot(2,2,4) +zz = 0.5.*(zh(1:end-1)+zh(2:end)); +plot(in.cloud_fraction, zz,'k'); +ylim([0 zmax]) +xlabel('Cloud fraction'); +ylabel('Height (km)'); +grid on Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/plot_i3rc.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/plot_i3rc.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/plot_i3rc.m (revision 6016) @@ -0,0 +1,275 @@ +% Location of loadnc.m +path(path, '../common') + +do_plot_sw_libradtran = 1; +do_plot_sw_spartacus_extras = 0; % Need to have run "make i3rc_spartacus_extra" + +% Load libRadTran benchmark +load i3rc_mls_cumulus_LIBRADTRAN + +% Load ECRAD/SPARTACUS cases +sp_code = 'i3rc_mls_cumulus'; +scases = {[sp_code '_ECRAD_ICA_OUT.nc'],... % Stored result of running ECRAD in ICA mode + [sp_code '_3reg_3d_out.nc'],... + [sp_code '_3reg_3d_clustering_out.nc'],... + [sp_code '_mcica_out.nc'],... + [sp_code '_tc_out.nc'],... + [sp_code '_3reg_1d_out.nc']}; +id_ica = 1; +id_1d = 6; +id_3d = 2; % Maximum entrapment +%id_3d = 7; % Computed entrapment +ecrad_sw_list = [id_ica id_3d 4 5]; +ecrad_legend = {'ECRAD ICA','ECRAD SPARTACUS','ECRAD McICA','ECRAD Tripleclouds'}; +ecrad_styles = {'b--','r--','g--','c--'}; + +if do_plot_sw_spartacus_extras + scases(end+1:end+6)={[sp_code '_3reg_3d_computed_out.nc'],... + [sp_code '_3reg_3d_minimum_out.nc'],... + [sp_code '_3reg_1d_computed_out.nc'],... + [sp_code '_3reg_1d_minimum_out.nc'],... + [sp_code '_3reg_3d_computedleast_out.nc'],... + [sp_code '_3reg_3d_fractal_out.nc']}; + ecrad_sw_list = [id_3d 7 8 id_1d 9 10 5 11 12]; + ecrad_legend = {'SPARTACUS 3D Max','SPARTACUS 3D Comp','SPARTACUS 3D Min',... + 'SPARTACUS 1D Max','SPARTACUS 1D Comp','SPARTACUS 1D Min',... + 'Tripleclouds','SPARTACUS 3D Comp least','SPARTACUS 3D Fract'}; + ecrad_styles = {'r--','r-','r-.','b--','bo','bx','c--','m--','m-.'}; + id_3d_min = 8; +end + +% Factor for conversion to heating rates in K day-1 +ff = 24.*3600.*(9.81./1004); +for icase = 1:length(scases) + sp{icase} = loadnc([scases{icase}]); + sp{icase}.hr_sw = ff.*diff(sp{icase}.flux_up_sw-sp{icase}.flux_dn_sw)./diff(sp{icase}.pressure_hl); + sp{icase}.hr_lw = ff.*diff(sp{icase}.flux_up_lw-sp{icase}.flux_dn_lw)./diff(sp{icase}.pressure_hl); +end + +% Load input data +sp_input = loadnc([sp_code '_sza.nc']); +sp_sza = acosd(sp_input.cos_solar_zenith_angle); + + +sza_axis = [0 90]; +sza_tick = [0:15:90]; + +% Plot shortwave 3D effect as shown in Fig. 4 of Hogan et al. (2016) +figure(1) +clf +set(gcf,'defaultlinelinewidth',1,'paperposition',[0.25 2.5 21 16]); + +subplot(2,2,1); +if do_plot_sw_libradtran + plot(sza,up_toa_1D,'b'); + hold on + errorbar(sza,up_toa_3D,up_toa_std_3D,'r'); +end + +for ii = 1:length(ecrad_sw_list) + iecrad = ecrad_sw_list(ii); + plot(sp_sza,sp{iecrad}.flux_up_sw(1,:),ecrad_styles{ii}); + hold on +end + +plot(sp_sza,sp{1}.flux_up_sw_clear(1,:),'k'); + +xlim(sza_axis); +ylabel('TOA upwelling flux (W m^{-2})'); +text(0,1.02,' \bf(a)','verticalalignment','bottom','units','normalized'); +ylim([0 300]); +grid on +set(gca,'xtick',sza_tick); +xlabel('Solar zenith angle (\circ)') +ylim([0 250]); +if do_plot_sw_libradtran + leg = {'libRadtran ICA (DISORT)',... + 'libRadtran 3D (MYSTIC)'}; + leg([1:length(ecrad_legend)]+2) = ecrad_legend; +else + leg = ecrad_legend; +end +leg{length(leg)+1} = 'Clear sky'; +hh=legend(leg,3); +set(hh,'fontsize',7) + +subplot(2,2,2); +plot(sza,dn_direct_surf_1D./cosd(sza),'b'); +hold on +errorbar(sza,dn_direct_surf_3D./cosd(sza), dn_direct_surf_std_3D./cosd(sza),'r'); + +for ii = 1:length(ecrad_sw_list) + iecrad = ecrad_sw_list(ii); + plot(sp_sza,sp{iecrad}.flux_dn_direct_sw(end,:)./cosd(sp_sza'),ecrad_styles{ii}); +end + +plot(sp_sza,sp{id_3d}.flux_dn_direct_sw_clear(end,:)./cosd(sp_sza'),'k'); + +xlim(sza_axis); +ylim([0 1100]); +grid on +set(gca,'xtick',sza_tick); +xlabel('Solar zenith angle (\circ)') +ylabel('Direct flux in direction of sun (W m^{-2})'); +h=legend(leg,3); +set(h,'fontsize',7) +text(0,1.02,' \bf(b)','verticalalignment','bottom','units','normalized'); + +up1dinterp = interp1(sza,up_toa_1D,sp_sza)'; + +subplot(2,2,3) +errorbar(sza,... + 100.*(up_toa_3D-up_toa_1D)./(up_toa_1D-sw_up_clear(end,:)),... + 100.*(up_toa_std_3D)./(up_toa_1D-sw_up_clear(end,:)),... + 'r'); +hold on +effect_3d = 100.*(sp{id_3d}.flux_up_sw(1,:)-sp{id_ica}.flux_up_sw(1,:)) ... + ./(sp{id_ica}.flux_up_sw(1,:)-sp{id_3d}.flux_up_sw_clear(1,:)); +effect_3d(end) = NaN; +plot(sp_sza,effect_3d,'r--'); + +if do_plot_sw_spartacus_extras + effect_edge = 100.*(sp{id_3d_min}.flux_up_sw(1,:)-sp{id_ica}.flux_up_sw(1,:)) ... + ./(sp{id_ica}.flux_up_sw(1,:)-sp{id_3d_min}.flux_up_sw_clear(1,:)); + effect_edge(end) = NaN; + plot(sp_sza,effect_edge,'r-.'); +end + +xlim(sza_axis); +ylim([-40 140]); +set(gca,'xtick',sza_tick); +ylabel('3D change to cloud radiative effect (%)'); +xlabel('Solar zenith angle (\circ)') +text(0,1.02,' \bf(d)','verticalalignment','bottom','units','normalized'); +grid on +if do_plot_sw_spartacus_extras + h=legend('libRadtran','SPARTACUS','SPARTACUS edge only',2); +else + h=legend('libRadtran','SPARTACUS',2); +end +set(h,'fontsize',8) + +subplot(2,2,4) +errorbar(sza,-(up_toa_3D-up_toa_1D),up_toa_std_3D,'r'); +hold on +effect_3d = sp{id_3d}.flux_up_sw(1,:)-sp{id_ica}.flux_up_sw(1,:); +effect_3d(end) = NaN; +plot(sp_sza,-effect_3d,'r--'); + +if do_plot_sw_spartacus_extras + effect_edge = sp{id_3d_min}.flux_up_sw(1,:)-sp{id_ica}.flux_up_sw(1,:); + effect_edge(end) = NaN; + plot(sp_sza,-effect_edge,'r-.'); +end + +xlim(sza_axis); +ylim([-25 30]); +set(gca,'xtick',sza_tick); +ylabel('3D change to cloud radiative effect (W m^{-2})'); +xlabel('Solar zenith angle (\circ)') +text(0,1.02,' \bf(c)','verticalalignment','bottom','units','normalized'); +grid on +if do_plot_sw_spartacus_extras + h=legend('libRadtran','SPARTACUS','SPARTACUS edge only',2); +else + h=legend('libRadtran','SPARTACUS',2); +end + +set(h,'fontsize',8) + +% Write selected cloud radiative forcings to the terminal window +isza = [1 6]; +sza(isza) + +crf_mystic_1d_toa = -(up_toa_1D(isza)-sw_up_clear(end,isza)) +crf_mystic_3deffect = up_toa_1D(isza)-up_toa_3D(isza) + +crf_spartacus_1d_toa = interp1(sp_sza,-sp{id_ica}.flux_up_sw(1,:) + sp{id_ica}.flux_up_sw_clear(1,:), sza(isza)) +crf_spartacus_3deffect = interp1(sp_sza,-effect_3d(:), sza(isza)) + +crf_mystic_3deffect_percentage = 100.* crf_mystic_3deffect ./ crf_mystic_1d_toa +crf_spartacus_3deffect_percentage = 100.* crf_spartacus_3deffect ./ crf_spartacus_1d_toa + + +% Plot the 3D impact on shortwave heating rates as in Fig. 5 of Hogan et al. (2016) +figure(2) +clf +set(gcf,'units','inches','paperposition',[0.25 0.25 10 9],'defaultlinelinewidth',1); + +sza_map = [1 9 16 24 31 38 41 45]; +sza_map = {1, [8 9], 16, [23 24], 31, [38 39], 41, 45}; + +for isza = [1 5]; %[2 6] + sza(isza) + hr_sp_clear = ff.*diff(sp{id_3d}.flux_up_sw_clear-sp{id_3d}.flux_dn_sw_clear)./diff(sp{id_3d}.pressure_hl); + ii = sza_map{isza}; + z_mid_sp = (sp_input.height_hl(1:end-1,1) + sp_input.height_hl(2:end,1))./2; + + plot(dat1D{isza}.hr,dat1D{isza}.z_mid,'b') + axis([1 4.5 0 3]); + hold on + + plot(dat3D{isza}.hr,dat3D{isza}.z_mid,'r') + if isza == 5 + errs=nan.*dat3D{isza}.hr_std; + ind = [2 4 6 16 26 36 43:2:49]; + ind = [1:5 8:5:38 42:50]; + errs(ind) = dat3D{isza}.hr_std(ind); + herrorbar(dat3D{isza}.hr,dat3D{isza}.z_mid,errs,'r') + end + + SPARTACUS_SZA = sp_sza(ii); + plot(mean(sp{id_ica}.hr_sw(:,ii),2),z_mid_sp./1000,'b--'); + plot(mean(sp{id_3d}.hr_sw(:,ii),2),z_mid_sp./1000,'r--'); + plot(mean(hr_sp_clear(:,ii),2),z_mid_sp./1000,'k-'); +end + +axis([1 4.5 0 3]); +xlabel('Shortwave heating rate (K d^{-1})'); +ylabel('Height (km)'); +text(1.25,3,['\theta_0=' num2str(sza(isza)) '\circ'],'verticalalignment','bottom') +text(2.4,3,'\theta_0=0\circ','verticalalignment','bottom') +h=legend(leg{[1 2 3 4 end]},4); +set(h,'fontsize',7); + +% Plot longwave 3D effect on heating rates as shown in Fig. 6 of Hogan +% et al. (2016) +p = interp1(sp_input.height_hl(:,1),sp_input.pressure_hl(:,1),z.*1000); +z_mid = 0.5.*(z(1:end-1)+z(2:end)); + +hr_clear = ff.*diff(lw_up_clear-lw_dn_clear)./diff(p); +hr_1d = ff.*diff(d{1}.lw_up-d{1}.lw_dn)./diff(p); +hr_3d = ff.*diff(d{2}.lw_up-d{2}.lw_dn)./diff(p); +hr_sp_3d = ff.*diff(sp{id_3d}.flux_up_lw-sp{id_3d}.flux_dn_lw)./diff(sp{id_3d}.pressure_hl); +hr_sp_1d = ff.*diff(sp{id_1d}.flux_up_lw-sp{id_1d}.flux_dn_lw)./diff(sp{id_1d}.pressure_hl); +hr_sp_clear = ff.*diff(sp{id_1d}.flux_up_lw_clear-sp{id_1d}.flux_dn_lw_clear)./diff(sp{id_1d}.pressure_hl); +hr_sp_3d_clustering = ff.*diff(sp{3}.flux_up_lw-sp{3}.flux_dn_lw)./diff(sp{3}.pressure_hl); + +cols = 'brmg'; +cols_clear = 'km'; + +figure(3) +clf +set(gcf,'units','inches','paperposition',[0.25 0.25 10 9],'defaultlinelinewidth',1); + +plot(smooth1D(hr_clear),z_mid,'k'); +hold on +plot(smooth1D(hr_1d),z_mid,cols(1)); +plot(smooth1D(hr_3d),z_mid,cols(2)); +plot(smooth1D(hr_sp_clear(:,1)),z_mid_sp./1000,'k--'); +plot(smooth1D(hr_sp_1d(:,1)),z_mid_sp./1000,[cols(1) '--']); +plot(smooth1D(hr_sp_3d_clustering(:,1)),z_mid_sp./1000,[cols(2) '--']); +h=plot(smooth1D(hr_sp_3d(:,1)),z_mid_sp./1000,[cols(3) '--']); +if cols(3) == 'm' + set(h,'color',[1 0.65 0]); +end + +ylim([0 3]); + +xlabel('Longwave heating rate (K d^{-1})'); +ylabel('Height (km)'); +xlim([-5 -1]); +h=legend('libRadtran clear','libRadtran ICA (DISORT)','libRadtran 3D (MYSTIC)',... + 'SPARTACUS clear','SPARTACUS 1D','SPARTACUS 3D clust', ... + 'SPARTACUS 3D no clust',3); +set(h,'fontsize',6); Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/smooth1D.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/smooth1D.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/i3rc/smooth1D.m (revision 6016) @@ -0,0 +1,4 @@ +function [Ds] = smooth1D(D) +Ds=D; +s = length(Ds); +Ds(2:s-1) = 0.25 .* (D(1:s-2)+D(3:s)) + 0.5 .* D(2:s-1); Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/Makefile (revision 6016) @@ -0,0 +1,209 @@ +INPUT = ecrad_meridian + +#DRIVER = totalview ../../bin/ecrad -a +DRIVER = ../../bin/ecrad +IFS_DRIVER = ../../bin/ecrad_ifs +IFS_DRIVER_BLOCKED = ../../bin/ecrad_ifs_blocked +CHANGENAM = ../common/change_namelist.sh + +# Various configuration files corresponding to cycles of ECMWF's +# Integrated Forecasting System (IFS) +#CONFIG = configCY43R3.nam +#CONFIG = configCY46R1.nam +#CONFIG = configCY47R1.nam +#CONFIG = configCY47R3.nam +CONFIG = configCY49R1.nam +CONFIG_ECCKD = configCY49R1_ecckd.nam +CONFIG_MIXED = configCY49R1_mixed.nam + +# Typing "make" will run radiation scheme on IFS profiles +all: test + +test: test_orig test_ecckd + +# Tests of CY47R1 configuration with RRTMG gas optics model and +# various solvers +test_orig: test_default test_noaer test_expexp test_vec test_tripleclouds test_spartacus \ + test_spartacus_maxentr + +# Tests of ecCKD gas optics model and various solvers +test_ecckd: test_ecckd_mcica test_ecckd_tc test_ecckd_tc_noaer test_ecckd_spartacus + +# Default IFS settings: McICA solver with exponential-exponential +# overlap +test_default: + $(DRIVER) $(CONFIG) $(INPUT).nc $(INPUT)_default_out.nc + +test_ifsdriver: + $(CHANGENAM) $(CONFIG) config_net.nam do_save_net_fluxes=true do_write_double_precision=true \ + sw_solver_name='"Tripleclouds"' lw_solver_name='"Tripleclouds"' + $(IFS_DRIVER) config_net.nam $(INPUT).nc $(INPUT)_ifsdriver_out.nc | tee $(INPUT)_ifsdriver_out.log + $(DRIVER) config_net.nam $(INPUT).nc $(INPUT)_net_out.nc | tee $(INPUT)_net_out.log + +test_ifsdriver_blocked: + $(CHANGENAM) $(CONFIG) config_net.nam do_save_net_fluxes=true do_write_double_precision=true \ + sw_solver_name='"Tripleclouds"' lw_solver_name='"Tripleclouds"' + $(IFS_DRIVER_BLOCKED) config_net.nam $(INPUT).nc $(INPUT)_ifsdriver_blocked_out.nc | tee $(INPUT)_ifsdriver_blocked_out.log + $(DRIVER) config_net.nam $(INPUT).nc $(INPUT)_net_out.nc | tee $(INPUT)_net_out.log + +# Turn off aerosols +test_noaer: + $(CHANGENAM) $(CONFIG) config_noaer.nam \ + use_aerosols=false + $(DRIVER) config_noaer.nam $(INPUT).nc $(INPUT)_noaer_out.nc + +# Older exponential-exponential overlap +test_expexp: + $(CHANGENAM) $(CONFIG) config_expexp.nam \ + overlap_scheme_name='"Exp-Exp"' + $(DRIVER) config_expexp.nam $(INPUT).nc $(INPUT)_expexp_out.nc + +# Tripleclouds solver with exponential-random overlap +test_tripleclouds: + $(CHANGENAM) $(CONFIG) config_tc.nam \ + sw_solver_name='"Tripleclouds"' lw_solver_name='"Tripleclouds"' + $(DRIVER) config_tc.nam $(INPUT).nc $(INPUT)_tc_out.nc + +# Longwave scattering; since 46R1 this is the default +test_lwscat: + $(CHANGENAM) $(CONFIG) config_lwscat.nam \ + do_lw_cloud_scattering="true" + $(DRIVER) config_lwscat.nam $(INPUT).nc $(INPUT)_lwscat_out.nc + +# 3D radiative transfer +test_spartacus: + $(CHANGENAM) $(CONFIG) config_spartacus.nam \ + sw_solver_name='"SPARTACUS"' lw_solver_name='"SPARTACUS"' \ + do_3d_effects="true" \ + do_sw_delta_scaling_with_gases="false" + $(DRIVER) config_spartacus.nam $(INPUT).nc $(INPUT)_spartacus_out.nc + +# 3D radiative transfer using the older "maximum entrapment" +test_spartacus_maxentr: + $(CHANGENAM) $(CONFIG) config_spartacus_maxentr.nam \ + sw_solver_name='"SPARTACUS"' lw_solver_name='"SPARTACUS"' \ + do_3d_effects="true" \ + sw_entrapment_name='"Maximum"' \ + do_sw_delta_scaling_with_gases="false" + $(DRIVER) config_spartacus_maxentr.nam $(INPUT).nc $(INPUT)_spartacus_maxentr_out.nc + +# "Cloudless" solver +test_cloudless: + $(CHANGENAM) $(CONFIG) config_cloudless.nam \ + use_aerosols=false \ + sw_solver_name='"Cloudless"' lw_solver_name='"Cloudless"' + $(DRIVER) config_cloudless.nam $(INPUT).nc $(INPUT)_cloudless_out.nc + +# Exponential-random overlap with "vectorizable" cloud generator +test_vec: + $(CHANGENAM) $(CONFIG) config_vec.nam use_vectorizable_generator=true + $(DRIVER) config_vec.nam $(INPUT).nc $(INPUT)_vec_out.nc + + +### The following targets use the $CONFIG_ECCKD configuration file ### + +# ecCKD gas optics scheme (note that default solver is Tripleclouds) +test_ecckd_mcica: + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_mcica.nam \ + sw_solver_name='"McICA"' lw_solver_name='"McICA"' + $(DRIVER) config_ecckd_mcica.nam $(INPUT).nc $(INPUT)_ecckd_mcica_out.nc + +# ecCKD with Tripleclouds solver (default) +test_ecckd_tc: + $(DRIVER) $(CONFIG_ECCKD) $(INPUT).nc $(INPUT)_ecckd_tc_out.nc + +test_mixed_gas: + $(DRIVER) $(CONFIG_MIXED) $(INPUT).nc $(INPUT)_sw_ecckd_lw_ecckd_out.nc + $(CHANGENAM) $(CONFIG_MIXED) config_mix.nam lw_gas_model_name='"RRTMG-IFS"' do_cloud_aerosol_per_lw_g_point=false + $(DRIVER) config_mix.nam $(INPUT).nc $(INPUT)_sw_ecckd_lw_rrtmg_out.nc + $(CHANGENAM) $(CONFIG_MIXED) config_mix.nam sw_gas_model_name='"RRTMG-IFS"' do_cloud_aerosol_per_sw_g_point=false + $(DRIVER) config_mix.nam $(INPUT).nc $(INPUT)_sw_rrtmg_lw_ecckd_out.nc + $(CHANGENAM) $(CONFIG_MIXED) config_mix.nam sw_gas_model_name='"RRTMG-IFS"' lw_gas_model_name='"RRTMG-IFS"' do_cloud_aerosol_per_lw_g_point=false do_cloud_aerosol_per_sw_g_point=false + $(DRIVER) config_mix.nam $(INPUT).nc $(INPUT)_sw_rrtmg_lw_rrtmg_out.nc + +# ecCKD with no aerosols +test_ecckd_noaer: + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_noaer.nam \ + use_aerosols=false + $(DRIVER) config_ecckd_noaer.nam $(INPUT).nc $(INPUT)_ecckd_noaer_out.nc + +# Test the different ways that aerosol optical properties can be +# averaged, outputing the aerosol properties in each gas-optics +# spectral interval, producing the following: +# aerosol_optics_rrtmg.nc: RRTMG gas optics, aerosol properties from band-wise file +# aerosol_optics_ecckd.nc: ecCKD gas optics, aerosol properties from high-res file +# aerosol_optics_rrtmg.nc: RRTMG gas optics, aerosol properties from high-res file +# aerosol_optics_ecckd.nc: ecCKD gas optics, aerosol properties from band-wise file +test_aerosol_averaging: + $(CHANGENAM) $(CONFIG) config_rrtmg_saveaer.nam \ + do_save_aerosol_optics=true + $(DRIVER) config_rrtmg_saveaer.nam $(INPUT).nc $(INPUT)_rrtmg_saveaer_out.nc + mv aerosol_optics.nc aerosol_optics_rrtmg.nc + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_saveaer.nam \ + do_save_aerosol_optics=true + $(DRIVER) config_ecckd_saveaer.nam $(INPUT).nc $(INPUT)_ecckd_saveaer_out.nc + mv aerosol_optics.nc aerosol_optics_ecckd.nc + $(CHANGENAM) $(CONFIG) config_rrtmg_gen_saveaer.nam \ + do_save_aerosol_optics=true use_general_aerosol_optics=true \ + aerosol_optics_override_file_name="'aerosol_ifs_48R1.nc'" + $(DRIVER) config_rrtmg_gen_saveaer.nam $(INPUT).nc $(INPUT)_rrtmg_gen_saveaer_out.nc + mv aerosol_optics.nc aerosol_optics_rrtmg_gen.nc + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_band_saveaer.nam \ + do_save_aerosol_optics=true \ + aerosol_optics_override_file_name="'aerosol_ifs_rrtm_46R1_with_NI_AM.nc'" + $(DRIVER) config_ecckd_band_saveaer.nam $(INPUT).nc $(INPUT)_ecckd_band_saveaer_out.nc + mv aerosol_optics.nc aerosol_optics_ecckd_band.nc + +# ecCKD gas optics with SPARTACUS solver (not currently correct) +test_ecckd_spartacus: + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_spartacus.nam \ + sw_solver_name='"SPARTACUS"' lw_solver_name='"SPARTACUS"' \ + do_3d_effects="true" + $(DRIVER) config_ecckd_spartacus.nam $(INPUT).nc $(INPUT)_ecckd_spartacus_out.nc + +# ecCKD gas optics with no aerosol +test_ecckd_tc_noaer: + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_tc_noaer.nam \ + use_aerosols=false + $(DRIVER) config_ecckd_tc_noaer.nam $(INPUT).nc $(INPUT)_ecckd_tc_noaer_out.nc + +# Profiling +TAG = default +profile: + mkdir -p profiling_$(TAG) + $(CHANGENAM) $(CONFIG) config_profile.nam \ + nrepeat=100 do_save_spectral_flux=false + DR_HOOK=1 DR_HOOK_OPT=prof DR_HOOK_PROFILE=profiling_$(TAG)/$(INPUT)_default_prof_out.drhook \ + $(DRIVER) config_profile.nam $(INPUT).nc $(INPUT)_default_prof_out.nc \ + | tee $(INPUT)_default_prof_out.log + if [[ -f gmon.out ]]; then gprof $(DRIVER) gmon.out > profiling_$(TAG)/$(INPUT)_default_prof_out.gprof; fi + $(CHANGENAM) $(CONFIG_ECCKD) config_profile.nam \ + nrepeat=100 do_save_spectral_flux=false do_save_radiative_properties=false + DR_HOOK=1 DR_HOOK_OPT=prof DR_HOOK_PROFILE=profiling_$(TAG)/$(INPUT)_ecckd_tc_prof_out.drhook \ + $(DRIVER) config_profile.nam $(INPUT).nc $(INPUT)_ecckd_tc_prof_out.nc \ + | tee $(INPUT)_ecckd_tc_prof_out.log + if [[ -f gmon.out ]]; then gprof $(DRIVER) gmon.out > $(INPUT)_ecckd_tc_prof_out.gprof; fi + + mv $(INPUT)_*_prof_out.* profiling_$(TAG) + +# ecCKD gas optics with spectral diagnostics every 25nm in the visible +# written to a separate file; do this both with the 32- and 96-gpoint +# models (which have 100nm and 25nm resolution in the visible, +# respectively). +DIAGBOUNDS="sw_diag_wavelength_bound=.2e-6,.225e-6,.25e-6,.275e-6,.3e-6,.325e-6,.35e-6,.375e-6,.4e-6,.425e-6,.45e-6,.475e-6,.5e-6,.525e-6,.55e-6,.575e-6,.6e-6,.625e-6,.65e-6,.675e-6,.7e-6" +test_diag: + $(CHANGENAM) $(CONFIG_ECCKD) config_diag.nam $(DIAGBOUNDS) sw_diag_file_name='"sw_diag_rrtmg.nc"' gas_model_name='"RRTMG-IFS"' + $(DRIVER) config_diag.nam $(INPUT).nc $(INPUT)_diag_rrtmg_out.nc + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_diag.nam $(DIAGBOUNDS) sw_diag_file_name='"sw_diag_rgb_orig.nc"' + $(DRIVER) config_ecckd_diag.nam $(INPUT).nc $(INPUT)_ecckd_diag_rgb_orig_out.nc + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_diag.nam $(DIAGBOUNDS) sw_diag_file_name='"sw_diag_rgb.nc"' \ + gas_optics_sw_override_file_name='"ecckd-1.4_sw_climate_rgb-32b_ckd-definition.nc"' + $(DRIVER) config_ecckd_diag.nam $(INPUT).nc $(INPUT)_ecckd_diag_rgb_out.nc + $(CHANGENAM) $(CONFIG_ECCKD) config_ecckd_diag.nam $(DIAGBOUNDS) sw_diag_file_name='"sw_diag_vfine.nc"' \ + gas_optics_sw_override_file_name='"ecckd-1.4_sw_climate_vfine-96b_ckd-definition.nc"' + $(DRIVER) config_ecckd_diag.nam $(INPUT).nc $(INPUT)_ecckd_diag_vfine_out.nc + +# Clean data files +clean: + rm -f *_out.nc tmp*.nc radiative_properties*.nc inputs.nc sw_diag*nc \ + config_*.nam gmon.out Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/README =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/README (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/README (revision 6016) @@ -0,0 +1,30 @@ +This directory contains "ecrad_meridian.nc", a pole-to-pole slice of +low-resolution IFS model data in a form to use as input to the offline +version of ecRad. It includes aerosols extracted from the CAMS +climatology used operationally in IFS Cycle 43R3. + +Up to ecRad version 1.1.6, the file included a modification for Earth +curvature effects within the IFS such that the online radiation scheme +never sees a solar zenith angle greater than 90 degrees. However, it +is important to test the offline ecRad for such conditions, so from +version 1.1.7, the cos_solar_zenith_angle variable has been modified +to allow the sun to go below the horizon. + +Typing "make" in this directory runs various configurations of ECRAD - +see the Makefile for details. + +To run with a configuration similar to older cycle 43R3, type + + make CONFIG=configCY43R3.nam + +The Matlab script plot_ifs.m and Python script plot_ifs.py can be used +to visualize the results. The file +"ecrad_meridian_default_out_REFERENCE.nc" contains a reference version +of the output file "ecrad_meridian_default_out.nc" (case "a" above), +which you can compare to be sure your compilation is working as +expected. Sometimes this file lags intermediate versions of ecRad, +especially git snapshots. It is always generated using gfortran in +double precision. + +Note that the shortwave diagnosed cloud cover will be set to -1 when +the sun is below the horizon. Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY43R3.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY43R3.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY43R3.nam (revision 6016) @@ -0,0 +1,67 @@ +! Configuration namelists for ECRAD radiation code +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file +! +! This version matches the configuration of ECMWF IFS Cycle 43R3 +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 32, ! Number of columns to process per thread +do_save_inputs = true, ! Save inputs in "inputs.nc"? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 3, +istartcol = 0, ! Use full range of columns by default +iendcol = 0, +nrepeat = 1, +/ +! +! The following namelist controls the behaviour of the SPARTACUS +! radiation code +! +&radiation +do_sw = true, ! Compute shortwave fluxes? +do_lw = true, ! Compute longwave fluxes? +do_sw_direct = true, ! Compute direct downward shortwave fluxes? +do_clear = true, ! Compute clear-sky fluxes? +directory_name = "../../data", ! Location of configuration files +liquid_model_name = "SOCRATES", ! Liquid droplet scattering model +ice_model_name = "Fu-IFS", ! Ice particle scattering model +sw_solver_name = "McICA", +lw_solver_name = "McICA", +overlap_scheme_name = "Exp-Exp", ! Exp-Ran, Max-Ran or Exp-Exp +cloud_fraction_threshold = 0.001e-3, ! +do_lw_aerosol_scattering= false, ! Aerosols scatter in the longwave? +do_lw_cloud_scattering = false, ! Clouds scatter in the longwave? +cloud_inhom_decorr_scaling = 0.5, ! Ratio of overlap decorr len of inhomogeneities to boundaries +use_beta_overlap = false, +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +do_3d_effects = false, ! Represent 3D effects? +sw_encroachment_name = "Maximum", +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +! Separate verbosity specified for setup and ordinary execution +iverbose = 1, +iverbosesetup = 3, +use_aerosols = true, ! Include aerosols in radiation calculations? +do_save_spectral_flux = false, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +do_lw_derivatives = true, ! Hogan-Bozzo style derivatives for approx updates +gas_model_name = "RRTMG-IFS", ! Gas model +do_surface_sw_spectral_flux = true, +do_fu_lw_ice_optics_bug = true, +do_sw_delta_scaling_with_gases = true, +! +! 12 IFS aerosol classes stored in aerosol_ifs_rrtm.nc: 1-3 Sea salt, +! 4-6 Boucher desert dust, 7 hydrophilic organics, 8 hydrophobic +! organics, 9&10 hydrophobic black carbon, 11 ammonium sulphate, 12 +! inactive SO2 +n_aerosol_types = 12, ! Aerosols are deactivated if this is zero +! +! Indices to the aerosol optical properties in aerosol_ifs_rrtm.nc, +! for each class, where negative numbers index hydrophilic aerosol +! types and positive numbers index hydrophobic aerosol types +i_aerosol_type_map = -1, -2, -3, 1, 2, 3, -4, 10, 11, 11, -5, 14, +! Tegen types are rather more simple +!i_aerosol_type_map = 2, 2, 2, 3, 3, 3, 1, 1, 4, 4, 6, 5, +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY46R1.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY46R1.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY46R1.nam (revision 6016) @@ -0,0 +1,71 @@ +! Configuration namelists for ECRAD radiation code +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file +! +! This version matches the expected configuration of ECMWF IFS Cycle +! 46R1: compared to 43R3, longwave scattering is on for clouds, the LW +! ice optics bug is off and SW delta scaling is done for particles +! only +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 16, ! Number of columns to process per thread +do_save_inputs = false, ! Save inputs in "inputs.nc"? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 0, +istartcol = 0, ! Use full range of columns by default +iendcol = 0, +nrepeat = 1, +/ +! +! The following namelist controls the behaviour of the SPARTACUS +! radiation code +! +&radiation +do_sw = true, ! Compute shortwave fluxes? +do_lw = true, ! Compute longwave fluxes? +do_sw_direct = true, ! Compute direct downward shortwave fluxes? +do_clear = true, ! Compute clear-sky fluxes? +directory_name = "../../data", ! Location of configuration files +liquid_model_name = "SOCRATES", ! Liquid droplet scattering model +ice_model_name = "Fu-IFS", ! Ice particle scattering model +sw_solver_name = "McICA", +lw_solver_name = "McICA", +overlap_scheme_name = "Exp-Ran", ! Exp-Ran, Max-Ran or Exp-Exp +cloud_fraction_threshold = 0.001e-3, ! +do_lw_aerosol_scattering= false, ! Aerosols scatter in the longwave? +do_lw_cloud_scattering = true, ! Clouds scatter in the longwave? +cloud_inhom_decorr_scaling = 0.5, ! Ratio of overlap decorr len of inhomogeneities to boundaries +use_beta_overlap = false, +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +do_3d_effects = false, ! Represent 3D effects? +sw_encroachment_name = "Computed", ! Minimum, Maximum or Computed are possible +!sw_encroachment_name = "Maximum", ! Minimum, Maximum or Computed are possible +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +! Separate verbosity specified for setup and ordinary execution +iverbose = 3, +iverbosesetup = 3, +use_aerosols = false, ! Include aerosols in radiation calculations? +do_save_spectral_flux = false, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +do_lw_derivatives = true, ! Hogan-Bozzo style derivatives for approx updates +gas_model_name = "RRTMG-IFS", ! Gas model +do_surface_sw_spectral_flux = true, +do_fu_lw_ice_optics_bug = false, +do_sw_delta_scaling_with_gases = false, +! +! 12 IFS aerosol classes stored in aerosol_ifs_rrtm.nc: 1-3 Sea salt, +! 4-6 Boucher desert dust, 7 hydrophilic organics, 8 hydrophobic +! organics, 9&10 hydrophobic black carbon, 11 ammonium sulphate, 12 +! inactive SO2 +n_aerosol_types = 12, ! Aerosols are deactivated if this is zero +! +! Indices to the aerosol optical properties in aerosol_ifs_rrtm.nc, +! for each class, where negative numbers index hydrophilic aerosol +! types and positive numbers index hydrophobic aerosol types +i_aerosol_type_map = -1, -2, -3, 1, 2, 3, -4, 10, 11, 11, -5, 14, +! Tegen types are rather more simple +!i_aerosol_type_map = 2, 2, 2, 3, 3, 3, 1, 1, 4, 4, 6, 5, +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY47R1.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY47R1.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY47R1.nam (revision 6016) @@ -0,0 +1,93 @@ +! Configuration namelists for ECRAD radiation code +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file +! +! This version matches the configuration of ECMWF IFS Cycle 47R1: +! compared to 46R1, the surface shortwave albedo and longwave +! emissivity mappings are specified +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 80, ! Number of columns to process per thread +do_save_inputs = false, ! Save inputs in "inputs.nc"? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 2, +istartcol = 0, ! Use full range of columns by default +iendcol = 0, +nrepeat = 1, +cloud_separation_scale_toa = 14000.0, +cloud_separation_scale_surface = 2500.0, +cloud_separation_scale_power = 3.5, +cloud_inhom_separation_factor = 0.75, +!do_save_aerosol_optics = false, +do_save_net_fluxes = false, +do_write_double_precision = false, +/ +! +! The following namelist controls the behaviour of the SPARTACUS +! radiation code +! +&radiation +do_sw = true, ! Compute shortwave fluxes? +do_lw = true, ! Compute longwave fluxes? +do_sw_direct = true, ! Compute direct downward shortwave fluxes? +do_clear = true, ! Compute clear-sky fluxes? +directory_name = "../../data", ! Location of configuration files +use_general_cloud_optics = false, +use_general_aerosol_optics = false, +liquid_model_name = "SOCRATES", ! Liquid droplet scattering model +ice_model_name = "Fu-IFS", ! Ice particle scattering model +sw_solver_name = "McICA", +lw_solver_name = "McICA", +overlap_scheme_name = "Exp-Exp", ! Exp-Ran, Max-Ran or Exp-Exp +cloud_fraction_threshold = 0.001e-3, ! +do_lw_aerosol_scattering= false, ! Aerosols scatter in the longwave? +do_lw_cloud_scattering = true, ! Clouds scatter in the longwave? +cloud_inhom_decorr_scaling = 0.5, ! Ratio of overlap decorr len of inhomogeneities to boundaries +use_beta_overlap = false, +use_vectorizable_generator = false, +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +do_3d_effects = false, ! Represent 3D effects? +sw_entrapment_name = "Explicit", ! Zero, Edge-only, Explicit, Non-fractal, Maximum are possible +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +! Separate verbosity specified for setup and ordinary execution +iverbose = 1, +iverbosesetup = 2, +use_aerosols = true, ! Include aerosols in radiation calculations? +do_save_spectral_flux = true, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +do_lw_derivatives = true, ! Hogan-Bozzo style derivatives for approx updates +gas_model_name = "RRTMG-IFS", ! Gas model +do_surface_sw_spectral_flux = false, +do_fu_lw_ice_optics_bug = false, +do_sw_delta_scaling_with_gases = false, +do_canopy_fluxes_lw = true, +do_canopy_fluxes_sw = true, +!do_cloud_aerosol_per_sw_g_point=false +! +! SURFACE ALBEDO AND EMISSIVITY +do_nearest_spectral_sw_albedo = false, +sw_albedo_wavelength_bound(1:5) = 0.25e-6, 0.44e-6, 0.69e-6, 1.19e-6, 2.38e-6, +i_sw_albedo_index(1:6) = 1,2,3,4,5,6, +do_nearest_spectral_lw_emiss = true, +lw_emiss_wavelength_bound(1:2) = 8.0e-6, 13.0e-6, +i_lw_emiss_index(1:3) = 1,2,1, +do_weighted_surface_mapping = false, ! false=less accurate, but consistent with cycle 47r1 +! +! AEROSOL PROPERTIES +!aerosol_optics_override_file_name = 'aerosol_ifs_rrtm_46R1_with_NI_AM.nc' +! 12 IFS aerosol classes stored in aerosol_ifs_rrtm.nc: 1-3 Sea salt, +! 4-6 Boucher desert dust, 7 hydrophilic organics, 8 hydrophobic +! organics, 9&10 hydrophobic black carbon, 11 ammonium sulphate, 12 +! inactive SO2 +n_aerosol_types = 12, ! Aerosols are deactivated if this is zero +! +! Indices to the aerosol optical properties in aerosol_ifs_rrtm.nc, +! for each class, where negative numbers index hydrophilic aerosol +! types and positive numbers index hydrophobic aerosol types +i_aerosol_type_map = -1, -2, -3, 1, 2, 3, -4, 10, 11, 11, -5, 14, +! Tegen types are rather more simple +!i_aerosol_type_map = 2, 2, 2, 3, 3, 3, 1, 1, 4, 4, 6, 5, +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY47R3.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY47R3.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY47R3.nam (revision 6016) @@ -0,0 +1,97 @@ +! Configuration namelists for ECRAD radiation code +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file +! +! This version matches the configuration of ECMWF IFS Cycle 47R3 and +! 48R1: compared to 47R1, cloud overlap has been changed to +! exponential-random. Compared to configCY47R1.nam in this directory, +! this file is also different in that it uses the Woodward (2001) dust +! optical properties (compare the codes in the i_aerosol_type_map) but +! in fact Woodward has been used in the operational IFS since at least +! cycle 43R3 when ecRad was introduced. +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 80, ! Number of columns to process per thread +do_save_inputs = false, ! Save inputs in "inputs.nc"? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 2, +istartcol = 0, ! Use full range of columns by default +iendcol = 0, +nrepeat = 1, +cloud_separation_scale_toa = 14000.0, +cloud_separation_scale_surface = 2500.0, +cloud_separation_scale_power = 3.5, +cloud_inhom_separation_factor = 0.75, +!do_save_aerosol_optics = false, +do_save_net_fluxes = false, +do_write_double_precision = false, +/ +! +! The following namelist controls the behaviour of the SPARTACUS +! radiation code +! +&radiation +do_sw = true, ! Compute shortwave fluxes? +do_lw = true, ! Compute longwave fluxes? +do_sw_direct = true, ! Compute direct downward shortwave fluxes? +do_clear = true, ! Compute clear-sky fluxes? +directory_name = "../../data", ! Location of configuration files +use_general_cloud_optics = false, +use_general_aerosol_optics = false, +liquid_model_name = "SOCRATES", ! Liquid droplet scattering model +ice_model_name = "Fu-IFS", ! Ice particle scattering model +sw_solver_name = "McICA", +lw_solver_name = "McICA", +overlap_scheme_name = "Exp-Ran", ! Exp-Ran, Max-Ran or Exp-Exp +cloud_fraction_threshold = 0.001e-3, ! +do_lw_aerosol_scattering= false, ! Aerosols scatter in the longwave? +do_lw_cloud_scattering = true, ! Clouds scatter in the longwave? +cloud_inhom_decorr_scaling = 0.5, ! Ratio of overlap decorr len of inhomogeneities to boundaries +use_beta_overlap = false, +use_vectorizable_generator = false, +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +do_3d_effects = false, ! Represent 3D effects? +sw_entrapment_name = "Explicit", ! Zero, Edge-only, Explicit, Non-fractal, Maximum are possible +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +! Separate verbosity specified for setup and ordinary execution +iverbose = 1, +iverbosesetup = 2, +use_aerosols = true, ! Include aerosols in radiation calculations? +do_save_spectral_flux = true, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +do_lw_derivatives = true, ! Hogan-Bozzo style derivatives for approx updates +gas_model_name = "RRTMG-IFS", ! Gas model +do_surface_sw_spectral_flux = false, +do_fu_lw_ice_optics_bug = false, +do_sw_delta_scaling_with_gases = false, +do_canopy_fluxes_lw = true, +do_canopy_fluxes_sw = true, +!do_cloud_aerosol_per_sw_g_point=false +! +! SURFACE ALBEDO AND EMISSIVITY +do_nearest_spectral_sw_albedo = false, +sw_albedo_wavelength_bound(1:5) = 0.25e-6, 0.44e-6, 0.69e-6, 1.19e-6, 2.38e-6, +i_sw_albedo_index(1:6) = 1,2,3,4,5,6, +do_nearest_spectral_lw_emiss = true, +lw_emiss_wavelength_bound(1:2) = 8.0e-6, 13.0e-6, +i_lw_emiss_index(1:3) = 1,2,1, +do_weighted_surface_mapping = false, ! false=less accurate, but consistent with cycle 47r1 +! +! AEROSOL PROPERTIES +!aerosol_optics_override_file_name = 'aerosol_ifs_rrtm_46R1_with_NI_AM.nc' +! 12 IFS aerosol classes stored in aerosol_ifs_rrtm.nc: 1-3 Sea salt, +! 4-6 Boucher desert dust, 7 hydrophilic organics, 8 hydrophobic +! organics, 9&10 hydrophobic black carbon, 11 ammonium sulphate, 12 +! inactive SO2 +n_aerosol_types = 12, ! Aerosols are deactivated if this is zero +! +! Indices to the aerosol optical properties in aerosol_ifs_rrtm.nc, +! for each class, where negative numbers index hydrophilic aerosol +! types and positive numbers index hydrophobic aerosol types +i_aerosol_type_map = -1, -2, -3, 7, 8, 9, -4, 10, 11, 11, -5, 14, +! Tegen types are rather more simple +!i_aerosol_type_map = 2, 2, 2, 3, 3, 3, 1, 1, 4, 4, 6, 5, +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY49R1.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY49R1.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY49R1.nam (revision 6016) @@ -0,0 +1,93 @@ +! Configuration namelists for ECRAD radiation code +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file +! +! This version matches the configuration of ECMWF IFS Cycle 49R1: +! compared to 47R3, it now uses general aerosol optics. +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 80, ! Number of columns to process per thread +do_save_inputs = false, ! Save inputs in "inputs.nc"? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 2, +istartcol = 0, ! Use full range of columns by default +iendcol = 0, +nrepeat = 1, +cloud_separation_scale_toa = 14000.0, +cloud_separation_scale_surface = 2500.0, +cloud_separation_scale_power = 3.5, +cloud_inhom_separation_factor = 0.75, +!do_save_aerosol_optics = false, +do_save_net_fluxes = false, +do_write_double_precision = false, +/ +! +! The following namelist controls the behaviour of the SPARTACUS +! radiation code +! +&radiation +do_sw = true, ! Compute shortwave fluxes? +do_lw = true, ! Compute longwave fluxes? +do_sw_direct = true, ! Compute direct downward shortwave fluxes? +do_clear = true, ! Compute clear-sky fluxes? +directory_name = "../../data", ! Location of configuration files +use_general_cloud_optics = false, +use_general_aerosol_optics = true, +liquid_model_name = "SOCRATES", ! Liquid droplet scattering model +ice_model_name = "Fu-IFS", ! Ice particle scattering model +sw_solver_name = "McICA", +lw_solver_name = "McICA", +overlap_scheme_name = "Exp-Ran", ! Exp-Ran, Max-Ran or Exp-Exp +cloud_fraction_threshold = 0.001e-3, ! +do_lw_aerosol_scattering= false, ! Aerosols scatter in the longwave? +do_lw_cloud_scattering = true, ! Clouds scatter in the longwave? +cloud_inhom_decorr_scaling = 0.5, ! Ratio of overlap decorr len of inhomogeneities to boundaries +use_beta_overlap = false, +use_vectorizable_generator = false, +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +do_3d_effects = false, ! Represent 3D effects? +sw_entrapment_name = "Explicit", ! Zero, Edge-only, Explicit, Non-fractal, Maximum are possible +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +! Separate verbosity specified for setup and ordinary execution +iverbose = 1, +iverbosesetup = 3, +use_aerosols = true, ! Include aerosols in radiation calculations? +do_save_spectral_flux = true, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +do_lw_derivatives = true, ! Hogan-Bozzo style derivatives for approx updates +gas_model_name = "RRTMG-IFS", ! Gas model +do_surface_sw_spectral_flux = true, +do_fu_lw_ice_optics_bug = false, +do_sw_delta_scaling_with_gases = false, +do_canopy_fluxes_lw = true, +do_canopy_fluxes_sw = true, +do_cloud_aerosol_per_sw_g_point=false, +do_cloud_aerosol_per_lw_g_point=false, +! +! SURFACE ALBEDO AND EMISSIVITY +do_nearest_spectral_sw_albedo = false, +sw_albedo_wavelength_bound(1:5) = 0.25e-6, 0.44e-6, 0.69e-6, 1.19e-6, 2.38e-6, +i_sw_albedo_index(1:6) = 1,2,3,4,5,6, +do_nearest_spectral_lw_emiss = true, +lw_emiss_wavelength_bound(1:2) = 8.0e-6, 13.0e-6, +i_lw_emiss_index(1:3) = 1,2,1, +do_weighted_surface_mapping = false, ! false=less accurate, but consistent with cycle 47r1 +! +! AEROSOL PROPERTIES +!aerosol_optics_override_file_name = 'aerosol_ifs_rrtm_46R1_with_NI_AM.nc' +! 12 IFS aerosol classes stored in aerosol_ifs_rrtm.nc: 1-3 Sea salt, +! 4-6 Boucher desert dust, 7 hydrophilic organics, 8 hydrophobic +! organics, 9&10 hydrophobic black carbon, 11 ammonium sulphate, 12 +! inactive SO2 +n_aerosol_types = 12, ! Aerosols are deactivated if this is zero +! +! Indices to the aerosol optical properties in aerosol_ifs_rrtm.nc, +! for each class, where negative numbers index hydrophilic aerosol +! types and positive numbers index hydrophobic aerosol types +i_aerosol_type_map = -1, -2, -3, 7, 8, 9, -4, 10, 11, 11, -5, 14, +! Tegen types are rather more simple +!i_aerosol_type_map = 2, 2, 2, 3, 3, 3, 1, 1, 4, 4, 6, 5, +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY49R1_ecckd.nam =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY49R1_ecckd.nam (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/configCY49R1_ecckd.nam (revision 6016) @@ -0,0 +1,93 @@ +! Configuration namelists for ECRAD radiation code +! +! The following namelist controls the behaviour of the driver routine, +! including parallelization options and overriding numbers read from +! the NetCDF input file +! +! This version is a test configuration of ECMWF IFS Cycle 49R1 but +! with the ecCKD gas optics scheme turned on. +! +&radiation_driver +do_parallel = true, ! Use OpenMP parallelization? +nblocksize = 80, ! Number of columns to process per thread +do_save_inputs = false, ! Save inputs in "inputs.nc"? +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +iverbose = 2, +istartcol = 0, ! Use full range of columns by default +iendcol = 0, +nrepeat = 1, +cloud_separation_scale_toa = 14000.0, +cloud_separation_scale_surface = 2500.0, +cloud_separation_scale_power = 3.5, +cloud_inhom_separation_factor = 0.75, +!do_save_aerosol_optics = false, +!sw_diag_wavelength_bound = .4e-6,.5e-6,.6e-6,.7e-6, ! Example for red-green-blue diagnostics +!sw_diag_file_name = 'sw_diag.nc', +do_save_net_fluxes = false, +do_write_double_precision = false, +/ +! +! The following namelist controls the behaviour of the SPARTACUS +! radiation code +! +&radiation +do_sw = true, ! Compute shortwave fluxes? +do_lw = true, ! Compute longwave fluxes? +do_sw_direct = true, ! Compute direct downward shortwave fluxes? +do_clear = true, ! Compute clear-sky fluxes? +directory_name = "../../data", ! Location of configuration files +use_general_cloud_optics = true, +use_general_aerosol_optics = true, +!liquid_model_name = "SOCRATES", ! Liquid droplet scattering model +!ice_model_name = "Fu-IFS", ! Ice particle scattering model +sw_solver_name = "Tripleclouds", +lw_solver_name = "Tripleclouds", +overlap_scheme_name = "Exp-Ran", ! Exp-Ran, Max-Ran or Exp-Exp +cloud_fraction_threshold = 0.001e-3, ! +do_lw_aerosol_scattering= false, ! Aerosols scatter in the longwave? +do_lw_cloud_scattering = true, ! Clouds scatter in the longwave? +cloud_inhom_decorr_scaling = 0.5, ! Ratio of overlap decorr len of inhomogeneities to boundaries +use_beta_overlap = false, +use_vectorizable_generator = false, +do_save_radiative_properties = false, ! Save raw radiation properties in radiative_properties.nc? +do_3d_effects = false, ! Represent 3D effects? +sw_entrapment_name = "Explicit", ! Zero, Edge-only, Explicit, Non-fractal, Maximum are possible +! Verbosity level: 0=none, 1=warning, 2=info, 3=progress, 4=detailed, 5=debug +! Separate verbosity specified for setup and ordinary execution +iverbose = 1, +iverbosesetup = 2, +use_aerosols = true, ! Include aerosols in radiation calculations? +do_save_spectral_flux = true, ! Save spectral fluxes in output file? +do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? +do_lw_derivatives = true, ! Hogan-Bozzo style derivatives for approx updates +gas_model_name = "ECCKD", ! Gas model +do_surface_sw_spectral_flux = false, +do_fu_lw_ice_optics_bug = false, +do_sw_delta_scaling_with_gases = false, +do_canopy_fluxes_lw = true, +do_canopy_fluxes_sw = true, +do_cloud_aerosol_per_sw_g_point=true, +do_cloud_aerosol_per_lw_g_point=true, +!gas_optics_sw_override_file_name = "ecckd-1.4_sw_climate_vfine-96b_ckd-definition.nc", +! +! SURFACE ALBEDO AND EMISSIVITY +do_nearest_spectral_sw_albedo = false, +sw_albedo_wavelength_bound(1:5) = 0.25e-6, 0.44e-6, 0.69e-6, 1.19e-6, 2.38e-6, +i_sw_albedo_index(1:6) = 1,2,3,4,5,6, +do_nearest_spectral_lw_emiss = false, +lw_emiss_wavelength_bound(1:2) = 8.0e-6, 13.0e-6, +i_lw_emiss_index(1:3) = 1,2,1, +! +! AEROSOL PROPERTIES +!aerosol_optics_override_file_name = 'aerosol_ifs_48R1.nc' +! 12 IFS aerosol classes stored in aerosol_ifs_rrtm.nc: 1-3 Sea salt, +! 4-6 Boucher desert dust, 7 hydrophilic organics, 8 hydrophobic +! organics, 9&10 hydrophobic black carbon, 11 ammonium sulphate, 12 +! inactive SO2 +n_aerosol_types = 12, ! Aerosols are deactivated if this is zero +! +! Indices to the aerosol optical properties in aerosol_ifs_rrtm.nc, +! for each class, where negative numbers index hydrophilic aerosol +! types and positive numbers index hydrophobic aerosol types +i_aerosol_type_map = -1, -2, -3, 7, 8, 9, -4, 10, 11, 11, -5, 14, +/ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/ecrad_meridian_default_out_REFERENCE.log =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/ecrad_meridian_default_out_REFERENCE.log (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/ecrad_meridian_default_out_REFERENCE.log (revision 6016) @@ -0,0 +1,109 @@ +../../bin/ecrad configCY49R1.nam ecrad_meridian.nc ecrad_meridian_default_out.nc +-------------------------- OFFLINE ECRAD RADIATION SCHEME -------------------------- +Copyright (C) 2014- ECMWF +Contact: Robin Hogan (r.j.hogan@ecmwf.int) +Floating-point precision: double +General settings: + Data files expected in "../../data" + Clear-sky calculations are ON (do_clear=T) + Saving intermediate radiative properties OFF (do_save_radiative_properties=F) + Saving spectral flux profiles ON (do_save_spectral_flux=T) + Gas model is "RRTMG-IFS" (i_gas_model=1) + Aerosols are ON (use_aerosols=T) + General aerosol optics ON (use_general_aerosol_optics=T) + Clouds are ON + Do cloud/aerosol/surface SW properties per g-point OFF (do_cloud_aerosol_per_sw_g_point=F) + Do cloud/aerosol/surface LW properties per g-point OFF (do_cloud_aerosol_per_lw_g_point=F) + Represent solar cycle in spectral irradiance OFF (use_spectral_solar_cycle=F) + Scale spectral solar irradiance OFF (use_spectral_solar_scaling=F) +Surface and top-of-atmosphere settings: + Saving top-of-atmosphere spectral fluxes OFF (do_toa_spectral_flux=F) + Saving surface shortwave spectral fluxes ON (do_surface_sw_spectral_flux=T) + Saving surface shortwave fluxes in abledo bands ON (do_canopy_fluxes_sw=T) + Saving surface longwave fluxes in emissivity bands ON (do_canopy_fluxes_lw=T) + Longwave derivative calculation is ON (do_lw_derivatives=T) + Nearest-neighbour spectral albedo mapping OFF (do_nearest_spectral_sw_albedo=F) + Nearest-neighbour spectral emissivity mapping ON (do_nearest_spectral_lw_emiss=T) + Planck-weighted surface albedo/emiss mapping OFF (do_weighted_surface_mapping=F) +Cloud settings: + Cloud fraction threshold = .100E-05 (cloud_fraction_threshold) + Cloud mixing-ratio threshold = .100E-08 (cloud_mixing_ratio_threshold) + General cloud optics OFF (use_general_cloud_optics=F) + Liquid optics scheme is "SOCRATES" (i_liq_model=1) + Ice optics scheme is "Fu-IFS" (i_ice_model=1) + Longwave ice optics bug in Fu scheme is OFF (do_fu_lw_ice_optics_bug=F) + Cloud overlap scheme is "Exp-Ran" (i_overlap_scheme=1) + Use "beta" overlap parameter is OFF (use_beta_overlap=F) + Cloud PDF shape is "Gamma" (i_cloud_pdf_shape=1) + Cloud inhom decorrelation scaling = .500 (cloud_inhom_decorr_scaling) +Solver settings: + Shortwave solver is "McICA" (i_solver_sw=2) + Shortwave delta scaling after merge with gases OFF (do_sw_delta_scaling_with_gases=F) + Longwave solver is "McICA" (i_solver_lw=2) + Longwave cloud scattering is ON (do_lw_cloud_scattering=T) + Longwave aerosol scattering is OFF (do_lw_aerosol_scattering=F) + Use vectorizable McICA cloud generator OFF (use_vectorizable_generator=F) +Reading RRTMG longwave data file ../../data/RADRRTM +Reading RRTMG shortwave data file ../../data/RADSRTM +Surface shortwave albedo + Mapping from 6 values to 14 bands (wavenumber ranges in cm-1) + 2600 to 3250: 0.00 0.00 0.00 0.00 0.00 1.00 + 3250 to 4000: 0.00 0.00 0.00 0.00 0.00 1.00 + 4000 to 4650: 0.00 0.00 0.00 0.00 0.69 0.31 + 4650 to 5150: 0.00 0.00 0.00 0.00 1.00 0.00 + 5150 to 6150: 0.00 0.00 0.00 0.00 1.00 0.00 + 6150 to 7700: 0.00 0.00 0.00 0.00 1.00 0.00 + 7700 to 8050: 0.00 0.00 0.00 0.00 1.00 0.00 + 8050 to 12850: 0.00 0.00 0.00 0.93 0.07 0.00 + 12850 to 16000: 0.00 0.00 0.48 0.52 0.00 0.00 + 16000 to 22650: 0.00 0.00 1.00 0.00 0.00 0.00 + 22650 to 29000: 0.00 0.99 0.01 0.00 0.00 0.00 + 29000 to 38000: 0.00 1.00 0.00 0.00 0.00 0.00 + 38000 to 50000: 0.83 0.17 0.00 0.00 0.00 0.00 + 820 to 2600: 0.00 0.00 0.00 0.00 0.00 1.00 +Surface longwave emissivity +Mapping from 16 longwave intervals to emissivity intervals: 1 1 1 1 1 2 2 2 1 1 1 1 1 1 1 1 +Reading NetCDF file ../../data/socrates_droplet_scattering_rrtm.nc + Reading coeff_lw(16,16) + Reading coeff_sw(14,16) +Closing NetCDF file ../../data/socrates_droplet_scattering_rrtm.nc +Reading NetCDF file ../../data/fu_ice_scattering_rrtm.nc + Reading coeff_lw(16,11) + Reading coeff_sw(14,10) +Closing NetCDF file ../../data/fu_ice_scattering_rrtm.nc +Reading NetCDF file ../../data/aerosol_ifs_49R1_20230119.nc + Reading wavenumber(331) + Reading mass_ext_hydrophobic(331,18) + Reading ssa_hydrophobic(331,18) + Reading asymmetry_hydrophobic(331,18) + Reading lidar_ratio_hydrophobic(331,18) + Reading mass_ext_hydrophilic(331,12,13) + Reading ssa_hydrophilic(331,12,13) + Reading asymmetry_hydrophilic(331,12,13) + Reading lidar_ratio_hydrophilic(331,12,13) + Reading relative_humidity1(12) +Closing NetCDF file ../../data/aerosol_ifs_49R1_20230119.nc +Aerosol mapping: + 1 -> hydrophilic type 1: Sea salt, bin 1, 0.03-0.5 micron, OPAC + 2 -> hydrophilic type 2: Sea salt, bin 2, 0.50-5.0 micron, OPAC + 3 -> hydrophilic type 3: Sea salt, bin 3, 5.0-20.0 micron, OPAC + 4 -> hydrophobic type 7: Desert dust, bin 1, 0.03-0.55 micron, Woodward 2001, Table 2 + 5 -> hydrophobic type 8: Desert dust, bin 2, 0.55-0.90 micron, Woodward 2001, Table 2 + 6 -> hydrophobic type 9: Desert dust, bin 3, 0.90-20.0 micron, Woodward 2001, Table 2 + 7 -> hydrophilic type 4: Hydrophilic organic matter, OPAC + 8 -> hydrophobic type 10: Hydrophobic organic matter, OPAC (hydrophilic at RH=20%) + 9 -> hydrophobic type 11: Black carbon, OPAC + 10 -> hydrophobic type 11: Black carbon, OPAC + 11 -> hydrophilic type 5: Ammonium sulfate (for sulfate), GACP Lacis et al https://gacp.giss.nasa.gov/data_sets/ + 12 -> hydrophobic type 14: Stratospheric sulfate, GACP (hydrophilic ammonium sulfate at RH 20%-30%) +Reading NetCDF file ../../data/mcica_gamma.nc + Reading fsd(81) + Reading x(1000,81) +Closing NetCDF file ../../data/mcica_gamma.nc +Reading NetCDF file ecrad_meridian.nc + Warning: variable co_vmr not found + Warning: variable no2_vmr not found +Performing radiative transfer calculations +Time elapsed in radiative transfer: 0.77346E-01 seconds +Writing NetCDF file ecrad_meridian_default_out.nc +------------------------------------------------------------------------------------ Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/plot_ifs.m =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/plot_ifs.m (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/plot_ifs.m (revision 6016) @@ -0,0 +1,132 @@ +% This matlab scripts plots some of the inputs to the radiation scheme +% in Fig. 1 and the outputs in Fig. 2 + +% Location of loadnc.m +path(path, '../common') + +code = 'ecrad_meridian'; +in = loadnc([code '.nc']); +cases = {[code '_noaer_out.nc'], + [code '_ecckd_tc_noaer_out.nc'], + [code '_default_out.nc'], + [code '_ecckd_tc_out.nc'], + [code '_expexp_out.nc'], + [code '_tc_out.nc'], + [code '_spartacus_out.nc'], + [code '_ecckd_spartacus_out.nc'], + [code '_default_out_REFERENCE.nc']}; +clear out +for icase = 1:length(cases) + out{icase} = loadnc(cases{icase}); +end +case_list = [1 2 3 4 5 6 7 8 9]; +leg = {'McICA no aerosols',... + 'ecCKD Tripleclouds no aerosols',... + 'McICA',... + 'ecCKD McICA',... + 'McICA Exp-Exp',... + 'Tripleclouds',... + 'SPARTACUS',... + 'ecCKD SPARTACUS',... + 'McICA REFERENCE'}; + +styles = {'b','b--','r','r--','g','m','c','k','k--'}; + +p = 0.01.*0.5.*median(in.pressure_hl(1:end-1,:)+in.pressure_hl(2:end,:),2); + +figure(1) +clf +set(gcf,'defaultlinelinewidth',1); +set(gcf,'units','inches','paperposition',[0.5 0.5 15 30]); +nplot = 4; + +subplot(nplot,1,1) +plot(in.lat,in.cos_solar_zenith_angle,'k') +xlim([-90 90]); +ylabel('Cosine of solar zenith angle'); + +subplot(nplot,1,2) +plot(in.lat,in.skin_temperature-273.15,'r'); +hold on +plot(in.lat,in.temperature_hl(end-1,:)-273.15,'b'); +legend('Skin temperature','Air between first two model levels'); +xlim([-90 90]); +ylabel('Temperature (\circC)'); +ylim([-50 60]); + +subplot(nplot,1,3) +%contour(in.lat,p,in.q_ice,10.^[-5 -5],'b'); +%hold on +%contour(in.lat,p,in.q_liquid,10.^[-5 -5],'r'); +contourf(in.lat,p,in.cloud_fraction,[0.05:0.1:0.95],'k'); +%shading flat +colormap(jet) +set(gca,'ydir','reverse'); +ylim([0 1013]); +xlim([-90 90]); +ylabel('Pressure (hPa)'); +text(-90, 0, [' ' 10 ' Cloud fraction'],'verticalalignment','top') + +subplot(nplot,1,4) +sea_salt = 1e9.*sum(squeeze(in.aerosol_mmr(end,1:3,:)),1); +dust = 1e9.*sum(squeeze(in.aerosol_mmr(end,4:6,:)),1); +organics = 1e9.*sum(squeeze(in.aerosol_mmr(end,7:8,:)),1); +black_carbon = 1e9.*sum(squeeze(in.aerosol_mmr(end,9:10,:)),1); +sulphate = 1e9.*sum(squeeze(in.aerosol_mmr(end,11:12,:)),1); + +plot(in.lat,sea_salt,'b'); +hold on +plot(in.lat,dust,'r'); +plot(in.lat,organics,'g'); +plot(in.lat,black_carbon,'k'); +plot(in.lat,sulphate,'m'); +legend('Sea salt','Dust','Organics','Black carbon','Sulphate'); +ylabel('Aerosol mass mixing ratio (\mug kg^{-1})'); +xlabel('Latitude (\circN)'); +xlim([-90 90]); +set(gca,'yscale','log'); + +figure(2) +clf +set(gcf,'defaultlinelinewidth',1); +set(gcf,'units','inches','paperposition',[0.5 0.5 15 30]); +nplot = 4; +subplot(nplot,1,1) +for icase = case_list + plot(in.lat, out{icase}.flux_dn_sw(end,:),styles{icase}) + hold on +% plot(in.lat, out{icase}.flux_dn_sw_clear(end,:),[styles{icase} '--']) +% plot(in.lat, out{icase}.flux_dn_direct_sw(end,:),[styles{icase} '--']) +end +xlim([-90 90]); +ylabel('Surface SW down (W m^{-2})'); +legend(leg{case_list}) + +subplot(nplot,1,2) +for icase = case_list + cre = out{icase}.flux_dn_sw(1,:)-out{icase}.flux_dn_sw_clear(1,:) ... + -out{icase}.flux_up_sw(1,:)+out{icase}.flux_up_sw_clear(1,:); + plot(in.lat, cre,styles{icase}) + hold on +end +xlim([-90 90]); +ylabel('SW cloud radiative effect (W m^{-2})'); + +subplot(nplot,1,3) +for icase = case_list + cre = out{icase}.flux_dn_lw(1,:)-out{icase}.flux_dn_lw_clear(1,:) ... + -out{icase}.flux_up_lw(1,:)+out{icase}.flux_up_lw_clear(1,:); + plot(in.lat, cre,styles{icase}) + hold on +end +xlim([-90 90]); +ylabel('LW cloud radiative effect (W m^{-2})'); + +subplot(nplot,1,4) +for icase = case_list + plot(in.lat, out{icase}.cloud_cover_sw,styles{icase}); + hold on +end +xlim([-90 90]); +ylabel('Cloud cover'); +xlabel('Latitude (\circN)'); Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/plot_ifs.py =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/plot_ifs.py (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/test/ifs/plot_ifs.py (revision 6016) @@ -0,0 +1,141 @@ +from netCDF4 import Dataset +import numpy as np +import matplotlib.pyplot as plt + +#% This python scripts plots some of the inputs to the radiation scheme +#% in Fig. 1 and the outputs in Fig. 2 +code = 'ecrad_meridian' +in_file=Dataset(code+'.nc','r') +pressure_hl=in_file.variables['pressure_hl'][:] +temperature_hl=in_file.variables['temperature_hl'][:] +lat=in_file.variables['lat'][:] +cos_solar_zenith_angle=in_file.variables['cos_solar_zenith_angle'][:] +skin_temperature=in_file.variables['skin_temperature'][:] +cloud_fraction=in_file.variables['cloud_fraction'][:] +aerosol_mmr=in_file.variables['aerosol_mmr'][:] +cases = [code+'_noaer_out.nc', + code+'_default_out.nc', + code+'_expran_out.nc', + code+'_tc_out.nc', + code+'_spartacus_out.nc', + code+'_spartacus_maxentr_out.nc'] + + +f = [0]*6 +k=0 +for icase in cases: + f[k] = Dataset(icase,'r') + k=k+1 + + + +case_list = [0,1,2,3,4,5] +leg = ['McICA Exp-Exp no aerosols', + 'McICA Exp-Exp', + 'McICA Exp-Ran', + 'Tripleclouds Exp-Ran', + 'SPARTACUS Exp-Ran', + 'Classic SPARTACUS Exp-Ran'] + +styles = ['b','r','g','m','c','k'] + + +p = 0.01*0.5*np.median(pressure_hl[:,0:-1]+pressure_hl[:,1::],0) + +nplot=4 +plt.figure(1,figsize=(10,10)) +# set(gcf,'defaultlinelinewidth',1); +# set(gcf,'units','inches','paperposition',[0.5 0.5 15 30]); +# nplot = 4; +#fig, (ax0, ax1) = plt.subplots(nrows=2) + +plt.subplot(nplot,1,1) +plt.plot(lat,cos_solar_zenith_angle,color='k', linewidth=2.0) +ax= plt.gca() +ax.set_xlim([-90,90]) +plt.ylabel('Cos solar zenith ang.') + + +plt.subplot(nplot,1,2) +plt.plot(lat,skin_temperature-273.15,color='r',linewidth=2.0,label='Skin temperature') +plt.plot(lat,temperature_hl[:,-1]-273.15,color='b', linewidth=2.0,label='Air between first two model levels') +plt.gca().set_xlim([-90,90]) +plt.ylabel('Temperature ($^\circ$C)'); +plt.gca().set_ylim([-50,60]); +plt.gca().legend(loc='best',fontsize='xx-small') + +plt.subplot(nplot,1,3) +CS=plt.contourf(lat,p,cloud_fraction.T,10, vmin=0.05, vmax=0.95,cmap="viridis") +plt.colorbar() +plt.contour(CS,levels=CS.levels[::4],colors='k') +plt.gca().set_ylim([0,1013]) +plt.gca().invert_yaxis() +plt.gca().set_xlim([-90,90]) +plt.ylabel('Pressure (hPa)') +textstyle = dict(size=10, color='white') +plt.gca().text(-70,100,'Cloud fraction',**textstyle) +# text(-90, 0, [' ' 10 ' Cloud fraction'],'verticalalignment','top') + + +print(aerosol_mmr.shape) +plt.subplot(nplot,1,4) +sea_salt = 1e9*np.sum(aerosol_mmr[:,0:2,-1],1); +dust = 1e9*np.sum(aerosol_mmr[:,3:5,-1],1); +organics = 1e9*np.sum(aerosol_mmr[:,6:7,-1],1); +black_carbon = 1e9*np.sum(aerosol_mmr[:,8:9,-1],1); +sulphate = 1e9*np.sum(aerosol_mmr[:,10:11,-1],1); + +plt.semilogy(lat,sea_salt,'b',label='Sea salt') +plt.semilogy(lat,dust,'r',label='Dust') +plt.semilogy(lat,organics,'g',label='Organics') +plt.semilogy(lat,black_carbon,'k',label='Black carbon') +plt.semilogy(lat,sulphate,'m',label='Sulphate') +plt.gca().legend(loc='best',fontsize='xx-small') +plt.ylabel('Aerosol mass mixing ratio\n ($\mu$g/kg)') +plt.xlabel('Latitude (deg N)') +plt.gca().set_xlim([-90,90]) + +plt.savefig('input.png') + +nplot=4 +plt.figure(2,figsize=(10,10)) +# set(gcf,'defaultlinelinewidth',1); +# set(gcf,'units','inches','paperposition',[0.5 0.5 15 30]); + +plt.subplot(nplot,1,1) +for icase in case_list: + print(leg[icase]) + plt.plot(lat, f[icase].variables['flux_dn_sw'][:,-1],label=leg[icase]) + plt.gca().set_xlim([-90, 90]); + plt.ylabel('Surface SW down \n(W m$^{-2}$)'); + plt.gca().legend(loc='best',fontsize='xx-small') + + +plt.subplot(nplot,1,2) +for icase in case_list: + cre = f[icase].variables['flux_dn_sw'][:,1]-f[icase].variables['flux_dn_sw_clear'][:,1]-f[icase].variables['flux_up_sw'][:,1]+f[icase].variables['flux_up_sw_clear'][:,1] + plt.plot(lat, cre,label=leg[icase]) + plt.gca().set_xlim([-90, 90]); + plt.ylabel('SW cloud radiative effect \n(W m$^{-2}$)'); + plt.gca().legend(loc='best',fontsize='xx-small') + + +plt.subplot(nplot,1,3) +for icase in case_list: + cre = f[icase].variables['flux_dn_lw'][:,1]-f[icase].variables['flux_dn_lw_clear'][:,1]-f[icase].variables['flux_up_lw'][:,1]+f[icase].variables['flux_up_lw_clear'][:,1] + plt.plot(lat, cre,label=leg[icase]) + plt.gca().set_xlim([-90, 90]); + plt.ylabel('LW cloud radiative effect \n(W m$^{-2}$)'); + plt.gca().legend(loc='best',fontsize='xx-small') + +plt.subplot(nplot,1,4) +for icase in case_list: + plt.plot(lat, f[icase].variables['cloud_cover_sw'],label=leg[icase]); + plt.gca().set_xlim([-90, 90]); + plt.ylabel('Cloud cover'); + plt.gca().legend(loc='best',fontsize='xx-small') + plt.xlabel('Latitude (deg N)'); + + +plt.savefig('output.png') +#plt.show() Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/Makefile =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/Makefile (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/Makefile (revision 6016) @@ -0,0 +1,17 @@ +SOURCES = easy_netcdf.F90 radiation_io.F90 random_numbers_mix.F90 print_matrix.F90 + +OBJECTS := $(SOURCES:.F90=.o) +LIBUTILITIES = ../lib/libutilities.a + +all: $(LIBUTILITIES) + +$(LIBUTILITIES): $(OBJECTS) + ar r $(LIBUTILITIES) $(OBJECTS) + +%.o: %.F90 + $(FC) $(FCFLAGS) -c $< + +clean: + rm -f *.o $(LIBUTILITIES) + +easy_netcdf.o: radiation_io.o Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/easy_netcdf.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/easy_netcdf.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/easy_netcdf.F90 (revision 6016) @@ -0,0 +1,2907 @@ +! easy_netcdf.F90 - Module providing convenient NetCDF read/write capability +! +! (C) Copyright 2014- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! Modifications +! 2017-04-28 R. Hogan Fix "reshape" when writing 3D array +! 2017-10-23 A. Bozzo Reading 4-D array +! 2018-03-14 R. Hogan Fix "reshape" properly this time +! 2019-01-04 R. Hogan Allow reading and writing a slice of a larger array +! 2019-01-07 R. Hogan HDF5 writing support, allowing larger files, provided NC_NETCDF4 defined +! 2019-01-16 R. Hogan Revised interpretation of "iverbose" +! 2019-06-17 R. Hogan Pass through deflate_level and shuffle to variable definition + +module easy_netcdf + + use netcdf + use parkind1, only : jprb, jpib, jprm, jprd + use radiation_io, only : nulout, nulerr, my_abort => radiation_abort + + implicit none + public + + !--------------------------------------------------------------------- + ! An object of this type provides convenient read or write access to + ! a NetCDF file + type netcdf_file + integer :: ncid = -1! NetCDF file ID + integer :: iverbose ! Verbosity: 0 = report only fatal errors, + ! 1 = ...and warnings, + ! 2 = ...and when opening files, + ! 3 = ...and when reading/writing variables, + ! 4 = ...and variable attributes and when writing dimensions, + ! 5 = ...and debugging information + logical :: do_transpose_2d = .false. ! Transpose 2D arrays on read/write? + logical :: is_write_mode = .false. ! .false. for read, .true. for write + logical :: is_define_mode = .true. ! .true. if in NetCDF define mode + logical :: is_double_precision = .false. ! Write reals in double precision? + logical :: do_permute_3d = .false. ! Permute 3D arrays on write? + logical :: do_permute_4d = .false. ! Permute 3D arrays on write? + integer :: i_permute_3d(3) = (/1,2,3/) ! New order of dimensions + integer :: i_permute_4d(4) = (/1,2,3,4/) ! New order of dimensions + character(len=511) :: file_name + contains + procedure :: open => open_netcdf_file + procedure :: create => create_netcdf_file + procedure :: close => close_netcdf_file + procedure :: is_open + procedure :: get_real_scalar + procedure :: get_int_scalar + procedure :: get_real_vector + procedure :: get_int_vector + procedure :: get_real_matrix + procedure :: get_real_array3 + procedure :: get_real_scalar_indexed + procedure :: get_real_vector_indexed + procedure :: get_real_matrix_indexed + procedure :: get_real_array3_indexed + procedure :: get_real_array4 + procedure :: get_char_vector + procedure :: get_char_matrix + generic :: get => get_real_scalar, get_int_scalar, & + & get_real_vector, get_int_vector, & + & get_real_matrix, get_real_array3, & + & get_real_array4, & + & get_real_scalar_indexed, get_real_vector_indexed, & + & get_real_matrix_indexed, get_real_array3_indexed, & + & get_char_vector, get_char_matrix + procedure :: get_real_scalar_attribute + procedure :: get_string_attribute + generic :: get_attribute => get_real_scalar_attribute, & + & get_string_attribute + procedure :: get_global_attribute + + procedure :: define_dimension + procedure :: define_variable + procedure :: put_attribute + procedure :: put_global_attributes + procedure :: put_global_attribute + procedure :: put_real_scalar + procedure :: put_real_vector + procedure :: put_int_vector + procedure :: put_real_matrix + procedure :: put_real_array3 + procedure :: put_real_scalar_indexed + procedure :: put_real_vector_indexed + procedure :: put_real_matrix_indexed + generic :: put => put_real_scalar, put_real_vector, & + & put_real_matrix, put_real_array3, & + & put_real_scalar_indexed, put_real_vector_indexed, & + & put_real_matrix_indexed, put_int_vector + procedure :: set_verbose + procedure :: transpose_matrices + procedure :: double_precision + procedure :: permute_3d_arrays + procedure :: get_rank + procedure :: exists + procedure :: get_outer_dimension + procedure :: attribute_exists + procedure :: global_attribute_exists +#ifdef NC_NETCDF4 + procedure :: copy_dimensions +#endif + procedure :: copy_variable_definition + procedure :: copy_variable + procedure, private :: get_array_dimensions + procedure, private :: get_variable_id + procedure, private :: end_define_mode + procedure, private :: print_variable_attributes + end type netcdf_file + +contains + + ! --- GENERIC SUBROUTINES --- + + !--------------------------------------------------------------------- + ! Open a NetCDF file with name "file_name", optionally specifying the + ! verbosity level (0-5) and if the file is for writing (the default + ! is read-only) + subroutine open_netcdf_file(this, file_name, iverbose, is_write_mode, is_hdf5_file) + class(netcdf_file) :: this + character(len=*), intent(in) :: file_name + integer, intent(in), optional :: iverbose + logical, intent(in), optional :: is_write_mode + logical, intent(in), optional :: is_hdf5_file ! Only for write mode + + integer :: istatus + integer :: i_write_mode + + + ! Store verbosity level in object + if (present(iverbose)) then + this%iverbose = iverbose + else + ! By default announce files being opened and closed, but not + ! variables read/written + this%iverbose = 2 + end if + + ! Store read/write mode in object + if (present(is_write_mode)) then + this%is_write_mode = is_write_mode + else + this%is_write_mode = .false. + end if + + ! By default we don't transpose 2D arrays on read/write + this%do_transpose_2d = .false. + + ! Store filename + this%file_name = file_name + + ! Open file according to write mode + if (.not. this%is_write_mode) then + istatus = nf90_open(file_name, NF90_NOWRITE, this%ncid) + if (this%iverbose >= 2) then + write(nulout,'(a,a)') 'Reading NetCDF file ', file_name + !write(nulout,'(a,a,a,i0,a)') 'Reading NetCDF file ', file_name, ' (ID=', this%ncid, ')' + end if + this%is_define_mode = .false. + else + i_write_mode = NF90_CLOBBER + ! Check if HDF5 file is to be written (which can be larger) + if (present(is_hdf5_file)) then + if (is_hdf5_file) then +#ifdef NC_NETCDF4 + i_write_mode = ior(i_write_mode, NF90_HDF5) +#else + if (this%iverbose >= 1) then + write(nulout,'(a,a)') 'Warning: cannot use HDF5 format for writing ', file_name, & + & ' unless compiled with NC_NETCDF4 defined' + end if +#endif + end if + end if + + istatus = nf90_create(file_name, i_write_mode, this%ncid) + if (this%iverbose >= 2) then + write(nulout,'(a,a)') 'Writing NetCDF file ', file_name + end if + this%is_define_mode = .true. + end if + + ! Check the file opened correctly + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error opening NetCDF file ', & + & file_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error opening NetCDF file') + end if + + end subroutine open_netcdf_file + + + !--------------------------------------------------------------------- + ! Open a NetCDF file for writing + subroutine create_netcdf_file(this, file_name, iverbose, is_hdf5_file) + class(netcdf_file) :: this + character(len=*), intent(in) :: file_name + integer, intent(in), optional :: iverbose + logical, intent(in), optional :: is_hdf5_file + + integer :: istatus + integer :: i_write_mode + + if (present(iverbose)) then + this%iverbose = iverbose + else + this%iverbose = 2 + end if + + this%do_transpose_2d = .false. + + i_write_mode = NF90_CLOBBER + ! Check if HDF5 file is to be written (which can be large) + if (present(is_hdf5_file)) then + if (is_hdf5_file) then +#ifdef NC_NETCDF4 + i_write_mode = ior(i_write_mode, NF90_HDF5) +#else + if (this%iverbose >= 1) then + write(nulout,'(a,a)') 'Warning: cannot use HDF5 format for writing ', file_name, & + & ' unless compiled with NC_NETCDF4 defined' + end if +#endif + end if + end if + + istatus = nf90_create(file_name, i_write_mode, this%ncid) + if (this%iverbose >= 2) then + write(nulout,'(a,a)') 'Writing NetCDF file ', file_name + !write(nulout,'(a,a,a,i0,a)') 'Writing NetCDF file ', file_name, ' (ID=', this%ncid, ')' + end if + this%is_define_mode = .true. + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a)') '*** Error opening NetCDF file ', file_name, & + & ': ', trim(nf90_strerror(istatus)) + stop + end if + this%file_name = file_name + + end subroutine create_netcdf_file + + + !--------------------------------------------------------------------- + ! Close the NetCDF file + subroutine close_netcdf_file(this) + class(netcdf_file) :: this + integer :: istatus + + if (this%iverbose >= 3) then + write(nulout,'(a,a)') 'Closing NetCDF file ', trim(this%file_name) + end if + + istatus = nf90_close(this%ncid) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error closing NetCDF file ', & + & trim(this%file_name), ': ', trim(nf90_strerror(istatus)) + stop + end if + + this%ncid = -1 + + end subroutine close_netcdf_file + + + !--------------------------------------------------------------------- + ! Set the verbosity level from 0 to 5, where the codes have the + ! following meaning: 0=errors only, 1=warning, 2=info, 3=progress, + ! 4=detailed, 5=debug + subroutine set_verbose(this, ival) + class(netcdf_file) :: this + integer, optional :: ival + + if (present(ival)) then + this%iverbose = ival + else + this%iverbose = 2 + end if + + end subroutine set_verbose + + + !--------------------------------------------------------------------- + ! Specify whether floating-point arrays should be written in double precision + subroutine double_precision(this, is_double) + class(netcdf_file) :: this + logical, optional :: is_double + + if (present(is_double)) then + this%is_double_precision = is_double + else + this%is_double_precision = .true. + end if + + end subroutine double_precision + + + !--------------------------------------------------------------------- + ! Specify whether 2D arrays should be transposed on read/write + subroutine transpose_matrices(this, do_transpose) + class(netcdf_file) :: this + logical, optional :: do_transpose + + if (present(do_transpose)) then + this%do_transpose_2d = do_transpose + else + this%do_transpose_2d = .true. + end if + + end subroutine transpose_matrices + + + !--------------------------------------------------------------------- + ! Specify that 3D arrays should be permuted on write, with the new + ! dimension order in the input argument "ipermute" (e.g. 3,2,1) + subroutine permute_3d_arrays(this, ipermute) + class(netcdf_file) :: this + integer, intent(in) :: ipermute(3) + + this%do_permute_3d = .true. + this%i_permute_3d = ipermute + + end subroutine permute_3d_arrays + + + !--------------------------------------------------------------------- + ! Specify that 4D arrays should be permuted on write, with the new + ! dimension order in the input argument "ipermute" (e.g. 4,3,2,1) + subroutine permute_4d_arrays(this, ipermute) + class(netcdf_file) :: this + integer, intent(in) :: ipermute(4) + + this%do_permute_4d = .true. + this%i_permute_4d = ipermute + + end subroutine permute_4d_arrays + + + ! --- PRIVATE SUBROUTINES --- + + !--------------------------------------------------------------------- + ! Return the NetCDF variable ID for variable "var_name", or abort if + ! not present + subroutine get_variable_id(this, var_name, ivarid) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(out) :: ivarid + + integer :: istatus + + istatus = nf90_inq_varid(this%ncid, var_name, ivarid) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_variable_id + + + !--------------------------------------------------------------------- + ! Return the array dimensions of variable with specified ID, along + ! with the number of dimensions and optionally the total number of + ! elements, or abort if variable not present + subroutine get_array_dimensions(this, ivarid, ndims, ndimlens, ntotal) + class(netcdf_file) :: this + integer, intent(in) :: ivarid + integer, intent(out) :: ndims + integer, intent(out) :: ndimlens(NF90_MAX_VAR_DIMS) + integer(kind=jpib), intent(out), optional :: ntotal + + integer :: j, istatus + integer :: idimids(NF90_MAX_VAR_DIMS) + + istatus = nf90_inquire_variable(this%ncid, ivarid, & + & ndims=ndims, dimids=idimids) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,i0,a,a)') '*** Error inquiring about NetCDF variable with id ', & + & ivarid, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ndimlens(:) = 0 + do j = 1,ndims + istatus = nf90_inquire_dimension(this%ncid, idimids(j), len=ndimlens(j)) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,i0,a,i0,a,a)') '*** Error reading length of dimension ', & + & j, ' of NetCDF variable with id ', ivarid, ': ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + end do + + if (present(ntotal)) then + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + end do + end if + + end subroutine get_array_dimensions + + + !--------------------------------------------------------------------- + ! End define mode, if in define mode, and check the error code + ! (errors are possible if variables are too large for the format, + ! for example) + subroutine end_define_mode(this) + class(netcdf_file) :: this + integer :: istatus + if (this%is_define_mode) then + istatus = nf90_enddef(this%ncid) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error ending define mode when writing ', & + & trim(this%file_name), ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + this%is_define_mode = .false. + end if + end subroutine end_define_mode + + + ! --- READING SUBROUTINES --- + + !--------------------------------------------------------------------- + ! Return true if file is open, false otherwise + function is_open(this) + class(netcdf_file) :: this + logical :: is_open + is_open = (this%ncid >= 0) + end function is_open + + !--------------------------------------------------------------------- + ! Return the number of dimensions of variable with name var_name, or + ! -1 if the variable is not found + function get_rank(this, var_name) result(ndims) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + + integer :: ndims + integer :: ivarid + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: istatus + + istatus = nf90_inq_varid(this%ncid, var_name, ivarid) + if (istatus /= NF90_NOERR) then + if (istatus == NF90_ENOTVAR) then + if (this%iverbose >= 1) then + write(nulout,'(a,a,a)') ' Warning: variable ', var_name, ' not found' + end if + else + write(nulerr,'(a,a,a)') '*** Error inquiring about variable ', & + & var_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + ndims = -1 + else + call this%get_array_dimensions(ivarid, ndims, ndimlens) + end if + + end function get_rank + + + !--------------------------------------------------------------------- + ! Return the length of the slowest-varying dimension of variable + ! with name var_name, or -1 if the variable is not found + function get_outer_dimension(this, var_name) result(n) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + + integer :: n + integer :: ndims + integer :: ivarid + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: istatus + + istatus = nf90_inq_varid(this%ncid, var_name, ivarid) + if (istatus /= NF90_NOERR) then + if (istatus == NF90_ENOTVAR) then + if (this%iverbose >= 1) then + write(nulout,'(a,a,a)') ' Warning: variable ', var_name, ' not found' + end if + else + write(nulerr,'(a,a,a)') '*** Error inquiring about variable ', & + & var_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + n = -1 + else + call this%get_array_dimensions(ivarid, ndims, ndimlens) + n = ndimlens(ndims) + end if + + end function get_outer_dimension + + + !--------------------------------------------------------------------- + ! Return true if the variable is present, false otherwise + function exists(this, var_name) result(is_present) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + + logical :: is_present + + integer :: ivarid + integer :: istatus + + istatus = nf90_inq_varid(this%ncid, var_name, ivarid) + if (istatus /= NF90_NOERR) then + is_present = .false. + else + is_present = .true. + end if + + end function exists + + + !--------------------------------------------------------------------- + ! Return true if the attribute is present, false otherwise. If + ! argument "len" is provided then return false if len is smaller + ! than the length of the attribute. This is useful if you have a + ! fixed array size and want to check whether the attribute will fit + ! into it. + function attribute_exists(this, var_name, attr_name, len) result(is_present) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name, attr_name + integer, optional, intent(in) :: len + + logical :: is_present + integer :: i_attr_len, ivarid + integer :: istatus + + istatus = nf90_inq_varid(this%ncid, var_name, ivarid) + if (istatus /= NF90_NOERR) then + is_present = .false. + else + istatus = nf90_inquire_attribute(this%ncid, ivarid, attr_name, & + & len=i_attr_len) + if (istatus /= NF90_NOERR) then + is_present = .false. + else + is_present = .true. + if (present(len)) then + if (i_attr_len > len) then + is_present = .false. + end if + end if + end if + end if + + end function attribute_exists + + + !--------------------------------------------------------------------- + ! Return true if the global attribute is present, false otherwise. + ! If argument "len" is provided then return false if len is smaller + ! than the length of the attribute. This is useful if you have a + ! fixed array size and want to check whether the attribute will fit + ! into it. + function global_attribute_exists(this, attr_name, len) result(is_present) + class(netcdf_file) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(in) :: len + + logical :: is_present + integer :: i_attr_len + integer :: istatus + + istatus = nf90_inquire_attribute(this%ncid, NF90_GLOBAL, attr_name, & + & len=i_attr_len) + if (istatus /= NF90_NOERR) then + is_present = .false. + else + is_present = .true. + if (present(len)) then + if (i_attr_len > len) then + is_present = .false. + end if + end if + end if + + end function global_attribute_exists + + + !--------------------------------------------------------------------- + ! The method "get" will read either a scalar, vector or matrix + ! depending on the rank of the output argument. This version reads a + ! scalar. + subroutine get_real_scalar(this, var_name, scalar) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(out) :: scalar + + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + + ! Inquire the ID, shape & size of the variable + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Compute number of elements of the variable in the file + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + end do + + if (this%iverbose >= 3) then + write(nulout,'(a,a)',advance='no') ' Reading ', var_name + call this%print_variable_attributes(ivarid,nulout) + end if + + ! Abort if the number of elements is anything other than 1 + if (ntotal /= 1) then + write(nulerr,'(a,a,a,i0,a)') '*** Error reading NetCDF variable ', & + & var_name, ' with total length ', ntotal, ' as a scalar' + call my_abort('Error reading NetCDF file') + end if + + ! Read variable + istatus = nf90_get_var(this%ncid, ivarid, scalar) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a scalar: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_scalar + + + !--------------------------------------------------------------------- + ! Read an integer scalar + subroutine get_int_scalar(this, var_name, scalar) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(out):: scalar + + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + + ! Inquire the ID, shape & size of the variable + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Compute number of elements of the variable in the file + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + end do + + if (this%iverbose >= 3) then + write(nulout,'(a,a)',advance='no') ' Reading ', var_name + call this%print_variable_attributes(ivarid,nulout) + end if + + ! Abort if the number of elements is anything other than 1 + if (ntotal /= 1) then + write(nulerr,'(a,a,a,i0,a)') '*** Error reading NetCDF variable ', & + & var_name, ' with total length ', ntotal, ' as a scalar' + call my_abort('Error reading NetCDF file') + end if + + ! Read variable + istatus = nf90_get_var(this%ncid, ivarid, scalar) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a scalar: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_int_scalar + + + !--------------------------------------------------------------------- + ! Read a scalar from a larger array, where "index" indexes the most + ! slowly varying dimension + subroutine get_real_scalar_indexed(this, var_name, scalar, index) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: index + real(jprb), intent(out) :: scalar + + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + + ! Inquire the ID, shape & size of the variable + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Compute number of elements of the slice in the file, + ! i.e. excluding the slowest varying dimension, indexed by "index" + ntotal = 1 + do j = 1, ndims-1 + ntotal = ntotal * ndimlens(j) + end do + + if (this%iverbose >= 3) then + write(nulout,'(a,a,i0,a,a)') ' Reading element ', index, ' of ', var_name + end if + + ! Abort if the number of elements is anything other than 1 + if (ntotal /= 1) then + write(nulerr,'(a,a,a,i0,a)') '*** Error reading NetCDF variable ', & + & var_name, ' with slice length ', ntotal, ' as a scalar' + call my_abort('Error reading NetCDF file') + end if + + if (index < 1 .or. index > ndimlens(ndims)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error reading element ', index, & + & ' of NetCDF variable ', & + & var_name, ' with outer dimension ', ndimlens(ndims) + call my_abort('Error reading NetCDF file') + end if + + ! Read variable + vstart(1:ndims-1) = 1 + vstart(ndims) = index + istatus = nf90_get_var(this%ncid, ivarid, scalar, start=vstart) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a scalar: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_scalar_indexed + + + !--------------------------------------------------------------------- + ! Read a 1D real array into "vector", which must be allocatable and + ! will be reallocated if necessary + subroutine get_real_vector(this, var_name, vector) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), allocatable, intent(out) :: vector(:) + + integer :: n ! Length of vector + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure variable has only one dimension in the file + n = 1 + do j = 1, ndims + n = n * ndimlens(j) + if (j > 1 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a vector: all dimensions above the first must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Reallocate if necessary + if (allocated(vector)) then + if (size(vector) /= n) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing vector to read ', var_name + end if + deallocate(vector) + allocate(vector(n)) + end if + else + allocate(vector(n)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a)',advance='no') ' Reading ', var_name, '(', n, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + ! Read variable + istatus = nf90_get_var(this%ncid, ivarid, vector) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a vector: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_vector + + + !--------------------------------------------------------------------- + ! Read a 1D character array into "vector", which must be allocatable + ! and will be reallocated if necessary + subroutine get_char_vector(this, var_name, vector) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + character(len=1), allocatable, intent(out) :: vector(:) + + integer :: n ! Length of vector + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure variable has only one dimension in the file + n = 1 + do j = 1, ndims + n = n * ndimlens(j) + if (j > 1 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a vector: all dimensions above the first must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Reallocate if necessary + if (allocated(vector)) then + if (size(vector) /= n) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing vector to read ', var_name + end if + deallocate(vector) + allocate(vector(n)) + end if + else + allocate(vector(n)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a)',advance='no') ' Reading ', var_name, '(', n, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + ! Read variable + istatus = nf90_get_var(this%ncid, ivarid, vector) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a vector of chars: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_char_vector + + + !--------------------------------------------------------------------- + ! Read a 1D integer array into "vector", which must be allocatable + ! and will be reallocated if necessary + subroutine get_int_vector(this, var_name, vector) + + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, allocatable, intent(out) :: vector(:) + + integer :: n ! Length of vector + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure variable has only one dimension in the file + n = 1 + do j = 1, ndims + n = n * ndimlens(j) + if (j > 1 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a vector: all dimensions above the first must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Reallocate if necessary + if (allocated(vector)) then + if (size(vector) /= n) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing vector to read ', var_name + end if + deallocate(vector) + allocate(vector(n)) + end if + else + allocate(vector(n)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a)',advance='no') ' Reading ', var_name, '(', n, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + ! Read variable + istatus = nf90_get_var(this%ncid, ivarid, vector) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as an integer vector: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_int_vector + + !--------------------------------------------------------------------- + ! Read a vector of data from a larger array; the vector must be + ! allocatable and will be reallocated if necessary + subroutine get_real_vector_indexed(this, var_name, vector, index) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: index + real(jprb), allocatable, intent(out) :: vector(:) + + integer :: n ! Length of vector + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + integer :: vcount(NF90_MAX_VAR_DIMS) + integer :: j + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure variable has only one dimension aside from the last one + n = 1 + do j = 1, ndims-1 + n = n * ndimlens(j) + if (j > 1 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading 1D slice from NetCDF variable ', & + & var_name, & + & ': all dimensions except the first and last must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Reallocate if necessary + if (allocated(vector)) then + if (size(vector) /= n) then + if (this%iverbose >= 1) then + write(nulout,'(a,i0,a,a)') ' Warning: resizing vector to length ', n, & + & ' to read slice of ', var_name + end if + deallocate(vector) + allocate(vector(n)) + end if + else + allocate(vector(n)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,i0,a,a)') ' Reading column ', index, ' of ', var_name + end if + + if (index < 1 .or. index > ndimlens(ndims)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error reading element ', index, & + & ' of NetCDF variable ', & + & var_name, ' with outer dimension ', ndimlens(ndims) + call my_abort('Error reading NetCDF file') + end if + + ! Read variable + vstart(1:ndims-1) = 1 + vstart(ndims) = index + vcount(1:ndims-1) = ndimlens(1:ndims-1) + vcount(ndims) = 1 + istatus = nf90_get_var(this%ncid, ivarid, vector, & + & start=vstart, count=vcount) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading 1D slice of NetCDF variable ', & + & var_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_vector_indexed + + + !--------------------------------------------------------------------- + ! Read 2D array into "matrix", which must be allocatable and will be + ! reallocated if necessary. Whether to transpose is specifed by the + ! final optional argument, but can also be specified by the + ! do_transpose_2d class data member. + subroutine get_real_matrix(this, var_name, matrix, do_transp) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), allocatable, intent(out) :: matrix(:,:) + logical, optional, intent(in):: do_transp ! Transpose data? + + real(jprb), allocatable :: tmp_matrix(:,:) + integer :: ndimlen1, ndimlen2 + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + logical :: do_transpose + + ! Decide whether to transpose the array + if (present(do_transp)) then + do_transpose = do_transp + else + do_transpose = this%do_transpose_2d + end if + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure the variable has no more than two non-singleton + ! dimensions + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + if (j > 2 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a matrix: all dimensions above the second must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Work out dimension lengths + if (ndims >= 2) then + ndimlen1 = ndimlens(1) + ndimlen2 = ntotal/ndimlen1 + else + ndimlen1 = ntotal + ndimlen2 = 1 + end if + + if (do_transpose) then + ! Read and transpose + allocate(tmp_matrix(ndimlen1, ndimlen2)) + + ! Reallocate if necessary + if (allocated(matrix)) then + if (size(matrix,1) /= ndimlen2 .or. size(matrix,2) /= ndimlen1) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing matrix to read ', var_name + end if + deallocate(matrix) + allocate(matrix(ndimlen2, ndimlen1)) + end if + else + allocate(matrix(ndimlen2, ndimlen1)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') ' Reading ', var_name, '(', & + & ndimlen2, ',', ndimlen1, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + istatus = nf90_get_var(this%ncid, ivarid, tmp_matrix) + matrix = transpose(tmp_matrix) + deallocate(tmp_matrix) + else + ! Read data without transposition + + ! Reallocate if necessary + if (allocated(matrix)) then + if (size(matrix,1) /= ndimlen1 .or. size(matrix,2) /= ndimlen2) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing matrix to read ', var_name + end if + allocate(matrix(ndimlen1, ndimlen2)) + end if + else + allocate(matrix(ndimlen1, ndimlen2)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') ' Reading ', var_name, '(', & + & ndimlen1, ',', ndimlen2, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + istatus = nf90_get_var(this%ncid, ivarid, matrix) + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a matrix: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_matrix + + + !--------------------------------------------------------------------- + ! Read 2D array of characters into "matrix", which must be + ! allocatable and will be reallocated if necessary. Whether to + ! transpose is specifed by the final optional argument, but can also + ! be specified by the do_transpose_2d class data member. + subroutine get_char_matrix(this, var_name, matrix, do_transp) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + character(len=1), allocatable, intent(inout) :: matrix(:,:) + logical, optional, intent(in):: do_transp ! Transpose data? + + character(len=1), allocatable:: tmp_matrix(:,:) + integer :: ndimlen1, ndimlen2 + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + integer :: vcount(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + logical :: do_transpose + + ! Decide whether to transpose the array + if (present(do_transp)) then + do_transpose = do_transp + else + do_transpose = this%do_transpose_2d + end if + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure the variable has no more than two non-singleton + ! dimensions + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + if (j > 2 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a matrix: all dimensions above the second must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Work out dimension lengths + if (ndims >= 2) then + ndimlen1 = ndimlens(1) + ndimlen2 = ntotal/ndimlen1 + else + ndimlen1 = ntotal + ndimlen2 = 1 + end if + + if (do_transpose) then + ! Read and transpose + allocate(tmp_matrix(ndimlen1, ndimlen2)) + + ! Reallocate if necessary + if (allocated(matrix)) then + if (size(matrix,1) /= ndimlen2 .or. size(matrix,2) /= ndimlen1) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing matrix to read ', var_name + end if + deallocate(matrix) + allocate(matrix(ndimlen2, ndimlen1)) + end if + else + allocate(matrix(ndimlen2, ndimlen1)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') ' Reading ', var_name, '(', & + & ndimlen2, ',', ndimlen1, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + istatus = nf90_get_var(this%ncid, ivarid, tmp_matrix) + matrix = transpose(tmp_matrix) + deallocate(tmp_matrix) + else + ! Read data without transposition + + ! Reallocate if necessary + if (allocated(matrix)) then + if (size(matrix,1) /= ndimlen1 .or. size(matrix,2) /= ndimlen2) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing matrix to read ', var_name + end if + allocate(matrix(ndimlen1, ndimlen2)) + end if + else + allocate(matrix(ndimlen1, ndimlen2)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') ' Reading ', var_name, '(', & + & ndimlen1, ',', ndimlen2, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + vstart = 1 + vcount(1:2) = [ndimlen1,1] + + do j = 1,ndimlen2 + vstart(2) = j + istatus = nf90_get_var(this%ncid, ivarid, matrix(:,j), start=vstart, count=vcount) + end do + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a matrix of characters: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_char_matrix + + + !--------------------------------------------------------------------- + ! Read matrix of data from a larger array, which must be allocatable + ! and will be reallocated if necessary. Whether to transpose is + ! specifed by the final optional argument, but can also be specified + ! by the do_transpose_2d class data member. + subroutine get_real_matrix_indexed(this, var_name, matrix, index, do_transp) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: index + real(jprb), allocatable, intent(out) :: matrix(:,:) + logical, optional, intent(in):: do_transp ! Transpose data? + + real(jprb), allocatable :: tmp_matrix(:,:) + integer :: ndimlen1, ndimlen2 + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + integer :: vcount(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + logical :: do_transpose + + ! Decide whether to transpose the array + if (present(do_transp)) then + do_transpose = do_transp + else + do_transpose = this%do_transpose_2d + end if + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure the variable has no more than two non-singleton + ! dimensions aside from the last one + ntotal = 1 + do j = 1, ndims-1 + ntotal = ntotal * ndimlens(j) + if (j > 2 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading 2D slice from NetCDF variable ', & + & var_name, & + & ': all dimensions except the first, second and last must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + if (index < 1 .or. index > ndimlens(ndims)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error reading element ', index, & + & ' of NetCDF variable ', & + & var_name, ' with outer dimension ', ndimlens(ndims) + call my_abort('Error reading NetCDF file') + end if + + ! Work out dimension lengths + if (ndims >= 2) then + ndimlen1 = ndimlens(1) + ndimlen2 = ntotal/ndimlen1 + else + ndimlen1 = ntotal + ndimlen2 = 1 + end if + + vstart(1:ndims-1) = 1 + vstart(ndims) = index + vcount(1:ndims-1) = ndimlens(1:ndims-1) + vcount(ndims) = 1 + + if (do_transpose) then + ! Read and transpose + allocate(tmp_matrix(ndimlen1, ndimlen2)) + + ! Reallocate if necessary + if (allocated(matrix)) then + if (size(matrix,1) /= ndimlen2 .or. size(matrix,2) /= ndimlen1) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing matrix to read ', var_name + end if + allocate(matrix(ndimlen2, ndimlen1)) + end if + else + allocate(matrix(ndimlen2, ndimlen1)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,i0,a,a,a,i0,a,i0,a)') ' Reading slice ', index, & + & ' of ', var_name, ' as ', ndimlen2, 'x', ndimlen1, ' array' + end if + + istatus = nf90_get_var(this%ncid, ivarid, tmp_matrix, & + & start=vstart, count=vcount) + matrix = transpose(tmp_matrix) + deallocate(tmp_matrix) + else + ! Read data without transposition + + ! Reallocate if necessary + if (allocated(matrix)) then + if (size(matrix,1) /= ndimlen1 .or. size(matrix,2) /= ndimlen2) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing matrix to read ', var_name + end if + allocate(matrix(ndimlen1, ndimlen2)) + end if + else + allocate(matrix(ndimlen1, ndimlen2)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,i0,a,a,a,i0,a,i0,a)') ' Reading slice ', index, & + & ' of ', var_name, ' as ', ndimlen1, 'x', ndimlen2, ' array' + end if + + istatus = nf90_get_var(this%ncid, ivarid, matrix, & + & start=vstart, count=vcount) + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading 2D slice of NetCDF variable ', & + & var_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_matrix_indexed + + + !--------------------------------------------------------------------- + ! Read 3D array into "var", which must be allocatable and will be + ! reallocated if necessary. Whether to pemute is specifed by the + ! final optional argument + subroutine get_real_array3(this, var_name, var, ipermute) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), allocatable, intent(out) :: var(:,:,:) + integer, optional, intent(in) :: ipermute(3) + + real(jprb), allocatable :: var_permute(:,:,:) + integer :: ndimlen1, ndimlen2, ndimlen3 + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + integer :: n_dimlens_permuted(3) + integer :: i_permute_3d(3) + logical :: do_permute + + ! Decide whether to permute + if (present(ipermute)) then + do_permute = .true. + i_permute_3d = ipermute + else + do_permute = this%do_permute_3d + i_permute_3d = this%i_permute_3d + end if + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure the variable has no more than three non-singleton + ! dimensions + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + if (j > 3 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a 3D array: all dimensions above the third must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Work out dimension lengths + if (ndims >= 3) then + ndimlen1 = ndimlens(1) + ndimlen2 = ndimlens(2) + ndimlen3 = ntotal/(ndimlen1*ndimlen2) + else if (ndims >= 2) then + ndimlen1 = ndimlens(1) + ndimlen2 = ntotal/ndimlen1 + ndimlen3 = 1 + else + ndimlen1 = ntotal + ndimlen2 = 1 + ndimlen3 = 1 + end if + + ! Deallocate if necessary + if (allocated(var)) then + deallocate(var) + end if + + if (do_permute) then + ! Read and permute + allocate(var_permute(ndimlen1, ndimlen2, ndimlen3)) + n_dimlens_permuted(i_permute_3d) = ndimlens(1:3) + + ! Reallocate if necessary + if (allocated(var)) then + if (size(var,1) /= n_dimlens_permuted(1) & + & .or. size(var,2) /= n_dimlens_permuted(2) & + & .or. size(var,3) /= n_dimlens_permuted(3)) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing array to read ', var_name + end if + deallocate(var) + allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), & + & n_dimlens_permuted(3))) + end if + else + allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), & + & n_dimlens_permuted(3))) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,i0,i0,a)',advance='no') ' Reading ', var_name, & + & ' (permuting dimensions ', i_permute_3d, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + istatus = nf90_get_var(this%ncid, ivarid, var_permute) + var = reshape(var_permute, n_dimlens_permuted, order=i_permute_3d) + deallocate(var_permute) + + else + ! Read data without permutation + + ! Reallocate if necessary + if (allocated(var)) then + if (size(var,1) /= ndimlen1 & + & .or. size(var,2) /= ndimlen2 & + & .or. size(var,3) /= ndimlen3) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing array to read ', var_name + end if + deallocate(var) + allocate(var(ndimlen1, ndimlen2, ndimlen3)) + end if + else + allocate(var(ndimlen1, ndimlen2, ndimlen3)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a,i0,a,i0,a)',advance='no') ' Reading ', var_name, & + & '(', ndimlen1, ',', ndimlen2, ',', ndimlen3, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + istatus = nf90_get_var(this%ncid, ivarid, var) + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a 3D array: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_array3 + + + !--------------------------------------------------------------------- + ! Read 3D array of data from a larger-dimensional array, which must + ! be allocatable and will be reallocated if necessary. Whether to + ! pemute is specifed by the final optional argument + subroutine get_real_array3_indexed(this, var_name, var, index, ipermute) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: index + real(jprb), allocatable, intent(out) :: var(:,:,:) + integer, optional, intent(in) :: ipermute(3) + + real(jprb), allocatable :: var_permute(:,:,:) + integer :: ndimlen1, ndimlen2, ndimlen3 + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + integer :: vcount(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + integer :: n_dimlens_permuted(3) + integer :: i_permute_3d(3) + logical :: do_permute + + ! Decide whether to permute + if (present(ipermute)) then + do_permute = .true. + i_permute_3d = ipermute + else + do_permute = this%do_permute_3d + i_permute_3d = this%i_permute_3d + end if + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure the variable has no more than three non-singleton + ! dimensions aside from the last one + ntotal = 1 + do j = 1, ndims-1 + ntotal = ntotal * ndimlens(j) + if (j > 3 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading 3D slice from NetCDF variable ', & + & var_name, & + & ': all dimensions above the third must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + if (index < 1 .or. index > ndimlens(ndims)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error reading element ', index, & + & ' of NetCDF variable ', & + & var_name, ' with outer dimension ', ndimlens(ndims) + call my_abort('Error reading NetCDF file') + end if + + ! Work out dimension lengths + if (ndims >= 3) then + ndimlen1 = ndimlens(1) + ndimlen2 = ndimlens(2) + ndimlen3 = ntotal/(ndimlen1*ndimlen2) + else if (ndims >= 2) then + ndimlen1 = ndimlens(1) + ndimlen2 = ntotal/ndimlen1 + ndimlen3 = 1 + else + ndimlen1 = ntotal + ndimlen2 = 1 + ndimlen3 = 1 + end if + + vstart(1:ndims-1) = 1 + vstart(ndims) = index + vcount(1:ndims-1) = ndimlens(1:ndims-1) + vcount(ndims) = 1 + + if (do_permute) then + ! Read and permute + allocate(var_permute(ndimlen1, ndimlen2, ndimlen3)) + n_dimlens_permuted(i_permute_3d) = ndimlens(1:3) + + ! Reallocate if necessary + if (allocated(var)) then + if (size(var,1) /= n_dimlens_permuted(1) & + & .or. size(var,2) /= n_dimlens_permuted(2) & + & .or. size(var,3) /= n_dimlens_permuted(3)) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing array to read ', var_name + end if + deallocate(var) + allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), & + & n_dimlens_permuted(3))) + end if + else + allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), & + & n_dimlens_permuted(3))) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,i0,a,a,a,i0,i0,i0,a)') ' Reading slice ', index, & + & ' of ', var_name, & + & ' (permuting dimensions ', i_permute_3d, ')' + end if + + istatus = nf90_get_var(this%ncid, ivarid, var_permute, & + & start=vstart, count=vcount) + var = reshape(var_permute, n_dimlens_permuted, order=i_permute_3d) + deallocate(var_permute) + + else + ! Read data without permutation + + ! Reallocate if necessary + if (allocated(var)) then + if (size(var,1) /= ndimlen1 & + & .or. size(var,2) /= ndimlen2 & + & .or. size(var,3) /= ndimlen3) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing array to read ', var_name + end if + deallocate(var) + allocate(var(ndimlen1, ndimlen2, ndimlen3)) + end if + else + allocate(var(ndimlen1, ndimlen2, ndimlen3)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,i0,a,a,a,i0,a,i0,a,i0,a)') ' Reading slice ', index, & + & ' of ', var_name, ' as ', ndimlen1, 'x', ndimlen2, 'x', & + & ndimlen3, 'array' + end if + + istatus = nf90_get_var(this%ncid, ivarid, var, & + & start=vstart, count=vcount) + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading 3D slice of NetCDF variable ', & + & var_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_array3_indexed + + + !--------------------------------------------------------------------- + ! Read 4D array into "var", which must be allocatable and will be + ! reallocated if necessary. Whether to pemute is specifed by the + ! final optional argument + subroutine get_real_array4(this, var_name, var, ipermute) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), allocatable, intent(out) :: var(:,:,:,:) + integer, optional, intent(in) :: ipermute(4) + + real(jprb), allocatable :: var_permute(:,:,:,:) + integer :: ndimlen1, ndimlen2, ndimlen3, ndimlen4 + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + integer :: n_dimlens_permuted(4) + integer :: i_permute_4d(4) + logical :: do_permute + + ! Decide whether to permute + if (present(ipermute)) then + do_permute = .true. + i_permute_4d = ipermute + else + do_permute = this%do_permute_4d + i_permute_4d = this%i_permute_4d + end if + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure the variable has no more than three non-singleton + ! dimensions + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + if (j > 4 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a 4D array: all dimensions above the third must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Work out dimension lengths + if (ndims >= 4) then + ndimlen1 = ndimlens(1) + ndimlen2 = ndimlens(2) + ndimlen3 = ndimlens(3) + ndimlen4 = ntotal/(ndimlen1*ndimlen2*ndimlen3) + else if (ndims >= 3) then + ndimlen1 = ndimlens(1) + ndimlen2 = ndimlens(2) + ndimlen3 = ntotal/(ndimlen1*ndimlen2) + else if (ndims >= 2) then + ndimlen1 = ndimlens(1) + ndimlen2 = ntotal/ndimlen1 + ndimlen3 = 1 + else + ndimlen1 = ntotal + ndimlen2 = 1 + ndimlen3 = 1 + end if + + ! Deallocate if necessary + if (allocated(var)) then + deallocate(var) + end if + + if (do_permute) then + ! Read and permute - not tested + allocate(var_permute(ndimlen1, ndimlen2, ndimlen3, ndimlen4)) + n_dimlens_permuted(i_permute_4d) = ndimlens(1:4) + + ! Reallocate if necessary + if (allocated(var)) then + if (size(var,1) /= n_dimlens_permuted(1) & + & .or. size(var,2) /= n_dimlens_permuted(2) & + & .or. size(var,3) /= n_dimlens_permuted(3) & + & .or. size(var,4) /= n_dimlens_permuted(4)) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing array to read ', var_name + end if + deallocate(var) + allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), & + & n_dimlens_permuted(3), n_dimlens_permuted(4))) + end if + else + allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), & + & n_dimlens_permuted(3), n_dimlens_permuted(4))) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,i0,i0,a)',advance='no') ' Reading ', var_name, & + & ' (permuting dimensions ', i_permute_4d, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + istatus = nf90_get_var(this%ncid, ivarid, var_permute) + var = reshape(var_permute, n_dimlens_permuted, order=i_permute_4d) + deallocate(var_permute) + + else + ! Read data without permutation + + ! Reallocate if necessary + if (allocated(var)) then + if (size(var,1) /= ndimlen1 & + & .or. size(var,2) /= ndimlen2 & + & .or. size(var,3) /= ndimlen3 & + & .or. size(var,4) /= ndimlen4) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing array to read ', var_name + end if + deallocate(var) + allocate(var(ndimlen1, ndimlen2, ndimlen3, ndimlen4)) + end if + else + allocate(var(ndimlen1, ndimlen2, ndimlen3, ndimlen4)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a,i0,a,i0,a,i0,a)',advance='no') ' Reading ', var_name, & + & '(', ndimlen1, ',', ndimlen2, ',', ndimlen3,',', ndimlen4, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + istatus = nf90_get_var(this%ncid, ivarid, var) + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a 4D array: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_array4 + + + !--------------------------------------------------------------------- + ! Get attribute as a character string + subroutine get_string_attribute(this, var_name, attr_name, attr_str) + class(netcdf_file) :: this + + character(len=*), intent(in) :: var_name, attr_name + character(len=*), intent(inout) :: attr_str + + integer :: i_attr_len, ivarid + integer :: istatus + integer :: j + + istatus = nf90_inq_varid(this%ncid, var_name, ivarid) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error inquiring about variable ', var_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + istatus = nf90_inquire_attribute(this%ncid, ivarid, attr_name, & + & len = i_attr_len) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading size of attribute ', attr_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ! Allocatable character strings not supported on enough compilers + ! yet + ! if (allocated(attr_str)) then + ! deallocate(attr_str) + ! end if + ! allocate(character(len=i_attr_len) :: attr_str) + if (len(attr_str) < i_attr_len) then + write(nulerr,'(a,a)') '*** Not enough space to read attribute ', attr_name + call my_abort('Error reading NetCDF file') + end if + + istatus = nf90_get_att(this%ncid, ivarid, attr_name, attr_str) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading attribute ', attr_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ! Pad with blanks since nf90_get_att does not do this + do j = i_attr_len+1,len(attr_str) + attr_str(j:j) = ' ' + end do + + end subroutine get_string_attribute + + + + !--------------------------------------------------------------------- + ! Get attribute as a real scalar + subroutine get_real_scalar_attribute(this, var_name, attr_name, attr) + class(netcdf_file) :: this + + character(len=*), intent(in) :: var_name, attr_name + real(jprb), intent(out) :: attr + + integer :: ivarid + integer :: istatus + + istatus = nf90_inq_varid(this%ncid, var_name, ivarid) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error inquiring about variable ', var_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + istatus = nf90_get_att(this%ncid, ivarid, attr_name, attr) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading attribute ', attr_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_real_scalar_attribute + + + !--------------------------------------------------------------------- + ! Get a global attribute as a character string + subroutine get_global_attribute(this, attr_name, attr_str) + class(netcdf_file) :: this + + character(len=*), intent(in) :: attr_name + character(len=*), intent(inout) :: attr_str + + integer :: i_attr_len + integer :: istatus + integer :: j + + istatus = nf90_inquire_attribute(this%ncid, NF90_GLOBAL, attr_name, & + & len = i_attr_len) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading size of global attribute ', attr_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ! Allocatable character strings not supported one enough compilers + ! yet + ! if (allocated(attr_str)) then + ! deallocate(attr_str) + ! end if + ! allocate(character(len=i_attr_len) :: attr_str) + if (len(attr_str) < i_attr_len) then + write(nulerr,'(a,a)') '*** Not enough space to read global attribute ', attr_name + call my_abort('Error reading NetCDF file') + end if + + istatus = nf90_get_att(this%ncid, NF90_GLOBAL, attr_name, attr_str) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading global attribute ', attr_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ! Pad with blanks since nf90_get_att does not do this + do j = i_attr_len+1,len(attr_str) + attr_str(j:j) = ' ' + end do + + end subroutine get_global_attribute + + + !--------------------------------------------------------------------- + ! Print a variable's long_name, units and comment, according to + ! verbosity level + subroutine print_variable_attributes(this, ivarid, iunit) + class(netcdf_file) :: this + integer, intent(in) :: ivarid ! NetCDF ID of variable + integer, intent(in) :: iunit ! Unit to print information to + + character(len=4000) :: attr_str + integer :: istatus + + if (this%iverbose >= 4) then + istatus = nf90_get_att(this%ncid, ivarid, 'long_name', attr_str) + if (istatus == NF90_NOERR) then + write(iunit, '(a,a,a)', advance='no') ': "', trim(attr_str), '"' + istatus = nf90_get_att(this%ncid, ivarid, 'units', attr_str) + if (istatus == NF90_NOERR) then + if (trim(attr_str) == '1') then + write(iunit, '(a)') ' (dimensionless)' + else + write(iunit, '(a,a,a)') ' (', trim(attr_str), ')' + end if + else + ! No units present + write(iunit, '(1x)') + end if + if (this%iverbose >= 5) then + istatus = nf90_get_att(this%ncid, ivarid, 'comment', attr_str) + if (istatus == NF90_NOERR) then + write(iunit, '(a,a,a)') 'comment="', trim(attr_str), '"' + end if + end if + end if + else + ! No long_name present + write(iunit, '(1x)') + end if + + end subroutine print_variable_attributes + + + ! --- WRITING SUBROUTINES --- + + !--------------------------------------------------------------------- + ! Define a dimension with name dim_name of length n (or 0 to + ! indicate the unlimited dimension) + subroutine define_dimension(this, dim_name, n) + class(netcdf_file) :: this + character(len=*), intent(in) :: dim_name + integer, intent(in) :: n + integer :: idimid, istatus + + istatus = nf90_def_dim(this%ncid, dim_name, n, idimid) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error defining ', dim_name, & + & ' as a dimension: ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + if (this%iverbose >= 4) then + write(nulout,'(a,a,a,i0)') ' Defining dimension ',trim(dim_name), & + & ' of length ', n + end if + + end subroutine define_dimension + + + !--------------------------------------------------------------------- + ! Define a variable with name var_name, and specify its shape via + ! the dim1_name, dim2_name and dim3_name optional arguments, which + ! are strings referring to existing dimensions. If none are + ! specified, the variable will be a scalar. The optional arguments + ! long_name, units and comment write string attributes with these + ! names. + subroutine define_variable(this, var_name, dim1_name, dim2_name, dim3_name, & + & dim4_name, long_name, units_str, comment_str, & + & standard_name, is_double, data_type_name, fill_value, & + & deflate_level, shuffle, chunksizes, ndims) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + character(len=*), intent(in), optional :: long_name, units_str, comment_str, standard_name + character(len=*), intent(in), optional :: dim1_name, dim2_name, dim3_name, dim4_name + logical, intent(in), optional :: is_double + character(len=*), intent(in), optional :: data_type_name + real(jprb), intent(in), optional :: fill_value + integer, intent(in), optional :: deflate_level ! Compression: 0 (none) to 9 (most) + logical, intent(in), optional :: shuffle ! Shuffle bytes before compression + integer, dimension(:), intent(in), optional :: chunksizes + integer, intent(in), optional :: ndims + + integer :: istatus, ndims_local, ndims_input, ivarid + integer, dimension(NF90_MAX_VAR_DIMS) :: idimids + integer :: data_type + + ! Sometimes a program may not know at compile time the exact + ! dimensions of a variable - if ndims is present then only up to + ! that many dimensions will be defined + ndims_input = 4 + if (present(ndims)) then + ndims_input = ndims + end if + + if (present(dim1_name) .and. ndims_input >= 1) then + ! Variable is at least one dimensional + ndims_local = 1 + istatus = nf90_inq_dimid(this%ncid, dim1_name, idimids(1)) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error inquiring ID of dimension ', & + & dim1_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + if (present(dim2_name) .and. ndims_input >= 2) then + ! Variable is at least two dimensional + ndims_local = 2 + istatus = nf90_inq_dimid(this%ncid, dim2_name, idimids(2)) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a)') '*** Error inquiring ID of dimension ', & + & dim2_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + if (present(dim3_name) .and. ndims_input >= 3) then + ! Variable is at least three dimensional + ndims_local = 3 + istatus = nf90_inq_dimid(this%ncid, dim3_name, idimids(3)) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error inquiring ID of dimension ', & + & dim3_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + if (present(dim4_name) .and. ndims_input >= 4) then + ! Variable is at least three dimensional + ndims_local = 4 + istatus = nf90_inq_dimid(this%ncid, dim4_name, idimids(4)) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error inquiring ID of dimension ', & + & dim4_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + end if + end if + end if + else + ! Variable is a scalar + ndims_local = 0 + end if + + ! Read output precision from optional argument "is_double" if + ! present, otherwise from default output precision for this file + if (present(data_type_name)) then + if (data_type_name == 'double') then + data_type = NF90_DOUBLE + else if (data_type_name == 'byte') then + data_type = NF90_BYTE + else if (data_type_name == 'short') then + data_type = NF90_SHORT + else if (data_type_name == 'int') then + data_type = NF90_INT + else if (data_type_name == 'float') then + data_type = NF90_FLOAT + else + write(nulerr,'(a,a,a)') '*** NetCDF data type "', data_type_name, '" not supported' + call my_abort('Error writing NetCDF file') + end if + else if (present(is_double)) then + if (is_double) then + data_type = NF90_DOUBLE + else + data_type = NF90_FLOAT + end if + else if (this%is_double_precision) then + data_type = NF90_DOUBLE + else + data_type = NF90_FLOAT + end if + + ! Define variable +#ifdef NC_NETCDF4 + istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims_local), & + & ivarid, deflate_level=deflate_level, shuffle=shuffle, chunksizes=chunksizes) +#else + istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims_local), ivarid) +#endif + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error defining variable ', var_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + ! Add optional attributes + if (present(long_name)) then + istatus = nf90_put_att(this%ncid, ivarid, "long_name", long_name) + if (this%iverbose >= 4) then + write(nulout,'(a,a,a,a,a)', advance='no') ' Defining ',trim(var_name), & + & ': "', long_name, '"' + end if + else + if (this%iverbose >= 4) then + write(nulout,'(a,a)', advance='no') ' Defining ',trim(var_name) + end if + end if + + if (present(units_str)) then + istatus = nf90_put_att(this%ncid, ivarid, "units", units_str) + if (this%iverbose >= 4) then + if (trim(units_str) == '1') then + write(nulout, '(a)') ' (dimensionless)' + else + write(nulout, '(a,a,a)') ' (', trim(units_str), ')' + end if + end if + else + if (this%iverbose >= 4) then + write(nulout, '(1x)') + end if + end if + + if (present(standard_name)) then + istatus = nf90_put_att(this%ncid, ivarid, "standard_name", standard_name) + end if + if (present(comment_str)) then + istatus = nf90_put_att(this%ncid, ivarid, "comment", comment_str) + end if + + if (present(fill_value)) then +#ifdef NC_NETCDF4 + if (data_type == NF90_DOUBLE) then + istatus = nf90_def_var_fill(this%ncid, ivarid, 0, real(fill_value,jprd)) + else if (data_type == NF90_FLOAT) then + istatus = nf90_def_var_fill(this%ncid, ivarid, 0, real(fill_value,jprm)) + else if (data_type == NF90_INT) then + istatus = nf90_def_var_fill(this%ncid, ivarid, 0, int(fill_value,4)) + else if (data_type == NF90_SHORT) then + istatus = nf90_def_var_fill(this%ncid, ivarid, 0, int(fill_value,2)) + else if (data_type == NF90_BYTE) then + istatus = nf90_def_var_fill(this%ncid, ivarid, 0, int(fill_value,1)) + end if +#else + if (data_type == NF90_DOUBLE) then + istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", real(fill_value,jprd)) + else if (data_type == NF90_FLOAT) then + istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", real(fill_value,jprm)) + else if (data_type == NF90_INT) then + istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", int(fill_value,4)) + else if (data_type == NF90_SHORT) then + istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", int(fill_value,2)) + else if (data_type == NF90_BYTE) then + istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", int(fill_value,1)) + end if +#endif + end if + + end subroutine define_variable + + + !--------------------------------------------------------------------- + ! Put CF-compliant global attributes into the file + subroutine put_global_attributes(this, title_str, inst_str, source_str, & + & comment_str, references_str, creator_name, creator_email_str, & + & contributor_name, project_str, conventions_str, prior_history_str) + class(netcdf_file) :: this + + character(len=*), intent(in), optional :: title_str + character(len=*), intent(in), optional :: inst_str + character(len=*), intent(in), optional :: source_str + character(len=*), intent(in), optional :: creator_name, creator_email_str + character(len=*), intent(in), optional :: contributor_name, project_str + character(len=*), intent(in), optional :: comment_str, conventions_str + character(len=*), intent(in), optional :: references_str, prior_history_str + + character(len=32) :: date_time_str + character(len=4000) :: command_line_str + character(len=4032) :: history_str + + integer :: time_vals(8) + integer :: i ! status + + call date_and_time(values=time_vals) + call get_command(command_line_str) + + write(date_time_str,"(i0.4,'-',i0.2,'-',i0.2,' ',i0.2,':',i0.2,':',i0.2)") & + & time_vals(1), time_vals(2), time_vals(3), time_vals(5), time_vals(6), time_vals(7) + + if (present(prior_history_str)) then + history_str = trim(prior_history_str) // new_line('a') & + & // trim(date_time_str) // ': ' // trim(command_line_str) + else + history_str = trim(date_time_str) // ': ' // trim(command_line_str) + end if + + if (present(title_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, "title", title_str) + if (present(inst_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, "institution", inst_str) + if (present(source_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, "source", source_str) + if (present(creator_name))i=nf90_put_att(this%ncid, NF90_GLOBAL, "creator_name", creator_name) + if (present(creator_email_str))i=nf90_put_att(this%ncid, NF90_GLOBAL, "creator_email", creator_email_str) + if (present(contributor_name))i=nf90_put_att(this%ncid, NF90_GLOBAL, "contributor_name", contributor_name) + + i = nf90_put_att(this%ncid, NF90_GLOBAL, "history", history_str) + + if (present(project_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, "project", project_str) + if (present(comment_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, "comment", comment_str) + if (present(references_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, & + & "references", references_str) + if (present(conventions_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, & + & "conventions", conventions_str) + + end subroutine put_global_attributes + + + !--------------------------------------------------------------------- + ! Put a non-standard global attribute into the file + subroutine put_global_attribute(this, attr_name, attr_str) + class(netcdf_file) :: this + + character(len=*), intent(in) :: attr_name, attr_str + + integer :: istatus + + istatus = nf90_put_att(this%ncid, NF90_GLOBAL, trim(attr_name), trim(attr_str)) + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing global attribute ', attr_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_global_attribute + + + !--------------------------------------------------------------------- + ! Put a non-standard variable attribute into the file + subroutine put_attribute(this, var_name, attr_name, attr_str) + class(netcdf_file) :: this + + character(len=*), intent(in) :: var_name, attr_name, attr_str + + integer :: istatus, ivarid + + call this%get_variable_id(var_name, ivarid) + + istatus = nf90_put_att(this%ncid, ivarid, trim(attr_name), trim(attr_str)) + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing attribute ', attr_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_attribute + + + !--------------------------------------------------------------------- + ! The "put" method saves a scalar, vector or matrix into the + ! variable with name var_name, according to the rank of the var + ! argument. This version saves a scalar. + subroutine put_real_scalar(this, var_name, var) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: var + + integer :: ivarid, ndims, istatus + integer(kind=jpib) :: ntotal + integer :: ndimlens(NF90_MAX_VAR_DIMS) + + ! If we are in define mode, exit define mode + call this%end_define_mode() + + ! Check the variable is a scalar + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) + if (ntotal /= 1) then + write(nulerr,'(a,a,a,i0)') '*** Error: attempt to write scalar to ', & + & var_name, ' which has total length ', ntotal + call my_abort('Error writing NetCDF file') + end if + + ! Save the scalar + istatus = nf90_put_var(this%ncid, ivarid, var) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing scalar ', var_name, ': ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_real_scalar + + + !--------------------------------------------------------------------- + ! Save a scalar. + subroutine put_real_scalar_indexed(this, var_name, index, var) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: var + integer, intent(in) :: index + + integer :: ivarid, ndims, istatus + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + + ! If we are in define mode, exit define mode + call this%end_define_mode() + + ! Check the variable is a scalar + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + if (index < 1 .or. index > ndimlens(ndims)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write scalar to element ', & + & index, ' of ', var_name, ' which has outer dimension ', ndimlens(ndims) + call my_abort('Error writing NetCDF file') + end if + + ! Save the scalar + vstart(1:ndims-1) = 1 + vstart(ndims) = index + istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing scalar to ', var_name, ': ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_real_scalar_indexed + + + !--------------------------------------------------------------------- + ! Save a vector with name var_name in the file + subroutine put_real_vector(this, var_name, var) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: var(:) + + integer :: ivarid, ndims, istatus + integer(kind=jpib) :: ntotal + integer :: ndimlens(NF90_MAX_VAR_DIMS) + + call this%end_define_mode() + + ! Check the vector is of the right length + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) + if (ntotal /= size(var,kind=jpib)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector of length ', & + & size(var), ' to ', var_name, ' which has total length ', ntotal + call my_abort('Error writing NetCDF file') + end if + + ! Save the vector + istatus = nf90_put_var(this%ncid, ivarid, var) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing vector ', var_name, ': ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_real_vector + + + !--------------------------------------------------------------------- + ! Save an integer vector with name var_name in the file + subroutine put_int_vector(this, var_name, var) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: var(:) + + integer :: ivarid, ndims, istatus + integer(kind=jpib) :: ntotal + integer :: ndimlens(NF90_MAX_VAR_DIMS) + + call this%end_define_mode() + + ! Check the vector is of the right length + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) + if (ntotal /= size(var,kind=jpib)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector of length ', & + & size(var), ' to ', var_name, ' which has total length ', ntotal + call my_abort('Error writing NetCDF file') + end if + + ! Save the vector + istatus = nf90_put_var(this%ncid, ivarid, var) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing vector ', var_name, ': ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_int_vector + + + !--------------------------------------------------------------------- + ! Save a vector slice with name var_name in the file + subroutine put_real_vector_indexed(this, var_name, var, index2, index3) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: var(:) + integer, intent(in) :: index2 + integer, intent(in), optional :: index3 + + integer :: ivarid, ndims, istatus + integer(kind=jpib) :: ntotal + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + integer :: vcount(NF90_MAX_VAR_DIMS) + + character(len=512) :: var_slice_name + integer :: index_last + + call this%end_define_mode() + + ! Check the vector is of the right length + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) + ntotal = ntotal / ndimlens(ndims) + if (present(index3)) then + ntotal = ntotal / ndimlens(ndims-1) + index_last = index3 + write(var_slice_name,'(a,a,i0,a,i0,a)') var_name, '(:,', index2, ',', index3, ')' + else + index_last = index2 + write(var_slice_name,'(a,a,i0,a)') var_name, '(:,', index2, ')' + end if + + if (ntotal /= size(var,kind=jpib)) then + write(nulerr,'(a,i0,a,a,i0)') '*** Error: attempt to write vector of length ', & + & size(var), ' to ', trim(var_slice_name), ' which has length ', ntotal + call my_abort('Error writing NetCDF file') + end if + if (index_last < 1 .or. index_last > ndimlens(ndims)) then + write(nulerr,'(a,a,a,i0)') '*** Error: attempt to write vector to ', & + & trim(var_slice_name), ' which has outer dimension ', ndimlens(ndims) + call my_abort('Error writing NetCDF file') + end if + + ! Save the vector + vstart(1:ndims-1) = 1 + vcount(1:ndims-1) = ndimlens(1:ndims-1) + vcount(ndims) = 1 + if (present(index3)) then + vstart(ndims) = index3 + vstart(ndims-1) = index2 + vcount(ndims-1) = 1 + else + vstart(ndims) = index2 + end if + + istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart, count=vcount) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing vector to ', trim(var_slice_name), & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_real_vector_indexed + + + !--------------------------------------------------------------------- + ! Save a matrix with name var_name in the file, transposing its + ! dimensions if either optional argument transp is .true., or the + ! transpose_matrices method has already been called. + subroutine put_real_matrix(this, var_name, var, do_transp) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: var(:,:) + real(jprb), allocatable :: var_transpose(:,:) + logical, optional, intent(in):: do_transp + + integer :: ivarid, ndims, nvarlen, istatus + integer(kind=jpib) :: ntotal + integer :: ndimlens(NF90_MAX_VAR_DIMS) + + logical :: do_transpose + + if (present(do_transp)) then + do_transpose = do_transp + else + do_transpose = this%do_transpose_2d + end if + + call this%end_define_mode() + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) + + nvarlen = size(var,1)*size(var,2) + + ! Check the total size of the variable to be stored (but receiving + ! ntotal is zero then there must be an unlimited dimension) + if (ntotal /= size(var,kind=jpib) .and. ntotal /= 0) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write matrix of total size ', & + & nvarlen, ' to ', var_name, ' which has total size ', ntotal + call my_abort('Error writing NetCDF file') + end if + + if (do_transpose) then + ! Save the matrix with transposition + if (this%iverbose >= 3) then + write(nulout,'(a,a,a)') ' Writing ', var_name, & + & ' (transposing dimensions)' + end if + allocate(var_transpose(size(var,2), size(var,1))) + var_transpose = transpose(var) + istatus = nf90_put_var(this%ncid, ivarid, var_transpose) + deallocate(var_transpose) + else + ! Save the matrix without transposition + if (this%iverbose >= 3) then + write(nulout,'(a,a)') ' Writing ', var_name + end if + istatus = nf90_put_var(this%ncid, ivarid, var) + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing matrix ', var_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_real_matrix + + + !--------------------------------------------------------------------- + ! Save a matrix slice with name var_name in the file, transposing its + ! dimensions if either optional argument transp is .true., or the + ! transpose_matrices method has already been called. + subroutine put_real_matrix_indexed(this, var_name, var, index3, index4, do_transp) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: var(:,:) + integer, intent(in) :: index3 + integer, intent(in), optional :: index4 + + real(jprb), allocatable :: var_transpose(:,:) + logical, optional, intent(in) :: do_transp + + integer :: ivarid, ndims, nvarlen, istatus + integer(kind=jpib) :: ntotal + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + integer :: vcount(NF90_MAX_VAR_DIMS) + + character(len=512) :: var_slice_name + + logical :: do_transpose + + if (present(do_transp)) then + do_transpose = do_transp + else + do_transpose = this%do_transpose_2d + end if + + call this%end_define_mode() + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) + + nvarlen = size(var,1)*size(var,2) + + ! Check the total size of the variable to be stored (but receiving + ! ntotal is zero then there must be an unlimited dimension) + ntotal = ntotal / ndimlens(ndims) + if (present(index4)) then + ntotal = ntotal / ndimlens(ndims-1) + write(var_slice_name,'(a,a,i0,a,i0,a)') var_name, '(:,:,', index3, ',', index4, ')' + else + write(var_slice_name,'(a,a,i0,a)') var_name, '(:,:,', index3, ')' + end if + if (ntotal /= size(var,kind=jpib) .and. ntotal /= 0) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write matrix of total size ', & + & nvarlen, ' to ', trim(var_slice_name), ' which has total size ', ntotal + call my_abort('Error writing NetCDF file') + end if + + vstart(1:ndims-1) = 1 + vcount(1:ndims-1) = ndimlens(1:ndims-1) + vcount(ndims) = 1 + if (present(index4)) then + vstart(ndims) = index4 + vstart(ndims-1) = index3 + vcount(ndims-1) = 1 + else + vstart(ndims) = index3 + end if + + if (do_transpose) then + ! Save the matrix with transposition + if (this%iverbose >= 3) then + write(nulout,'(a,a,a)') ' Writing ', trim(var_slice_name), & + & ' (transposing dimensions)' + end if + allocate(var_transpose(size(var,2), size(var,1))) + var_transpose = transpose(var) + istatus = nf90_put_var(this%ncid, ivarid, var_transpose, start=vstart, count=vcount) + deallocate(var_transpose) + else + ! Save the matrix without transposition + if (this%iverbose >= 3) then + write(nulout,'(a,a)') ' Writing ', trim(var_slice_name) + end if + istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart, count=vcount) + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a)') '*** Error writing ', trim(var_slice_name), & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_real_matrix_indexed + + + !--------------------------------------------------------------------- + ! Save a 3D array with name var_name in the file. The optional + ! argument permute specifies that the dimensions should first be + ! permuted according to the three integers therein (or if + ! permute_3d_arrays has already been called). ipermute is + ! interpretted such that if OLD and NEW are 3-element vectors + ! containing the size of each dimension in memory and in the written + ! file, respectively, then NEW=OLD(ipermute). + subroutine put_real_array3(this, var_name, var, ipermute) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: var(:,:,:) + real(jprb), allocatable :: var_permute(:,:,:) + integer, optional, intent(in) :: ipermute(3) + + integer :: ivarid, ndims, nvarlen, istatus + integer(kind=jpib) :: ntotal + integer :: ndimlens(NF90_MAX_VAR_DIMS) + + logical :: do_permute ! Do we permute? + integer :: i_permute_3d(3) + integer :: n_dimlens_permuted(3) + integer :: i_order(3) + + ! Decide whether to permute + if (present(ipermute)) then + do_permute = .true. + i_permute_3d = ipermute + else + do_permute = this%do_permute_3d + i_permute_3d = this%i_permute_3d + end if + + call this%end_define_mode() + + ! Check total size + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) + nvarlen = size(var,1)*size(var,2)*size(var,3) + if (ntotal /= size(var,kind=jpib)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write array of total size ', & + & nvarlen, ' to ', var_name, ' which has total size ', ntotal + call my_abort('Error writing NetCDF file') + end if + + if (do_permute) then + ! Save array after permuting dimensions + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,i0,i0,a)') ' Writing ', var_name, & + & ' (permuting dimensions: ', i_permute_3d, ')' + end if + n_dimlens_permuted = (/ size(var,i_permute_3d(1)), & + & size(var,i_permute_3d(2)), & + & size(var,i_permute_3d(3)) /) + !! FIX: This makes it look like the dimensions have stayed the same + ! if (this%iverbose >= 4) then + ! write(nulout,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a)') ' (', & + ! & n_dimlens_permuted(1), ',', n_dimlens_permuted(2), & + ! & ',', n_dimlens_permuted(3), ') -> (', ndimlens(1), & + ! & ',', ndimlens(2), ',', ndimlens(3), ')' + ! end if + allocate(var_permute(n_dimlens_permuted(1), & + & n_dimlens_permuted(2), n_dimlens_permuted(3))) + ! Due to the odd way that ORDER works in Fortran RESHAPE, we + ! need to do this: + i_order(i_permute_3d) = (/ 1, 2, 3 /) + var_permute = reshape(var, n_dimlens_permuted, order=i_order) + istatus = nf90_put_var(this%ncid, ivarid, var_permute) + deallocate(var_permute) + else + ! Save array without permuting dimensions + if (this%iverbose >= 3) then + write(nulout,'(a,a)') ' Writing ', var_name + end if + istatus = nf90_put_var(this%ncid, ivarid, var) + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing array ', var_name, & + & ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_real_array3 + + +#ifdef NC_NETCDF4 + !--------------------------------------------------------------------- + ! Copy dimensions from "infile" to "this" + subroutine copy_dimensions(this, infile) + class(netcdf_file) :: this + type(netcdf_file), intent(in) :: infile + + integer :: jdim + integer :: ndims + integer :: idimids(1024) + integer :: dimlen + character(len=512) :: dimname + integer :: istatus + integer :: include_parents + + include_parents = 0 + + istatus = nf90_inq_dimids(infile%ncid, ndims, idimids, include_parents) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading dimensions of NetCDF file: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + do jdim = 1,ndims + istatus = nf90_inquire_dimension(infile%ncid, idimids(jdim), & + & name=dimname, len=dimlen) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading NetCDF dimension properties: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + call this%define_dimension(trim(dimname), dimlen) + end do + + end subroutine copy_dimensions +#endif + + !--------------------------------------------------------------------- + ! Copy variable definition and attributes from "infile" to "this" + subroutine copy_variable_definition(this, infile, var_name) + class(netcdf_file) :: this + type(netcdf_file), intent(in) :: infile + character(len=*), intent(in) :: var_name + +#ifdef NC_NETCDF4 + integer :: deflate_level ! Compression: 0 (none) to 9 (most) + logical :: shuffle ! Shuffle bytes before compression + integer :: chunksizes(NF90_MAX_VAR_DIMS) +#endif + integer :: data_type + integer :: ndims + integer :: idimids_in(NF90_MAX_VAR_DIMS) + integer :: idimids_out(NF90_MAX_VAR_DIMS) + integer :: nattr + character(len=512) :: attr_name + character(len=512) :: dim_name + + integer :: istatus + integer :: ivarid_in, ivarid_out + integer :: jattr, jdim + + if (this%iverbose >= 4) then + write(nulout,'(a,a)') ' Copying definition of ', trim(var_name) + end if + + ! Get variable ID from name + istatus = nf90_inq_varid(infile%ncid, trim(var_name), ivarid_in) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a)') '*** Error inquiring about NetCDF variable "', & + & trim(var_name), '": ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ! Get variable properties +#ifdef NC_NETCDF4 + istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type, ndims=ndims, & + & dimids=idimids_in, chunksizes=chunksizes, deflate_level=deflate_level, & + & shuffle=shuffle, natts=nattr) +#else + istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type, ndims=ndims, & + & dimids=idimids_in, natts=nattr) +#endif + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading NetCDF variable properties: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ! Map dimension IDs + do jdim = 1,ndims + istatus = nf90_inquire_dimension(infile%ncid, idimids_in(jdim), name=dim_name) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading NetCDF dimension name: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + istatus = nf90_inq_dimid(this%ncid, trim(dim_name), idimids_out(jdim)) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading NetCDF dimension ID: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + end do + + ! Create variable +#ifdef NC_NETCDF4 + istatus = nf90_def_var(this%ncid, var_name, data_type, idimids_out(1:ndims), & + & ivarid_out, deflate_level=deflate_level, shuffle=shuffle, chunksizes=chunksizes(1:ndims)) +#else + istatus = nf90_def_var(this%ncid, var_name, data_type, idimids_out(1:ndims), ivarid_out) +#endif + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error defining variable "', var_name, & + & '": ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + ! Copy attributes + do jattr = 1,nattr + istatus = nf90_inq_attname(infile%ncid, ivarid_in, jattr, attr_name) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading attribute: ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + istatus = nf90_copy_att(infile%ncid, ivarid_in, trim(attr_name), & + & this%ncid, ivarid_out) + + end do + + end subroutine copy_variable_definition + + + !--------------------------------------------------------------------- + ! Copy variable from "infile" to "this" + subroutine copy_variable(this, infile, var_name) + class(netcdf_file) :: this + class(netcdf_file), intent(in) :: infile + character(len=*), intent(in) :: var_name + + integer :: ivarid_in, ivarid_out + integer :: ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer(kind=jpib) :: ntotal, ntotal_out + integer :: data_type + integer :: istatus + + ! We use the Fortran-77 functions because they don't check that + ! the rank of the arguments is correct + integer, external :: nf_get_var_double, nf_put_var_double + integer, external :: nf_get_var_int, nf_put_var_int + + real(kind=jprd), allocatable :: data_real(:) + integer, allocatable :: data_int(:) + + ! If we are in define mode, exit define mode + call this%end_define_mode() + + if (this%iverbose >= 4) then + write(nulout,'(a,a)') ' Copying ', trim(var_name) + end if + + call infile%get_variable_id(var_name, ivarid_in) + call infile%get_array_dimensions(ivarid_in, ndims, ndimlens, ntotal) + istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + call this%get_variable_id(var_name, ivarid_out) + call this%get_array_dimensions(ivarid_out, ndims, ndimlens, ntotal_out) + if (ntotal /= ntotal_out) then + write(nulerr,'(a)') '*** Error: size mismatch between input and output variables' + call my_abort('Error writing NetCDF file') + end if + + if (data_type == NF90_DOUBLE .or. data_type == NF90_FLOAT) then + allocate(data_real(ntotal)) + !istatus = nf90_get_var(infile%ncid, ivarid_in, data_real(1)) + istatus = nf_get_var_double(infile%ncid, ivarid_in, data_real) + if (istatus /= NF90_NOERR) then + deallocate(data_real) + write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + !istatus = nf90_put_var(this%ncid, ivarid_out, data_real) + istatus = nf_put_var_double(this%ncid, ivarid_out, data_real) + deallocate(data_real) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + else + allocate(data_int(ntotal)) + !istatus = nf90_get_var(infile%ncid, ivarid_in, data_int) + istatus = nf_get_var_int(infile%ncid, ivarid_in, data_int) + if (istatus /= NF90_NOERR) then + deallocate(data_int) + + write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + !istatus = nf90_put_var(this%ncid, ivarid_out, data_int) + istatus = nf_put_var_int(this%ncid, ivarid_out, data_int) + deallocate(data_int) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + end if + + end subroutine copy_variable + +end module easy_netcdf Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/print_matrix.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/print_matrix.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/print_matrix.F90 (revision 6016) @@ -0,0 +1,75 @@ +module print_matrix_mod +contains + subroutine print_vector(vec, name, unit) + use parkind1, only : jprb + real(jprb), intent(in) :: vec(:) + character(*), intent(in), optional :: name + integer, intent(in), optional :: unit + integer :: i + integer :: unit_local + if (present(unit)) then + unit_local = unit + else + unit_local = 6 + end if + if (present(name)) then + write(unit_local,'(a,a,$)') name, '=[' + end if + do i = 1,size(vec,1) + write(unit_local,'(f16.8,$)') vec(i) + end do + if (present(name)) then + write(unit_local,'(a)') ']' + else + write(unit_local,'(x)') + end if + + end subroutine print_vector + + subroutine print_matrix(mat, name, unit) + use parkind1, only : jprb + real(jprb), intent(in) :: mat(:,:) + character(*), intent(in), optional :: name + integer, intent(in), optional :: unit + integer :: i, j + integer :: unit_local + if (present(unit)) then + unit_local = unit + else + unit_local = 6 + end if + + if (present(name)) then + write(unit_local,'(a,a,$)') name, '=[' + end if + do i = 1,size(mat,1) + do j = 1,size(mat,2) + write(unit_local,'(f16.8,$)') mat(i,j) + end do + if (present(name) .and. i == size(mat,1)) then + write(unit_local,'(a)') ']' + else + write(unit_local,'(x)') + end if + end do + end subroutine print_matrix + + subroutine print_array3(name, mat) + use parkind1, only : jprb + character(*), intent(in) :: name + real(jprb), intent(in) :: mat(:,:,:) + integer :: i, j, k + write(6,'(a,a)') name, '=' + do k = 1,size(mat,3) + do i = 1,size(mat,1) + do j = 1,size(mat,2) + write(6,'(f16.8,$)') mat(i,j,k) + end do + write(6,'(x)') + end do + write(6,'(x)') + end do + end subroutine print_array3 + + +end module print_matrix_mod Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/radiation_io.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/radiation_io.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/radiation_io.F90 (revision 6016) @@ -0,0 +1,63 @@ +! radiation_io.F90 - Provides logging and abort functionality +! +! (C) Copyright 2015- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! This file provides an interface to the provision of file units used +! for logging (nulout and nulerr) and for reading data files +! (nulrad), as well as an abort routine that should do clean-up +! appropriate for the environment in which the radiation scheme is +! embedded. +! +! Rewrite this file as appropriate if the radiation scheme is to be +! embedded into a model other than the ECMWF Integrated Forecasting +! System. + +module radiation_io + + ! In the IFS, nulout is equivalent to standard output but only + ! output from the primary node will be logged, while nulerr is + ! equivalent to standard error, and text sent to this unit from any + ! node will be logged. Normally, nulerr should only be used before + ! calling radiation_abort. + use yomlun_ifsaux, only : nulout, nulerr + + implicit none + public + + ! This unit may be used for reading radiation configuration files, + ! but should be closed as soon as the file is read + integer :: nulrad = 25 + +contains + + ! Abort the program with optional error message. Normally you would + ! log details of the error to nulerr before calling this subroutine. + subroutine radiation_abort(text) + character(len=*), intent(in), optional :: text + if (present(text)) then + write(nulerr,'(a)') text +#ifdef __PGI + stop 1 +#else + error stop 1 +#endif + else +#ifdef __PGI + stop 'Error in radiation scheme' +#else + error stop 'Error in radiation scheme' +#endif + end if + end subroutine radiation_abort + +end module radiation_io Index: LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/random_numbers_mix.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/random_numbers_mix.F90 (revision 6016) +++ LMDZ6/trunk/libf/phylmd/ecrad-acc/utilities/random_numbers_mix.F90 (revision 6016) @@ -0,0 +1,440 @@ +!**** *RANDOM_NUMBERS_MIX* - Portable Random Number Generator + +! (C) Copyright 2002- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + +! Purpose. +! -------- +! Generate machine-independent pseudo-random numbers + +!** Interface. +! ---------- +! CALL initialize_random_numbers (kseed, yd_stream) +! CALL uniform_distribution (px , yd_stream) +! CALL gaussian_distribution (px , yd_stream) +! CALL random_number_restartfile (fname, action) +! CALL wr_rangen_state (nunit) + +! Explicit arguments : +! -------------------- +! kseed (input) : integer seed in the range [0,HUGE(kseed)] +! yd_stream (optional) : the state of the random number generator +! px (output) : array to receive random numbers in the range + +! In the case of uniform_distribution, px has values in the range [0.0,1.0) + +! Implicit arguments : +! -------------------- +! None + +! Method. +! ------- +! Based loosly on ZUFALL (Petersen, 1994). + +! The main difference between this generator and ZUFALL is that integer arithmetic +! is used. This ensures portability to vector machines that implement different +! real arithmetic. In particular, vector machines often implement non-IEEE +! arithmetic for their vector pipes. This routine will give identical results for +! any integer type with at least 32 bits. + +! The generator is a lagged-Fibonacci generator: x(i) = x(i-p) + x(i-q) mod 2**m. +! Lagged-Fibonacci generators have very long repeat periods: (2**q -1) * 2**(m-1) +! (i.e about 2.85E191 for q=607, m=30). They pass most tests for randomness. + +! p and q must be chosen carefully. Values from the following table are OK. +! Larger values give better random numbers, but smaller values are more +! cache-friendly. + +! q p +! 9689 4187 +! 4423 2098 +! 2281 1029 +! 1279 418 +! 607 273 +! 521 168 +! 250 103 +! 127 63 +! 97 33 +! 55 24 +! 43 22 +! 31 13 +! 24 10 + +! The initial q values of x are set using the binary shirt register method of +! Burns and Pryor 1999. + +! Mascagni et al (1995) show how to choose different sets of initial values that +! are guaranteed to be drawn from different maximal-length cycles. This requires +! the initial values of x(1)...x(q) to be in "canonical form". Specifically, +! x(1) must be zero and all but a particular one or two values of x must be +! even. For q=607 and p=273, only one element (jpq-jps) must be odd. + +! Externals. +! ---------- +! None + +! Reference. +! ---------- +! Burns P.J. and Pryor D.V. 1999, +! Surface Radiative Transport at Large Scale via Monte Carlo. +! Annual Review of Heat Transfer, Vol 9. +! +! Petersen W.P., 1994, Lagged Fibonacci Series Random Number Generator +! for the NEC SX-3. International Journal of High Speed Computing +! Vol. 6, No. 3, pp387-398. +! +! Mascagni M., Cuccaro S.A., Pryor D.V., Robinson M.L., 1995, +! A Fast, High Quality and Reproducible Parallel Lagged-Fibonacci +! Pseudorandom Number Generator. Journal of Computational Physics +! Vol 119. pp211-219. + +! Author. +! ------- +! Mike Fisher *ECMWF* + +! Modifications. +! -------------- +! Original : 2002-09-25 +! Made parallel friendly: 2003-08-11 Robert Pincus +! M Leutbecher: 2004-05-10 restart capability +! M Fisher: 2005-03-30 replaced LCG initialization with shift register +! ------------------------------------------------------------------ + +#ifdef RS6K +@PROCESS HOT(NOVECTOR) NOSTRICT +#endif +MODULE RANDOM_NUMBERS_MIX +USE YOMHOOK, ONLY : LHOOK, DR_HOOK, JPHOOK +USE PARKIND1, ONLY : JPIM, JPRB + +IMPLICIT NONE + +SAVE + +PRIVATE +PUBLIC RANDOMNUMBERSTREAM,WR_RANGEN_STATE, & + & INITIALIZE_RANDOM_NUMBERS, UNIFORM_DISTRIBUTION, GAUSSIAN_DISTRIBUTION ! ,& +! & RANDOM_NUMBER_RESTARTFILE, + +INTEGER(KIND=JPIM), PARAMETER :: JPP=273, JPQ=607, JPS=105 +INTEGER(KIND=JPIM), PARAMETER :: JPMM=30 +INTEGER(KIND=JPIM), PARAMETER :: JPM=2**JPMM +INTEGER(KIND=JPIM), PARAMETER :: JPNUMSPLIT=(JPQ-2)/(JPP-1) +INTEGER(KIND=JPIM), PARAMETER :: JPLENSPLIT=(JPQ-JPP+JPNUMSPLIT-1)/JPNUMSPLIT +INTEGER(KIND=JPIM), PARAMETER :: INITVALUE = 12345678 + +TYPE RANDOMNUMBERSTREAM + PRIVATE + INTEGER(KIND=JPIM) :: IUSED + INTEGER(KIND=JPIM) :: INITTEST ! Should initialize to zero, but can't in F90 + INTEGER(KIND=JPIM), DIMENSION(JPQ) :: IX + REAL(KIND=JPRB) :: ZRM +END TYPE RANDOMNUMBERSTREAM + +CONTAINS +!------------------------------------------------------------------------------- +SUBROUTINE INITIALIZE_RANDOM_NUMBERS (KSEED, YD_STREAM) + !------------------------------------------------------------------------------- + ! Initialize fibgen + !------------------------------------------------------------------------------- + INTEGER(KIND=JPIM), INTENT(IN ) :: KSEED + TYPE(RANDOMNUMBERSTREAM), INTENT(INOUT) :: YD_STREAM + + INTEGER, PARAMETER :: JPMASK=123459876 + INTEGER(KIND=JPIM), PARAMETER :: JPWARMUP_SHFT=64, JPWARMUP_LFG=999 + INTEGER(KIND=JPIM) :: IDUM,JK,JJ,JBIT + REAL(KIND=JPRB), DIMENSION(JPWARMUP_LFG) :: ZWARMUP + + !------------------------------------------------------------------------------- + ! Initialize the buffer using a binary shift register (Burns and Pryor, 1999). + ! The Galois representation is used for the shift register as it is more + ! efficient than the Fibonacci representation. The magic numbers 31 and 87 + ! define the shift register primitive polynomial=(32,7,5,3,2,1,0). + ! + ! To ensure that different seeds produce distinct initial buffer states in + ! canonical form, bits 0...jpmm-2 of the initial seed (after XORing with jpmask + ! and spinning up using the linear congruential generator) are used to construct + ! x(2), and the remaining bits are used to construct x(jpq). + !------------------------------------------------------------------------------- + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:INITIALIZE_RANDOM_NUMBERS',0,ZHOOK_HANDLE) + IDUM = ABS(IEOR(KSEED,JPMASK)) + IF (IDUM==0) IDUM=JPMASK + + DO JJ=1,JPWARMUP_SHFT + IF (BTEST(IDUM,31)) THEN + IDUM=IBSET(ISHFT(IEOR(IDUM,87),1),0) + ELSE + IDUM=IBCLR(ISHFT(IDUM,1),0) + ENDIF + ENDDO + + YD_STREAM%IX(1:JPQ-1)= 0 + YD_STREAM%IX(2) = ISHFT(IBITS(IDUM,0,JPMM-1),1) + YD_STREAM%IX(JPQ) = IBITS(IDUM,JPMM-1,BIT_SIZE(IDUM)+1-JPMM) + + DO JBIT=1,JPMM-1 + DO JJ=3,JPQ-1 + IF (BTEST(IDUM,31)) THEN + IDUM=IBSET(ISHFT(IEOR(IDUM,87),1),0) + YD_STREAM%IX(JJ)=IBSET(YD_STREAM%IX(JJ),JBIT) + ELSE + IDUM=IBCLR(ISHFT(IDUM,1),0) + ENDIF + ENDDO + ENDDO + + YD_STREAM%IX(JPQ-JPS) = IBSET(YD_STREAM%IX(JPQ-JPS),0) + + !------------------------------------------------------------------------------- + ! Initialize some constants + !------------------------------------------------------------------------------- + + YD_STREAM%IUSED=JPQ + YD_STREAM%ZRM=1.0_JPRB/REAL(JPM,JPRB) + + !------------------------------------------------------------------------------- + ! Check the calculation of jpnumsplit and jplensplit. + !------------------------------------------------------------------------------- + + IF (JPP+JPNUMSPLIT*JPLENSPLIT < JPQ) THEN + CALL ABOR1 ('initialize_random_numbers: upper limit of last loop < jpq') + ENDIF + + IF (JPLENSPLIT >=JPP) THEN + CALL ABOR1 ('initialize_random_numbers: loop length > jpp') + ENDIF + + IF (JPNUMSPLIT>1) THEN + IF ((JPQ-JPP+JPNUMSPLIT-2)/(JPNUMSPLIT-1) < JPP) THEN + CALL ABOR1 ('initialize_random_numbers: jpnumsplit is bigger than necessary') + ENDIF + ENDIF + + !------------------------------------------------------------------------------- + ! Set initTest to show that the stream is initialized. + !------------------------------------------------------------------------------- + + YD_STREAM%INITTEST = INITVALUE + + !------------------------------------------------------------------------------- + ! Warm up the generator. + !------------------------------------------------------------------------------- + + CALL UNIFORM_DISTRIBUTION (ZWARMUP, YD_STREAM) + +IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:INITIALIZE_RANDOM_NUMBERS',1,ZHOOK_HANDLE) +END SUBROUTINE INITIALIZE_RANDOM_NUMBERS + +!@PROCESS HOT NOSTRICT +SUBROUTINE UNIFORM_DISTRIBUTION (PX,YD_STREAM) + !-------------------------------------------------------------------------------- + ! Generate uniformly distributed random numbers in the range 0.0<= px < 1.0 + !-------------------------------------------------------------------------------- + INTEGER(KIND=JPIM), PARAMETER :: IVAR = INT(Z"3FFFFFFF",JPIM) + TYPE(RANDOMNUMBERSTREAM), INTENT(INOUT) :: YD_STREAM + REAL(KIND=JPRB), DIMENSION(:), INTENT( OUT) :: PX + + INTEGER(KIND=JPIM) :: JJ, JK, IN, IFILLED + + ! This test is a little dirty but Fortran 90 doesn't allow for the initialization + ! of components of derived types. + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! DR_HOOK removed to reduce overhead +! IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:UNIFORM_DISTRIBUTION',0,ZHOOK_HANDLE) + IF(YD_STREAM%INITTEST /= INITVALUE) & + & CALL ABOR1 ('uniform_distribution called before initialize_random_numbers') + + !-------------------------------------------------------------------------------- + ! Copy numbers that were generated during the last call, but not used. + !-------------------------------------------------------------------------------- + + IN=SIZE(PX) + IFILLED=0 + + DO JJ=YD_STREAM%IUSED+1,MIN(JPQ,IN+YD_STREAM%IUSED) + PX(JJ-YD_STREAM%IUSED) = YD_STREAM%IX(JJ)*YD_STREAM%ZRM + IFILLED=IFILLED+1 + ENDDO + + YD_STREAM%IUSED=YD_STREAM%IUSED+IFILLED + + IF (IFILLED==IN) THEN +! IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:UNIFORM_DISTRIBUTION',1,ZHOOK_HANDLE) +! DR_HOOK removed to reduce overhead + RETURN + ENDIF + + !-------------------------------------------------------------------------------- + ! Generate batches of jpq numbers until px has been filled + !-------------------------------------------------------------------------------- + + DO WHILE (IFILLED=jpm) yd_stream%ix(jj) = yd_stream%ix(jj)-jpm + YD_STREAM%IX(JJ) = IAND(IVAR,YD_STREAM%IX(JJ) + YD_STREAM%IX(JJ-JPP+JPQ)) + ENDDO + + DO JK=1,JPNUMSPLIT + !OCL NOVREC + DO JJ=1+JPP+(JK-1)*JPLENSPLIT,MIN(JPQ,JPP+JK*JPLENSPLIT) +! yd_stream%ix(jj) = yd_stream%ix(jj) + yd_stream%ix(jj-jpp) +! if (yd_stream%ix(jj)>=jpm) yd_stream%ix(jj) = yd_stream%ix(jj)-jpm + YD_STREAM%IX(JJ) = IAND(IVAR,YD_STREAM%IX(JJ) + YD_STREAM%IX(JJ-JPP)) + ENDDO + ENDDO + + YD_STREAM%IUSED = MIN(JPQ,IN-IFILLED) + PX(IFILLED+1:IFILLED+YD_STREAM%IUSED) = YD_STREAM%IX(1:YD_STREAM%IUSED)*YD_STREAM%ZRM + IFILLED = IFILLED+YD_STREAM%IUSED + ENDDO + +!IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:UNIFORM_DISTRIBUTION',1,ZHOOK_HANDLE) +! DR_HOOK removed to reduce overhead +END SUBROUTINE UNIFORM_DISTRIBUTION +!------------------------------------------------------------------------------- +SUBROUTINE GAUSSIAN_DISTRIBUTION (PX, YD_STREAM) + TYPE(RANDOMNUMBERSTREAM), INTENT(INOUT) :: YD_STREAM + REAL(KIND=JPRB), INTENT( OUT) :: PX(:) + !-------------------------------------------------------------------------------- + ! Generate normally-distributed random numbers using the Box-Muller method. + ! + ! NB: this routine does not use buffering. This means that the following calls: + ! call gaussian_distribution (zx(1:k)) + ! call gaussian_distribution (zx(k+1:n)) + ! will produce different numbers for elements k+1 onwards than the single call: + ! call gaussian_distribution (zx(1:n)) + !-------------------------------------------------------------------------------- + + INTEGER(KIND=JPIM) :: ILEN, J + REAL(KIND=JPRB) :: ZFAC, ZTWOPI + REAL(KIND=JPRB) :: ZX(SIZE(PX)+1) + + !-------------------------------------------------------------------------------- + ! Generate uniform random points in the range [0,1) + !-------------------------------------------------------------------------------- + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:GAUSSIAN_DISTRIBUTION',0,ZHOOK_HANDLE) + CALL UNIFORM_DISTRIBUTION (ZX, YD_STREAM) + + !-------------------------------------------------------------------------------- + ! Generate gaussian deviates using Box-Muller method + !-------------------------------------------------------------------------------- + + ZTWOPI = 8.0_JPRB*ATAN(1.0_JPRB) + ILEN=SIZE(PX) + + DO J=1,ILEN-1,2 + ZFAC = SQRT(-2.0_JPRB*LOG(1.0_JPRB-ZX(J))) + PX(J ) = ZFAC*COS(ZTWOPI*ZX(J+1)) + PX(J+1) = ZFAC*SIN(ZTWOPI*ZX(J+1)) + ENDDO + + !-------------------------------------------------------------------------------- + ! Generate the last point if ilen is odd + !-------------------------------------------------------------------------------- + + IF (MOD(ILEN,2) /= 0) THEN + ZFAC = SQRT(-2.0_JPRB*LOG(1.0_JPRB-ZX(ILEN))) + PX(ILEN) = ZFAC*COS(ZTWOPI*ZX(ILEN+1)) + ENDIF + +IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:GAUSSIAN_DISTRIBUTION',1,ZHOOK_HANDLE) +END SUBROUTINE GAUSSIAN_DISTRIBUTION +!------------------------------------------------------------------------------- +!!$SUBROUTINE RANDOM_NUMBER_RESTARTFILE( CDFNAME, CDACTION,YD_STREAM ) +!!$!-------------------------------------------------------------------------------- +!!$! +!!$! read (cdaction='r') or write (cdaction='w') restart file +!!$! for random number generator +!!$! +!!$!-------------------------------------------------------------------------------- +!!$CHARACTER (LEN=*), INTENT(IN) :: CDFNAME +!!$CHARACTER (LEN=1 ), INTENT(IN) :: CDACTION +!!$TYPE(RANDOMNUMBERSTREAM), INTENT(INOUT) :: YD_STREAM +!!$ +!!$INTEGER(KIND=JPIM) :: IUNIT, IRET, IBYTES_IN_JPIM +!!$ +!!$REAL(KIND=JPRB) :: ZHOOK_HANDLE +!!$IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:RANDOM_NUMBER_RESTARTFILE',0,ZHOOK_HANDLE) +!!$IBYTES_IN_JPIM= CEILING(REAL(BIT_SIZE(YD_STREAM%IUSED))/8.0_JPRB - TINY(1.0_JPRB)) +!!$ +!!$IF (IBYTES_IN_JPIM /= 4) THEN +!!$ CALL ABOR1('random_number_restartfile: number of bytes for JPIM is not 4 ') +!!$ENDIF +!!$ +!!$CALL PBOPEN(IUNIT, CDFNAME, CDACTION, IRET) +!!$IF (IRET /= 0) THEN +!!$ CALL ABOR1('random_number_restartfile: PBOPEN FAILED opening '//CDFNAME) +!!$ENDIF +!!$ +!!$ +!!$IF (CDACTION=='r' .OR. CDACTION=='R') THEN +!!$ CALL PBREAD(IUNIT, YD_STREAM%IX, IBYTES_IN_JPIM*JPQ, IRET) +!!$ IF (IRET < 0) THEN +!!$ CALL ABOR1('random_number_restartfile: PBREAD could not read ix from '//CDFNAME) +!!$ ENDIF +!!$ CALL PBREAD(IUNIT, YD_STREAM%IUSED, IBYTES_IN_JPIM , IRET) +!!$ IF (IRET < 0) THEN +!!$ CALL ABOR1('random_number_restartfile: PBREAD could not read iused from '//CDFNAME) +!!$ ENDIF +!!$ +!!$! l_initialized = .TRUE. +!!$ YD_STREAM%INITTEST = INITVALUE +!!$ YD_STREAM%ZRM=1.0_JPRB/REAL(JPM,JPRB) +!!$ELSEIF(CDACTION=='w' .OR. CDACTION=='W') THEN +!!$ CALL PBWRITE(IUNIT, YD_STREAM%IX, IBYTES_IN_JPIM*JPQ, IRET) +!!$ IF (IRET < 0) THEN +!!$ CALL ABOR1('random_number_restartfile: PBWRITE could not write ix on '//CDFNAME) +!!$ ENDIF +!!$ CALL PBWRITE(IUNIT, YD_STREAM%IUSED, IBYTES_IN_JPIM , IRET) +!!$ IF (IRET < 0) THEN +!!$ CALL ABOR1('random_number_restartfile: PBWRITE could not write iused on '//CDFNAME) +!!$ ENDIF +!!$ +!!$ELSE +!!$ CALL ABOR1 ('random_number_restartfile: cdaction = '//CDACTION//' is undefined.') +!!$ENDIF +!!$ +!!$CALL PBCLOSE(IUNIT, IRET) +!!$IF (IRET /= 0) THEN +!!$ CALL ABOR1('random_number_restartfile: PBCLOSE FAILED closing '//CDFNAME) +!!$ENDIF +!!$ +!!$IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:RANDOM_NUMBER_RESTARTFILE',1,ZHOOK_HANDLE) +!!$END SUBROUTINE RANDOM_NUMBER_RESTARTFILE + + +SUBROUTINE WR_RANGEN_STATE( KUNIT, YD_STREAM ) +!-------------------------------------------------------------------------------- +! write state of random number generator to unit kunit +!-------------------------------------------------------------------------------- +INTEGER(KIND=JPIM), INTENT(IN) :: KUNIT +TYPE(RANDOMNUMBERSTREAM), INTENT(IN) :: YD_STREAM + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:WR_RANGEN_STATE',0,ZHOOK_HANDLE) +WRITE( KUNIT, * ) 'module random_numbers_mix, generator state is' +WRITE( KUNIT, '(8I10)') YD_STREAM%IX +WRITE( KUNIT, '(I10)') YD_STREAM%IUSED + +IF (LHOOK) CALL DR_HOOK('RANDOM_NUMBERS_MIX:WR_RANGEN_STATE',1,ZHOOK_HANDLE) +END SUBROUTINE WR_RANGEN_STATE + +END MODULE RANDOM_NUMBERS_MIX