!-------------------------------------- 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 --------------------------------------
***s/r e_dateo - to obtain date from either the given analysis (GLB run)
* or from the namelist key Mod_runstrt_S (LAM run)
*
subroutine e_dateo 1,1
implicit none
*
#include "e_grids.cdk"
#include "modconst.cdk"
#include "pilot.cdk"
#include "filename.cdk"
#include "path.cdk"
*
logical get_date
external get_date
* ---------------------------------------------------------------------
*
if (LAM) then
*
call e_infiles
*
if ( (Mod_runstrt_S.eq.'@#$%') .and.
$ (Pil_sfc2d_L .or. Pil_3df_L) ) then
if ( .not. get_date (Mod_runstrt_S,
$ trim(pilot_dir )//'/'//trim(pilot_f(1))) ) stop
endif
*
else
*
if (.not.
$ get_date (Mod_runstrt_S,trim(Path_input_S)//'/ANALYSIS')) stop
Pil_jobstrt_S = Mod_runstrt_S
Pil_jobend_S = Mod_runstrt_S
*
endif
*
* ---------------------------------------------------------------------
*
return
end
*
logical function get_date (datpdf,filename),3
implicit none
*
character* (*) datpdf,filename
*
integer fnom, fstouv, fstinf, fstprm, fstfrm, fclos, wkoffit
external fnom, fstouv, fstinf, fstprm, fstfrm, fclos, wkoffit
*
character*1 typ, grd
character*4 var
character*12 lab
character*16 datev_S
integer key,ni1,nj1,nk1,datestp,unf,
$ det, ipas, p1, p2, p3, g1, g2, g3, g4, bit,
$ dty, swa, lng, dlf, ubc, ex1, ex2, ex3, kind, err
real*8 one,sid,rsid,dayfrac
parameter (one=1.0d0, sid=86400.0d0, rsid=one/sid)
*
* ---------------------------------------------------------------------
*
datpdf = '@#$%'
get_date = .false.
write (6,1001) trim(filename)
*
unf = 0
if (wkoffit(filename) .gt. -1 ) then
if (fnom (unf,filename,'RND+OLD',0).lt.0) then
write (6,2001) trim(filename)
stop
endif
if (fstouv(unf ,'RND').lt.0) then
write (6,2002) trim(filename)
stop
endif
*
key = fstinf (unf, ni1,nj1,nk1,-1,' ',-1,-1,-1,' ','UU' )
if ( key .lt. 0 ) then
key = fstinf (unf, ni1,nj1,nk1,-1,' ',-1,-1,-1,' ','UT1')
if ( key .lt. 0 ) then
write(6,*) 'No U-component of the wind in analysis'
call e_arret('e_date0')
endif
endif
*
err = fstprm ( key, datestp, det, ipas, ni1, nj1, nk1,bit,dty,
$ p1,p2,p3, typ, var, lab, grd, g1,g2,g3,g4,
$ swa,lng, dlf, ubc, ex1, ex2, ex3 )
*
err = fstfrm (unf)
err = fclos (unf)
*
call datf2p ( datpdf, datestp )
dayfrac = dble(det*ipas)*rsid
call incdatsd ( datev_S, datpdf, dayfrac )
datpdf = datev_S
endif
*
if ( datpdf == '@#$%' ) then
write (6,1002)
else
write (6,1003) trim(datpdf)
get_date = .true.
endif
*
1001 format (/' ESTABLISHING VALIDITY TIME OF U-component of the wind'
$ /' in file: ',a)
1002 format (/' UNABLE TO DETERMINE INITIAL CONDITION VALIDITY TIME',
$ /' -----ABORT ----- in e_dateo'/)
1003 format (/' INITIAL CONDITION VALIDITY TIME= ',a)
2001 format (/' ABORT in e_dateo: Trying to open file ',a)
2002 format (/' ABORT in e_dateo: File ',a,' not RND')
*
* ---------------------------------------------------------------------
*
return
end