!-------------------------------------- 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 gethybprm2(kulfst,kulout,kip2,kip3,cdetiket,kstampv 7,2
& ,pptop,ppref,prcoef,kip1_var_prm,ktrials)
implicit none
c
integer ktrials
integer kulfst(ktrials)
integer kulout,kstampv,kip2,kip3,kip1_var_prm
real pptop,ppref,prcoef
character*(*) cdetiket
#if defined (DOC)
*
***s/r gethybprm
*
*
* Author : C. Charette ARMA/AES Sep 2004
*
* Revision :
* Bin He. ARMA/MSC Apr. 2008
* -- Reading multiple trial files.
* S. Pellerin, ARMA, August 2008
* - Introduction of version 2
*
** Purpose: Set the 3 parameters required to define the vertical hybrid
* coordinate for a specific trial field.
*
* Notes : The parameters are first obtained from the field 'HY'.
* If 'HY' is not present, it then looks for the field 'PT'
* where it assumes that the trial fields are on ETA levels
* and the parameters accordingly.
* The program is aborted if both 'HY' and 'PT' are not present
*
*Arguments
*
* Input:
* kstampv : valid date time stamp of the variable
* cdetiket: etikette of trial field
* kulfst : file unit of trial field
* kulout : standard output
* kip2 : ip2 of trial field
* kip3 : ip3 of trial field
*
* Output:
* pptop : average pressure at the top (mb)
* ppref : reference pressure (mb)
* prcoef : coefficient
* kip1_var_prm: IP1 of variable from which the parameters were determined
*
#endif
integer fstinf,fstluk,fstprm,read_decode_hyb
integer ini,inj,ink,ikey,ier,iip1,jjj
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
real zpttrl(1),zdiff,zepsilon
character *12 cletiket
character *4 clnomvar
character *2 cltypvar
character *1 clgrtyp2
logical llhy,llpt,llabort
integer k,koutmpg
pointer (pxpttrl,zpttrl)
write(kulout,*) ' '
write(kulout,*) '-------- ENTERING GETHYBPRM ---------'
write(kulout,*) ' '
c
c Recherche du HY du champ d essai
c
iip1 = -1
cltypvar = ' '
llhy = .FALSE.
write(kulout,*)
& 'Reading HY on trial field file on unit ',kulfst
c
do k=1,ktrials
ikey = FSTINF(kulfst(k), INI, INJ, INK, kstampv, cdetiket,
& iip1, kip2, kip3,cltypvar,'HY')
if(ikey >= 0) then
koutmpg=kulfst(k)
exit
endif
enddo
c
c
if(ikey.lt.0) then
write(kulout,*) ' ******* WARNING ******* '
write(kulout,*) 'No HY found in ',kulfst
else
ier = fstprm(ikey, idateo2, ideet2, inpas2, ini, inj
& ,ink,inbits,idatyp2, iip1,iip2, iip3
& ,cltypvar,clnomvar,cletiket,clgrtyp2, iig12, iig22,iig32
& ,iig42,iswa,ilng,idltf,iubc,iextra1, iextra2, iextra3)
llhy = .TRUE.
c
c ----Decode vertical coordinate parameters from HY
c
ier = read_decode_hyb(koutmpg,'HY',kip2,kip3
& ,cletiket,kstampv,pptop,ppref,prcoef)
kip1_var_prm = iip1
write(kulout,*)
& ' The trial field vertical coordinate is defined from HY '
write(kulout,*)
& ' The hybride coordinate parameters are: '
write(kulout,*) ' PTOP = ',pptop, ' (read from HY)'
write(kulout,*) ' PREF = ',ppref, ' (read from HY)'
write(kulout,*) ' RCOEF= ',prcoef,' (read from HY)'
endif
c *********************************************************
c-----Look for field PT (ptop) if necessary
c
if (.not. llhy) then
llpt = .FALSE.
write(kulout,*)
& 'Reading PT on trial field file '
c
do k=1,ktrials
ikey = FSTINF(kulfst(k), INI, INJ, INK, kstampv, cdetiket
& ,iip1, kip2, kip3,cltypvar,'PT')
if(ikey >= 0) then
koutmpg=kulfst(k)
exit
endif
enddo
c
if(ikey.lt.0) then
write(kulout,*) ' ******* WARNING ******* '
write(kulout,*) 'No PT found in ',kulfst
if(.not.llhy) then
write(kulout,*) ' ******* ERROR ******* '
write(kulout,*) 'No PT and no HY found in ',kulfst
call abort3d
(kulout,'GETHYBPRM')
endif
else
ier = fstprm(ikey, idateo2, ideet2, inpas2, ini, inj
& ,ink,inbits,idatyp2, iip1,iip2, iip3
& ,cltypvar,clnomvar,cletiket,clgrtyp2, iig12, iig22,iig32
& ,iig42,iswa,ilng,idltf,iubc,iextra1, iextra2, iextra3)
c
llpt = .TRUE.
call hpalloc(pxpttrl,ini*inj,ier,0)
ikey = FSTLUK(zpttrl, ikey, INI, INJ, INK)
c
c---------Check if PT is uniform
zepsilon = 0.00001
llabort = .false.
do jjj = 1,ini*inj
zdiff = abs(zpttrl(jjj)-zpttrl(1))
if(zdiff .gt. zepsilon) llabort = .true.
enddo
if(llabort) then
write(kulout,*) ' ******* ERROR ******* '
write(kulout,*) 'PT (ptop) is NOT UNIFORM'
call abort3d(kulout,'GETHYBPRM')
endif
c
pptop = zpttrl(1)
ppref = 800.0
prcoef = 1.0
kip1_var_prm = iip1
write(kulout,*)
& ' Field PT (ptop) is found and is uniform '
write(kulout,*)
& ' The coordinate is assumed to be ETA which is'
& ,' a special case of the hybrid coordinate with r=1 '
write(kulout,*)
& ' The hybride coordinate parameters are set to:'
write(kulout,*) ' PTOP = ',pptop,' MB',' (from PT(1,1) field)'
write(kulout,*)
& ' PREF = ',ppref,' MB',' (any non-zero value is ok)'
write(kulout,*) ' RCOEF= ',prcoef,' (should be one)'
call hpdeallc(pxpttrl,ier,1)
endif
endif
c
write(kulout,*) ' '
write(kulout,*) '-------- LEAVING GETHYBPRM ---------'
write(kulout,*) ' '
return
end