!-------------------------------------- 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 getfldprm2(kip1s,kip2,kip3,knlev,cdetiket,cdtypvar,kgid 14,1
& ,cdvar,kstampv,knmaxlev,kinmpg,kulout,kip1style,kip1kind,
& ktrials,koutmpg)
implicit none
c
integer kulout,kstampv,knmaxlev,knlev,kgid
integer kip1s(knmaxlev),kip1style,kip1kind,kip2,kip3
integer ktrials, koutmpg
integer kinmpg(ktrials)
character*(*) cdtypvar
character*(*) cdvar
character*(*) cdetiket
#if defined (DOC)
*
***s/r getfldprm2
*
*
* Author : S. Pellerin ARMA/AES Nov. 1999
*
* Revision :
* J. Halle *CMDA/AES dec 2000
* - adapt to TOVS level 1b.
* S. Pellerin *ARMA/SMC Nov. 2001
* - clean up write statements
* C. Charette *ARMA/SMC Sept 2004
* - Conversion to hybrid vertical coordinate
* - Added arguments kip1style,kip1kind
* Bin He *ARMA/SMC* Jan.2008
* - added reading multiple trial files.
* S. Pellerin, ARMA, August 2008
* - Introduction of version 2
* L. Fillion - ARMA/EC - 20 May 2008 - Update to v_10_1_1.
* L. Fillion - ARMA/EC - 28 May 2008
* - Change declaration/allocation of ikeys array. -qcheck compiling option OK on IBM.
* L. Fillion - ARMA/EC - 9 Jan 2009 - Upgrade to v_10_1_2 of 3dvar.
* L. Fillion - ARMA/EC - 9 FEB 2010 - Cosmetic.
*
** Purpose: Get 3D grid parameters for a specific trial field
* and check for consitancies between grid parameters
* of the levels.
*
*Arguments
*
* Input:
* cdvar : variable name to get the vertical levels from
* kstampv : valid date time stamp of the variable
* knmaxlev: maximum number of levels
* kinmpg : file unit of trial field
* kulout : standard output
* ktrials : number of trial files.
*
* Output:
* kip1s(knmaxlev) : list of ip1s of variable cdvar
* kip2 : ip2 for variable cdvar
* kip3 : ip3 for variable cdvar
* knlev : number of levels of variable cdvar
* cdetiket : etiket of field cdvar
* cdtypvar : typvar of field cdvar
* kgid : handle of the field descriptor
* kip1style : style in which ip1 is encoded (15 or 31 bits)
* kip1kind : kind of vertical coord encoded in ip1
* koutmpg : the unit which contains the selected records.
*
#endif
integer fstinl,fstprm,ezqkdef,newdate
integer ini,inj,ink,jlev,ier
integer idateo, idateo2, idatyp, idatyp2, ideet, ideet2, idltf,
& iextra1, iextra2, iextra3, iig12, iig22,
& iig32, iig42, ilng, inbits,iig1,iig2,iig3,iig4,
& inpas,inpas2, iswa, iubc, iip2, iip3
c
integer ipmode,idate2,idate3,idatefull
integer k,ier1
real zlev
character *12 cletiket
character *4 clnomvar
character *3 clnomvar_3
character *2 cltypvar
character *1 clgrtyp2,clgrtyp,clstring
logical llflag
integer ikeys(knmaxlev)
c
knlev = 0
c
do k=1,ktrials
if(cdvar.eq.'U1') then
clnomvar_3='UT1'
ier = fstinl(kinmpg(k),INI,INJ, INK, kstampv, ' ', -1, -1, -1,
& ' ',clnomvar_3,ikeys, knlev, knmaxlev)
else if(cdvar.eq.'V1') then
clnomvar_3='VT1'
ier = fstinl(kinmpg(k),ini,inj, ink, kstampv, ' ', -1, -1, -1,
& ' ',clnomvar_3,ikeys, knlev, knmaxlev)
else
! write(kulout,*) 'getfldprm2: k = ',k
! write(kulout,*) 'getfldprm2: kinmpg(k) = ',kinmpg(k)
! write(kulout,*) 'getfldprm2: kstampv = ',kstampv
! write(kulout,*) 'getfldprm2: cdvar = ',cdvar
!
ier = fstinl(kinmpg(k),INI,INJ, INK, kstampv, ' ', -1, -1, -1,
& ' ',cdvar,IKEYS, KNLEV, knmaxlev)
!
! write(kulout,*) 'getfldprm2: INI = ',INI
! write(kulout,*) 'getfldprm2: INJ = ',INJ
! write(kulout,*) 'getfldprm2: INK = ',INK
! write(kulout,*) 'getfldprm2: IKEYS = ',IKEYS
! write(kulout,*) 'getfldprm2: KNLEV = ',KNLEV
endif
*
if(knlev > 0 ) then
ier1 = newdate(kstampv,idate2,idate3,-3)
idatefull = idate2*100 + idate3/1000000
idateo = -9999
ideet = -9999
inpas = -9999
cdetiket = '-9999999'
clgrtyp = '-'
kip2 = -9999
kip3 = -9999
cdtypvar = '-'
idatyp = -9999
iig1 = -9999
iig2 = -9999
iig3 = -9999
iig4 = -9999
llflag = .true.
koutmpg = kinmpg(k)
exit
endif
enddo !! End of loop k
c
if (knlev.gt.0) then
C if (knlev.ne.0) then
do jlev = 1, knlev
ier = fstprm(ikeys(jlev), idateo2, ideet2, inpas2, ini, inj,
& ink,inbits,idatyp2, kip1s(jlev),iip2, iip3,
& cltypvar,clnomvar,cletiket,clgrtyp2, iig12, iig22,iig32
& ,iig42,iswa,ilng,idltf,iubc,iextra1, iextra2, iextra3)
llflag = (llflag.and.(idateo.eq.idateo2.or.idateo.eq.-9999))
llflag = (llflag.and.(ideet.eq.ideet2.or.ideet.eq.-9999))
llflag = (llflag.and.(inpas.eq.inpas2.or.inpas.eq.-9999))
! llflag = (llflag.and.(cdetiket.eq.cletiket.or.cdetiket.eq.
! & '-9999999'))
llflag = (llflag.and.(clgrtyp.eq.clgrtyp2.or.clgrtyp.eq.'-'))
llflag = (llflag.and.(kip2.eq.iip2.or.kip2.eq.-9999))
llflag = (llflag.and.(kip3.eq.iip3.or.kip3.eq.-9999))
llflag = (llflag.and.(cdtypvar.eq.cltypvar.or.cdtypvar.eq.
& '-'))
llflag = (llflag.and.(idatyp.eq.idatyp2.or.idatyp.eq.-9999))
llflag = (llflag.and.(iig1.eq.iig12.or.iig1.eq.-9999))
llflag = (llflag.and.(iig2.eq.iig22.or.iig2.eq.-9999))
llflag = (llflag.and.(iig3.eq.iig32.or.iig3.eq.-9999))
llflag = (llflag.and.(iig4.eq.iig42.or.iig4.eq.-9999))
if (llflag) then
idateo = idateo2
ideet = ideet2
inpas = inpas2
cdetiket = cletiket
clgrtyp = clgrtyp2
kip2 = iip2
kip3 = iip3
cdtypvar = cltypvar
idatyp = idatyp2
iig1 = iig12
iig2 = iig22
iig3 = iig32
iig4 = iig42
else
write(kulout,*)
& '****** Unit ', kinmpg
& ,' contains mixed dateo,deet,npas,etiket,grtyp,ip2,ip3'
& ,',typvar,datyp,ig1,ig2,ig3 and/or ig4 '
& ,'for variable ',cdvar,' and datev, ',kstampv
CALL ABORT3D
(kulout,'getfldprm2')
endif
enddo
c
kgid = ezqkdef(ini,inj,clgrtyp,iig1,iig2,iig3,iig4,koutmpg)
C
C-------Determine the style in which ip1 is encoded (15bits or 31 bits)
C A value <= 32767 (2**16 -1) means that ip1 is compacted in 15 bits
C Determine the type of P which was encoded in IP1
C
if(kip1s(1) .le. 32767) then
kip1style = 3
else
kip1style = 2
endif
c
c-------Determine the type of P (see doc. of convip)
c
ipmode = -1
call CONVIP(kip1s(1),zlev,KIP1KIND,
& ipmode,clstring, .false. )
else
do k=1,ktrials
ier = fstinl(kinmpg(k),ini,inj, ink, -1, ' ', -1, -1, -1,
& ' ',cdvar,ikeys, knlev, knmaxlev)
enddo
write(kulout,*) 'Error - getfldprm2: no record found at time '
& ,idatefull,' for field ',cdvar,' but',knlev,
& ' records found in unit ',kinmpg(k)
endif
c
return
end