psmile_close_files_byid.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_Close_File_byid
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_close_file_byid ( id_varid,id_taskid, ierror )
00012 !
00013 ! !USES:
00014 !
00015       use PSMILe, dummy_interface => PSMILE_Close_File_byid
00016       implicit none
00017       include 'prism.inc'
00018 
00019 !
00020 ! !INPUT PARAMETERS:
00021 !
00022       Integer, Intent (In)            :: id_varid
00023       Integer, Intent (In)            :: id_taskid
00024 ! !OUTPUT PARAMETERS:
00025       Integer, Intent (Out)           :: ierror
00026       
00027 !
00028 ! !LOCAL VARIABLES
00029 !
00030 
00031       integer                             :: ierrp(3)
00032       integer                             :: iicomp_id,il_i
00033       logical                 :: ll_open
00034       Type(IO_Data),Pointer               :: pl_io_info
00035 !
00036 ! !DESCRIPTION:
00037 !
00038 ! Closes a file associated with a field(id_varid)
00039 !
00040 !
00041 ! !REVISION HISTORY:
00042 !
00043 !   Date      Programmer   Description
00044 ! ----------  ----------   -----------
00045 ! 05.11.03    R. Vogelsang created
00046 ! 09.12.03    R. Vogelsang ProTeX header added
00047 ! 23.3.04     R. Vogelsang Added the taskid to the interface and related code.
00048 !
00049 !EOP
00050 !----------------------------------------------------------------------
00051 
00052        Character(len=len_cvs_string),save :: open_by_id= 
00053 '$Id: psmile_close_files_byid.F90 2325 2010-04-21 15:00:07Z valcke $'
00054 
00055       ierror = 0
00056 #ifdef __PSMILE_WITH_IO
00057 #ifdef VERBOSE
00058       print*,trim(ch_id),' : PSMILe_Close_File_byid: start'
00059       call psmile_flushstd
00060 #endif
00061 
00062       if (.not.associated(Fields)) then
00063 
00064          ierror = PRISM_Error_Internal
00065          call psmile_error ( ierror, 'Fields not allocated ', &
00066                              ierrp, 0, __FILE__, __LINE__ )
00067       endif
00068       if ( (id_varid .gt. Size(Fields)).or.(id_varid.lt.1) .or. &
00069            (Fields(id_varid)%status .eq. PSMILe_Status_undefined) ) then
00070 
00071          ierror = PRISM_Error_Internal
00072          call psmile_error ( ierror, 'Fields(varid) status undefined ', &
00073                              ierrp, 0, __FILE__, __LINE__ )
00074       endif
00075 
00076        
00077       if (.not.associated(Fields(id_varid)%io_chan_infos)) then
00078 
00079          ierror = PRISM_Error_Internal
00080          call psmile_error ( ierror, 'Fields has no I/O infos! ', &
00081                              ierrp, 0, __FILE__, __LINE__ )
00082       endif
00083 
00084 !
00085 !     IO infos are pointing to io_chan_infos(taskid)
00086 !
00087       if(id_taskid .le. size(Fields(id_varid)%io_task_lookup)) then
00088 
00089         il_i=Fields(id_varid)%io_task_lookup(id_taskid)
00090 
00091       else
00092 
00093         ierror = PRISM_Error_IO_Meta
00094         ierrp (1) = id_taskid
00095         call psmile_error ( ierror &
00096                           , 'Task id out of range! ', &
00097                             ierrp, 1, __FILE__, __LINE__ )
00098         return
00099 
00100       endif
00101 
00102       if (il_i.gt.0) then
00103 
00104          Fields(id_varid)%io_infos =>  Fields(id_varid)%io_chan_infos(il_i)
00105 
00106       else
00107         ierror = PRISM_Error_IO_Meta
00108         ierrp (1) = id_taskid
00109         call psmile_error ( ierror &
00110                           , 'Negative task id! ', &
00111                             ierrp, 1, __FILE__, __LINE__ )
00112         return
00113       endif
00114 
00115       pl_io_info => Fields(id_varid)%io_infos
00116 
00117       iicomp_id=Fields(id_varid)%comp_id
00118       if(.not.associated(IO_Comps_infos(iicomp_id)%pelist)) then
00119         ierror=PRISM_Error_IO_Domain
00120         ierrp(1)=iicomp_id
00121         call psmile_error ( ierror &
00122                          ,'pelist for component does not exist!' &
00123                          ,ierrp, 1, __FILE__,__LINE__)
00124       endif
00125 
00126       call mpp_set_current_pelist(IO_Comps_infos(iicomp_id)%pelist)
00127 
00128       ll_open=pl_io_info%opened
00129       if(pl_io_info%format.ne.MPP_NETCDF) &
00130         inquire(unit=pl_io_info%file_unit,opened=ll_open)
00131 
00132 #ifdef VERBOSE
00133         print*,trim(ch_id),' : PSMILe_Close_File_byid: mpp_close: ' &
00134               ,id_varid,pl_io_info%file_unit,trim(pl_io_info%filename) &
00135               ,ll_open,pl_io_info%current_filesize
00136         call psmile_flushstd
00137 #endif
00138 
00139       if(ll_open) then
00140 !RV    If the filesize is zero it might be that the file has not been
00141 !RV    initialized, means that the first mpp_write has not been issued.
00142 !RV    Therfore, don't call mpp_flush.
00143         if(pl_io_info%current_filesize.gt.0) &
00144           call mpp_flush(pl_io_info%file_unit)
00145         call mpp_close(pl_io_info%file_unit)
00146         pl_io_info%opened=.false.
00147       endif
00148 
00149 #ifdef VERBOSE
00150       print*,trim(ch_id),' : PSMILe_Close_File_byid: end'
00151       call psmile_flushstd
00152 #endif
00153 
00154 #endif
00155       end subroutine PSMILe_Close_File_byid