psmile_write_4d_log.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, SGI Germany, Munich, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE:   psmile_write_2d_dble
!
! !INTERFACE:

      subroutine psmile_write_4d_log(unit                 &
                                     ,var                 &
                                     ,domain              &
                                     ,a                   &
                                     ,a_shape             &
                                     ,v_shape             &
                                     ,time                &
                                     ,time_used           &
                                     ,id_blockid          &
                                     ,block_used          &
                                     ,ierror)
!
! !USES:
!

      use psmile
#ifdef __PSMILE_WITH_IO
      implicit none
      include 'prism.inc'
!
! !INPUT PARAMETERS:
!
      integer,intent(in) :: unit
      Type(fieldtype),intent(in) :: var
      Type(domain2D),intent(inout)  :: domain
      integer,intent(in) :: a_shape(2,*)
      integer,intent(in) :: v_shape(2,*)
      logical            , intent(inout) :: a(a_shape(1,1):a_shape(2,1)  
                                       ,a_shape(1,2):a_shape(2,2)  
                                       ,a_shape(1,3):a_shape(2,3)  
                                       ,a_shape(1,4):a_shape(2,4)) 
      double precision, intent(in) :: time
      logical,intent(in) :: time_used
      integer,intent(in) :: id_blockid
      logical,intent(in) :: block_used
!
! !OUTPUT PARAMETERS:
!
      integer, intent(out) :: ierror
!
! !LOCAL VARIABLES:
!
      integer :: ierrp(2)
      integer :: i,j,k,l
      double precision,allocatable    :: atmp(:,:,:,:)
!
! !DESCRIPTION:
!
! Writes a logical partitioned 4d array to a file.
! Subblocks are supported.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
!  09.12.03   R. Vogelsang created
!  6.05.04    R. Vogelsang bugfixes a=atmp
!
!EOP
!----------------------------------------------------------------------

      character(len=len_cvs_string),save :: mcvs = 
'$Id: psmile_write_4d_log.F90 2325 2010-04-21 15:00:07Z valcke $'
      
      ierror=0

#ifdef VERBOSE
      print*,trim(ch_id),' :   psmile_write_4d_log: start'
      print*,trim(ch_id),' :   psmile_write_4d_log: size ',size(a)
      call psmile_flushstd

#endif

      allocate( atmp(a_shape(1,1):a_shape(2,1)  &
                    ,a_shape(1,2):a_shape(2,2)  &
                    ,a_shape(1,3):a_shape(2,3)  &
                    ,a_shape(1,4):a_shape(2,4)),stat=ierror)

      if ( ierror /= 0 ) then
         ierrp (1) = 1
         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'atmp', ierrp, 1, __FILE__, __LINE__ )
         return
      endif

!
!     Workaround. One can not write directly logical as integers.
!     Internal representation of logicals are compiler dependent.
!
      do l=a_shape(1,4),a_shape(2,4)
        do k=a_shape(1,3),a_shape(2,3)
          do j=a_shape(1,2),a_shape(2,2)
            do i=a_shape(1,1),a_shape(2,1)
              if(a(i,j,k,l)) then
                atmp(i,j,k,l)=1
              else
                atmp(i,j,k,l)=0
              endif
            enddo
          enddo
        enddo
      enddo

      if(block_used) then
      if(id_blockid.le.0) then
         ierror = PRISM_Error_Internal
         call psmile_error ( ierror, 'id_blockid <= 0! ', &
                             ierrp, 0, __FILE__, __LINE__ )
      endif
      if(time_used) then
        call mpp_write(unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
                                             ,v_shape(1,2):v_shape(2,2) &
                                             ,v_shape(1,3):v_shape(2,3) &
                                             ,v_shape(1,4):v_shape(2,4)) &
                                      ,tstamp=time,blockid=id_blockid)
      else
        call mpp_write( unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
                                              ,v_shape(1,2):v_shape(2,2) &
                                             ,v_shape(1,3):v_shape(2,3) &
                                              ,v_shape(1,4):v_shape(2,4)) &
                                              , blockid=id_blockid)
      endif
      else
      if(time_used) then
        call mpp_write(unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
                                             ,v_shape(1,2):v_shape(2,2) &
                                             ,v_shape(1,3):v_shape(2,3) &
                                             ,v_shape(1,4):v_shape(2,4)) &
                                      ,tstamp=time)
      else
        call mpp_write( unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
                                              ,v_shape(1,2):v_shape(2,2) &
                                             ,v_shape(1,3):v_shape(2,3) &
                                              ,v_shape(1,4):v_shape(2,4)))
      endif
      endif

      deallocate(atmp,stat=ierror)

      if ( ierror /= 0 ) then
         ierrp (1) = 1
         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'deallocate(atmp)', ierrp, 1, __FILE__ &
                           , __LINE__ )
         return
      endif
#ifdef __PSMILE_IO_SYNC
      call mpp_flush(unit)
#endif



#ifdef VERBOSE
      print*,trim(ch_id),' :   psmile_write_4d_log: end'
      call psmile_flushstd

#endif
#endif
      end subroutine psmile_write_4d_log