psmile_write_4d_int.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, SGI Germany, Munich, Germany.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE:   psmile_write_4d_int
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_write_4d_int(unit                 &
00012                                      ,var                 &
00013                                      ,domain              &
00014                                      ,a                   &
00015                                      ,a_shape             &
00016                                      ,v_shape             &
00017                                      ,time                &
00018                                      ,time_used           &
00019                                      ,id_blockid          &
00020                                      ,block_used          &
00021                                      ,ierror)
00022 !
00023 ! !USES:
00024 !
00025       use psmile
00026 #ifdef __PSMILE_WITH_IO
00027       implicit none
00028       include 'prism.inc'
00029 !
00030 ! !INPUT PARAMETERS:
00031 !
00032       integer,intent(in) :: unit
00033       Type(fieldtype),intent(in) :: var
00034       Type(domain2D),intent(inout)  :: domain
00035       integer,intent(in) :: a_shape(2,*)
00036       integer,intent(in) :: v_shape(2,*)
00037       integer        , intent(inout)  :: a(a_shape(1,1):a_shape(2,1)  
00038                                        ,a_shape(1,2):a_shape(2,2)  
00039                                        ,a_shape(1,3):a_shape(2,3)  
00040                                        ,a_shape(1,4):a_shape(2,4)) 
00041       double precision, intent(in) :: time
00042       logical,intent(in) :: time_used
00043       integer,intent(in) :: id_blockid
00044       logical,intent(in) :: block_used
00045 !
00046 ! !OUTPUT PARAMETERS:
00047 !
00048       integer, intent(out) :: ierror
00049 !
00050 ! !LOCAL VARIABLES:
00051 !
00052       double precision,allocatable    :: atmp(:,:,:,:)
00053       integer :: ierrp(2)
00054 !
00055 ! !DESCRIPTION:
00056 !
00057 ! Writes an integer partitioned 4d array to a file.
00058 ! Subblocks are supported.
00059 !
00060 ! !REVISION HISTORY:
00061 !
00062 !   Date      Programmer   Description
00063 ! ----------  ----------   -----------
00064 !  09.12.03   R. Vogelsang created
00065 !  6.05.04    R. Vogelsang bugfixes a=atmp
00066 !
00067 !EOP
00068 !----------------------------------------------------------------------
00069 
00070       character(len=len_cvs_string),save :: mcvs = 
00071 '$Id: psmile_write_4d_int.F90 2325 2010-04-21 15:00:07Z valcke $'
00072       
00073       ierror=0
00074 
00075 #ifdef VERBOSE
00076       print*,trim(ch_id),' :   psmile_write_4d_real: start'
00077       print*,trim(ch_id),' :   psmile_write_4d_real: size ',size(a)
00078       call psmile_flushstd
00079 
00080 #endif
00081 
00082       allocate( atmp(a_shape(1,1):a_shape(2,1)  &
00083                     ,a_shape(1,2):a_shape(2,2)  &
00084                     ,a_shape(1,3):a_shape(2,3)  &
00085                     ,a_shape(1,4):a_shape(2,4)),stat=ierror)
00086 
00087       if ( ierror /= 0 ) then
00088          ierrp (1) = 1
00089          ierror = PRISM_Error_Alloc
00090          call psmile_error ( ierror, 'atmp', ierrp, 1, __FILE__, __LINE__ )
00091          return
00092       endif
00093 
00094       atmp=a
00095       if(block_used) then
00096       if(id_blockid.le.0) then
00097          ierror = PRISM_Error_Internal
00098          call psmile_error ( ierror, 'id_blockid <= 0! ', &
00099                              ierrp, 0, __FILE__, __LINE__ )
00100       endif
00101       if(time_used) then
00102         call mpp_write(unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
00103                                              ,v_shape(1,2):v_shape(2,2) &
00104                                              ,v_shape(1,3):v_shape(2,3) &
00105                                              ,v_shape(1,4):v_shape(2,4)) &
00106                                       ,tstamp=time,blockid=id_blockid)
00107       else
00108         call mpp_write( unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
00109                                               ,v_shape(1,2):v_shape(2,2) &
00110                                              ,v_shape(1,3):v_shape(2,3) &
00111                                               ,v_shape(1,4):v_shape(2,4)) &
00112                                               , blockid=id_blockid)
00113       endif
00114       else
00115       if(time_used) then
00116         call mpp_write(unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
00117                                              ,v_shape(1,2):v_shape(2,2) &
00118                                              ,v_shape(1,3):v_shape(2,3) &
00119                                              ,v_shape(1,4):v_shape(2,4)) &
00120                                       ,tstamp=time)
00121       else
00122         call mpp_write( unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
00123                                               ,v_shape(1,2):v_shape(2,2) &
00124                                              ,v_shape(1,3):v_shape(2,3) &
00125                                               ,v_shape(1,4):v_shape(2,4)))
00126       endif
00127       endif
00128 
00129       deallocate(atmp,stat=ierror)
00130 
00131       if ( ierror /= 0 ) then
00132          ierrp (1) = 1
00133          ierror = PRISM_Error_Alloc
00134          call psmile_error ( ierror, 'deallocate(atmp)', ierrp, 1, __FILE__ &
00135                            , __LINE__ )
00136          return
00137       endif
00138 #ifdef __PSMILE_IO_SYNC
00139       call mpp_flush(unit)
00140 #endif
00141 
00142 
00143 
00144 #ifdef VERBOSE
00145       print*,trim(ch_id),' :   psmile_write_4d_int: end'
00146       call psmile_flushstd
00147 
00148 #endif
00149 #endif
00150       end subroutine psmile_write_4d_int