!-------------------------------------- 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 --------------------------------------
!
C
C X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
C
subroutine lbal0(pgdpsi,pgdchi,pvort,pdiv,ldhelm),10
*
***s/r lbal0 - Balance fields. In: (Psi,Chiu,Tu,q,psu); Out: (Psi,Chi,T,q,ps)
*
*
*Author : Luc Fillion -ARMA/EC Mar 2007.
*Revision:
* Luc Fillion - ARMA/EC 10 Jul 2009.
*
* -------------------
** Purpose: Used for LA-XD-Var analysis
*
*Arguments
* none
*
implicit none
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comgrd_param.cdk"
#include "comcst.cdk"
#include "comcva.cdk"
#include "comgd0.cdk"
#include "compdg.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comsim.cdk"
#include "comfftla.cdk"
!
logical ldhelm
real*8 pgdpsi(ni,nflev,nj)
real*8 pgdchi(ni,nflev,nj)
real*8 pvort(ni,nflev,nj)
real*8 pdiv(ni,nflev,nj)
!
real*8 zscalt
real*8 zu0(0:ni+1,nflev,0:nj+1)
real*8 zv0(0:ni+1,nflev,0:nj+1)
real*8 zu2(-1:ni+2,nflev,-1:nj+2)
real*8 zv2(-1:ni+2,nflev,-1:nj+2)
real*8 ztt0(ni,nflev,nj)
real*8 ztt(ni,nflev,nj)
real*8 zq(ni,nflev,nj)
real*8 zgdchib(ni,nflev,nj)
real*8 zomega(ni,nflev,nj)
real*8 zvort(ni,nflev,nj)
real*8 zdiv(ni,nflev,nj)
real*8 zgdpsi(ni,nflev,nj)
real*8 zp2d(mni_in,mnj_in)
real*8 zp(ni,nflev,nj)
real*8 zpnl(ni,nflev,nj)
real*8 ztb(ni,nflev,nj)
real*8 tt0_s(ni,nflev,nj)
real*8 zchib(ni,nflev,nj)
real*8 q0_s(ni,nflev,nj)
real*8 gps0_s(ni,1,nj)
real*8 zpin(mni_in,nflev,mnj_in)
real*8 zlnps(ni,nj)
real*8 zwh(ni,nj)
real*8 zwh2(ni,nj)
real*8 zpsb(ni,nj)
real*8 zps0(ni,nj)
!
real*8 zsps0(nla,2)
real*8 zspt0(nla,2,nflev)
real*8 zsppb(nla,2,nflev)
!
logical llmass,llchib,lldiab,llconv,llcond
logical llfplane
integer ji,jj,jk,jband,jm,nip1,njp1,jk1,jk2,ilev,ila
integer ilen,ierr
integer idum1,idum2,idum3,idum4
real*8 zmin,zmax,zcscl
*
**
llmass=.true.
llfplane=.true.
!
if(llmass) then
!
call zero(ni*nj*nflev,ztb)
call zero(ni*nj*nflev,zp)
call zero(ni*nj*nflev,zpnl)
call zero(ni*nj*nflev,zchib)
call zero(ni*nj,zpsb)
!
!*1. Save Unbalanced part
! --------------------
!
do jj=1,nj
do ji=1,ni
do jk=1,nflev
tt0_s(ji,jk,jj) = tt0(ji,jk,jj)
q0_s(ji,jk,jj) = q0(ji,jk,jj)
enddo
gps0_s(ji,1,jj) = gps0(ji,1,jj)
enddo
enddo
!
!*2. Build Balanced part
! -------------------
!
!*2.1 1st Order Baer-Tribbia
!
if(ldhelm) then
lldiab = .false.
call linbal_la(zp,pgdpsi,llfplane,.false.,'P')
write(nulout,*) 'lbal0: linmi = ',linmi
!cluc if(linmi) call inmi_P(zpnl,pgdpsi,lldiab)
!
do jj=1,nj
do jk=1,nflev
do ji=1,ni
zp(ji,jk,jj) = zp(ji,jk,jj)+zpnl(ji,jk,jj)
enddo
enddo
enddo
else
do jj=1,nj
do jk=1,nflev
do ji=1,ni
zp(ji,jk,jj) = pvort(ji,jk,jj)
enddo
enddo
enddo
endif
!
if(cptot.eq.'GD') then
zscalt = 0.1
if(lsw) then
do jj=1,nj ! Barotropic option
do ji=1,ni
tt0(ji,mk,jj)=tt0(ji,mk,jj)+ ! tt0 already contains Tu
& zscalt*zp(ji,mk,jj)
enddo
enddo
else
do jj=1,nj ! Baroclinic option
do ji=1,ni
do jk2=1,nflev
do jk1=1,nflev
tt0(ji,jk1,jj)=tt0(ji,jk1,jj)+ ! tt0 already contains Tu
& ptot(jk1,jk2,jj)*zp(ji,jk2,jj)
enddo
gps0(ji,1,jj)=gps0(ji,1,jj)+
& ptot(nflev+1,jk2,jj)*zp(ji,jk2,jj)
enddo
enddo
enddo
endif
else if(cptot.eq.'SP') then
zscalt = 0.1
if(lsw) then
do jj=1,nj ! Barotropic option
do ji=1,ni
tt0(ji,mk,jj)=tt0(ji,mk,jj)+ ! tt0 already contains Tu
& zscalt*zp(ji,mk,jj)
enddo
enddo
else
do jj=1,nj
do ji=1,ni
zps0(ji,jj) = gps0(ji,1,jj)
enddo
enddo
!
zsps0(:,:) = 0.0
zspt0(:,:,:) = 0.0
zsppb(:,:,:) = 0.0
!
call re2spla(zsps0,zps0,1)
call re2spla(zsppb,zp,nflev)
!
do jband = 1, nband
do jm = 1, mbandsp(jband)
ila=mila(jm,jband)
do jk1 = 1, nflev
do jk2 = 1, nflev
zspt0(ila,1,jk1) = zspt0(ila,1,jk1) +
& sptot(jk1,jk2,jband) * zsppb(ila,1,jk2)
enddo
enddo
do jk2 = 1, nflev
zsps0(ila,1) = zsps0(ila,1) +
& sptot(nflev+1,jk2,jband)*zsppb(ila,1,jk2)
enddo
enddo ! end loop on jm
enddo ! end loop on jband
!
call sp2rela(ztt0,zspt0,nflev)
!
do jj=1,nj
do ji=1,ni
do jk=1,nflev
tt0(ji,jk,jj) = ztt0(ji,jk,jj) + tt0(ji,jk,jj) ! Tb + Tu
enddo
enddo
enddo
!
call sp2rela(zps0,zsps0,1)
!
do jj=1,nj
do ji=1,ni
gps0(ji,1,jj) = zps0(ji,jj)
enddo
enddo
endif ! lsw
endif ! cptot
!
!*2.2 Compute Balanced Chi: Result in pgdchi
!
if(linmi) then
lldiab = ldiabatic
!cluc call inmi_Chi(zchib,pgdpsi,lldiab)
endif
!
!*3 Add Balanced and Unbalanced components
! --------------------------------------
!
do jj=1,nj
do ji=1,ni
do jk=1,nflev
pgdchi(ji,jk,jj)=zchib(ji,jk,jj)+pgdchi(ji,jk,jj)
tt0(ji,jk,jj)=tt0(ji,jk,jj)+tt0_s(ji,jk,jj)
q0(ji,jk,jj)=q0_s(ji,jk,jj)
enddo
if(nflev.ne.1) then
gps0(ji,1,jj)=gps0(ji,1,jj)+gps0_s(ji,1,jj)
endif
enddo
enddo
endif
!
return
end