!-------------------------------------- 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 --------------------------------------
!
subroutine vloc_corns(pcorns) 4,15
!
use mod4dv
, only : l4dvar
use modfgat, only : nstamplist
IMPLICIT NONE
#if defined (DOC)
*
***s/r vloc_corns - Vertical Localization of CORNS vertical correlations.
* Based on approach used in sucorns2.ftn following Mark Buehner's global code.
* This is found newcessary to control the noise and impact of raw CORNS
* when TOVS data are assimilated in stratospheric mode; i.e. it was found in lam4d
* that stratospheric chanels only can impact (~ 0.5 deg) the PBL vertical gradient
* which is undesirable. Reversely, troposheric data can have a noisy impact on stratospheric
* increments using raw CORNS. These effects are serious during the summer and can significantly
* slow-down the minimization (60 to 200 iterations in FGAT mode).
*
* N.B.: THe case nanalvar .eq.3 is also supported here.
*
*Author : Luc Fillion - ARMA/EC - 17 Feb 2009.
*Revision:
*
#endif
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcst.cdk"
#include "comspg.cdk"
#include "rpnstd.cdk"
#include "comfftla.cdk"
#include "comgrd_param.cdk"
#include "cvcord.cdk"
*
real*8 pcorns(nksdim2,nksdim2,0:nband-1,1)
!
INTEGER IJ,II,II2,IN,JK1,JK2,jband
integer ibrpstamp
real*8 zps
real*8 ztt(nflev,nflev,nband),ztpsi(nflev,nflev,nband)
real*8 zprof(jpnflev)
real*8 zgaspar(nflev,nflev)
!
!!
write(NULOUT,*)' *********************************************'
write(NULOUT,*)' vloc_corns --- Vertical Localization of CORNS'
write(NULOUT,*)' *********************************************'
!
!1. Apply vertical localization to CORNS
! ------------------------------------
!
zps = 101000. 0
call calcpres(zprof,vhybinc,nflev,zps,rptopinc
& ,rprefinc,rcoefinc,1)
!
do jk1=1,nflev
write(nulout,*)'vloc_corns:lev,hyb,zprof,log= ',jk1,vhybinc(jk1)
& ,zprof(jk1),log(zprof(jk1))
enddo
!
! PP-PP correlations
!
write(nulout,*)'vloc_corns: RVLOCPSI = ',RVLOCPSI
call v_gaspar(zgaspar,zprof,RVLOCPSI)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1,jk2,jband-1,1)
& = pcorns(jk1,jk2,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! PP-CC correlations
!
write(nulout,*)'vloc_corns: RVLOCPSI = ',RVLOCPSI
call v_gaspar(zgaspar,zprof,RVLOCPSI)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1,jk2+nflev,jband-1,1)
!cluc & = 0.0
& = pcorns(jk1,jk2+nflev,jband-1,1)*zgaspar(jk1,jk2)
pcorns(jk1+nflev,jk2,jband-1,1)
!cluc & = 0.0
& = pcorns(jk1+nflev,jk2,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! PP-Tu correlations (meanningfull for mbal_order = 0)
!
write(nulout,*)'vloc_corns: RVLOCPSI = ',RVLOCPSI
call v_gaspar(zgaspar,zprof,RVLOCPSI)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1,jk2+2*nflev,jband-1,1)
& = pcorns(jk1,jk2+2*nflev,jband-1,1)*zgaspar(jk1,jk2)
pcorns(jk1+2*nflev,jk2,jband-1,1)
& = pcorns(jk1+2*nflev,jk2,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! PP-Lnq correlations
!
write(nulout,*)'vloc_corns: RVLOCPSI = ',RVLOCPSI
call v_gaspar(zgaspar,zprof,RVLOCPSI)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1,jk2+3*nflev,jband-1,1)
& = 0.0
!cluc & = pcorns(jk1,jk2+3*nflev,jband-1,1)*zgaspar(jk1,jk2)
pcorns(jk1+3*nflev,jk2,jband-1,1)
& = 0.0
!cluc & = pcorns(jk1+3*nflev,jk2,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! PP-Tb correlations
!
if(nanalvar.eq.4) then
write(nulout,*)'vloc_corns: RVLOCBALT = ',RVLOCBALT
call v_gaspar(zgaspar,zprof,RVLOCBALT)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1,jk2+nksdim,jband-1,1)
& = pcorns(jk1,jk2+nksdim,jband-1,1)*zgaspar(jk1,jk2)
pcorns(jk1+nksdim,jk2,jband-1,1)
& = pcorns(jk1+nksdim,jk2,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
endif
!
! CC-CC correlations
!
write(nulout,*)'vloc_corns: RVLOCCHI = ',RVLOCCHI
call v_gaspar(zgaspar,zprof,RVLOCCHI)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1+nflev,jk2+nflev,jband-1,1)
& = pcorns(jk1+nflev,jk2+nflev,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! CC-TT correlations
!
write(nulout,*)'vloc_corns: RVLOCCHI = ',RVLOCCHI
call v_gaspar(zgaspar,zprof,RVLOCCHI)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1+nflev,jk2+2*nflev,jband-1,1)
& = 0.0
!cluc & = pcorns(jk1+nflev,jk2+2*nflev,jband-1,1)*zgaspar(jk1,jk2)
pcorns(jk1+2*nflev,jk2+nflev,jband-1,1)
& = 0.0
!cluc & = pcorns(jk1+2*nflev,jk2+nflev,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! CC-Lnq correlations
!
write(nulout,*)'vloc_corns: RVLOCCHI = ',RVLOCCHI
call v_gaspar(zgaspar,zprof,RVLOCCHI)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1+nflev,jk2+3*nflev,jband-1,1)
& = 0.0
! & = pcorns(jk1+nflev,jk2+3*nflev,jband-1,1)*zgaspar(jk1,jk2)
pcorns(jk1+3*nflev,jk2+nflev,jband-1,1)
& = 0.0
!cluc & = pcorns(jk1+3*nflev,jk2+nflev,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! Tu-Tu correlations
!
write(nulout,*)'vloc_corns: RVLOCUNBALT = ',RVLOCUNBALT
call v_gaspar(zgaspar,zprof,RVLOCUNBALT)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1+2*nflev,jk2+2*nflev,jband-1,1)
& = pcorns(jk1+2*nflev,jk2+2*nflev,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! Tu-Lnq correlations
!
write(nulout,*)'vloc_corns: RVLOCUNBALT = ',RVLOCUNBALT
call v_gaspar(zgaspar,zprof,RVLOCUNBALT)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1+2*nflev,jk2+3*nflev,jband-1,1)
& = 0.0
!cluc & = pcorns(jk1+2*nflev,jk2+3*nflev,jband-1,1)*zgaspar(jk1,jk2)
pcorns(jk1+3*nflev,jk2+2*nflev,jband-1,1)
& = 0.0
!cluc & = pcorns(jk1+3*nflev,jk2+2*nflev,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! Lnq
!
write(nulout,*)'vloc_corns: RVLOCLQ = ',RVLOCLQ
call v_gaspar(zgaspar,zprof,RVLOCLQ)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1+3*nflev,jk2+3*nflev,jband-1,1)
& = pcorns(jk1+3*nflev,jk2+3*nflev,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
!
! TB_TB
!
if(nanalvar.eq.4) then
write(nulout,*)'vloc_corns: RVLOCBALT = ',RVLOCBALT
call v_gaspar(zgaspar,zprof,RVLOCBALT)
!
do jk1=1,nflev
do jk2=1,nflev
do jband=1,nband
pcorns(jk1+4*nflev,jk2+4*nflev,jband-1,1)
& = pcorns(jk1+4*nflev,jk2+4*nflev,jband-1,1)*zgaspar(jk1,jk2)
enddo
enddo
enddo
endif
!
! call normcornsla(pcorns)
!
998 continue
return
end