!-------------------------------------- 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 teststagwinds 1,21
#if defined (DOC)
*
*** s/r TESTSTAGWINDS - Number of tests used for theSpectral interpolation of wind fields
* . to GEM's staggered grid (option available in 4D-Var mode only)
*
*
* Author : P. Gauthier *ARMA/MSC May, 2003
* Revision:
* Arguments:
* . -none-
*
#endif
use modstag
, only: level2_staggrid, rlati_s, nj_s,njlath_s, rwt_s,
& lstagwinds
use modalp_stag, only: dalp_s, dealp_s
implicit none
*
*
#include "pardim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comdim.cdk"
#include "comleg.cdk"
#include "comgem.cdk"
#include "comgdpar.cdk"
#include "comgd0.cdk"
#include "comgd1.cdk"
#include "comspg.cdk"
#include "comsp.cdk"
integer :: ierr, j, m0, ilaodd, ilaeven, jn, jm, ila0, itest
real*8 :: dlrad2deg,zdellon, zxwave (1:NI+2), zx, dlval_even, dlval_odd
logical llprint
llprint = .false.
ctypvara = ' '
dlrad2deg =180.d0/rpi
!ITEST Nature of the test
itest = 0 ! ----------------------------
! 11 SPDIV.ne.0 and vt(njlath_S).ne.0
! 21 SPVOR.ne.0 and vt(njlath_S).ne.0
! 12 SPDIV.ne.0 and vt0(1:nj_s).ne.0
! 22 SPVOR.ne.0 and vt0(1:nj_s).ne.0
! 13 SPDIV.ne.0 and vt0(njlath_s+1).ne.0 and vt0(njlath_s-1).ne.0
! 23 SPVOR.ne.0 and vt0(njlath_s+1).ne.0 and vt0(njlath_s-1).ne.0
! 14 SPDIV.ne.0 and ut0(1:nj).ne.0
! 24 SPVOR.ne.0 and ut0(1:nj).ne.0
select case (itest)
case(11)
write(nulout,*)'TEST No.',itest,' SPDIV.ne.0 and vt0(njlath_S).ne.0'
case(21)
write(nulout,*)'TEST No.',itest,' SPVOR.ne.0 and vt0(njlath_S).ne.0'
case(12)
write(nulout,*)'TEST No.',itest,' SPDIV.ne.0 and vt0(1:nj_s).ne.0'
case(22)
write(nulout,*)'TEST No.',itest,' SPVOR.ne.0 and vt0(1:nj_s).ne.0'
case(14)
write(nulout,*)'TEST No.',itest,' SPDIV.ne.0 and ut0(1:nj).ne.0'
case(24)
write(nulout,*)'TEST No.',itest,' SPVOR.ne.0 and ut0(1:nj).ne.0'
case(13)
write(nulout,*)'TEST No.',itest,' SPDIV.ne.0 and '
S ,'vt0(njlath_s+1).ne.0 and vt0(njlath_s-1).ne.0 '
case(23)
write(nulout,*)'TEST No.',itest,' SPVOR.ne.0 and '
S ,'vt0(njlath_s+1).ne.0 and vt0(njlath_s-1).ne.0 '
case(31)
write(nulout,*)'TEST No.',itest,' SPVOR.eq.0 and '
S ,'and vt0(njlath_S) = 1.'
case default
end select
!
call readnml('NAMGDPAR',ierr)
call getfst(nulstd,'G','A')
!
level2_staggrid = .FALSE.
call gdsp
!
! Testing adjoint of staggering
! <X, StagWinds SPG>_G = <StagWinds_Ad X, SPG>_S
! SPG is arbitrary and so is X (in grid-point space)
call transfer('SP0G')
! At this point COMSPG contains Ytilde used for the transpose test
! Setting some components to zero is useful to aid in pinpointing errors
! --------------------------
if(itest/10.eq.1) then
spvorg(:,:,1:nflev) = 0.d0
else if(itest/10.eq.2) then
spdivg(:,:,1:nflev) = 0.d0
else if(itest/10.eq.3) then
write(nulout,fmt='(///,4x,A)')
S 'SETTING VORTICITY = 0, DIVERGENCE (1:NTRUNC+1).NE.0'
spvorg(:,:,1:nflev) = 0.d0
spdivg(:,:,1:nflev) = 0.d0
spdivg(2:ntrunc+1,1,1:nflev) = 1.d0
end if
!
call spgd
call postproc(nulinclr,1,'GRID','GDSPSPGD')
! Output of the original wind components on the Gaussian grid
write(nulout,fmt='(//,4x,A)')'VT0 on Gaussian grid: north-south cross-section'
do j = nj,1,-1
write(nulout,fmt='(g12.6,2(3x,g12.6))')rlati(j)*dlrad2deg, vt0(1,nflev/2,j), vt0(2,nflev/2,j)
end do
!
write(nulout,fmt='(//,4x,A)')'UT0 on Gaussian grid: north-south cross-section'
do j = nj,1,-1
write(nulout,fmt='(g12.6,2(3x,g12.6))')rlati(j)*dlrad2deg, ut0(1,nflev/2,j), ut0(2,nflev/2,j)
end do
!
zdellon = 180./real(ni)
write(nulout,fmt='(//,4x,A)')'VT0 on Gaussian grid: equatorial cross-section'
do j = 1,ni
write(nulout,fmt='(g12.6,2(3x,g12.6))')(j-1)*zdellon, vt0(j,nflev/2,njlath), vt0(j,nflev/2,njlath-1)
end do
write(nulout,fmt='(//,4x,A)')'UT0 on Gaussian grid: equatorial cross-section'
do j = 1,ni
write(nulout,fmt='(g12.6,2(3x,g12.6))')(j-1)*zdellon, ut0(j,nflev/2,njlath), ut0(j,nflev/2,njlath-1)
end do
!
call transfer('SPG0')
if(lstagwinds) then
call stagwinds(nulout)
call postproc(nulinclr,1,'GRID','TSTSTAG')
!
! Winds are now defined on the staggered grid
! Output of the wind components on the staggered grid
!
write(nulout,fmt='(//,4x,A)')'VT0 on staggered grid: north-south cross-section'
do j = nj_s,1,-1
write(nulout,fmt='(g12.6,3x,g12.6)')rlati_s(j)*dlrad2deg, vt0(1,nflev/2,j)
end do
!
write(nulout,fmt='(//,4x,A)')'UT0 on staggered grid: north-south cross-section'
do j = nj,1,-1
write(nulout,fmt='(g12.6,3x,g12.6)')rlati(j)*dlrad2deg, ut0(1,nflev/2,j)
end do
!
write(nulout,fmt='(//,4x,A)')'VT0 on staggered grid: equatorial cross-section'
do j = 1,ni
write(nulout,fmt='(g12.6,3x,g12.6)')(j-1)*zdellon, vt0(j,nflev/2,njlath_s)
end do
!
write(nulout,fmt='(//,4x,A)')'UT0 on staggered grid: equatorial cross-section'
do j = 1,ni
write(nulout,fmt='(g12.6,3x,g12.6)')(real(j) - 0.5)*zdellon, ut0(j,nflev/2,njlath)
end do
else
call spgd
end if
call transfer('GD01')
!
! At this point COMGD0 contains X used for the transpose test
! Setting some components to zero is useful to aid in pinpointing errors
! --------------------------
if(itest.ne.0) then
call transfer ('ZGD0') ! this is for some specific tests only
if (mod(itest,10).eq.1) then
if(lstagwinds) then
vt0(1:ni,1:nflev,njlath_s) = vt1(:,1:nflev,njlath_s)
!vt0(1:ni,1:nflev,njlath_s) = 1.d0
else
vt0(1:ni,1:nflev,njlath) = vt1(:,1:nflev,njlath)
vt0(1:ni,1:nflev,njlath+1) = vt1(:,1:nflev,njlath)
end if
else if (mod(itest,10).eq.2) then
if(lstagwinds) then
vt0(1:ni,1:nflev,1:nj_s) = vt1(1:ni,1:nflev,1:nj_s)
else
vt0(1:ni,1:nflev,1:nj) = vt1(1:ni,1:nflev,1:nj)
end if
else if (mod(itest,10).eq.3) then
write(nulout,*)'Antisymmetric case'
if(lstagwinds) then
vt0(1:ni,1:nflev,njlath_s+1) = vt1(:,1:nflev,njlath_s)
vt0(1:ni,1:nflev,njlath_s-1) = -vt1(:,1:nflev,njlath_s)
else
vt0(1:ni,1:nflev,njlath) = vt1(:,1:nflev,njlath)
vt0(1:ni,1:nflev,njlath+1) = -vt1(:,1:nflev,njlath)
end if
else if(mod(itest,10).eq.4) then
ut0(1:ni,1:nflev,1:nj) = ut1(1:ni,1:nflev,1:nj)
end if
end if
! ----------------------\
! End of testing zone )
! ---------------------/
if(lstagwinds) then
! First inner product of the transpose test
level2_staggrid = .true.
call doteucl('G',nulout)
!
level2_staggrid = .false.
call stagwinds_ad(nulout)
else
level2_staggrid = .false.
call doteucl('G',nulout)
call spgda
end if
!----------------------------------\
! if(lstagwinds) call verifistag (m0)
!----------------------------------/
call transfer('SP01')
if(llprint) then
write(nulout,fmt='(//,12x,A,/8x,A)')'Output from stagwinds_ad: components of divergence'
S ,'Real (EVEN) Imaginary (EVEN) Real (ODD) Imaginary (ODD)'
do jm = 0,0
ila0 = nind(jm)
do jn = jm,ntrunc-1,2
ilaeven = ila0 +(jn-jm)
ilaodd = ilaeven + 1
! write(nulout,fmt='(4x,A,2(3x,i3),4(4x,g12.6))')'(n,m) = ',jn
! S ,jm,spdiv(ilaeven,1,nflev/2),spdiv(ilaeven,2,nflev/2)
! S ,spdiv(ilaodd,1,nflev/2),spdiv(ilaodd,2,nflev/2)
dlval_even = rwt_s(njlath_s)*dealp_s(ilaeven,njlath_s)
S *r1snp1(ilaeven)
dlval_odd = rwt_s(njlath_s)*dealp_s(ilaodd ,njlath_s)
S *r1snp1(ilaodd)
write(nulout,fmt='(4x,a,4x,g12.6,4x,g12.6,4x,a,4x,g12.6,4x,g12.6)')
S 'DLVAL_even = ',dlval_even,spdiv(ilaeven,1,nflev/2)
S ,'DLVAL_ODD = ',dlval_odd,spdiv(ilaodd,1,nflev/2)
end do
end do
end if
!
! Second inner product of the transpose test
call transfer('SPG0')
call doteucl('S',nulout)
!
end subroutine teststagwinds