psmile_write_3d_real.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2007-2010, SGI Germany, Munich, Germany.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE:   psmile_write_3d_real
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_write_3d_real(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 
00026       use psmile
00027 #ifdef __PSMILE_WITH_IO
00028       implicit none
00029       include 'prism.inc'
00030 !
00031 ! !INPUT PARAMETERS:
00032 !
00033       integer,intent(in) :: unit
00034       Type(fieldtype),intent(in) :: var
00035       Type(domain2D),intent(inout)  :: domain
00036       integer,intent(in) :: a_shape(2,*)
00037       integer,intent(in) :: v_shape(2,*)
00038       real            , intent(inout) :: a(a_shape(1,1):a_shape(2,1)  
00039                                        ,a_shape(1,2):a_shape(2,2)  
00040                                        ,a_shape(1,3):a_shape(2,3)) 
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 a real partitioned 2d 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 !
00066 !EOP
00067 !----------------------------------------------------------------------
00068 
00069       character(len=len_cvs_string),save :: mcvs = 
00070 '$Id: psmile_write_3d_real.F90 2325 2010-04-21 15:00:07Z valcke $'
00071       
00072       ierror=0
00073 
00074 #ifdef VERBOSE
00075       print*,trim(ch_id),' :   psmile_write_3d_real: start'
00076       print*,trim(ch_id),' :   psmile_write_3d_real: size',size(a)
00077       call psmile_flushstd
00078 #endif
00079 
00080 
00081       allocate(atmp(a_shape(1,1):a_shape(2,1)  &
00082                    ,a_shape(1,2):a_shape(2,2)  &
00083                    ,a_shape(1,3):a_shape(2,3)),stat=ierror) 
00084       if ( ierror /= 0 ) then
00085          ierrp (1) = 1
00086          ierror = PRISM_Error_Alloc
00087          call psmile_error ( ierror, 'atmp', ierrp, 1, __FILE__, __LINE__ )
00088          return
00089       endif
00090 
00091       atmp=a
00092 
00093       if(block_used) then
00094       if(id_blockid.le.0) then
00095          ierror = PRISM_Error_Internal
00096          call psmile_error ( ierror, 'id_blockid <= 0! ', &
00097                              ierrp, 0, __FILE__, __LINE__ )
00098       endif
00099 
00100       if(time_used) then
00101         call mpp_write(unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
00102                                              ,v_shape(1,2):v_shape(2,2) &
00103                                              ,v_shape(1,3):v_shape(2,3)) &
00104                                       ,tstamp=time,blockid=id_blockid)
00105       else
00106         call mpp_write( unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
00107                                               ,v_shape(1,2):v_shape(2,2) &
00108                                               ,v_shape(1,3):v_shape(2,3))&
00109                                               ,blockid=id_blockid)
00110       endif
00111       else
00112       if(time_used) then
00113         call mpp_write(unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
00114                                              ,v_shape(1,2):v_shape(2,2) &
00115                                              ,v_shape(1,3):v_shape(2,3)) &
00116                                       ,tstamp=time)
00117       else
00118         call mpp_write( unit,var,domain,atmp(v_shape(1,1):v_shape(2,1) &
00119                                               ,v_shape(1,2):v_shape(2,2) &
00120                                               ,v_shape(1,3):v_shape(2,3)))
00121       endif
00122       endif
00123 
00124       deallocate(atmp,stat=ierror)
00125 
00126       if ( ierror /= 0 ) then
00127          ierrp (1) = 1
00128          ierror = PRISM_Error_Alloc
00129          call psmile_error ( ierror, 'deallocate(atmp)', ierrp, 1, __FILE__ &
00130                            , __LINE__ )
00131          return
00132       endif
00133 
00134 #ifdef __PSMILE_IO_SYNC
00135       call mpp_flush(unit)
00136 #endif
00137 
00138 #ifdef VERBOSE
00139       print*,trim(ch_id),' :   psmile_write_3d_real: end'
00140       call psmile_flushstd
00141 
00142 #endif
00143 #endif
00144       end subroutine psmile_write_3d_real