!-------------------------------------- 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 readgd_lusdev(pfld,cdnomvar,knlev) 12,3
#if defined (DOC)
*
***s/r readgd_lusdev - In grdtyp = 'LU mode: Read the gridpoint standard deviation of (UU,VV,TT,ES,P0)
*
*Author : Luc Fillion - ARMA/EC - 10 Sept 2007.
*Revision: Luc Fillion - ARMA/EC - 22 Apr 2009. - Update on v_10_2_1.
*
* Arguments:
* input:
*
#endif
implicit none
*implicits
*
* Global variables
*
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "rpnstd.cdk"
#include "comgem.cdk"
#include "comgrd_param.cdk"
#include "comcva.cdk"
#include "comgd0.cdk"
*
character*2 cdnomvar
integer knlev
real*8 pfld(nila,knlev,njla)
!
integer jvar,jn,jlev,inip1,injp1
integer ikey,ji,jj,jk,jlat
real*8 zwork,zscale
real*8 zgr,zgsig
real*8 zstd2d(nila,njla)
real*8 zstd3d(nila,knlev,njla)
!---------------------------------------------------------------------
!
write(nulout,*) 'readgd_lusdev:****************************'
write(nulout,*) 'readgd_lusdev: READ ',cdnomvar
write(nulout,*) 'readgd_lusdev:****************************'
!
idate(1) = -1
ip1 = -1
ip2 = -1
ip3 = -1
*
cletiket = 'LUSTDDEV'
cltypvar ='E'
!
pfld(:,:,:) = 0.0
!
if(cdnomvar.ne.'P0') then
write(nulout,*) 'Reading 3D variables'
do jk=1,knlev
ip1 = nip1(jk)
ikey = vfstlir
(zstd2d,nulbgst,ini,inj,ink,idate(1)
& ,cletiket,ip1,ip2,ip3,cltypvar,cdnomvar)
!
if(ikey .lt.0 ) then
call abort3d
(nulout
& ,'readgd_lusdev: Problem with background stat file')
endif
!
if(clnomvar .eq. 'UU') then
zscale = rmsknt ! from knots to m/s
do ji = 1, mni_in
do jj = 1, mnj_in
pfld(ji,jk,jj) = zscale*zstd2d(ji,jj)
if(pfld(ji,jk,jj).le.0.0) then
write(nulout,*) 'readgd_lusdev: ji,jj,jk,st-dev UU=',
& ji,jj,jk,pfld(ji,jk,jj)
endif
enddo
enddo
elseif(clnomvar .eq. 'VV') then
zscale = rmsknt ! from knots to m/s
do ji = 1, mni_in
do jj = 1, mnj_in
pfld(ji,jk,jj) = zscale*zstd2d(ji,jj)
enddo
enddo
elseif(clnomvar .eq. 'TT') then
zscale = 1.0
do ji = 1, mni_in
do jj = 1, mnj_in
pfld(ji,jk,jj) = zscale*zstd2d(ji,jj)
enddo
enddo
elseif(clnomvar .eq. 'GZ') then
zscale = RG*10.
do ji = 1, mni_in
do jj = 1, mnj_in
pfld(ji,jk,jj) = zscale*zstd2d(ji,jj)
enddo
enddo
elseif(clnomvar .eq. 'ES') then
do ji = 1, mni_in
do jj = 1, mnj_in
pfld(ji,jk,jj) = zstd2d(ji,jj)
enddo
enddo
endif
enddo
else
!
write(nulout,*) 'Reading 2D variables'
ikey = vfstlir
(zstd2d,nulbgst,ini,inj,ink,idate(1)
& ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
!
do jj = 1, mnj_in
do ji = 1, mni_in
pfld(ji,1,jj) = zstd2d(ji,jj)*RMBTPA
enddo
enddo
endif
!
do jk = 1,knlev
do jj = 1,mnj_in
do ji = mni_in+1,ni
pfld(ji,jk,jj) = pfld(mni_in,jk,jj)
enddo
enddo
do ji = 1,ni
do jj = mnj_in+1,nj
pfld(ji,jk,jj) = pfld(ji,jk,mnj_in)
enddo
enddo
enddo
!
! Make fields bi-periodic over horizontal analysis domain
!
! inip1 = nila+1
! injp1 = njla+1
! if(ink.eq.1) then
! do jj = 1,mnj_in
! do ji = 1,mni_in
! zstd2d(ji,jj) = pfld(ji,1,jj)
! enddo
! enddo
! call mach2(zstd2d,nila,njla,inip1,injp1)
! do jj = 1,njla
! do ji = 1,nila
! pfld(ji,1,jj) = zstd2d(ji,jj)
! enddo
! enddo
! else
! call mach3(pfld,nila,njla,ink,inip1,injp1)
! endif
!
WRITE(nulout,*)'DONE in READGD_LUSDEV'
!
return
end