!-------------------------------------- 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 sugrdlam2 1,6
#if defined (DOC)
!
!**** sugrdlam2 - Defines a 2nd embedded computational grid within one generated by sugrdlam.ftn
!
*Author : L. Fillion ARMA/EC 27 Apr 2009
*Revision:
*: L. Fillion ARMA/EC May 2010 - Flag if grids 1 and 2 are identical so as to avoid interpolations etc.
!
#endif
!
IMPLICIT NONE
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comlunla.cdk"
#include "comcst.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgrd2.cdk"
#include "comgemla.cdk"
#include "comgemla2.cdk"
#include "comgembgh.cdk"
#include "comgdpar.cdk"
!
logical llF_stagger_L,llF_print_L,llF_gauss_L
integer Imargin,iNX,iF_nxla,IF_nimax
integer iNY,iF_nyla,iF_njmax
integer ierr,ji,jj,j1,j2
integer vstretch_axis2
integer igdid,iunsrc
!
integer fstfrm, fnom, fstouv, fstprm
integer gdgaxes,ezqkdef,ezgdef_fmem,gdxyfll
integer tictacig1, tictacig2, tictacig3
real zlat4,zlon4,zx,zy
real zxlon1_4,zxlat1_4,zxlon2_4,zxlat2_4
real ZF_x(nila2),ZF_y(njla2)
real zax(nila2),zay(njla2)
real zF_dxla,zF_xbeg,zF_xend,ZF_amp,zF_dxmax
real zF_dyla,zF_ybeg,zF_yend,zF_dymax
!
real*8 a_8,b_8,c_8,d_8,xyz1_8(3),xyz2_8(3)
real*8 zrot_t(3,3),zunit(3,3)
real*8 zlat,zdlon,zdlat
real*8 ZF_x_8(nila2)
real*8 ZF_y_8(njla2)
real*8 zdx(nila2,njla2), zdy(nila2,njla2)
!
!!
WRITE(nulout,FMT='(/,'' sugrdlam2- LAM Embedded Grid definition'')')
!
cgrtypa = 'Z'
!
! 1. Build (lon,lat) of analysis grid (radians) and
! Build (lon,lat) of analysis grid (degrees) as in GEM
! ----------------------------------------------------
!
! X-Direction
!
write(nulout,*) 'sugrdlam2: X-DIRECTION **************'
zF_dxla = grd_dx2 ! to avoid i/o in vstretch_axis2
zF_xbeg = grd_x02
zF_xend = grd_xl2
iNX = nila2
iF_nxla = nila2
llF_stagger_L = .false.
llF_print_L = .true.
zF_dxmax = grd_dx2
llF_gauss_L = .false.
!
write(nulout,*) 'sugrdlam2: zF_dxla=',zF_dxla
write(nulout,*) 'sugrdlam2: zF_xbeg=',zF_xbeg
write(nulout,*) 'sugrdlam2: zF_xend=',zF_xend
write(nulout,*) 'sugrdlam2: iNX=',iNX
write(nulout,*) 'sugrdlam2: iF_nxla=',iF_nxla
write(nulout,*) 'sugrdlam2: zF_dxmax=',zF_dxmax
!
ierr=vstretch_axis2(ZF_x_8, zF_dxla, zF_xbeg, zF_xend, Imargin, iNX,
& iF_nxla, ZF_amp, llF_stagger_L, llF_print_L, zF_dxmax,
& IF_nimax, llF_gauss_L)
do ji=1,nila2
! write(nulout,*) 'sugrdlam: ji,ZF_x_8(ji)=',ji,ZF_x_8(ji)
grd_x_82(ji)=ZF_x_8(ji) ! will be usefull when writing on RPN standard files.
enddo
do jj=1,njla2
do ji=1,nila2
rlon_an2(ji,jj)=ZF_x_8(ji)*rdeg2rad
enddo
enddo
!
! Y-Direction
!
write(nulout,*) 'sugrdlam: Y-DIRECTION **************'
zF_dyla = grd_dy2 ! to avoid i/o in vstretch_axis2
zF_ybeg = grd_y02
zF_yend = grd_yl2
iNY = njla2
iF_nyla = njla2
llF_stagger_L = .false.
llF_print_L = .true.
zF_dymax = grd_dy2
llF_gauss_L = .false.
!
ierr=vstretch_axis2(ZF_y_8, zF_dyla, zF_ybeg, zF_yend, Imargin, iNY,
& iF_nyla, ZF_amp, llF_stagger_L, llF_print_L, zF_dymax,
& IF_njmax, llF_gauss_L)
do jj=1,njla2
grd_y_82(jj)=ZF_y_8(jj) ! will be usefull when writing on RPN standard files.
enddo
do jj=1,njla2
do ji=1,nila2
rlat_an2(ji,jj)=ZF_y_8(jj)*rdeg2rad
enddo
enddo
!
! 1.1 Set resolution arrays ( >> & ^^ RPN file positional records)
! -------------------------------------------------------------
!
do ji=1,nila2
! write(nulout,*) 'sugrdlam: ji,grd_x_82(ji)=',ji,grd_x_82(ji)
enddo
!
do jj=1,njla2
! write(nulout,*) 'sugrdlam: jj,grd_y_82(jj)=',jj,grd_y_82(jj)
enddo
!
zdlon= grd_dx2*rdeg2rad
zdlat= grd_dy2*rdeg2rad
!
do jj= -4,njla2+4
do ji= -4,nila2+4
rdlon_an2(ji,jj) = zdlon
rdlat_an2(ji,jj) = zdlat
if(rdlon_an2(ji,jj).le.0.) then
write(nulout,*) 'sugrdlam2: ji,jj = ',ji,jj
call abort3d(nulout,'sugrdlam2: rdlon_an2(ji,jj).le.0.')
endif
if(rdlat_an2(ji,jj).le.0.) then
write(nulout,*) 'sugrdlam2: ji,jj = ',ji,jj
call abort3d(nulout,'sugrdlam2: rdlat_an2(ji,jj).le.0.')
endif
enddo
enddo
!
! West
!
do jj= -4, njla2+4
zlat = rlat_an2(1,jj)+(jj-1)*grd_dy2*rdeg2rad
do ji= -4, 0
rlat_an2(ji,jj)=zlat
rlon_an2(ji,jj)=rlon_an2(1,1)+(ji-1)*grd_dx2*rdeg2rad
enddo
enddo
!
! East
!
do jj= -4, njla2+4
zlat = rlat_an2(1,jj)+(jj-1)*grd_dy2*rdeg2rad
do ji= 1,4
rlat_an2(nila2+ji,jj)=zlat
rlon_an2(nila2+ji,jj)=rlon_an2(nila2,1)+ji*grd_dx2*rdeg2rad
enddo
enddo
!
! North on (1,..nila2) interval
!
do jj= 1,4
zlat = rlat_an2(1,njla2)+jj*grd_dy2*rdeg2rad
do ji= 1,nila2
rlat_an2(ji,njla2+jj)=zlat
rlon_an2(ji,njla2+jj)=rlon_an2(ji,njla2)
enddo
enddo
!
! South on (1,..nila2) interval
!
do jj= -4,0
zlat = rlat_an2(1,1)+(jj-1)*grd_dy2*rdeg2rad
do ji= 1,nila2
rlat_an2(ji,jj)=zlat
rlon_an2(ji,jj)=rlon_an2(ji,1)
enddo
enddo
!
do ji=1,nila2
zax(ji)=ZF_x_8(ji)
enddo
do jj=1,njla2
zay(jj)=ZF_y_8(jj)
enddo
!
! 2. Set extended file parameters
! ----------------------------
!
zxlon1_4 = grd_xlon12
zxlat1_4 = grd_xlat12
zxlon2_4 = grd_xlon22
zxlat2_4 = grd_xlat22
!
call cxgaig('E',mig1tic2,mig2tic2,mig3tic2,mig4tic2,
& zxlat1_4,zxlon1_4,zxlat2_4,zxlon2_4)
!
write(nulout,*) 'sugrdlam2: '
write(nulout,*) 'sugrdlam2: mig1tic2 = ',mig1tic2
write(nulout,*) 'sugrdlam2: mig2tic2 = ',mig2tic2
write(nulout,*) 'sugrdlam2: mig3tic2 = ',mig3tic2
write(nulout,*) 'sugrdlam2: mig4tic2 = ',mig4tic2
write(nulout,*) 'sugrdlam2: '
!
ngid_an2= ezgdef_fmem(nila2,njla2,'Z','E',mig1tic2,
& mig2tic2,mig3tic2,mig4tic2,zax,zay) ! mig2tic2 etc already built by sugeom...
!
! Set ip1,ip2,ip3 of positional parameters (= ig1,ig2,ig3 of extended fields)
!
write(nulout,*) 'sugrdlam2: grd_ni2,grd_nj2 = ',grd_ni2,grd_nj2
!
call ipig(mig1flda2,mig2flda2,mig3flda2,
& grd_dx2,grd_dy2,grd_nila2,grd_njla2,grd_ni2,grd_nj2,
& grd_rot_82, grd_roule2)
!
write(nulout,*) 'sugrdlam2: mig1flda2,mig2flda2,mig3flda2',
& mig1flda2,mig2flda2,mig3flda2
!
! 3. Set non-extended inner file parameters
! (i.e. the embedded LAM forecast grid extension but with current spatial resolution)
! --------------------------------------------------------------------------
!
! Scalar Grid:
!
ngid_in2= ezgdef_fmem(mni_in2,mnj_in2,'Z','E',
& mig1tic2, mig2tic2,mig3tic2,mig4tic2,zax,zay) ! tic tac same as extended grid
!
! Set ip1,ip2,ip3 of positional parameters (= ig1,ig2,ig3 of scalar fields)
!
call ipig(mig1in2,mig2in2,mig3in2,
& grd_dx2,grd_dy2,mni_in2,mnj_in2,mni_in2,mnj_in2,
& grd_rot_82, grd_roule2)
!
write(nulout,*) 'sugrdlam2: mni_in2,mnj_in2=',mni_in2,mnj_in2
write(nulout,*) 'sugrdlam2: mig1in2,mig2in2,mig3in2 = ',mig1in2,mig2in2,mig3in2
!
! U Grid:
! ------
ngidu_in2= ezgdef_fmem(mni_in2-1,mnj_in2,'Z','E',
& mig1tic2, mig2tic2,mig3tic2,mig4tic2,zax,zay) ! tic tac same as extended grid
!
! Set ip1,ip2,ip3 of positional parameters (= ig1,ig2,ig3 of scalar fields)
!
! call ipig(mig1in_u,mig2in_u,mig3in_u,
! & grd_dx,grd_dy,mni_in-1,mnj_in,mni_in-1,mnj_in,
! & grd_rot_8, grd_roule)
!
! mig1in_u = mig1in
! mig2in_u = mig2in+1
! mig3in_u = mig3in
! write(nulout,*) 'sugrdlam: mig1in_u,mig2in_u,mig3in_u = ',mig1in_u,mig2in_u,mig3in_u
!
! V Grid:
! ------
ngidv_in2= ezgdef_fmem(mni_in,mnj_in-1,'Z','E',
& mig1tic2, mig2tic2,mig3tic2,mig4tic2,zax,zay) ! tic tac same as extended grid
!
! Set ip1,ip2,ip3 of positional parameters (= ig1,ig2,ig3 of scalar fields)
!
! call ipig(mig1in_v,mig2in_v,mig3in_v,
! & grd_dx,grd_dy,mni_in,mnj_in-1,mni_in,mnj_in-1,
! & grd_rot_8, grd_roule)
!
! mig1in_v = mig1in
! mig2in_v = mig2in+2
! mig3in_v = mig3in
! write(nulout,*) 'sugrdlam: mig1in_v,mig2in_v,mig3in_v = ',mig1in_v,mig2in_v,mig3in_v
!
! 4. Set grid spacing dxlam,dylam
! ----------------------------
!
! call sudxdy_lu(ngid_an)
!
! 5. Ensure namelist parameters mextendx, mextendy are not zero
! since in that case no bi-periodicization is done which means
! the Mesovar cant operate since it relies on Bi-periodic assumptions
! which is basically required for the basic-state fields prepared
! on the analysis grid by subasic_gd.ftn. The latter fields are necessary
! for TL operators used in the definition of the control variables and
! possibly also for observation operators.
! ----------------------------------------------------------
!
if(mextendx2.eq.0.) then
write(nulout,*)'sugrdlam2: WARNING !!!!!!!!!!! mextendx2 = 0'
!cluc call abort3d(nulout,'sugrdlam2: mextendx2 = 0')
else if(mextendy2.eq.0.) then
write(nulout,*)'sugrdlam2: WARNING !!!!!!!!!!! mextendy2 = 0'
!cluc call abort3d(nulout,'sugrdlam2: mextendy2 = 0')
endif
!
! 6. Flag if grids 1 and 2 are identical so as to avoid interpolations etc.
! ---------------------------------------------------------------------------
!
if(nila2.eq.nila) then
if(njla2.eq.njla) then
if(mig1tic2.eq.mig1tic) then
if(mig2tic2.eq.mig2tic) then
if(mig3tic2.eq.mig3tic) then
if(mig4tic2.eq.mig4tic) then
lsame_grid12 = .true.
endif
endif
endif
endif
endif
endif
!
1001 format (/1x,'COMPUTE MODEL GRID (S/R E_GRIDGEF)',
$ /1x,34('='))
1005 format (/1x,'AJUSTED RPN/FST grid descriptors Grd_xlat1,',
$ 'Grd_xlon1,Grd_xlat2,Grd_xlon2:'
$ /4f12.6/1x,73('='))
1020 FORMAT (/1X,'FINAL HORIZONTAL GRID CONFIGURATION:'
$ /1X,' nila2=',I4,' FROM Grd_x0=',F9.3,' TO Grd_xl=',F9.3,' DEGREES'
$ /1X,' njla2=',I4,' FROM Grd_y0=',F9.3,' TO Grd_yl=',F9.3,' DEGREES'
$ /1X,' CENTRAL POINT OF THE GRID Grd_xlon1,Grd_xlat1=',
$ 2F9.3,' DEGREES'/1x,74('='))
1025 FORMAT(/1X,'THE CONSTANT RESOLUTION AREA HAS:'
$ /1X,' nila2=',I4,' OF GRID-LENGTH=',F9.4,' DEGREES'
$ 1x,'(',i4,',',i4,' )',
$ /1X,' njla2=',I4,' OF GRID-LENGTH=',F9.4,' DEGREES'
$ 1x,'(',i4,',',i4,' )',
$ /1x,56('='))
1030 FORMAT(/1X,'THE VARIABLE RESOLUTION AREA HAS:'
$ /1X,i3,' POINTS TO THE WEST AND ',i3,' POINTS TO THE EAST'
$ /2x,'WITH STRETCHING FACTOR=',F8.4,
$ ' AND MINIMUM RESOLUTION=',F8.4,
$ /1X,i3,' POINTS ON THE SOUTH AND ',i3,' POINTS ON THE NORTH'
$ /2x,'WITH STRETCHING FACTOR=',F8.4,
$ ' AND MINIMUM RESOLUTION=',F8.4)
1031 FORMAT(1x,64('='))
1035 FORMAT(2x,'RESOLUTION IS LIMITED TO ',F9.4,1x,
$ 'DEGREES OVER LAST',I4,' DELTA-',a1,' AT ',
$ 'EACH ENDS OF THE ',a1,' AXIS.')
*
*----------------------------------------------------------------------
*
return
end