psmile_put_int.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Put_int 
!
! !INTERFACE:

subroutine psmile_put_int  ( field_id, task_id, julian_day, julian_sec, &
              julian_dayb, julian_secb, data_array, action, info, ierror )
!
! !USES:
!
   use PRISM_constants
   use PRISM_calendar

   use PSMILe
   use PSMILe_SMIOC, only : sga_smioc_comp, transient, transient_out

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

!  Handle to the variable information

   Integer, Intent (In)            :: task_id

!  Task number for the Output

   Real (PSMILe_float_kind), Intent (In)   :: julian_day, julian_dayb(2)
   Real (PSMILe_float_kind), Intent (In)   :: julian_sec, julian_secb(2)

!  Date with  bounds on which the information is located in time
!  Time interval for which the data is representative
!  lower bound: julian_*b(1), upper bound: julian_*b(2)
!
   Integer, Intent (In)            :: data_array(*)

!  The data itself

   Logical, Intent (In)            :: action(3)  ! 1: Coupling ation
                                                 ! 2: IO action
                                                 ! 3: Restart action
!
!  Switches to activate calls for coupling and/or I/O
!
! !OUTPUT PARAMETERS:
!
   Integer, Intent (InOut)         :: info

!  Returned info about action performed

   Integer, Intent (Out)           :: ierror

!  Returns the error code of psmile_put_int ;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
   Integer            :: add_scalar
   Integer            :: mul_scalar

   Integer, Allocatable           :: data_scattered(:)
   Integer, Allocatable           :: data_reduced(:)

   Integer            :: shape_in(2,6)

   Integer            :: i, j ! loop count
   Integer            :: len_gathered, len_scattered
   Integer            :: len, len_3d, len_reduced
   Integer            :: nbr_fields ! number of fields in a bundle

   Integer            :: rdim(6)
   Integer            :: nbr_reductions

   Integer            :: local_reduce
   Integer            :: local_timeop

   Logical            :: local_scatter
   Logical            :: local_multiply
   Logical            :: local_add

   Logical            :: local_operation = .false.
   Logical            :: mask_set
   Logical            :: mask_needed
   Logical, Pointer   :: mask_array(:)
   Logical, Pointer   :: mask_aux  (:)

   Type (GridFunction), Pointer :: fp
   Type (Taskout_type), Pointer :: Taskout

!  SMIOC data

   Type (transient),     Pointer :: sga_smioc_transi(:)
   Type (transient_out), Pointer :: sga_transi_out

!  For I/O

#ifdef __PSMILE_WITH_IO
   Real (PSMILe_float_kind) :: jd_end,js_end,delta_sec
   Real (PSMILe_float_kind) :: jd_cur,js_cur

   Integer            :: il_taskid,il_transiouts,il_smioc_loc
   Integer            :: il_taskid_restr
   Integer            :: lag,add_days

   Logical            :: debug_action, restart_action
#endif

!  For statistics
  
   Integer            :: stat_nsum
   Integer            :: nsum

   Integer            :: shape_out(2,6)

   Integer, Allocatable           :: recv_buf(:)
   Integer, Allocatable           :: stat_max(:)
   Integer, Allocatable           :: stat_min(:)
   Integer, Allocatable           :: stat_sum(:)
   Integer, Allocatable           :: stat_mean(:)

   Logical            :: stats

   Character(len=6), Save :: cstats (3)

   Integer :: n_grid_dim

!  Error parameters

   Integer            :: ierr
   Integer, Parameter :: nerrp = 3
   Integer            :: ierrp (nerrp)

!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Put_int " takes the data and sends them
!          to remote application on the the io library
!
! TO DO: rdim, the dimension along which the reduction operation shall
!        be performed needs to be read in from the SMIOC.
!
!        We still need to center the date/time for output of
!        summed/averaged fields
!
!        Apply error handling for coupling and I/O

