prism_calc_newdate_double.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, SGI Germany, Munich, Germany.
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISM_Calc_newdate_double
!
! !INTERFACE:

subroutine prism_calc_newdate_double ( date, date_incr, ierror )
!
! !USES:
!
  use PRISM, dummy_interface => prism_calc_newdate_double
  use PRISM_calendar

  use PSMILE, only : ch_id, len_cvs_string

  implicit none
!
! !INPUT PARAMETERS:
!
  Double Precision, Intent(In)            :: date_incr
!
! !INPUT/OUTPUT PARAMETERS:
!
  Type (PRISM_Time_struct), Intent(InOut) :: date
!
! !OUTPUT PARAMETERS:
!
  Integer, Intent(Out)                    :: ierror
!
! !LOCAL VARIABLES
!
  Double Precision :: julian_day, julian_sec

  Integer          :: add_days
!
! !DESCRIPTION:
!
! Subroutine "prism_calc_newdate_double" add or substracts a time increment
!  in seconds to the PRISM_Time_Struct dependent on the sign of date_incr.
!  If date_incr is negative abs(date_incr) will be subtracted, in case
!  sign is positive date_incr will be added.
!
!
!
! !REVISION HISTORY:
!   Date      Programmer   Description
! ----------  ----------   -----------
! 04.02.09    R. Redler    created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: prism_calc_newdate_double.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
  Character(len=len_cvs_string), save :: mycvs = 
      '$Id: prism_calc_newdate_double.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': prism_calc_newdate_double '

      call psmile_flushstd
#endif /* VERBOSE */

!----------------------------------------------------------------------

  ierror   = 0
  add_days = 0

  call psmile_date2ju ( date, julian_day, julian_sec )

  julian_sec = julian_sec + date_incr
  add_days   = floor(julian_sec / 86400.0)
  julian_day = julian_day + add_days
  julian_sec = julian_sec - float(add_days) * 86400.0

  call psmile_ju2date ( date, julian_day, julian_sec )

!----------------------------------------------------------------------
#ifdef VERBOSE
      print *, trim(ch_id), ': prism_calc_newdate_double eof ierror ', ierror

      call psmile_flushstd
#endif /* VERBOSE */
!----------------------------------------------------------------------

end subroutine prism_calc_newdate_double