!-------------------------------------- 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 varoutlow 2,21
use mod4dv
, only : l4dvar
#if defined (DOC)
*
***s/r varoutlow - Output analysis increments at analysis resolution onto RPN standard file.
*
#endif
!Author : Luc Fillion - ARMA/EC - sept 2009
!Revision: Luc Fillion - ARMA/EC - 31 May 2010 - Extend to allow grd_typ= 'LU' mode.
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "compost.cdk"
#include "cvcord.cdk"
#include "rpnstd.cdk"
#include "comgdpar.cdk"
#include "comcst.cdk"
#include "cominterp.cdk"
#include "comct0.cdk"
#include "comfilt.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgemla.cdk"
#include "comcva.cdk"
#include "comleg.cdk"
*
integer vfstluk,write_encode_hyb,fstecr
integer jvar, jcol
integer jlev,inbrlev,imode,inbitstr,ilimlvhu
integer gddst
integer ezgdef_fmem
#include "localpost.cdk"
C
integer idatyp_la,inbits_la
integer itrlgid,ip0gid,igidv_trl,iip1,iip2,ji,jj,jk
integer ip1_pak_trl,ip1_vco_trl,ip1_pak_anl,ip1_vco_anl
integer ip1_pak_inclr,ip1_pak_hy,ip1_vco_inclr,iip1_hyb_prm
integer itrlnlev,iwindnlev,igdgid,iip3
integer iip2_image,iip3_image
integer iig1,iig2,iig3,iig4,ezgprm,ikey,iwindgid,vezsint
integer iig1V,iig2V,iig3V,iig4V
integer ibrpstamp,inpak_inc
!
integer k,koutmpg
integer ig1tic,ig2tic,ig3tic,ig4tic
integer ig1in,ig2in,ig3in
integer iip1s_inclr(jpnflev)
integer ig1in_u,ig2in_u,ig3in_u
integer ig1in_v,ig2in_v,ig3in_v
!
real*8 zmin,zmax,zdlon,zwork
real*8 zptophr, zprefhr,zrcoefhr
real*8 zlowvar(mni_in,mnj_in)
!
real zptop4, zpref4,zrcoef4,zdummy
real ax(mni_in),ay(mnj_in)
real ax_u(mni_in),ay_v(mnj_in)
real zxlon1_4,zxlat1_4,zxlon2_4,zxlat2_4
!
character*1 cltypinc,cltypanl
character*2 clvar
character*3 clname
character*3 clnomvar_image
character*3 clnomvar_3
LOGICAL llimplemented
data cltypinc,cltypanl /'R','A'/
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting varoutlow",//)')
!
idatyp_la = 5 ! can be used for other grd_typ also
inbits_la = -32 ! can be used for other grd_typ also
cetikinc='ANINCLOW'
!
if(l4dvar) then
ibrpstamp=nstamplist(1)
else
ibrpstamp=nbrpstamp
endif
!
!*2 Grid properties
! ***************
!
zxlon1_4 = grd_xlon1
zxlat1_4 = grd_xlat1
zxlon2_4 = grd_xlon2
zxlat2_4 = grd_xlat2
!
do ji=1,mni_in
ax(ji) = grd_x_8(ji)
enddo
!
do ji=1,mni_in-1
ax_u(ji) = grd_u_x_8(ji)
enddo
!
if(grd_typ.eq.'LU') then ! to be removed once done properly
do ji=1,mni_in-1
ax_u(ji) = ax(ji)
enddo
endif
!
do jj=1,mnj_in
ay(jj) = grd_y_8(jj)
enddo
!
do jj=1,mnj_in-1
ay_v(jj) = grd_v_y_8(jj)
enddo
!
if(grd_typ.eq.'LU') then ! to be removed once done properly
do jj=1,mnj_in-1
ay_v(jj) = ay(jj)
enddo
endif
!
call cxgaig('E',ig1tic,ig2tic,ig3tic,ig4tic,
& zxlat1_4,zxlon1_4,zxlat2_4,zxlon2_4)
!
call cigaxg('E', zxlat1_4, zxlon1_4, zxlat2_4, zxlon2_4,
& ig1tic,ig2tic,ig3tic,ig4tic)
!
ngid_in = ezgdef_fmem(mni_in,mnj_in,'Z','E',ig1tic, ig2tic,ig3tic,ig4tic,
& ax,ay)
ngidu_in = ezgdef_fmem(mni_in-1,mnj_in,'Z','E',ig1tic, ig2tic,ig3tic,ig4tic,
& ax_u,ay)
ngidv_in = ezgdef_fmem(mni_in,mnj_in-1,'Z','E',ig1tic, ig2tic,ig3tic,ig4tic,
& ax,ay_v)
!
! Set ip1,ip2,ip3 of positional parameters (= ig1,ig2,ig3 of scalar fields)
!
call ipig(ig1in,ig2in,ig3in,
& grd_dx,grd_dy,mni_in,mnj_in,mni_in,mnj_in,
& grd_rot_8,grd_roule)
ig3in = 0
!
ig2in_u=ig2in+1
ig2in_v=ig2in+2
!
if(ig1in.lt.0) then
write(nulout,*) 'varoutlow: ig1in = ',ig1in
call abort3d(nulout,'varoutlow: ig1in.le.0')
endif
if(ig2in.lt.0) then
write(nulout,*) 'varoutlow: ig2in = ',ig2in
call abort3d(nulout,'varoutlow: ig2in.le.0')
endif
if(ig3in.lt.0) then
write(nulout,*) 'varoutlow: ig3in = ',ig3in
call abort3d(nulout,'varoutlow: ig3in.le.0')
endif
!
! Scalar grid
! -----------
!
! Write >>:
cltypvar = 'X'
clnomvar = '>>'
clgrtyp = 'E'
!
ierr = vfstecr(grd_x_8,zwork,inbits_la,nulinclr,ibrpstamp,
& ideet,inpas,mni_in,1,1,ig1in,ig2in,ig3in,cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1tic,ig2tic,ig3tic,ig4tic
& ,ndtinc,.true.)
!
if(ierr.lt.0) then
call abort3d(nulout,'varoutlow: >> for Scalar grid: ierr < 0')
endif
!
! Write ^^
cltypvar = 'X'
clnomvar = '^^'
clgrtyp = 'E'
ierr = vfstecr(grd_y_8,zwork,inbits_la,nulinclr,ibrpstamp,
& ideet,inpas,1,mnj_in,1,ig1in,ig2in,ig3in,cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1tic,ig2tic,ig3tic,ig4tic
& ,ndtinc,.true.)
!
if(ierr.lt.0) then
call abort3d(nulout,'varoutlow: ^^ for Scalar grid: ierr < 0')
endif
!
! U grid
! ------
!
! Write >>:
cltypvar = 'X'
clnomvar = '>>'
clgrtyp = 'E'
ierr = vfstecr(grd_u_x_8,zwork,inbits_la,nulinclr,ibrpstamp,
& ideet,inpas,mni_in,1,1,ig1in,ig2in_u,ig3in,cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1tic,ig2tic,ig3tic,ig4tic
& ,ndtinc,.true.)
!
if(ierr.lt.0) then
call abort3d(nulout,'varoutlow: >> for UU grid: ierr < 0')
endif
!
! Write ^^
cltypvar = 'X'
clnomvar = '^^'
clgrtyp = 'E'
ierr = vfstecr(grd_y_8,zwork,inbits_la,nulinclr,ibrpstamp,
& ideet,inpas,1,mnj_in,1,ig1in,ig2in_u,ig3in,cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1tic,ig2tic,ig3tic,ig4tic
& ,ndtinc,.true.)
!
if(ierr.lt.0) then
call abort3d(nulout,'varoutlow: ^^ for UU grid: ierr < 0')
endif
!
! V grid
! ------
!
! Write >>:
cltypvar = 'X'
clnomvar = '>>'
clgrtyp = 'E'
ierr = vfstecr(grd_x_8,zwork,inbits_la,nulinclr,ibrpstamp,
& ideet,inpas,mni_in,1,1,ig1in,ig2in_v,ig3in,cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1tic,ig2tic,ig3tic,ig4tic
& ,ndtinc,.true.)
!
if(ierr.lt.0) then
call abort3d(nulout,'varoutlow: ^^ for VV grid: ierr < 0')
endif
!
! Write ^^
cltypvar = 'X'
clnomvar = '^^'
clgrtyp = 'E'
ierr = vfstecr(grd_y_8,zwork,inbits_la,nulinclr,ibrpstamp,
& ideet,inpas,1,mnj_in-1,1,ig1in,ig2in_v,ig3in,cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1tic,ig2tic,ig3tic,ig4tic
& ,ndtinc,.true.)
!
if(ierr.lt.0) then
call abort3d(nulout,'varoutlow: ^^ for VV grid: ierr < 0')
endif
!
nip2 = 0
Niter=0
clgrtyp='Z'
!
do jvar = 1,nppcvar
do jlev = 1,mdimppcvar(jvar)
call gdout2(cppcvar(jvar),zlowvar,mni_in,mnj_in
& ,jlev,llimplemented,IIP1S_INCLR(jlev))
!
! write(nulout,*) 'varoutlow: inbits_la =',inbits_la
! write(nulout,*) 'varoutlow: nulinclr =',nulinclr
! write(nulout,*) 'varoutlow: ibrpstamp =',ibrpstamp
! write(nulout,*) 'varoutlow: ideet =',ideet
! write(nulout,*) 'varoutlow: inpas =',inpas
! write(nulout,*) 'varoutlow: mni_in =',mni_in
! write(nulout,*) 'varoutlow: mnj_in =',mnj_in
! write(nulout,*) 'varoutlow: jlev =',jlev
! write(nulout,*) 'varoutlow: iip1s_inclr(jlev) =',iip1s_inclr(jlev)
! write(nulout,*) 'varoutlow: nip2 =',nip2
! write(nulout,*) 'varoutlow: niter =',niter
! write(nulout,*) 'varoutlow: cltypinc =',cltypinc
! write(nulout,*) 'varoutlow: jvar =',jvar
! write(nulout,*) 'varoutlow: cppcvar(jvar) =',cppcvar(jvar)
! write(nulout,*) 'varoutlow: cetikinc =',cetikinc
! write(nulout,*) 'varoutlow: clgrtyp =',clgrtyp
! write(nulout,*) 'varoutlow: ig1in =',ig1in
! write(nulout,*) 'varoutlow: ig2in =',ig2in
! write(nulout,*) 'varoutlow: ig3in =',ig3in
! write(nulout,*) 'varoutlow: idatyp_la =',idatyp_la
!
! if(cppcvar(jvar).eq.'P0') then
! zlowvar(:,:) = 1010.e3
! cetikinc = 'CST1010'
! endif
IERR = VFSTECR(zlowvar,zwork,inbits_la
& ,nulinclr,ibrpstamp,ideet,inpas,mni_in,mnj_in,1,iip1s_inclr(jlev)
& ,nip2,niter,cltypinc,cppcvar(jvar),cetikinc,clgrtyp,ig1in
& ,ig2in,ig3in,0,idatyp_la,.true.)
!stag cetikinc='ANINCLOW'
!
if(ierr.lt.0) then
write(nulout,*) 'varoutlow: writing field ',cppcvar(jvar)
call abort3d(nulout,'varoutlow: ierr < 0')
endif
enddo
enddo
!
write(nulout,*) 'END of varoutlow'
!
RETURN
END