prism_put_inquire.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_Put_inquire
!
! !INTERFACE:

subroutine prism_put_inquire ( field_id, date, date_bounds, info, ierror )
!
! !USES:
!
  use PRISM, dummy_interface => prism_put_inquire
  use PRISM_calendar
  use PSMILe
  use PSMILe_SMIOC, only : sga_smioc_comp, transient

  implicit none
!
! !INPUT PARAMETERS:
!
  Integer, Intent (In)                 :: field_id

!     Handle to the variable information

  Type(PRISM_Time_Struct), Intent (In) :: date

!     Date on which the information is located in time

  Type(PRISM_Time_Struct), Intent (In) :: date_bounds(2)

!     Time interval for which the data is representative
!     lower bound: date_bounds(1), upper bound: date_bounds(2)
!
!
! !OUTPUT PARAMETERS:
!
  
  Integer, Intent (Out)               :: info

!     returned info about action performed

  Integer, Intent (Out)               :: ierror

!     Returns the error code of prism_put_inquire;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
  Type (GridFunction), Pointer :: fp
  Type (transient), Pointer    :: sga_smioc_transi(:)

  Double Precision   :: julian_day, julian_dayb(2)
  Double Precision   :: julian_sec, julian_secb(2)

  Double Precision   :: delta_sec

  Logical            :: action(3)
  Logical            :: flag(3)

  Integer            :: add_days
  Integer            :: lag

  Integer            :: i, j
  Integer            :: il_nb_transi_out

  Integer, Parameter :: nerrp = 2
  Integer            :: ierrp (nerrp)
  !
!
! !DESCRIPTION:
!
!  Subroutine "prism_put_inquire" takes the data and sends them
!          to remote application on the the io library
!
!
! !REVISION HISTORY:
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.03    R. Redler    created
! 04.12.14    R. Redler    revised
!
!EOP
!----------------------------------------------------------------------
!
! $Id: prism_put_inquire.F90 3248 2011-06-23 13:03:19Z coquart $
! $Author: coquart $
!
  Character(len=len_cvs_string), save :: mycvs = 
      '$Id: prism_put_inquire.F90 3248 2011-06-23 13:03:19Z coquart $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
   print *, trim(ch_id), ': prism_put_inquire: field_id', field_id
   call psmile_flushstd
#endif /* VERBOSE */

!----------------------------------------------------------------------
!  1st Initialization
!----------------------------------------------------------------------

   ierror          = 0
   info            = PRISM_NOACTION
   flag            = .false.
   action          = .false.

!----------------------------------------------------------------------
!  2nd Check field_id
!----------------------------------------------------------------------

   if ( Fields(field_id)%status /= PSMILe_status_defined ) then

      ierror = PRISM_Error_Arg

      print *, trim(ch_id), ': prism_put_inquire: eof field_id not defined'
      call psmile_flushstd

      return

   endif

   fp               => Fields(field_id)
   sga_smioc_transi => sga_smioc_comp(Fields(field_id)%comp_id)%sga_smioc_transi
   il_nb_transi_out =  sga_smioc_transi(fp%smioc_loc)%ig_nb_transi_out

!-----------------------------------------------------------------------
! 3rd Return in case there is nothing to do
!-----------------------------------------------------------------------

   if ( il_nb_transi_out < 1 ) then
#ifdef VERBOSE
      print *, trim(ch_id), ': prism_put_inquire: eof ig_nb_transi_out ', il_nb_transi_out
      call psmile_flushstd
#endif /* VERBOSE */
      return
   endif

   if ( fp%smioc_loc == PRISM_UNDEFINED ) then

      ierror = PRISM_Error_Arg

      print *, trim(ch_id), ': prism_put_inquire: WARNING: smioc_loc undefined'
      call psmile_flushstd

      return

   endif

!-----------------------------------------------------------------------
! 4th Check date information
!-----------------------------------------------------------------------
!
!  ... convert date and date bounds into julian days and seconds
!
   call psmile_date2ju ( date,           julian_day,     julian_sec    )
   call psmile_date2ju ( date_bounds(1), julian_dayb(1), julian_secb(1))
   call psmile_date2ju ( date_bounds(2), julian_dayb(2), julian_secb(2))

