!-------------------------------------- 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 subggrd 2,2
! use modfgat, only : nstamplist, nobsgid, nobs, notag, nstepobs
!
IMPLICIT NONE
#if defined (DOC)
*
*s/r subggrd :
!
*Author: L. Fillion - 21 March 2005 - MSC/CAN
* L. Fillion ARMA/EC May 2006: LAM4D upgrade to v10_0_0.
* L. Fillion ARMA/EC 13 Jan 2009: LAM4D upgrade to v10_1_2.
*
*-----------------------------------------------------------------------
*
* Purpose: Set geometrical arrays related to NLM computational grid.
*
*-----------------------------------------------------------------------
*
* Argument:
*
#endif
*
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comgdpar.cdk"
#include "namgdpar.cdk"
#include "compdg.cdk"
#include "comgem.cdk"
#include "comgemla.cdk"
#include "comgembgh.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "rpnstd.cdk"
*
integer ji,jj,jk,jlev
integer ikey, ierr, iabt, igrchk, ini, inj, ink
*
integer ip2t,vfstlir,vfstluk
integer idtyp, ip1, ip2, ip3, ig1, ig2, ig3, ig4, idt, ipas
+ , ibits,iswa, ilng, idltf, iubc, ix1, ix2, ix3
integer iip2,iip3,itrlnlev
integer iig1,iig2,iig3,iflag
integer ip1kind,ip1style,itrlgid,ibrpstamp
integer k,koutmpg
integer iip1s_trl(jpnflev)
!
character*2 cnom
character*8 cetiket,cletiket
character*1 clgr, ctyp, cltypvar
*
integer ip1_pak_trl,ip1_vco_trl,ip0gid
integer k,koutmpg
integer idatet
integer fstinf, fstprm
integer ezqkdef
real*8 z2d(90,114)
real*8 zfld(nit+njt)
real*8 zlatbeg,zlonbeg,zdlon,zdlat,zlat,zsave,ztol,zcon
!
!!
write(nulout,*) 'SUBGGRD: Set arrays of the Basic-state geometry'
write(nulout,*) 'SUBGGRD: reading from unit ',ninmpg(1)
!
! call getfldprm2(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
! & ,IP0GID,clnomvar,ibrpstamp,jpnflev,ninmpg
! & ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
!
! Longitudes
cletiket = ' '
cltypvar = ' '
ikey = fstinf(ninmpg(1), INI, INJ, INK, -1,cletiket, nig1t
& ,nig2t,nig3t,cltypvar,'>>')
ikey = vfstluk(zfld, ikey, INI, INJ, INK)
!
! do ji=1,nit
! write(nulout,*) 'subggrd: ji, trial longitude = ',ji,zfld(ji)
! enddo
!
do ji=1,nit-1
zdlon=abs(zfld(ji+1)-zfld(ji))
enddo
!
zsave=0.
ztol=1.e-4
iflag = 0
do ji=1,nit-1
zdlon=abs(zfld(ji+1)-zfld(ji))*rdeg2rad
zcon=abs((zsave-zdlon)/zdlon)
zsave=zdlon
if((zcon.gt.ztol).and.(grd_typ.eq.'LU')) then
if(ji.ne.1) then
iflag = 1
endif
endif
enddo
if(iflag.eq.1) then
write(nulout,*) 'SUBGGRD: Analysis grd_typ is LU '
write(nulout,*) 'SUBGGRD: But Non-uniform Basic-State grid'
endif
!
do jj= 1,njt
do ji= 1,nit
rlon_bgh(ji,jj)=rdeg2rad*zfld(ji)
enddo
enddo
!
! Latitudes
!
cletiket = ' '
cltypvar = ' '
ikey = fstinf(ninmpg, INI, INJ, INK, -1,cletiket, nig1t
& ,nig2t,nig3t,cltypvar,'^^')
ikey = vfstluk(zfld, ikey, INI, INJ, INK)
!
! do jj=1,njt
! write(nulout,*) 'subggrd: jj, trial latitude = ',jj,zfld(jj)
! enddo
!
zsave=0.
if(iflag.eq.0) then
do jj=1,njt-1
zdlat=abs(zfld(jj+1)-zfld(jj))*rdeg2rad
zcon=abs((zsave-zdlat)/zdlat)
zsave=zdlat
if((zcon.gt.ztol).and.(grd_typ.eq.'LU')) then
if(ji.ne.1) then
iflag = 1
endif
endif
enddo
endif
!
do jj= 1,njt
do ji= 1,nit
rlat_bgh(ji,jj)=rdeg2rad*zfld(jj)
enddo
enddo
!
if(iflag.eq.1) then
write(nulout,*) 'SUBGGRD: Analysis grd_typ is LU '
write(nulout,*) 'SUBGGRD: But Non-uniform Basic-State grid'
else
write(nulout,*) 'subggrd: LON UNIFORM SPACING = ',zdlon*rrad2deg
write(nulout,*) 'subggrd: LAT UNIFORM SPACING = ',zdlat*rrad2deg
endif
!
do jj= 1,njt
do ji= 1,nit
rdlon_bgh(ji,jj) = zdlon
rdlat_bgh(ji,jj) = zdlat
enddo
enddo
c
c* Get distance between grid points in meters
c
cletiket = ' '
cltypvar = ' '
ibrpstamp= -1
!
! call getfldprm2(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
! & ,ITRLGID,'UU',ibrpstamp,jpnflev,ninmpg
! & ,nulout,ip1style,ip1kind,ntrials,koutmpg)
!
! cletiket = ' '
! ikey = fstinf(koutmpg,ini,inj,ink,-1,cletiket,
! & -1,-1,-1,' ','UU')
! write(nulout,*) 'subgpar: ini,inj,ink=',ini,inj,ink
! ierr = fstprm(ikey,idatet,idt,ipas,ini,inj,ink,ibits,idtyp,
! & ip1,ip2,ip3,ctyp,cnom,cetiket,clgr,ig1,ig2,ig3,ig4,
! & iswa,ilng,idltf,iubc,ix1,ix2,ix3)
! if (ikey.lt.0) then
! ikey = fstinf(koutmpg,ini,inj,ink,-1,' ',
! & -1,-1,-1,' ',' ')
! ierr = fstprm(ikey,idatet,idt,ipas,ini,inj,ink,ibits,idtyp,
! & ip1,ip2,ip3,ctyp,cnom,cetiket,clgr,ig1,ig2,ig3,ig4,
! & iswa,ilng,idltf,iubc,ix1,ix2,ix3)
! ierr = fstprm(ikey,idatet,idt,ipas,ini,inj,ink,ibits,idtyp,
! & ip1,ip2,ip3,ctyp,cnom,cetiket,clgr,ig1,ig2,ig3,ig4,
! & iswa,ilng,idltf,iubc,ix1,ix2,ix3)
! write(nulout,9600) 'UU', cetiket, ini, inj
! 9600 format(///,4x,'In SUGETGD: cannot find a record with ',/,
! & ' NOMVAR=',a2,' and ETIKET=',a8,' in the trial',/,
! & ' field file.',/,10x,'JOB IS ABORTED',//,
! & ' The dimensions INI,INJ found',
! & ' in the trial field file are: ',2i6 )
! call abort3d(nulout
! & ,'SUBGPAR: Problem with trial field file')
! endif
!
! nigdgid = ezqkdef(ini, inj, 'Z', ig1, ig2, ig3, ig4, ninmpg)
!
! call sudxdy(zdx,zdx,ninmpg,nit,njt)
!
! ierr=vfstlir(z2d,ninmpg,ini,inj,1,nstamplist(1)
! & ,cletiket,0,0,0,'P',cfstvar2d(1))
! write(nulout,*) 'subggrd: z2d=',z2d
!
return
end