!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***s/r bac - backsubstitution ( memory management and call to bacp_2 )
*
#include "model_macros_f.h"
*
subroutine bac( Itr, Itnlh ) 1,1
*
implicit none
*
integer Itr, Itnlh
*
*author
* Alain Patoine - Gabriel Lemay
*
*revision
* v2_00 - Desgagne M. - initial MPI version
* v2_30 - Edouard S. - adapt for vertical hybrid coordinate
* v2_31 - Desgagne M. - removed treatment of Hu and Qc
* v3_00 - Desgagne & Lee - Lam configuration
*
*object
*******************************************************************************
* _____________________ *
* tau | | *
* q' = --- Q ; where Q = 0 , and | NONHYDROSTATIC ONLY | *
* z 1 |_____________________| *
* *
* / \ / ~ \ *
* | ~~ ~~ | gamma | ~ z dP | *
* Q = Q - gamma | R' - N' | dz + & --------- | P + ----- -- | dz *
* k+1 k | 3 3 | k H 2 3 | cappa dz | k *
* \ /k g tau \ /k *
* *
*******************************************************************************
* _____________________ *
* | | | *
* | | NONHYDROSTATIC ONLY | *
* | |_____________________| *
* z | *
* s | 1 *
* s = ------- P | ------- | z q' | *
* R T* b s | b | s s | *
* d s | s *
* | *
* | *
* / s \ | *
* pi' = b | e - 1 | | *
* \ / | *
* | *
* | *
* q = ln ( z + pi' ) + q' *
* | *
* | *
* b s | *
* phi' = P - R T* ------ - R T* q' *
* d z | d *
* *
*******************************************************************************
* *
* 1 | 1 *
* (R,N) = - ----- (R,N) - ----- (R,N) *
* 2 cappa th | cappa 3 *
* | *
* | *
* / ~~~~ ~~~~ \ | ~~~~ *
* {1} = gamma | (z R ) - (z N ) | | ( also recognized as ZETA ) *
* \ 2 2 / | *
* | ~~~~~~~~~~~~~~~~~~~~~~~~~ *
* | / \ *
* gamma / ~ \2 dP | | z q' gamma z P | *
* {2} = --------------- | z | -- + | ---- - & ------------- | *
* cappa tau R T* \ / dz | | tau H 2 3 | *
* d | \ cappa g tau / *
* | *
* | _____________________ *
* / \ | | *
* X = - X + 2 | {1} - {2} | | NONHYDROSTATIC ONLY | *
* k+1 k \ /k |_____________________| *
* *
* *
* / / \ \ *
* | z | P - phi' | | / *
* | 1 \ 1 1 / | | 0 if b = 0 *
* X = d | -------------------- | with d = | 1 *
* 1 T | * | T | 1 elsewhere *
* \ tau R T / \ *
* *
* ~~ *
* ( ) : vertical staggering. *
* *
* *
*******************************************************************************
* *
* 1 1 / tau \ *
* w = - --- R' + ----- {$} ; where {$} = P - R T* | q' + --- X | *
* g vv g tau d \ z / *
* *
* & _____________________ *
* / \ H | | *
* (mu) = - tau | R - N | + ------- {$} | NONHYDROSTATIC ONLY | *
* lin \ 3 3 / 2 2 |_____________________| *
* g tau *
* *
* *
* / q' \ (q'-s) / pi' \ / \ *
* (mu) = | e - 1 | + e | 1 + --- | | (mu) - q' | *
* \ / \ z / \ lin / *
* *
*******************************************************************************
* _____________________ *
* | | | *
* | | NONHYDROSTATIC ONLY | *
* | |_____________________| *
* / cappa \ | *
* T' = tau T* | R - N + ----- X | + cappa T* q' *
* lin \ th th z / | *
* | *
* | *
* | -s + q' *
* | *
* *
* / \ / \ *
* pi | /\A + /\b | | * / b s /\b s \ | * *
* T'= -- | ------------- | | T' - T | --- - -------- - 1 | |-T *
* z | s | | lin \ z /\A + /\b / | *
* \ /\A + /\b e / \ / *
* *
* *
* where /\A = dA/d(eta) *
* /\b = db/d(eta) *
*******************************************************************************
* *
* / \ *
* | 1 dP | *
* U = tau | R" - N - --- ---- | *
* | U U 2 dx | *
* \ a / *
* *
* / \ *
* | C dP | *
* V = tau | R" - N - --- ---- | *
* | V V 2 dy | *
* \ a / *
* *
* . b s *
* pi* = X - ---- *
* tau *
* *
* . *
* / dpi* \ /\b s *
* | ---- + D | = R - N - ----------------- *
* \ dpi* / cn cn tau ( /\A + /\b ) *
* *
* *
* phi = phi' + phi* + phi *
* s *
* *
* T = T' + T* *
* *
* *
* F = tau R ( passive advection of humidity etc. ) *
* (hu,qc,tr) (hu,qc,tr) *
* *
*******************************************************************************
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* Itr I current nonlinear iteration number
* Itnlh I total number of nonlinear iterations
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "schm.cdk"
#include "p_geof.cdk"
#include "rhsc.cdk"
#include "nl.cdk"
#include "vt0.cdk"
#include "vtx.cdk"
#include "lctl.cdk"
*
*modules
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
*
integer pnerr, pnlod, pnlkey1(26),k
real wijk0(LDIST_SHAPE,l_nk), wijk1(LDIST_SHAPE,l_nk)
**
* __________________________________________________________________
*
if (Lun_debug_L) write(Lun_out,1000)
pnlkey1( 1) = VMM_KEY(st0)
pnlkey1( 2) = VMM_KEY(pipt0)
pnlkey1( 3) = VMM_KEY(qt0)
pnlkey1( 4) = VMM_KEY(fit0)
pnlkey1( 5) = VMM_KEY(fipt0)
pnlkey1( 6) = VMM_KEY(topo)
pnlkey1( 7) = VMM_KEY(tt0)
pnlkey1( 8) = VMM_KEY(tpt0)
pnlkey1( 9) = VMM_KEY(tplt0)
pnlkey1(10) = VMM_KEY(ut0)
pnlkey1(11) = VMM_KEY(vt0)
pnlkey1(12) = VMM_KEY(psdt0)
pnlkey1(13) = VMM_KEY(tdt0)
pnlkey1(14) = VMM_KEY(gptx)
pnlkey1(15) = VMM_KEY(gxtx)
pnlkey1(16) = VMM_KEY(ru)
pnlkey1(17) = VMM_KEY(rv)
pnlkey1(18) = VMM_KEY(rcn)
pnlkey1(19) = VMM_KEY(rth)
pnlod = 19
if (.not. Schm_hydro_L) then
pnlkey1(20) = VMM_KEY(qpt0)
pnlkey1(21) = VMM_KEY(wt0)
pnlkey1(22) = VMM_KEY(mut0)
pnlkey1(23) = VMM_KEY(multx)
pnlkey1(24) = VMM_KEY(rvv)
pnlkey1(25) = VMM_KEY(r3)
pnlkey1(26) = VMM_KEY(r3p)
pnlod = 26
endif
*
pnerr = vmmlod(pnlkey1,pnlod)
*
pnerr = VMM_GET_VAR(st0)
pnerr = VMM_GET_VAR(pipt0)
pnerr = VMM_GET_VAR(qt0)
pnerr = VMM_GET_VAR(fit0)
pnerr = VMM_GET_VAR(fipt0)
pnerr = VMM_GET_VAR(topo)
pnerr = VMM_GET_VAR(tt0)
pnerr = VMM_GET_VAR(tpt0)
pnerr = VMM_GET_VAR(tplt0)
pnerr = VMM_GET_VAR(ut0)
pnerr = VMM_GET_VAR(vt0)
pnerr = VMM_GET_VAR(psdt0)
pnerr = VMM_GET_VAR(tdt0)
pnerr = VMM_GET_VAR(gptx)
pnerr = VMM_GET_VAR(gxtx)
pnerr = VMM_GET_VAR(ru)
pnerr = VMM_GET_VAR(rv)
pnerr = VMM_GET_VAR(rcn)
pnerr = VMM_GET_VAR(rth)
if (.not. Schm_hydro_L) then
pnerr = VMM_GET_VAR(qpt0)
pnerr = VMM_GET_VAR(wt0)
pnerr = VMM_GET_VAR(mut0)
pnerr = VMM_GET_VAR(multx)
pnerr = VMM_GET_VAR(rvv)
pnerr = VMM_GET_VAR(r3)
pnerr = VMM_GET_VAR(r3p)
else
qpt0_ = 0
wt0_ = 0
mut0_ = 0
multx_= 0
rvv_ = 0
r3_ = 0
r3p_ = 0
endif
*
c if (Acid_test_L) then topo,gptx,nl_ntrh,rth
c call glbstat (st0, 'ST0',LDIST_DIM,1,8+acid_i0,G_ni-7-acid_in,
c % 8+acid_j0,G_nj-7-acid_jn,1,1)
c endif
call bacp_2 ( Itr, Itnlh, st0, pipt0, qt0,
% fit0, fipt0, topo, tt0, tpt0, tplt0,
% ut0, vt0, psdt0, tdt0,
% qpt0, wt0, mut0, multx, gptx, gxtx,
% ru, rv, rth, r3, r3p, rvv, rcn,
% nl_nu, nl_nv, nl_nth, nl_n3, nl_n3p,
$ nl_ncn,wijk0,wijk1,LDIST_DIM, l_nk )
*
c if (Acid_test_L) then pipt0,qt0,gxtx,psdt0,tdt0,tplt0
c if (Lun_out.gt.0) write(Lun_out,*) 'after bacp_2'
c call glbstat (st0,'ST0',LDIST_DIM,1,8+acid_i0,G_ni-7-acid_in,
c % 8+acid_j0,G_nj-7-acid_jn,1,1)
pnerr = vmmuld(-1,0)
1000 format (5X,'BACK SUBSTITUTION: (S/R BAC)')
* __________________________________________________________________
*
return
end