!--------------------------------------- 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 --------------------------------------
MODULE timeCoord_mod 13,2
use mpivar_mod
use obsSpaceData_mod
implicit none
save
private
! public variables
public :: tim_dstepobs,tim_dstepobsinc
public :: tim_nstepobs,tim_nstepobsinc
! public procedures
public :: tim_setup
public :: tim_sutimeinterp,tim_setTimeInterpWeight,tim_getTimeInterpWeight
public :: tim_getDateStamp,tim_setDateStamp
real*8 :: tim_dstepobs
real*8 :: tim_dstepobsinc
integer :: tim_nstepobs
integer :: tim_nstepobsinc
integer, parameter :: mxstepobs=9
real*8,pointer :: timeInterpWeight(:,:) => NULL() ! weights for linear temporal interpolation of increment to obs times
integer :: datestamp ! window centre of analysis validity
contains
subroutine tim_setup 1,1
implicit none
integer :: nulnam,ierr,fnom,fclos
real*8 :: dstepobs,dstepobsinc
NAMELIST /NAMTIME/dstepobs,dstepobsinc
dstepobs = 6.0d0
dstepobsinc = 6.0d0
nulnam=0
ierr=fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
read(nulnam,nml=namtime,iostat=ierr)
if(ierr.ne.0) call abort3d('tim_setup: Error reading namelist')
if(mpi_myid.eq.0) write(*,nml=namtime)
ierr=fclos(nulnam)
tim_dstepobs = dstepobs
tim_dstepobsinc = dstepobsinc
tim_nstepobs = 2*nint((3.d0 - tim_dstepobs/2.d0)/tim_dstepobs) + 1
tim_nstepobsinc = 2*nint((3.d0 - tim_dstepobsinc/2.d0)/tim_dstepobsinc) + 1
if(mpi_myid.eq.0) write(*,*) 'tim_setup: dstepobs =',tim_dstepobs
if(mpi_myid.eq.0) write(*,*) 'tim_setup: nstepobs =',tim_nstepobs
if(mpi_myid.eq.0) write(*,*) 'tim_setup: dstepobsinc=',tim_dstepobsinc
if(mpi_myid.eq.0) write(*,*) 'tim_setup: nstepobsinc=',tim_nstepobsinc
end subroutine tim_setup
subroutine tim_sutimeinterp(lobsSpaceData) 1,11
!*
!***s/r sutimeinterp
!*
IMPLICIT NONE
type(struct_obs) :: lobsSpaceData
integer :: jobs,jstep
real*8 :: stepObsIndex
if(mpi_myid.eq.0) write(*,*) ' '
if(mpi_myid.eq.0) write(*,*) '-------- ENTERING TIM_SUTIMEINTERP ---------'
if(mpi_myid.eq.0) write(*,*) ' '
! Compute the number of step obs over a 6 hours assimilation window
if(mpi_myid.eq.0) write(*,*) 'TIM_SUTIMEINTERP: Number of step obs inc : ',tim_nstepobsinc
if(associated(timeInterpWeight)) deallocate(timeInterpWeight)
allocate(timeInterpWeight(obs_numHeader(lobsSpaceData),mxstepobs))
timeInterpWeight(:,:)=0.0d0
do jobs=1, obs_numHeader(lobsSpaceData)
! return the step stamp associated with date and time of the observation
! building the list of step stamp and counting number of obs in each step
if(tim_nstepobsinc.eq.1) then
call tim_setTimeInterpWeight(1.0d0,jobs,1)
else
call getStepObsIndex(stepObsIndex,tim_getDatestamp(), &
obs_headElem_i(lobsSpaceData,OBS_DAT,jobs), &
obs_headElem_i(lobsSpaceData,OBS_ETM,jobs),tim_nstepobsinc)
if(floor(stepObsIndex).ge.tim_nstepobsinc) then
write(*,*) 'tim_sutimeinterp: stepObsIndex too big=',jobs,stepObsIndex
call tim_setTimeInterpWeight(1.0d0,jobs,tim_nstepobsinc)
elseif(floor(stepObsIndex).le.0) then
write(*,*) 'tim_sutimeinterp: stepObsIndex too small=',jobs,stepObsIndex
call tim_setTimeInterpWeight(1.0d0,jobs,1)
else
call tim_setTimeInterpWeight(1.0d0-(stepObsIndex-floor(stepObsIndex)),jobs,floor(stepObsIndex))
call tim_setTimeInterpWeight(stepObsIndex-floor(stepObsIndex),jobs,floor(stepObsIndex)+1)
endif
endif
enddo
if(mpi_myid.eq.0) write(*,*) ' '
if(mpi_myid.eq.0) write(*,*) '-------- END OF TIM_SUTIMEINTERP ---------'
if(mpi_myid.eq.0) write(*,*) ' '
end subroutine tim_sutimeinterp
SUBROUTINE tim_setTimeInterpWeight(weight_in,headerIndex,stepObs) 5
implicit none
integer, intent(in) :: headerIndex,stepObs
real(kind=8),intent(in):: weight_in
timeInterpWeight(headerIndex,stepObs)=weight_in
end SUBROUTINE tim_setTimeInterpWeight
FUNCTION tim_getTimeInterpWeight(headerIndex,stepObs) result(weight_out) 4
implicit none
real(kind=8) :: weight_out
integer,intent(in) :: headerIndex,stepObs
weight_out=timeInterpWeight(headerIndex,stepObs)
end FUNCTION tim_getTimeInterpWeight
subroutine tim_setDatestamp(datestamp_in) 1
!
! object: to control access to the minimization object. Sets the date
! of the window centre of analysis validity to the indicated value.
implicit none
integer, intent(in) :: datestamp_in
datestamp = datestamp_in
end subroutine tim_setDatestamp
function tim_getDatestamp() result(datestamp_out) 17
!
! object: to control access to the minimization object. Returns the date
! of the window centre of analysis validity.
implicit none
integer :: datestamp_out
datestamp_out = datestamp
end function tim_getDatestamp
end MODULE timeCoord_mod