!        Fill info object
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.02    R. Redler    created
! 04.01.28    R. Redler    major revision to adjust to SMIOC
! 04.07.05    R. Redler    Restart added
!
!EOP
!----------------------------------------------------------------------
! $Id: psmile_put_int.F90 2687 2010-10-28 15:15:52Z coquart $
! $Author: coquart $
!----------------------------------------------------------------------
!
   Data cstats /'masked', 'valid', 'all'/
!
#ifdef VERBOSE
   print *, trim(ch_id), ': psmile_put_int : field_id', field_id

   call psmile_flushstd
#endif /* VERBOSE */

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

   ierror         = 0
   local_reduce   = PSMILe_undef

   local_operation = .false.

   Nullify(mask_array)
   Nullify(mask_aux)

   fp      => Fields(field_id)
   Taskout => Fields(field_id)%Taskout(task_id)
   sga_smioc_transi => sga_smioc_comp(Fields(field_id)%comp_id)%sga_smioc_transi
   sga_transi_out => sga_smioc_transi(fp%smioc_loc)%sga_transi_out(task_id)
   n_grid_dim = Grids(Methods(fp%method_id)%grid_id)%n_dim

!-----------------------------------------------------------------------
! Determine size of data_array
!-----------------------------------------------------------------------

   len = fp%size

   if ( fp%transi_type == PSMILe_bundle ) then
       nbr_fields = fp%var_shape(2,n_grid_dim+1)
   else
       nbr_fields = 1
   endif

   len_3d = len / nbr_fields

!-----------------------------------------------------------------------
! Set switches
!-----------------------------------------------------------------------

   local_scatter = sga_transi_out%sg_src_local_trans%ig_scatter == PSMILe_true
   local_timeop  = sga_transi_out%ig_src_timeop
!rr local reduction operation currently not yet activated
!  local_reduce  = PSMILe_undef

   mul_scalar = sga_transi_out%sg_src_local_trans%dg_mult_scalar
   add_scalar = sga_transi_out%sg_src_local_trans%dg_add_scalar

   local_add      = add_scalar /= PSMILe_dundef
   local_multiply = mul_scalar /= PSMILe_dundef

!  local_operation = .false.

   mask_set = fp%mask_id /= PRISM_UNDEFINED

   if (mask_set) then
      mask_set = Masks(fp%mask_id)%status /= PSMILe_status_free
   endif

!-----------------------------------------------------------------------
! In case that there is no mask defined for the field create one.
!-----------------------------------------------------------------------

   stats = sga_transi_out%iga_stats(1) == PSMILe_true .or. &
           sga_transi_out%iga_stats(2) == PSMILe_true .or. &
           sga_transi_out%iga_stats(3) == PSMILe_true

   mask_needed = stats .or. local_scatter .or. &
                 local_reduce == PSMILe_max .or.  local_reduce == PSMILe_min

   if ( mask_set ) mask_array => Masks(fp%mask_id)%mask_array

   if ( mask_needed ) then
     allocate (mask_aux(len_3d), STAT=ierr)
     if ( ierr /= 0 ) then
        ierrp (1) = 1
        ierror = PRISM_Error_Alloc
        call psmile_error ( ierror, 'mask_aux', ierrp(1), 1, &
                            __FILE__, __LINE__ )
        return
     endif

     mask_aux = .true.

     if (.not. mask_set) mask_array => mask_aux
   endif

!-----------------------------------------------------------------------
! Set lower date bounds
!-----------------------------------------------------------------------

   if ( Taskout%nsum == 0 ) then
      Taskout%start_day = julian_dayb(1)
      Taskout%start_sec = julian_secb(1)
   endif

