psmile_write_2d_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_2d_real
00008 !
00009 ! !INTERFACE:
00010 
00011 
00012       subroutine psmile_write_2d_real(unit                &
00013                                      ,var                 &
00014                                      ,domain              &
00015                                      ,ain                   &
00016                                      ,a_shape             &
00017                                      ,v_shape             &
00018                                      ,time                &
00019                                      ,time_used           &
00020                                      ,id_blockid          &
00021                                      ,block_used          &
00022                                      ,ierror)
00023 !
00024 ! !USES:
00025 !
00026 
00027       use psmile
00028 #ifdef __PSMILE_WITH_IO
00029 
00030       implicit none
00031       include 'prism.inc'
00032 !
00033 ! !INPUT PARAMETERS:
00034 !
00035       integer,intent(in)           :: unit
00036       Type(fieldtype),intent(in)   :: var
00037       Type(domain2D),intent(inout) :: domain
00038       integer,intent(in)           :: a_shape(2,*)
00039       integer,intent(in)           :: v_shape(2,*)
00040       real , intent(inout) :: ain(a_shape(1,1):a_shape(2,1)  
00041                                  ,a_shape(1,2):a_shape(2,2)) 
00042       double precision, intent(in):: time
00043       logical,intent(in) :: time_used
00044       integer,intent(in) :: id_blockid
00045       logical,intent(in) :: block_used
00046 !
00047 ! !OUTPUT PARAMETERS:
00048 !
00049 
00050       integer, intent(out) :: ierror
00051 !
00052 ! !LOCAL VARIABLES
00053 !
00054       double precision     :: a(v_shape(1,1):v_shape(2,1)  
00055                                ,v_shape(1,2):v_shape(2,2)) 
00056       integer::ierrp(2)
00057 !
00058 ! !DESCRIPTION:
00059 !
00060 ! Writes a real partitioned 2d array to a file.
00061 ! Subblocks are supported.
00062 !
00063 ! !REVISION HISTORY:
00064 !
00065 !   Date      Programmer   Description
00066 ! ----------  ----------   -----------
00067 !  09.12.03   R. Vogelsang created
00068 !
00069 !EOP
00070 !----------------------------------------------------------------------
00071 
00072       character(len=len_cvs_string),save :: mcvs = 
00073 '$Id: psmile_write_2d_real.F90 2325 2010-04-21 15:00:07Z valcke $'
00074       
00075       ierror=0
00076 
00077 #ifdef VERBOSE
00078       print*,trim(ch_id),' :   psmile_write_2d_real: start'
00079       print*,trim(ch_id),' :   psmile_write_2d_real: v_shape,a_shape' &
00080                         ,v_shape(1:2,1:2),a_shape(1:2,1:2)
00081       call psmile_flushstd
00082 
00083 #endif
00084 
00085       ! The Cray pointer used in subroutine MPP_WRITE_2DDECOMP_2D_
00086       ! (file mpp_write_2Ddecomp.h) does not work properly with all
00087       ! compilers when a_shape and v_shape are different, and both
00088       ! ain and a are declared over a_shape, but only the v_shape
00089       ! array section is transferred to mpp_write. We therefore
00090       ! have to extract the v_shape array section and copy that
00091       ! into an array dimensioned with v_shape and pass this
00092       ! to mpp_write.  
00093 
00094         a(v_shape(1,1):v_shape(2,1),v_shape(1,2):v_shape(2,2)) = &
00095       ain(v_shape(1,1):v_shape(2,1),v_shape(1,2):v_shape(2,2))
00096 
00097       if(block_used) then
00098       if(id_blockid.le.0) then
00099          ierror = PRISM_Error_Internal
00100          call psmile_error ( ierror, 'id_blockid <= 0! ', &
00101                              ierrp, 0, __FILE__, __LINE__ )
00102       endif
00103       if(time_used) then
00104         call mpp_write( unit,var,domain,a,tstamp=time,blockid=id_blockid )
00105       else
00106         call mpp_write( unit,var,domain,a,blockid=id_blockid )
00107       endif
00108       else
00109       if(time_used) then
00110         call mpp_write( unit,var,domain,a,tstamp=time )
00111       else
00112         call mpp_write( unit,var,domain,a )
00113       endif
00114       endif
00115 #ifdef __PSMILE_IO_SYNC
00116       call mpp_flush(unit)
00117 #endif
00118 
00119 #ifdef VERBOSE
00120       print*,trim(ch_id),' :   psmile_write_2d_real: end'
00121       call psmile_flushstd
00122 
00123 #endif
00124 
00125 #endif
00126       end subroutine psmile_write_2d_real