!-------------------------------------- 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 subgpar 1,3
use modfgat
, only : nstamplist
use mod4dv, only : l4dvar
!
IMPLICIT NONE
#if defined (DOC)
*
*s/r subgpar :
* Author C. Page (UQAM) May 2003.
!
*Revision: L. Fillion - 26 Oct 04 - MSC/CAN - Rename sugetgd to subgpar and pursue work.
* L. Fillion ARMA/MSC May 2006: Mesovar upgrade to v10_0_0.
* L. Fillion ARMA/EC 22 May 2008: Upgrade lam4d to v_10_1_1
*
*-----------------------------------------------------------------------
*
* Purpose: to get grid parameters grtyp, ig1, ig2 and ig3 from
* trial field used to select needed obs for Limited-Area
* mode in brpacma subroutine. Store into comgdpar.
* Also computes grid point spacing in meters needed for
* Limited-Area : cormdl
*
*-----------------------------------------------------------------------
*
* Argument:
*
#endif
*
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comgdpar.cdk"
#include "comdimo.cdk"
#include "namgdpar.cdk"
#include "compdg.cdk"
#include "comgem.cdk"
!#include "comgemla.cdk"
#include "comgembgh.cdk"
#include "comgrd_param.cdk"
#include "cvcord.cdk"
#include "maxlev.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 ip1kind,ip1style
integer iig1,iig2,iig3
integer iip1,iip2,iip3,itrlnlev,ip1_pak_trl,ip1_vco_trl,itrlgid,ibrpstamp
integer iip1s_trl(jpnflev)
integer ikeys(levmax)
character*2 cnom
character*8 cetiket,cletiket
character*1 clgr, ctyp, cltypvar
*
integer idatet,igdid
integer fstinf, fstprm, fstinl
real*8 zfld(ni+nj)
real*8 zlatbeg,zlonbeg,zdlon,zdlat,zlat
!
!!
write(nulout,*) ''
write(nulout,*) '******************************************************** '
write(nulout,'(10x,"SUBGPAR: LOOKING FOR PARAMETERS IN 1ST TRIAL FIELD")')
write(nulout,*) '******************************************************** '
write(nulout,*) ''
!
cletiket = ' '
ikey = fstinf(ninmpg(1),ini,inj,ink,-1,cletiket,
& -1,-1,-1,' ','UU')
write(nulout,*) 'subgpar: ini,inj,ink=',ini,inj,ink
if (ikey.lt.0) then
ikey = fstinf(ninmpg(1),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)
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
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)
!
! Transfer trial field grid parameters to COMGDPAR
!
ndeett = idt
npast = ipas
nip2t = ip2
nig1t = ig1
nig2t = ig2
nig3t = ig3
nig4t = ig4
cgrtypt = clgr
nit = ini
njt = inj
write(nulout,*) 'subgpar: nit,njt = ',nit,njt
write(nulout,*) 'subgpar: nig1t,nig2t,nig3t,nig4t=',nig1t,nig2t,nig3t,nig4t
!
! get total number of vertical levels = nkt in the 1st trial file
!
! write(nulout,*) 'subgpar: looking nb of levels at date ',idatet
! ierr = fstinl(ninmpg(1),INI,INJ,INK, idatet, ' ', -1, -1, -1,
! & ' ','UU',IKEYS, NKT, levmax)
!
! nkt = ink
! write(nulout,*) 'subgpar: NB LEV in 1st TRIAL FILE: nkt set to ',nkt
!
! get Rotation parameters nig1rbg,nig2rbg,nig3rbg,nig4rbg
!
cletiket = ' '
cltypvar = ' '
ikey = fstinf(ninmpg(1), iNI, iNJ, iNK, -1,cletiket, -1
& ,-1,-1,cltypvar,'>>')
!
ierr = fstprm(ikey,idatet,idt,ipas,ini,inj,ink,ibits,idtyp,
& ip1,ip2,ip3,ctyp,cnom,cetiket,clgr,
& nig1rbg,nig2rbg,nig3rbg,nig4rbg,
& iswa,ilng,idltf,iubc,ix1,ix2,ix3)
!
write(nulout,*) 'subgpar: nig1rbg,nig2rbg,nig3rbg,nig4rbg=',
& nig1rbg,nig2rbg,nig3rbg,nig4rbg
!
! also useful are the real form of the rotation parameters
! i.e. rlatrbg, rlon1bg, rlat2bg, rlon2bg
!
call cigaxg('E', rlat1bg, rlon1bg, rlat2bg, rlon2bg,
& nig1rbg,nig2rbg,nig3rbg,nig4rbg)
!
write(nulout,*) 'subgpar: rlat1bg, rlon1bg, rlat2bg, rlon2bg=',
& rlat1bg, rlon1bg, rlat2bg, rlon2bg
!
return
end