!-----------------------------------------------------------------------
! Allocate arrays for manipulation of data_array
!-----------------------------------------------------------------------


   if ( local_timeop /= PSMILe_undef .or. local_add .or. local_multiply ) then

      local_operation = .true.

      if ( .not. associated(Taskout%buffer_int ) ) then
         Allocate(Taskout%buffer_int (1:len), STAT = ierr )
         if ( ierr /= 0 ) then
            ierrp (1) = 1
            ierror = PRISM_Error_Alloc
            call psmile_error ( ierror, 'Taskout%buffer_int ', &
                 ierrp(1), 1, __FILE__, __LINE__ )
            return
         endif

         Taskout%buffer_int  = 0.0
         Taskout%nsum = 0
      endif

   endif


!-----------------------------------------------------------------------
! 2nd  Sum up if local_timeop = 3601 or local_timeop = 3600 
!-----------------------------------------------------------------------

   if ( local_timeop /= PSMILe_undef ) then

      Taskout%nsum=Taskout%nsum+1
 
      Taskout%buffer_int (1:len) = &
           Taskout%buffer_int (1:len) + data_array(1:len)

      info = info + 1

   endif

!-----------------------------------------------------------------------
! Set upper date bounds
!-----------------------------------------------------------------------

   Taskout%end_day = julian_dayb(2)
   Taskout%end_sec = julian_secb(2)

!-----------------------------------------------------------------------
! ... Return if no I/O or coupling is required.
!-----------------------------------------------------------------------

   if ( .not. action(1) .and. .not. action(2) .and. .not. action(3) ) then
#ifdef VERBOSE
         print *, trim(ch_id), ': psmile_put_int: eof nothing to do! ierror ', ierror
#endif /* VERBOSE */
         return
      endif

!-----------------------------------------------------------------------
! 3rd  Multiply and/or add scalar on summation or original fields
!-----------------------------------------------------------------------
!
! ... Multiplication with a constant

   IF ( local_multiply ) THEN

! ... for time averaged fields

      if (( local_timeop /= PSMILe_undef) .OR. ( local_add ) ) then 

         Taskout%buffer_int (1:len) = Taskout%buffer_int (1:len) * mul_scalar

      else

! ... for ordinary fields

         Taskout%buffer_int (1:len) = data_array(1:len) * mul_scalar

      endif

  ENDIF
  !
  !
! Addition of a constant

   if ( local_add ) then

! ... for time averaged fields

      if ( local_timeop /= PSMILe_undef ) then

         Taskout%buffer_int (1:len) = Taskout%buffer_int (1:len)   &
                                    + (add_scalar*Taskout%nsum)

      else

! ... for ordinary fields

         Taskout%buffer_int (1:len) = data_array(1:len) + add_scalar

      endif

   endif
!-----------------------------------------------------------------------
! ... Do the average if required if local_timeop = 3600
!-----------------------------------------------------------------------

   if ( local_timeop == PSMILe_tave  .and. Taskout%nsum > 0 ) then

       Taskout%buffer_int (1:len) = Taskout%buffer_int (1:len) &
                                  / int (Taskout%nsum)
   endif

!-----------------------------------------------------------------------
! 4th  Scatter original data or summed up fields
!-----------------------------------------------------------------------

   if ( local_scatter ) then

      !
      ! WARNING: Implement procedure for bundles and vectors
      !
      ! ... Determine length of data arrays to be handled (ignoring the number
      !     of fields for the moment) number of fields is taken into account
      !     again during the scattering and gathering.
      
      if ( .not. mask_set ) then

         len_gathered  = len_3d
         len_scattered = len_gathered

      else
         len           = len_3d
         len_gathered  = 0
         len_scattered = 1

         do i = 1, n_grid_dim

            len_scattered = len_scattered                                &
                 * ( Masks(fp%mask_id)%mask_shape(2,i) -   &
                     Masks(fp%mask_id)%mask_shape(1,i) + 1 )
         enddo

         if ( len_scattered /= len ) then
            ierrp (1) = field_id
            ierrp (2) = len
            ierrp (3) = len_scattered
            ierror = PRISM_Error_Size

            call psmile_error ( ierror,  fp%local_name, ierrp, 3, &
               __FILE__, __LINE__ )
            return
         endif

         len_gathered = count(mask_array)

      endif

