!-------------------------------------- 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 abal(ppsi,pchi,pvort,ldhelm) 1,13
*
***s/r abal - Adjoint of lbal.
* - In: Sensitivitiy of (Psi,Chi,T,q,ps)
* - Out: Sensitivitiy of (Psi,Chiu,Tu,q,psu)
*
*Author : Luc Fillion - CGD/NCAR - Jul 99
*Revision: Luc Fillion - MSC- 29 Aug 2005 - Add diabatic forcing term
*
* -------------------
** Purpose: Used for LA-XD-Var analysis
*
*Arguments
* none
*
implicit none
logical ldhelm
real*8 ppsi(ni,nflev,nj)
real*8 pchi(ni,nflev,nj)
real*8 pvort(ni,nflev,nj)
*
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comcst.cdk"
#include "comct0.cdk"
#include "comcva.cdk"
#include "comsim.cdk"
#include "comgd0.cdk"
#include "comcorr.cdk"
#include "compdg.cdk"
#include "comfftla.cdk"
!
!
logical llmass,llchib,lladiab,llconv,llcond
logical llfplane
integer ji,jj,jk,ipt,jpt,jla,ik,jband,jm,ila
integer jk1,jk2
integer jrow,jcol,nim,njm,nijkm
integer idim
real*8 zcoriolis,zscalt
real*8 zgdpsi(ni,nflev,nj)
real*8 zgdchib(ni,nflev,nj)
real*8 zpsiomeg(ni,nflev,nj)
real*8 zomega(ni,nflev,nj)
real*8 ztt(ni,nflev,nj)
real*8 zq(ni,nflev,nj)
real*8 zp(ni,nflev,nj)
real*8 zt0(ni,nflev,nj)
real*8 zps0(ni,nj)
!
real*8 zsppb(nla,2,nflev)
real*8 zspt0(nla,2,nflev)
real*8 zsps0(nla,2)
!
!!
llmass=.true.
llfplane=.true.
llchib=.false.
if(nflev.eq.1) llchib = .false.
!
lladiab=.true.
llconv=.false.
llcond=.false.
!
nijkm = ni*nflev*nj
call zero(nijkm,zgdpsi)
call zero(nijkm,zpsiomeg)
call zero(nijkm,zgdchib)
call zero(nijkm,zomega)
call zero(nijkm,ztt)
call zero(nijkm,zq)
call zero(nijkm,zp)
!
zcoriolis=2.*romega
!
do jj=1,nj
do ji=1,ni
do jk=1,nflev
zgdchib(ji,jk,jj)=pchi(ji,jk,jj)
enddo
enddo
enddo
!
! Adjoint of Omega balance operator
!
if(llchib) then
!ping call achib(zomega,zgdchib)
!ping call aomega_bal(zpsiomeg,ztt,zq,zomega,lladiab,llconv,llcond)
!
do jk=1,nflev
do ji=1,ni
do jj=1,nj
ppsi(ji,jk,jj)=ppsi(ji,jk,jj)+zpsiomeg(ji,jk,jj)
tt0(ji,jk,jj)=tt0(ji,jk,jj)+ztt(ji,jk,jj)
q0(ji,jk,jj)=q0(ji,jk,jj)+zq(ji,jk,jj)/qg(ji,jk,jj)
enddo
enddo
enddo
endif
!
! Adjoint of Tb operator
!
zscalt = 0.1
if(llmass) then
if(lsw) then
do jj=1,nj ! Barotropic option
do ji=1,ni
zp(ji,mk,jj) = 0.0
zp(ji,mk,jj) = zp(ji,mk,jj)+zscalt*tt0(ji,mk,jj)
enddo
enddo
else
if(cptot.eq.'GD') then
do jj=1,nj ! Baroclinic option
do ji=1,ni
do jk1=1,nflev
zp(ji,jk1,jj) = 0.0
do jk2=1,nflev
zp(ji,jk1,jj) = zp(ji,jk1,jj)+
& ptot(jk2,jk1,jj)*tt0(ji,jk2,jj)
enddo
enddo
do jk1=1,nflev
zp(ji,jk1,jj) = zp(ji,jk1,jj)+
& ptot(nflev+1,jk1,jj)*gps0(ji,1,jj)
enddo
enddo
enddo
!
else if(cptot.eq.'SP') then
!
if(lsw) then
do jj=1,nj ! Barotropic option
do ji=1,ni
zp(ji,mk,jj) = 0.0
zp(ji,mk,jj) = zp(ji,mk,jj)+zscalt*tt0(ji,mk,jj)
enddo
enddo
else
do jj=1,nj
do ji=1,ni
do jk=1,nflev
zt0(ji,jk,jj) = tt0(ji,jk,jj)
enddo
zps0(ji,jj) = gps0(ji,1,jj)
enddo
enddo
!
call aviproj(zt0,zt0,nflev)
call re2spla(zspt0,zt0,nflev)
call re2spla(zsps0,zps0,1)
zsppb(:,:,:) = 0.0
!
do jband = 1, nband
do jm = 1, mbandsp(jband)
ila=mila(jm,jband)
do jk1 = 1, nflev
zsppb(ila,1,jk1) = 0.0
do jk2 = 1, nflev
zsppb(ila,1,jk1) = zsppb(ila,1,jk1) +
& sptot(jk2,jk1,jband) * zspt0(ila,1,jk2)
enddo
enddo
do jk = 1, nflev
zsppb(ila,1,jk) = zsppb(ila,1,jk) +
& sptot(nflev+1,jk,jband)*zsps0(ila,1)
enddo
enddo ! end loop on jm
enddo ! end loop on jband
call sp2rela(zp,zsppb,nflev) ! Build spectral Pb
call avproj(zp,zp,nflev)
endif ! lsw
endif ! cptot
endif ! llmass
!
if(ldhelm) then
call alinbal_la(ppsi,zp,llfplane,.false.,'P')
else
do jk=1,nflev
do jj=1,nj
do ji=1,ni
pvort(ji,jk,jj) = pvort(ji,jk,jj)+
& zp(ji,jk,jj)
enddo
enddo
enddo
endif
endif
!
return
end