psmile_write_4d_dble.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_dble
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_write_4d_dble(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 
00029       implicit none
00030       include 'prism.inc'
00031 !
00032 ! !INPUT PARAMETERS:
00033 !
00034       integer,intent(in)           :: unit
00035       Type(fieldtype),intent(in)   :: var
00036       Type(domain2D),intent(inout) :: domain
00037       integer,intent(in)           :: a_shape(2,*)
00038       integer,intent(in)           :: v_shape(2,*)
00039       double precision, intent(inout) :: a(a_shape(1,1):a_shape(2,1)  
00040                                        ,a_shape(1,2):a_shape(2,2)  
00041                                        ,a_shape(1,3):a_shape(2,3)  
00042                                        ,a_shape(1,4):a_shape(2,4)) 
00043       double precision, intent(in) :: time
00044       logical,intent(in):: time_used
00045       integer,intent(in)::id_blockid
00046       logical,intent(in)::block_used
00047 !
00048 ! !OUTPUT PARAMETERS:
00049 !
00050 
00051       integer, intent(out) :: ierror
00052 !
00053 ! !LOCAL VARIABLES
00054 !
00055       integer::ierrp(2)
00056 !
00057 ! !DESCRIPTION:
00058 !
00059 ! Writes a double precision partitioned 4d array to a file.
00060 ! Subblocks are supported.
00061 !
00062 ! !REVISION HISTORY:
00063 !
00064 !   Date      Programmer   Description
00065 ! ----------  ----------   -----------
00066 !  09.12.03   R. Vogelsang created
00067 !
00068 !EOP
00069 !----------------------------------------------------------------------
00070 
00071       character(len=len_cvs_string),save :: mcvs = 
00072 '$Id: psmile_write_4d_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
00073       
00074       ierror=0
00075 
00076 #ifdef VERBOSE
00077       print*,trim(ch_id),' :   psmile_write_4d_dble: start'
00078       call psmile_flushstd
00079 
00080 #endif
00081 
00082       if(block_used) then
00083       if(id_blockid.le.0) then
00084          ierror = PRISM_Error_Internal
00085          call psmile_error ( ierror, 'id_blockid <= 0! ', &
00086                              ierrp, 0, __FILE__, __LINE__ )
00087       endif
00088 
00089       if(time_used) then
00090         call mpp_write( unit,var,domain,a(v_shape(1,1):v_shape(2,1) &
00091                                          ,v_shape(1,2):v_shape(2,2) &
00092                                          ,v_shape(1,3):v_shape(2,3) &
00093                                          ,v_shape(1,4):v_shape(2,4)) &
00094                                        ,tstamp=time,blockid=id_blockid)
00095       else
00096         call mpp_write( unit,var,domain,a(v_shape(1,1):v_shape(2,1) &
00097                                          ,v_shape(1,2):v_shape(2,2) &
00098                                          ,v_shape(1,3):v_shape(2,3) &
00099                                          ,v_shape(1,4):v_shape(2,4))&
00100                                          ,blockid=id_blockid)
00101       endif
00102       else
00103       if(time_used) then
00104         call mpp_write( unit,var,domain,a(v_shape(1,1):v_shape(2,1) &
00105                                          ,v_shape(1,2):v_shape(2,2) &
00106                                          ,v_shape(1,3):v_shape(2,3) &
00107                                          ,v_shape(1,4):v_shape(2,4)) &
00108                                        ,tstamp=time)
00109       else
00110         call mpp_write( unit,var,domain,a(v_shape(1,1):v_shape(2,1) &
00111                                          ,v_shape(1,2):v_shape(2,2) &
00112                                          ,v_shape(1,3):v_shape(2,3) &
00113                                          ,v_shape(1,4):v_shape(2,4)))
00114       endif
00115       endif
00116 #ifdef __PSMILE_IO_SYNC
00117       call mpp_flush(unit)
00118 #endif
00119 
00120 #ifdef VERBOSE
00121       print*,trim(ch_id),' :   psmile_write_4d_dble: end'
00122       call psmile_flushstd
00123 
00124 #endif
00125 
00126 #endif
00127       end subroutine psmile_write_4d_dble