!-----------------------------------------------------------------------
! Allocate appropriate memory and scatter data onto data_scattered
!-----------------------------------------------------------------------

      Allocate (data_scattered(len_scattered), STAT = ierr )

      if ( ierr /= 0 ) then
         ierrp (1) = len_scattered
         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'data_scattered', &
              ierrp(1), 1, __FILE__, __LINE__ )
         return
      endif

      if ( local_operation ) then

         call psmile_loc_trans_int  ( PSMILe_scat, nbr_fields, &
              len_gathered, Taskout%buffer_int , &
              len_scattered, data_scattered, field_id )
      else

         call psmile_loc_trans_int  ( PSMILe_scat, nbr_fields, &
              len_gathered, data_array, &
              len_scattered, data_scattered, field_id )

      endif

   endif ! local_scatter



!-----------------------------------------------------------------------
! 5th Determine the input shape for reduction operations
!-----------------------------------------------------------------------

   shape_in = 1

   do i = 1, n_grid_dim
      shape_in(1,i) = fp%var_shape(1,i)
      shape_in(2,i) = fp%var_shape(2,i)
   enddo

   if ( Fields(field_id)%transi_type == PSMILe_bundle ) &
      shape_in(2,6) = nbr_fields

!-----------------------------------------------------------------------
! 6th  Minimum or Maximum reduction operations
!-----------------------------------------------------------------------

   if ( local_reduce == PSMILe_max .or. local_reduce == PSMILe_min )  then

! ... Determine and set shapes of input and output arrays

      shape_out   = shape_in
      len_reduced = 1

      nbr_reductions = 0 ! needs to be set according to SMIOC input
      rdim = 6

      do i = 1, nbr_reductions
         shape_out(1,rdim(i)) = 1
         shape_out(2,rdim(i)) = 1
      enddo

      do i = 1, 6
         len_reduced = len_reduced * ( shape_out(2,i)-shape_out(1,i) + 1 )
      enddo

      allocate (data_reduced(len_reduced), STAT=ierr)
      if ( ierr /= 0 ) then
         ierrp (1) = len_reduced
         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'data_reduced', ierrp(1), 1, &
              __FILE__, __LINE__ )
         return
      endif

      if ( local_scatter ) then

! ... for gathered fields

         call psmile_multi_reduce_int  ( local_reduce, shape_in, &
              data_scattered, shape_out, data_reduced, mask_array, ierror )
      else

         if ( local_operation ) then

! ... for locally modified fields

            call psmile_multi_reduce_int  ( local_reduce, shape_in, &
                 Taskout%buffer_int ,     &
                 shape_out, data_reduced, mask_array, ierror )
         else

! ... for ordinary fields

            call psmile_multi_reduce_int  ( local_reduce,shape_in, &
                 data_array, shape_out, data_reduced, mask_array, ierror )

         endif ! local_operation

      endif ! local_scatter

   endif ! local_reduce

!-----------------------------------------------------------------------
! 7th  Calculate statistics
!
!      j = 1: for masked points
!      j = 2: for valid points
!      j = 3: for all points
!
!-----------------------------------------------------------------------

   if (stats) then

      shape_out      = 1
      shape_out(2,6) = nbr_fields

!     Allocate work vectors for statistics

      allocate (recv_buf(1:shape_out(2,6)), &
                stat_max(1:shape_out(2,6)), &
                stat_min(1:shape_out(2,6)), &
                stat_sum(1:shape_out(2,6)), &
                stat_mean(1:shape_out(2,6)), STAT=ierr)
      if ( ierr /= 0 ) then
         ierrp (1) = nbr_fields * 5
         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'recv_buf', ierrp(1), 1, __FILE__, __LINE__ )
         return
      endif