!   ... check whether bounds are consistent

   if ( julian_dayb(2) <  julian_dayb(1) .or. &
      ( julian_dayb(1) == julian_dayb(2) .and. &
        julian_secb(2) <  julian_secb(1) ) ) then

      ierror = PRISM_Error_Date

      print *, trim(ch_id), ': prism_put_inquire: WARNING: upper bound < lower bound'
      call psmile_flushstd

      return

   endif

!  ... check whether date is within bounds

   if ( ( julian_dayb(1) >  julian_day       .or.  &
          julian_day     >  julian_dayb(2) ) .or.  &
        ( julian_dayb(1) == julian_day       .and. &
          julian_sec     <  julian_secb(1) ) .or.  &
        ( julian_dayb(2) == julian_day       .and. &
          julian_sec     >  julian_secb(2) ) ) then

      ierrp (1) = field_id

      ierror = PRISM_Error_Date

      print *, trim(ch_id), ': prism_put_inquire: WARNING: date out of bounds'
      call psmile_flushstd

      return

   endif

!----------------------------------------------------------------------
! 5th Check whether any action is required because of Average or Summation
!----------------------------------------------------------------------

   do i = 1, il_nb_transi_out
      if ( sga_smioc_transi(fp%smioc_loc)%sga_transi_out(i)%ig_src_timeop /= PSMILe_undef ) then
           info = info + 1
#ifdef VERBOSE
           print *, trim(ch_id), ': prism_put_inquire: eof summation required'
           call psmile_flushstd
#endif /* VERBOSE */
           exit
      endif
   enddo

!-----------------------------------------------------------------------
! 6th Loop over the tasks for a particular prism_put_inquire
!-----------------------------------------------------------------------

   do i = 1, il_nb_transi_out

!------------------------------------------------------------------------
!  ... shift date and bounds according to lag information
!      We assume the upper bound lies halfway between two
!      consecutive calls to Prism_put_inquire and that the delta_t
!      does not change between two consecutive calls to
!      Prism_put_inquire.
!------------------------------------------------------------------------

      lag = sga_smioc_transi(fp%smioc_loc)%sga_transi_out(i)%ig_lag

      if ( lag /= PSMILe_undef ) then

#ifdef DEBUG
         print *, trim(ch_id), ': prism_put_inquire: lag is active and set to ', lag
#endif
         delta_sec = (julian_dayb(2) - julian_day) * 86400.0 &
              +  julian_secb(2) - julian_secb(1)

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

         julian_secb(1) = julian_secb(1) + lag * delta_sec
         add_days       = floor(julian_secb(1) / 86400.0)
         julian_dayb(1) = julian_dayb(1) + add_days
         julian_secb(1) = julian_secb(1) - float(add_days) * 86400.0

         julian_secb(2) = julian_secb(2) + lag * delta_sec
         add_days       = floor(julian_secb(2) / 86400.0)
         julian_dayb(2) = julian_dayb(2) + add_days
         julian_secb(2) = julian_secb(2) - float(add_days) * 86400.0

      endif

!-----------------------------------------------------------------------
! ... determine the concrete action that has to be performed for this
!     particular task.
!-----------------------------------------------------------------------

      call psmile_check_action ( field_id, i, .true.,       &
                                julian_day, julian_dayb(1), &
                                julian_sec, julian_secb(1), &
                                action )

! accumulate actions in flag for all tasks

      do j = 1, 3
         if (action(j)) flag(j) = .true.
      enddo

   enddo ! il_nb_transi_out

   if ( flag(1) ) info = info + 1000 ! Coupling
   if ( flag(2) ) info = info +  100 ! IO
   if ( flag(3) ) info = info +   10 ! Restart

#ifdef VERBOSE
   print *, trim(ch_id), ': prism_put_inquire: eof ierror ', ierror
   call psmile_flushstd
#endif /* VERBOSE */
!
end subroutine prism_put_inquire