prism_put_restart.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_restart
!
! !INTERFACE:

   subroutine prism_put_restart ( field_id, date, date_bounds, data_array, info, ierror )
!
! !USES:
!
      use PRISM_constants
      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)

      Double Precision, Intent (In)        :: data_array(*)

!     the data itself
!
! !OUTPUT PARAMETERS:
!

      integer, Intent (Out)               :: info

!     returned info about action performed

      integer, Intent (Out)               :: ierror

!     Returns the error code of prism_put_restart;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer            :: il_taskid_restr, il_transiouts, il_smioc_loc
      Double Precision   :: julian_day, julian_dayb(2)
      Double Precision   :: julian_sec, julian_secb(2)

! WARNING: WORKAROUND
      Logical            :: restart_action

      Integer            :: task_id
      Integer, Parameter :: nerrp = 1
      Integer            :: ierrp (nerrp)

      Type (Transient), pointer    :: sga_smioc_transi(:)
      Type (GridFunction), Pointer :: fp

! !DESCRIPTION:
!
!    Subroutine "prism_put_restart" takes the data and writes a restart.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 04.11.18    R. Redler    created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: prism_put_restart.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
  Character(len=len_cvs_string), save :: mycvs = 
      '$Id: prism_put_restart.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
#ifdef VERBOSE
      print *, trim(ch_id), ': prism_put_restart: field_id', field_id

      call psmile_flushstd
#endif /* VERBOSE */

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

      ierror = 0
      info   = PRISM_NOACTION

      sga_smioc_transi => sga_smioc_comp(Fields(field_id)%comp_id)%sga_smioc_transi
      fp               => Fields(field_id)

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

      if ( Fields(field_id)%status /= PSMILe_status_defined ) then
         ierrp (1) = field_id
      
         ierror = PRISM_Error_Arg
      
         call psmile_error ( ierror, 'field_id', &
                             ierrp(1), 1, __FILE__, __LINE__ )
         return
      endif

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

      if ( Fields(field_id)%smioc_loc == PRISM_UNDEFINED ) return

!-----------------------------------------------------------------------
! 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

           ierrp (1) = field_id

           ierror = PRISM_Error_Date

           call psmile_error ( ierror, 'upper bound < lower bound', &
                             ierrp(1), 1, __FILE__, __LINE__ )
           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

         call psmile_error ( ierror, 'date out of bounds', &
                             ierrp(1), 1, __FILE__, __LINE__ )
         return

      endif

!-----------------------------------------------------------------------
! 5th Write out for the first task only
!-----------------------------------------------------------------------

      task_id = 1

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

      il_smioc_loc=fp%smioc_loc

      il_transiouts=0

      if(associated(sga_smioc_transi(il_smioc_loc)%sga_transi_out)) &
           il_transiouts=size(sga_smioc_transi(il_smioc_loc)%sga_transi_out)
      !
      !      Shift task id into the range of task ids for restart!
      !

      il_taskid_restr=3*il_transiouts+task_id+1

      !
      !      Coherence check
      !

      restart_action = .false.

      if(il_taskid_restr.le.size( fp%io_task_lookup)) &
           restart_action = fp%io_task_lookup(il_taskid_restr).gt.0

!------------------------------------------------------------------------
! 6th Dump out fields into restart file
!------------------------------------------------------------------------

      if ( restart_action ) then

#ifdef VERBOSE
          print *, trim(ch_id), ': prism_put_restart: dump out field ', trim(fp%local_name)
          call psmile_flushstd
#endif /* VERBOSE */

          if ( Fields(field_id)%dataType == PRISM_Integer ) &
               call psmile_write_byid_int ( field_id, il_taskid_restr, &
               data_array, julian_dayb(2), julian_secb(2), ierror )

          if ( Fields(field_id)%dataType == PRISM_Real ) &
               call psmile_write_byid_real ( field_id, il_taskid_restr, &
               data_array, julian_dayb(2), julian_secb(2), ierror )

          if ( Fields(field_id)%dataType == PRISM_Double_Precision ) &
               call psmile_write_byid_dble ( field_id, il_taskid_restr, &
               data_array, julian_dayb(2), julian_secb(2), ierror )

          info = info + 10

      endif

#ifdef VERBOSE
      print *, trim(ch_id), ': prism_put_restart: eof ierror ', ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
   end subroutine prism_put_restart