!     Compute statistics for each statistic which is available

      do j = 1, 3

      if ( sga_transi_out%iga_stats(j) == PSMILe_true ) then 

         !-----------------------------------------------------------------------
         ! In case that there is no mask defined for the field create one.
         !-----------------------------------------------------------------------

         if ( mask_set ) then

            select case (j) 
            case (1) 
               mask_aux = .not. Masks(fp%mask_id)%mask_array
               mask_array => mask_aux            
            case (2)
               mask_array => Masks(fp%mask_id)%mask_array
            case (3)
               mask_aux = .true.
               mask_array => mask_aux            
            end select

         else

            mask_aux = j > 1
            mask_array => mask_aux            

         endif

         if ( local_scatter ) then

            ! ... for gathered fields

            call psmile_multi_reduce_int  ( PSMILe_max, shape_in, &
                 data_scattered, shape_out, stat_max, mask_array, ierror )

            call psmile_multi_reduce_int  ( PSMILe_min, shape_in, &
                 data_scattered, shape_out, stat_min, mask_array, ierror )

            call psmile_multi_reduce_int  ( PSMILe_integral, shape_in, &
                 data_scattered, shape_out, stat_sum, mask_array, ierror )
         else

            if ( local_operation ) then

               ! ... for locally modified fields

               call psmile_multi_reduce_int  ( PSMILe_max, shape_in, &
                    Taskout%buffer_int ,   &
                    shape_out, stat_max, mask_array, ierror )

               call psmile_multi_reduce_int  ( PSMILe_min, shape_in, &
                    Taskout%buffer_int ,   &
                    shape_out, stat_min, mask_array, ierror )

               call psmile_multi_reduce_int  ( PSMILe_integral, shape_in, &
                    Taskout%buffer_int ,   &
                    shape_out, stat_sum, mask_array, ierror )
            else

               ! ... for ordinary fields

               call psmile_multi_reduce_int  ( PSMILe_max,   &
                    shape_in, data_array, shape_out, stat_max, &
                    mask_array, ierror )

               call psmile_multi_reduce_int  ( PSMILe_min,   &
                    shape_in, data_array, shape_out, stat_min, &
                    mask_array, ierror )

               call psmile_multi_reduce_int  ( PSMILe_integral,   &
                    shape_in, data_array, shape_out, stat_sum, &
                    mask_array, ierror )

            endif ! local_operation

         endif ! local_scatter

         if ( Comps(fp%comp_id)%act_comm /= MPI_COMM_NULL ) then

            call MPI_Allreduce ( stat_max, recv_buf, shape_out(2,6), MPI_INTEGER, &
                 MPI_MAX, Comps(fp%comp_id)%act_comm, ierror )

            stat_max (:) = recv_buf(:)

            call MPI_Allreduce ( stat_min, recv_buf, shape_out(2,6), MPI_INTEGER, &
                 MPI_MIN, Comps(fp%comp_id)%act_comm, ierror )

            stat_min (:) = recv_buf(:)

            call MPI_Allreduce ( stat_sum, recv_buf, shape_out(2,6), MPI_INTEGER, &
                 MPI_SUM, Comps(fp%comp_id)%act_comm, ierror )

            stat_sum (:) = recv_buf(:)

            !if the whole field is being used
            if (j == 3) then
               stat_nsum = len_3d
            else
               stat_nsum = count(mask_array)
            endif

            call MPI_Allreduce ( stat_nsum, nsum, 1, MPI_INTEGER, &
                 MPI_SUM, Comps(fp%comp_id)%act_comm, ierror )

            if (nsum > 0) then
               stat_mean(:) = stat_sum(:) / nsum
            else
               stat_mean = 0.0
            endif

         endif

         write (*, 9990) trim(ch_id)
         write (*, 9980) trim(ch_id), trim(cstats (j))

         write (*,*) trim(ch_id), &
              ': ... for field ', trim(fp%local_name)

         write (*,'(1x,a,a)') trim(ch_id), &
              ': BundleNr.       Min           Max           Sum           Mean'

         write (*, 9950)

         do i = 1, shape_out(2,6)
            write(*,'(1x,a,a2,i3,6x,4(1x,e14.6))') trim(ch_id), &
                 ': ', i, stat_min(i), stat_max(i), stat_sum(i), stat_mean(i)
         enddo

         write (*, 9990) trim(ch_id)

         call psmile_flushstd

      endif ! iga_stat

      enddo ! j-loop

!     Deallocate arrays needed for statistics

      Deallocate (recv_buf, stat_min, stat_max, stat_sum, stat_mean, STAT=ierror)
#if defined ( VERBOSE) 
      if ( ierror /= 0 ) then
         ierrp (1) = nbr_fields
         ierror = PRISM_Error_Dealloc
         call psmile_error ( ierror, 'recv_buf, stat_{min,max,sum,mean}', &
              ierrp(1), 1, __FILE__, __LINE__ )
         return
      endif
#endif
   end if ! stats


#ifdef __PSMILE_WITH_IO
!RV  For testing only. At this position the call anticipates the OASIS 3 flag
!RV  EXPOUT.
!-----------------------------------------------------------------------
! 8th Perform I/O if required
!-----------------------------------------------------------------------

#ifdef VERBOSE
   print *, trim(ch_id), ': psmile_put_int : io_action', action(2)

   call psmile_flushstd
#endif /* VERBOSE */

   lag = sga_transi_out%ig_lag

   if ( action(2) ) then
!
!     The time stamps written to a file are mapped onto the
!     model time axis.
!
      if(lag /= PSMILe_undef) then

        delta_sec = (julian_dayb(2) - julian_day) * 86400.0 &
                   +  julian_secb(2) - julian_secb(1)

        js_cur   = julian_sec - lag * delta_sec
        add_days = floor(js_end / 86400.0)
        jd_cur   = julian_day + add_days
        js_cur = js_cur - int (add_days) * 86400.0

      else

        js_cur=julian_sec
        jd_cur=julian_day

      endif

      if ( local_reduce /= PSMILe_undef )  then

!!$             call psmile_write_byid_int  ( field_id, task_id, data_reduced, &
!!$                                           jd_cur, js_cur, ierror )
          
         print *, 'psmile_put_int : output of reduced field not supported.'

      else if ( local_scatter ) then

         call psmile_write_byid_int  ( field_id, task_id, data_scattered, &
              jd_cur, js_cur, ierror )

      else

         if ( local_operation ) then

            call psmile_write_byid_int  ( field_id, task_id, &
                 Taskout%buffer_int , &
                 jd_cur, js_cur, ierror )

            Taskout%buffer_int  = 0.0
            Taskout%nsum = 0
         else

            call psmile_write_byid_int  ( field_id, task_id, data_array, &
                 jd_cur, js_cur, ierror )

         endif ! local_operation

      endif ! local_reduce

   endif ! action(2)

!-----------------------------------------------------------------------
! 9th Debug output of Send data if required
!-----------------------------------------------------------------------

   il_smioc_loc=fp%smioc_loc
   debug_action=sga_transi_out%ig_debugmode.eq.PSMILe_true
   if ( debug_action ) then
      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 debugging!
!
      il_taskid=il_transiouts+task_id
!
!      Coherence check
!
      if(il_taskid.le.size( fp%io_task_lookup)) &
         debug_action= fp%io_task_lookup(il_taskid).gt.0
   endif

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

   call psmile_flushstd
#endif /* VERBOSE */

   if ( debug_action ) then
 
       if ( local_reduce /= PSMILe_undef )  then
 
!!$             call psmile_write_byid_int  ( field_id, il_taskid, data_reduced, &
!!$                                           julian_day, julian_sec, ierror )
          
          print *, 'psmile_put_int : output of reduced field not supported.'

       else if ( local_scatter ) then

          call psmile_write_byid_int  ( field_id, il_taskid, data_scattered, &
               julian_day, julian_sec, ierror )

       else

          if ( local_operation ) then

             call psmile_write_byid_int  ( field_id, il_taskid, &
                  Taskout%buffer_int , &
                  julian_day, julian_sec, ierror )
          else

             call psmile_write_byid_int  ( field_id, il_taskid, data_array, &
                  julian_day, julian_sec, ierror )

          endif ! local_operation

       endif ! local_reduce

    endif ! debug_action

#endif

!-----------------------------------------------------------------------
! 10th Send data if required
!-----------------------------------------------------------------------

    if ( action(1) ) then

       if ( local_reduce /= PSMILe_undef )  then

!!$         call psmile_put_field_int  (field_id, task_id, data_reduced, &
!!$                                     len_3d, nbr_fields, ierror)

         print *, 'psmile_put_int : coupling of reduced field not supported.'

      else if ( local_scatter ) then

         call psmile_put_field_int  (field_id, task_id, data_scattered, &
              len_3d, nbr_fields, ierror)

      else

         if ( local_operation ) then

            call psmile_put_field_int  (field_id, task_id, &
                 Taskout%buffer_int , &
                 len_3d, nbr_fields, ierror)

            ! defer reset when it is time for lag driven restart action
            if ( .not. action(3) ) then
               Taskout%buffer_int  = 0.0
               Taskout%nsum = 0
            endif

         else

            call psmile_put_field_int  (field_id, task_id, data_array, &
                 len_3d, nbr_fields, ierror)

         endif ! local_operation

      endif ! local_reduce

   endif ! action(1)

#ifdef __PSMILE_WITH_IO

!-----------------------------------------------------------------------
! 11th Write coupling restart if required
!-----------------------------------------------------------------------

    if ( action(3) ) then

       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
!
!      The time stamp which has to be written to the lag restart file is
!      Jobend date to be able to relocated these data in the next job
!      where the new JobStart date corresponds to the old JobEnd date. 
!
       if(restart_action) &
          call psmile_date2ju ( PRISM_Jobend_date, jd_end, js_end )

       if ( local_reduce /= PSMILe_undef )  then

!!$         if ( restart_action ) &
!!$         call psmile_write_byid_int  ( field_id, il_taskid_restr, data_reduced, &
!!$                                       jd_end, js_end, ierror )
          print *, 'psmile_put_int : restart of reduced field not supported.'

       else if ( local_scatter ) then

          if ( restart_action ) &
          call psmile_write_byid_int  ( field_id, il_taskid_restr, &
                                        data_scattered, &
                                        jd_end, js_end, ierror )

       else

          if ( local_operation ) then

             if ( restart_action ) &
               call psmile_write_byid_int  ( field_id, il_taskid_restr, &
                                             Taskout%buffer_int , &
                                             jd_end, js_end, ierror )

             Taskout%buffer_int  = 0.0
             Taskout%nsum = 0

          else

             if ( restart_action )  &
               call psmile_write_byid_int  ( field_id, il_taskid_restr, &
                                             data_array, &
                                             jd_end, js_end, ierror )

          endif ! local_operation

       endif ! local_reduce

    endif ! action(3)

#endif

!-----------------------------------------------------------------------
! 12th Free Memory
!-----------------------------------------------------------------------

   if ( allocated(data_reduced) )   deallocate(data_reduced)
   if ( allocated(data_scattered) ) deallocate(data_scattered)
   if ( associated(mask_aux) )      deallocate(mask_aux)

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

   call psmile_flushstd
#endif /* VERBOSE */

!  Formats

9990  format (1x, a, ': ', 65('='))
9980  format (1x, a, ': Statistics over ', a, ' points')
9950  format (1x, a, ': ', 65('-'))

! 
end subroutine psmile_put_int