From 8c86e8d418ad91ed25da7485f63704754ebaf77f Mon Sep 17 00:00:00 2001 From: Bin Liu Date: Thu, 30 Mar 2023 02:29:45 +0000 Subject: [PATCH] Remove the unneeded libsrc/wrflib. --- libsrc/wrflib/CMakeLists.txt | 11 - libsrc/wrflib/ext_ncd_get_dom_ti.code | 157 - libsrc/wrflib/ext_ncd_get_var_td.code | 227 - libsrc/wrflib/ext_ncd_get_var_ti.code | 174 - libsrc/wrflib/ext_ncd_put_dom_ti.code | 164 - libsrc/wrflib/ext_ncd_put_var_td.code | 233 - libsrc/wrflib/ext_ncd_put_var_ti.code | 144 - libsrc/wrflib/field_routines.F90 | 175 - libsrc/wrflib/io_int_stubs.f90 | 157 - libsrc/wrflib/model_data_order.inc | 8 - libsrc/wrflib/module_driver_constants.F90 | 180 - libsrc/wrflib/module_machine.F90 | 175 - libsrc/wrflib/pack_utils.c | 390 - libsrc/wrflib/streams.h | 16 - libsrc/wrflib/transpose.code | 40 - libsrc/wrflib/wrf_io.F90.orig | 3685 ---------- libsrc/wrflib/wrf_io.f90 | 8169 --------------------- libsrc/wrflib/wrf_io_flags.h | 15 - libsrc/wrflib/wrf_status_codes.h | 133 - 19 files changed, 14253 deletions(-) delete mode 100644 libsrc/wrflib/CMakeLists.txt delete mode 100644 libsrc/wrflib/ext_ncd_get_dom_ti.code delete mode 100644 libsrc/wrflib/ext_ncd_get_var_td.code delete mode 100644 libsrc/wrflib/ext_ncd_get_var_ti.code delete mode 100644 libsrc/wrflib/ext_ncd_put_dom_ti.code delete mode 100644 libsrc/wrflib/ext_ncd_put_var_td.code delete mode 100644 libsrc/wrflib/ext_ncd_put_var_ti.code delete mode 100644 libsrc/wrflib/field_routines.F90 delete mode 100755 libsrc/wrflib/io_int_stubs.f90 delete mode 100644 libsrc/wrflib/model_data_order.inc delete mode 100644 libsrc/wrflib/module_driver_constants.F90 delete mode 100644 libsrc/wrflib/module_machine.F90 delete mode 100644 libsrc/wrflib/pack_utils.c delete mode 100644 libsrc/wrflib/streams.h delete mode 100644 libsrc/wrflib/transpose.code delete mode 100644 libsrc/wrflib/wrf_io.F90.orig delete mode 100644 libsrc/wrflib/wrf_io.f90 delete mode 100644 libsrc/wrflib/wrf_io_flags.h delete mode 100644 libsrc/wrflib/wrf_status_codes.h diff --git a/libsrc/wrflib/CMakeLists.txt b/libsrc/wrflib/CMakeLists.txt deleted file mode 100644 index a5e6358025..0000000000 --- a/libsrc/wrflib/CMakeLists.txt +++ /dev/null @@ -1,11 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -file(GLOB WRFLIB_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90) -file(GLOB WRFLIB_C_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.c) -set_source_files_properties( ${WRFLIB_SRC} PROPERTIES COMPILE_FLAGS ${WRFLIB_Fortran_FLAGS} ) -set(WRFLIB_C_FLAGS "${WRFLIB_C_INCLUDES} -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'") -set_source_files_properties( ${WRFLIB_C_SRC} PROPERTIES COMPILE_FLAGS ${WRFLIB_C_FLAGS} ) -set( wrflib "WRFLIB" CACHE INTERNAL "WRF Library for I/O" ) -include_directories(${NETCDF_INCLUDE_DIRS}) -add_library( ${wrflib} STATIC ${WRFLIB_SRC} ${WRFLIB_C_SRC} ) -set_target_properties( ${wrflib} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - diff --git a/libsrc/wrflib/ext_ncd_get_dom_ti.code b/libsrc/wrflib/ext_ncd_get_dom_ti.code deleted file mode 100644 index fe365f153c..0000000000 --- a/libsrc/wrflib/ext_ncd_get_dom_ti.code +++ /dev/null @@ -1,157 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - TYPE_BUFFER - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,Buffer) -#else - Data = '' - stat = NF_GET_ATT_TEXT(DH%NCID,NF_GLOBAL,Element,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - COPY - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif -ENDIF - return diff --git a/libsrc/wrflib/ext_ncd_get_var_td.code b/libsrc/wrflib/ext_ncd_get_var_td.code deleted file mode 100644 index bd28dc38a3..0000000000 --- a/libsrc/wrflib/ext_ncd_get_var_td.code +++ /dev/null @@ -1,227 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - TYPE_BUFFER ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = LENGTH - VCount(2) = 1 -#ifndef CHAR_TYPE - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE (NCID,VarID,VStart,VCount,Buffer) -#else - if(Len1 > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - Data = '' - stat = NF_GET_VARA_TEXT (NCID,VarID,VStart,VCount,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - COPY - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return diff --git a/libsrc/wrflib/ext_ncd_get_var_ti.code b/libsrc/wrflib/ext_ncd_get_var_ti.code deleted file mode 100644 index 47a161ba99..0000000000 --- a/libsrc/wrflib/ext_ncd_get_var_ti.code +++ /dev/null @@ -1,174 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - TYPE_BUFFER - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif -#ifndef CHAR_TYPE - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) -#else - if(XLen > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Data ) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - endif - COPY -#ifndef CHAR_TYPE - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/libsrc/wrflib/ext_ncd_put_dom_ti.code b/libsrc/wrflib/ext_ncd_put_dom_ti.code deleted file mode 100644 index 2d5b1a3e9e..0000000000 --- a/libsrc/wrflib/ext_ncd_put_dom_ti.code +++ /dev/null @@ -1,164 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif -ENDIF - return diff --git a/libsrc/wrflib/ext_ncd_put_var_td.code b/libsrc/wrflib/ext_ncd_put_var_td.code deleted file mode 100644 index 750e1ecd37..0000000000 --- a/libsrc/wrflib/ext_ncd_put_var_td.code +++ /dev/null @@ -1,233 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(LENGTH < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == LENGTH) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),LENGTH,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = LENGTH - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = LENGTH - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_TYPE,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - if(LENGTH > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(LENGTH < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = LENGTH - VCount(2) = 1 -#ifdef LOG - allocate(Buffer(LENGTH), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/libsrc/wrflib/ext_ncd_put_var_ti.code b/libsrc/wrflib/ext_ncd_put_var_ti.code deleted file mode 100644 index 05bfc64ca3..0000000000 --- a/libsrc/wrflib/ext_ncd_put_var_ti.code +++ /dev/null @@ -1,144 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo -#endif -#ifdef CHAR_TYPE - if(len_trim(Data).le.0) then - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element),len_trim(null),null) - else - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS ) - endif -#else - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS ) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif -#ifdef LOG - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/libsrc/wrflib/field_routines.F90 b/libsrc/wrflib/field_routines.F90 deleted file mode 100644 index cd9bcfa7bf..0000000000 --- a/libsrc/wrflib/field_routines.F90 +++ /dev/null @@ -1,175 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- -subroutine ext_ncd_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - real, dimension(*) ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_REAL(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_REAL(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_RealFieldIO - -subroutine ext_ncd_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - real*8 ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_DoubleFieldIO - -subroutine ext_ncd_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - integer ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_IntFieldIO - -subroutine ext_ncd_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer,dimension(NVarDims) ,intent(in) :: VStart - integer,dimension(NVarDims) ,intent(in) :: VCount - logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data - integer ,intent(out) :: Status - integer,dimension(:,:,:),allocatable :: Buffer - integer :: stat - integer :: i,j,k - - allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(IO == 'write') then - do k=1,VCount(3) - do j=1,VCount(2) - do i=1,VCount(1) - if(data(i,j,k)) then - Buffer(i,j,k)=1 - else - Buffer(i,j,k)=0 - endif - enddo - enddo - enddo - stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Buffer) - else - stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Buffer) - Data = Buffer == 1 - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_LogicalFieldIO diff --git a/libsrc/wrflib/io_int_stubs.f90 b/libsrc/wrflib/io_int_stubs.f90 deleted file mode 100755 index 83c580a57d..0000000000 --- a/libsrc/wrflib/io_int_stubs.f90 +++ /dev/null @@ -1,157 +0,0 @@ -! Stubs version of wrf io spi subroutines -! -!--- get_dom_ti_real -SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) :: Element - REAL , INTENT(INOUT) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER , INTENT(INOUT) :: Outcount - INTEGER , INTENT(INOUT) :: Status - - write(6,*) 'Calling dummy 1' -RETURN -END SUBROUTINE ext_int_get_dom_ti_real - - -SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) - - write(6,*) 'Calling dummy 2' -RETURN -END SUBROUTINE ext_int_get_dom_ti_integer - - -!--- get_dom_ti_char -SUBROUTINE ext_int_get_dom_ti_char ( DataHandle,Element, Data, Status ) - write(6,*) 'Calling dummy 3' - -RETURN -END SUBROUTINE ext_int_get_dom_ti_char - - -!--- get_var_info -SUBROUTINE ext_int_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & - DomainStart , DomainEnd , WrfType, Status ) - - write(6,*) 'Calling dummy 4' -RETURN -END SUBROUTINE ext_int_get_var_info - - -!--- read_field -SUBROUTINE ext_int_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd , & - Status ) - write(6,*) 'Calling dummy 5' - RETURN - -END SUBROUTINE ext_int_read_field - - -!--- close -SUBROUTINE ext_int_ioclose ( DataHandle, Status ) - - write(6,*) 'Calling dummy 6' - RETURN -END SUBROUTINE ext_int_ioclose - - -!--- initialize -SUBROUTINE ext_int_ioinit( SysDepInfo, Status ) - - write(6,*) 'Calling dummy 7' -END SUBROUTINE ext_int_ioinit - - - -!--- open_for_read -SUBROUTINE ext_int_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & - DataHandle , Status ) - - write(6,*) 'Calling dummy 8' - RETURN -END SUBROUTINE ext_int_open_for_read - - - -!SUBROUTINE int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & -! DataHandle, Data, Count, code ) - -! write(6,*) 'Calling dummy 9' -!RETURN -!END SUBROUTINE int_get_ti_header_c - - -! NETCDF STUBS -!SUBROUTINE ext_ncd_ioinit(SysDepInfo, Status) - -!RETURN -!END SUBROUTINE ext_ncd_ioinit - - -!subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) - -!RETURN -!END subroutine ext_ncd_open_for_read - - -!subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) - -!RETURN -!END subroutine ext_ncd_get_dom_ti_integer - - -!subroutine ext_ncd_ioclose(DataHandle, Status) - -! return -!end subroutine ext_ncd_ioclose - - -!subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) - -! return -!end subroutine ext_ncd_get_dom_ti_char - - -!subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,Status) - -! return -!end subroutine ext_ncd_get_dom_ti_real - - -!subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder, & -! Stagger,DomainStart,DomainEnd,WrfType,Status) - -! return -!end subroutine ext_ncd_get_var_info - - -!subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & -! IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & -! DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - -! return -!end subroutine ext_ncd_read_field - - -!subroutine wrf_error_fatal(massage) - -!stop -!end subroutine wrf_error_fatal - - -!subroutine int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, & -! DataHandle, Data, Count, code ) -! write(6,*) 'Calling dummy 10' -!RETURN -!END SUBROUTINE int_gen_ti_header_c - - - - - - - diff --git a/libsrc/wrflib/model_data_order.inc b/libsrc/wrflib/model_data_order.inc deleted file mode 100644 index 91a5098b8f..0000000000 --- a/libsrc/wrflib/model_data_order.inc +++ /dev/null @@ -1,8 +0,0 @@ -!STARTOFREGISTRYGENERATEDINCLUDE 'inc/model_data_order.inc' -! -! WARNING This file is generated automatically by use_registry -! using the data base in the file named Registry. -! Do not edit. Your changes to this file will be lost. -! -INTEGER , PARAMETER :: model_data_order = DATA_ORDER_XZY -!ENDOFREGISTRYGENERATEDINCLUDE diff --git a/libsrc/wrflib/module_driver_constants.F90 b/libsrc/wrflib/module_driver_constants.F90 deleted file mode 100644 index e5e7f71872..0000000000 --- a/libsrc/wrflib/module_driver_constants.F90 +++ /dev/null @@ -1,180 +0,0 @@ -!WRF:DRIVER_LAYER:CONSTANTS -! -! This MODULE contains all of the constants used in the model. These -! are separated by usage within the code. - -#define MAX_DOMAINS_F 21 -# define IWORDSIZE 4 -# define DWORDSIZE 8 -# define RWORDSIZE 4 -# define LWORDSIZE 4 - -MODULE module_driver_constants - - ! 0. The following tells the rest of the model what data ordering we are - ! using - - INTEGER , PARAMETER :: DATA_ORDER_XYZ = 1 - INTEGER , PARAMETER :: DATA_ORDER_YXZ = 2 - INTEGER , PARAMETER :: DATA_ORDER_ZXY = 3 - INTEGER , PARAMETER :: DATA_ORDER_ZYX = 4 - INTEGER , PARAMETER :: DATA_ORDER_XZY = 5 - INTEGER , PARAMETER :: DATA_ORDER_YZX = 6 - INTEGER , PARAMETER :: DATA_ORDER_XY = DATA_ORDER_XYZ - INTEGER , PARAMETER :: DATA_ORDER_YX = DATA_ORDER_YXZ - - -#include "model_data_order.inc" - - ! 1. Following are constants for use in defining maximal values for array - ! definitions. - ! - - ! The maximum number of levels in the model is how deeply the domains may - ! be nested. - - INTEGER , PARAMETER :: max_levels = 20 - - ! The maximum number of nests that can depend on a single parent and other way round - - INTEGER , PARAMETER :: max_nests = 20 - - ! The maximum number of parents that a nest can have (simplified assumption -> one only) - - INTEGER , PARAMETER :: max_parents = 1 - - ! The maximum number of domains is how many grids the model will be running. - - INTEGER , PARAMETER :: max_domains = ( MAX_DOMAINS_F - 1 ) / 2 + 1 - - ! The maximum number of nest move specifications allowed in a namelist - - INTEGER , PARAMETER :: max_moves = 50 - - ! The maximum number of eta levels - !DJW 140701 Increased from 501 to 1001 since I can imagine using more than - !501 total vertical levels across multiple nested domains. Now that the - !code is modified to allow specification of all domains eta_levels using a - !array of length max_eta, this will need to be larger. I'll also add a check - !in module_initialize_real to ensure we don't exceed this value. - - INTEGER , PARAMETER :: max_eta = 1001 - - ! The maximum number of ocean levels in the 3d U Miami ocean. - - INTEGER , PARAMETER :: max_ocean = 501 - - ! The maximum number of pressure levels to interpolate to, for diagnostics - - INTEGER , PARAMETER :: max_plevs = 100 - - ! The maximum number of height levels to interpolate to, for diagnostics - - INTEGER , PARAMETER :: max_zlevs = 100 - - ! The maximum number of trackchem - - INTEGER , PARAMETER :: max_trackchem = 100 - - ! The maximum number of outer iterations (for DA minimisation) - - INTEGER , PARAMETER :: max_outer_iterations = 100 - - ! The maximum number of instruments (for radiance DA) - - INTEGER , PARAMETER :: max_instruments = 30 - - ! The maximum number of obs indexes (for conventional DA obs) - - INTEGER , PARAMETER :: num_ob_indexes = 28 - - - ! The maximum number of bogus storms - - INTEGER , PARAMETER :: max_bogus = 5 - - ! The maximum number of fields that can be sent or received in coupled mode - - INTEGER , PARAMETER :: max_cplfld = 20 - - ! The maximum number of domains used by the external model with which wrf is communicating in coupled mode - - INTEGER , PARAMETER :: max_extdomains = 5 - - ! 2. Following related to driver level data structures for DM_PARALLEL communications - -#ifdef DM_PARALLEL - INTEGER , PARAMETER :: max_comms = 1024 -#else - INTEGER , PARAMETER :: max_comms = 1 -#endif - - ! 3. Following is information related to the file I/O. - - ! These are the bounds of the available FORTRAN logical unit numbers for the file I/O. - ! Only logical unit numbers within these bounds will be chosen for I/O unit numbers. - - INTEGER , PARAMETER :: min_file_unit = 10 - INTEGER , PARAMETER :: max_file_unit = 99 - - ! 4. Unfortunately, the following definition is needed here (rather - ! than the more logical place in share/module_model_constants.F) - ! for the namelist reads in frame/module_configure.F, and for some - ! conversions in share/set_timekeeping.F - ! Actually, using it here will mean that we don't need to set it - ! in share/module_model_constants.F, since this file will be - ! included (USEd) in: - ! frame/module_configure.F - ! which will be USEd in: - ! share/module_bc.F - ! which will be USEd in: - ! phys/module_radiation_driver.F - ! which is the other important place for it to be, and where - ! it is passed as a subroutine parameter to any physics subroutine. - ! - ! P2SI is the number of SI seconds in an planetary solar day - ! divided by the number of SI seconds in an earth solar day -#if defined MARS - ! For Mars, P2SI = 88775.2/86400. - REAL , PARAMETER :: P2SI = 1.0274907 -#elif defined TITAN - ! For Titan, P2SI = 1378080.0/86400. - REAL , PARAMETER :: P2SI = 15.95 -#else - ! Default for Earth - REAL , PARAMETER :: P2SI = 1.0 -#endif - CONTAINS - SUBROUTINE init_module_driver_constants - END SUBROUTINE init_module_driver_constants - END MODULE module_driver_constants - -! routines that external packages can call to get at WRF stuff that isn't available -! through argument lists; since they are external we don't want them using WRF -! modules unnecessarily (complicates the build even more) - SUBROUTINE inquire_of_wrf_data_order_xyz( data_order ) - USE module_driver_constants, ONLY : DATA_ORDER_XYZ - IMPLICIT NONE - INTEGER, INTENT(OUT) :: data_order - data_order = DATA_ORDER_XYZ - END SUBROUTINE inquire_of_wrf_data_order_xyz - - SUBROUTINE inquire_of_wrf_data_order_xzy( data_order ) - USE module_driver_constants, ONLY : DATA_ORDER_XZY - IMPLICIT NONE - INTEGER, INTENT(OUT) :: data_order - data_order = DATA_ORDER_XZY - END SUBROUTINE inquire_of_wrf_data_order_xzy - - SUBROUTINE inquire_of_wrf_iwordsize( iwordsz ) - IMPLICIT NONE - INTEGER, INTENT(OUT) :: iwordsz - iwordsz = IWORDSIZE - END SUBROUTINE inquire_of_wrf_iwordsize - - SUBROUTINE inquire_of_wrf_rwordsize( rwordsz ) - IMPLICIT NONE - INTEGER, INTENT(OUT) :: rwordsz - rwordsz = RWORDSIZE - END SUBROUTINE inquire_of_wrf_rwordsize - diff --git a/libsrc/wrflib/module_machine.F90 b/libsrc/wrflib/module_machine.F90 deleted file mode 100644 index 1888337f39..0000000000 --- a/libsrc/wrflib/module_machine.F90 +++ /dev/null @@ -1,175 +0,0 @@ -!WRF:DRIVER_LAYER:DECOMPOSITION -! -# define IWORDSIZE 4 -# define DWORDSIZE 8 -# define RWORDSIZE 4 -# define LWORDSIZE 4 - -MODULE module_machine - - USE module_driver_constants - - ! Machine characteristics and utilities here. - - ! Tile strategy defined constants - INTEGER, PARAMETER :: TILE_NONE = 0, TILE_X = 1, TILE_Y = 2, TILE_XY = 3 - - CONTAINS - - RECURSIVE SUBROUTINE rlocproc(p,maxi,nproc,ml,mr,ret) - IMPLICIT NONE - INTEGER, INTENT(IN) :: p, maxi, nproc, ml, mr - INTEGER, INTENT(OUT) :: ret - INTEGER :: width, rem, ret2, bl, br, mid, adjust, & - p_r, maxi_r, nproc_r, zero - adjust = 0 - rem = mod( maxi, nproc ) - width = maxi / nproc - mid = maxi / 2 - IF ( rem>0 .AND. (((mod(rem,2).EQ.0).OR.(rem.GT.2)).OR.(p.LE.mid))) THEN - width = width + 1 - END IF - IF ( p.LE.mid .AND. mod(rem,2).NE.0 ) THEN - adjust = adjust + 1 - END IF - bl = max(width,ml) ; - br = max(width,mr) ; - IF (pmaxi-br-1) THEN - ret = nproc-1 - ELSE - p_r = p - bl - maxi_r = maxi-bl-br+adjust - nproc_r = max(nproc-2,1) - zero = 0 - CALL rlocproc( p_r, maxi_r, nproc_r, zero, zero, ret2 ) ! Recursive - ret = ret2 + 1 - END IF - RETURN - END SUBROUTINE rlocproc - - INTEGER FUNCTION locproc( i, m, numpart ) - implicit none - integer, intent(in) :: i, m, numpart - integer :: retval, ii, im, inumpart, zero - ii = i - im = m - inumpart = numpart - zero = 0 - CALL rlocproc( ii, im, inumpart, zero, zero, retval ) - locproc = retval - RETURN - END FUNCTION locproc - - SUBROUTINE patchmap( res, y, x, py, px ) - implicit none - INTEGER, INTENT(IN) :: y, x, py, px - INTEGER, DIMENSION(x,y), INTENT(OUT) :: res - INTEGER :: i, j, p_min, p_maj - DO j = 0,y-1 - p_maj = locproc( j, y, py ) - DO i = 0,x-1 - p_min = locproc( i, x, px ) - res(i+1,j+1) = p_min + px*p_maj - END DO - END DO - RETURN - END SUBROUTINE patchmap - - SUBROUTINE region_bounds( region_start, region_end, & - num_p, p, & - patch_start, patch_end ) - ! 1-D decomposition routine: Given starting and ending indices of a - ! vector, the number of patches dividing the vector, and the number of - ! the patch, give the start and ending indices of the patch within the - ! vector. This will work with tiles too. Implementation note. This is - ! implemented somewhat inefficiently, now, with a loop, so we can use the - ! locproc function above, which returns processor number for a given - ! index, whereas what we want is index for a given processor number. - ! With a little thought and a lot of debugging, we can come up with a - ! direct expression for what we want. For time being, we loop... - ! Remember that processor numbering starts with zero. - - IMPLICIT NONE - INTEGER, INTENT(IN) :: region_start, region_end, num_p, p - INTEGER, INTENT(OUT) :: patch_start, patch_end - INTEGER :: offset, i - patch_end = -999999999 - patch_start = 999999999 - offset = region_start - do i = 0, region_end - offset - if ( locproc( i, region_end-region_start+1, num_p ) == p ) then - patch_end = max(patch_end,i) - patch_start = min(patch_start,i) - endif - enddo - patch_start = patch_start + offset - patch_end = patch_end + offset - RETURN - END SUBROUTINE region_bounds - - SUBROUTINE least_aspect( nparts, minparts_y, minparts_x, nparts_y, nparts_x ) - IMPLICIT NONE - ! Input data. - INTEGER, INTENT(IN) :: nparts, & - minparts_y, minparts_x - ! Output data. - INTEGER, INTENT(OUT) :: nparts_y, nparts_x - ! Local data. - INTEGER :: x, y, mini - mini = 2*nparts - nparts_y = 1 - nparts_x = nparts - DO y = 1, nparts - IF ( mod( nparts, y ) .eq. 0 ) THEN - x = nparts / y - IF ( abs( y-x ) .LT. mini & - .AND. y .GE. minparts_y & - .AND. x .GE. minparts_x ) THEN - mini = abs( y-x ) - nparts_y = y - nparts_x = x - END IF - END IF - END DO - END SUBROUTINE least_aspect - - SUBROUTINE init_module_machine - RETURN - END SUBROUTINE init_module_machine - -END MODULE module_machine - -SUBROUTINE wrf_sizeof_integer( retval ) - IMPLICIT NONE - INTEGER retval -! IWORDSIZE is defined by CPP - retval = IWORDSIZE - RETURN -END SUBROUTINE wrf_sizeof_integer - -SUBROUTINE wrf_sizeof_real( retval ) - IMPLICIT NONE - INTEGER retval -! RWORDSIZE is defined by CPP - retval = RWORDSIZE - RETURN -END SUBROUTINE wrf_sizeof_real - -SUBROUTINE wrf_sizeof_doubleprecision( retval ) - IMPLICIT NONE - INTEGER retval -! DWORDSIZE is defined by CPP - retval = DWORDSIZE - RETURN -END SUBROUTINE wrf_sizeof_doubleprecision - -SUBROUTINE wrf_sizeof_logical( retval ) - IMPLICIT NONE - INTEGER retval -! LWORDSIZE is defined by CPP - retval = LWORDSIZE - RETURN -END SUBROUTINE wrf_sizeof_logical - diff --git a/libsrc/wrflib/pack_utils.c b/libsrc/wrflib/pack_utils.c deleted file mode 100644 index 3caa8cc04f..0000000000 --- a/libsrc/wrflib/pack_utils.c +++ /dev/null @@ -1,390 +0,0 @@ -#ifndef MS_SUA -# include -# include -#endif -#include -#include "streams.h" - -#ifndef CRAY -# ifdef NOUNDERSCORE -# define INT_PACK_DATA int_pack_data -# define INT_GET_TI_HEADER_C int_get_ti_header_c -# define INT_GEN_TI_HEADER_C int_gen_ti_header_c -# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c -# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c -# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c -# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field -# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field -# define PERTURB_REAL perturb_real -# define INSPECT_HEADER inspect_header -# define RESET_MASK reset_mask -# define SET_MASK set_mask -# define GET_MASK get_mask -# else -# ifdef F2CSTYLE -# define INT_PACK_DATA int_pack_data__ -# define INT_GET_TI_HEADER_C int_get_ti_header_c__ -# define INT_GEN_TI_HEADER_C int_gen_ti_header_c__ -# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c__ -# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c__ -# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c__ -# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field__ -# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field__ -# define PERTURB_REAL perturb_real__ -# define INSPECT_HEADER inspect_header__ -# define RESET_MASK reset_mask__ -# define SET_MASK set_mask__ -# define GET_MASK get_mask__ -# else -# define INT_PACK_DATA int_pack_data_ -# define INT_GET_TI_HEADER_C int_get_ti_header_c_ -# define INT_GEN_TI_HEADER_C int_gen_ti_header_c_ -# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c_ -# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c_ -# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c_ -# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field_ -# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field_ -# define PERTURB_REAL perturb_real_ -# define INSPECT_HEADER inspect_header_ -# define RESET_MASK reset_mask_ -# define SET_MASK set_mask_ -# define GET_MASK get_mask_ -# endif -# endif -#endif - -#ifdef MEMCPY_FOR_BCOPY -# define bcopy(A,B,C) memcpy((B),(A),(C)) -#endif - -/* CALL int_pack_data ( hdrbuf , hdrbufsiz * inttypesize , int_local_output_buffer, int_local_output_cursor ) */ - -void INT_PACK_DATA ( unsigned char *buf , int *ninbytes , unsigned char *obuf, int *cursor ) -{ - int i, lcurs ; - lcurs = *cursor - 1 ; - for ( i = 0 ; i < *ninbytes ; i++ ) - { - obuf[lcurs++] = buf[i] ; - } - *cursor = lcurs+1 ; -} - -int -INT_GEN_TI_HEADER_C ( char * hdrbuf, int * hdrbufsize, /* hdrbufsize is in bytes */ - int * itypesize, int * typesize, - int * DataHandle, char * Data, - int * Count, int * code ) -{ - int i ; - char * p ; - p = hdrbuf ; - p += sizeof(int) ; - bcopy( code, p, sizeof(int) ) ; p += sizeof(int) ; /* 2 */ - bcopy( DataHandle, p, sizeof(int) ) ; p += sizeof(int) ; /* 3 */ - bcopy( typesize, p, sizeof(int) ) ; p += sizeof(int) ; /* 4 */ - bcopy( Count, p, sizeof(int) ) ; p += sizeof(int) ; /* 5 */ - bcopy( Data, p, *Count * *typesize ) ; p += *Count * *typesize ; /* 6++ */ - *hdrbufsize = (int) (p - hdrbuf) ; - bcopy( hdrbufsize, hdrbuf, sizeof(int) ) ; - return(0) ; -} - -int -INT_GET_TI_HEADER_C ( char * hdrbuf, int * hdrbufsize, int * n, /* hdrbufsize and n are in bytes */ - int * itypesize, int * typesize, - int * DataHandle, char * Data, - int * Count, int * code ) -{ - int i ; - char * p ; - p = hdrbuf ; - bcopy( p, hdrbufsize, sizeof(int) ) ; p += sizeof(int) ; /* 1 */ - bcopy( p, code, sizeof(int) ) ; p += sizeof(int) ; /* 2 */ - bcopy( p, DataHandle, sizeof(int) ) ; p += sizeof(int) ; /* 3 */ - bcopy( p, typesize, sizeof(int) ) ; p += sizeof(int) ; /* 4 */ - bcopy( p, Count, sizeof(int) ) ; p += sizeof(int) ; /* 5 */ - if ( *Count * *typesize > 0 ) { - bcopy( p, Data, *Count * *typesize ) ; p += *Count * *typesize ; /* 6++ */ - } - *n = (int)( p - hdrbuf ) ; - return(0) ; -} - -#define MAX_FLDS 2000 -static char fld_name[MAX_FLDS][256] ; -static char *fld_cache[MAX_FLDS] ; -static int fld_curs[MAX_FLDS] ; -static int fld_bufsize[MAX_FLDS] ; -static int fld = 0 ; -static int numflds = 0 ; -static int frst = 1 ; - -int INIT_STORE_PIECE_OF_FIELD () -{ - int i ; - if ( frst ) { - for ( i = 0 ; i < MAX_FLDS ; i++ ) { - fld_cache[i] = NULL ; - } - frst = 0 ; - } - numflds = 0 ; - for ( i = 0 ; i < MAX_FLDS ; i++ ) { - strcpy( fld_name[i], "" ) ; - if ( fld_cache[i] != NULL ) free( fld_cache[i] ) ; - fld_cache[i] = NULL ; - fld_curs[i] = 0 ; - fld_bufsize[i] = 0 ; - } - return(0) ; -} - -int INIT_RETRIEVE_PIECES_OF_FIELD () -{ - fld = 0 ; - return(0) ; -} - -int -ADD_TO_BUFSIZE_FOR_FIELD_C ( int varname[], int * chunksize ) -{ - int i, n ; - int found ; - char vname[256] ; - - n = varname[0] ; - for ( i = 1; i <= n ; i++ ) { vname[i-1] = varname[i] ; } - vname[n] = '\0' ; - - found = -1 ; - for ( i = 0 ; i < numflds ; i++ ) { if ( !strcmp( fld_name[i], vname ) ) { found = i ; break ; } } - if ( found == -1 ) { - found = numflds++ ; - strcpy( fld_name[found], vname ) ; - fld_bufsize[found] = *chunksize ; - } - else - { - fld_bufsize[found] += *chunksize ; - } - if ( fld_cache[found] != NULL ) { free( fld_cache[found] ) ; } - fld_cache[found] = NULL ; - return(0) ; -} - -int -STORE_PIECE_OF_FIELD_C ( char * buf , int varname[], int * chunksize, int *retval ) -{ - int i, n ; - int found ; - char vname[256] ; - - n = varname[0] ; - for ( i = 1; i <= n ; i++ ) { vname[i-1] = varname[i] ; } - vname[n] = '\0' ; - - found = -1 ; - for ( i = 0 ; i < numflds ; i++ ) { if ( !strcmp( fld_name[i], vname ) ) { found = i ; break ; } } - if ( found == -1 ) { -#ifndef MS_SUA - fprintf(stderr,"frame/pack_utils.c: field (%s) not found; was not set up with add_to_bufsize_for_field\n",vname ) ; -#endif - *retval = 1 ; - return(0) ; - } - - if ( fld_cache[found] == NULL ) { - fld_cache[found] = (char *) malloc( fld_bufsize[found] ) ; - fld_curs[found] = 0 ; - } - - if ( fld_curs[found] + *chunksize > fld_bufsize[found] ) { -#ifndef MS_SUA - fprintf(stderr, -"frame/pack_utils.c: %s would overwrite %d + %d > %d [%d]\n",vname, fld_curs[found], *chunksize, fld_bufsize[found], found ) ; -#endif - *retval = 1 ; - return(0) ; - } - - bcopy( buf, fld_cache[found]+fld_curs[found], *chunksize ) ; - fld_curs[found] += *chunksize ; - *retval = 0 ; - return(0) ; -} - -int -RETRIEVE_PIECES_OF_FIELD_C ( char * buf , int varname[], int * insize, int * outsize, int *retval ) -{ - int i, n ; - int found ; - char vname[256] ; - - if ( fld < numflds ) { -#ifndef MS_SUA - if ( fld_curs[fld] > *insize ) { - fprintf(stderr,"retrieve: fld_curs[%d] (%d) > *insize (%d)\n",fld,fld_curs[fld], *insize ) ; - } -#endif - *outsize = ( fld_curs[fld] <= *insize ) ? fld_curs[fld] : *insize ; - bcopy( fld_cache[fld], buf, *outsize ) ; - varname[0] = (int) strlen( fld_name[fld] ) ; - for ( i = 1 ; i <= varname[0] ; i++ ) varname[i] = fld_name[fld][i-1] ; - if ( fld_cache[fld] != NULL ) free ( fld_cache[fld] ) ; - fld_cache[fld] = NULL ; - fld_bufsize[fld] = 0 ; - fld++ ; - *retval = 0 ; - } - else { - numflds = 0 ; - *retval = -1 ; - } - return(0) ; -} - -#define INDEX_2(A,B,NB) ( (B) + (A)*(NB) ) -#define INDEX_3(A,B,C) INDEX_2( (A), INDEX_2( (B), (C), (me[1]-ms[1]+1) ), (me[1]-ms[1]+1)*(me[0]-ms[0]+1) ) -/* flip low order bit of fp number */ -int -PERTURB_REAL ( float * field, int ds[], int de[], int ms[], int me[], int ps[], int pe[] ) -{ - int i,j,k ; - int le ; /* index of little end */ - float x = 2.0 ; - unsigned int y ; - unsigned char a[4], *p ; - if ( sizeof(float) != 4 ) return(-1) ; - /* check endianness of machine */ - bcopy ( &x, a, 4 ) ; - le = 0 ; - if ( a[0] == 0x40 ) le = 3 ; - for ( k = ps[2]-ms[2] ; k <= pe[2]-ms[2] ; k++ ) - for ( j = ps[1]-ms[1] ; j <= pe[1]-ms[1] ; j++ ) - for ( i = ps[0]-ms[0] ; i <= pe[0]-ms[0] ; i++ ) - { - /* do not change zeros */ - if ( field[ INDEX_3(k,j,i) ] != 0.0 ) { - p = (unsigned char *)&(field[ INDEX_3(k,j,i) ] ) ; - if ( *(p+le) & 1 ) { *(p+le) &= 0x7e ; } - else { *(p+le) |= 1 ; } - } - } - return(0) ; -} - -int INSPECT_HEADER ( char * buf, int * sz, int * line ) -{ - int i ; -#ifndef MS_SUA - fprintf(stderr,"INSPECT_HEADER: line = %d ", *line ) ; - if ( buf != NULL && sz != NULL ) { - for ( i = 0 ; i < *sz && i < 256 ; i++ ) { if ( (buf[i] >= 'a' && buf[i] <= 'z') || buf[i] == '_' || - (buf[i] >= 'A' && buf[i] <= 'Z') || - (buf[i] >= '0' && buf[i] <= '9') ) fprintf(stderr,"%c",buf[i]) ; - } - fprintf(stderr,"\n") ; - } -#endif - return(0) ; -} - -/* note that these work the same as the routines in tools/misc.c, but are Fortran callable. - They must be kept in sync, functionally. */ - -void -RESET_MASK ( unsigned int * mask , int *e ) -{ - int w ; - unsigned int m, n ; - - w = *e / (8*sizeof(int)-1) ; - n = 1 ; - m = ~( n << *e % (8*sizeof(int)-1) ) ; - if ( w >= 0 && w < IO_MASK_SIZE ) { - mask[w] &= m ; - } -} - -void -SET_MASK ( unsigned int * mask , int *e ) -{ - int w ; - unsigned int m, n ; - - w = *e / (8*sizeof(int)-1) ; - n = 1 ; - m = ( n << *e % (8*sizeof(int)-1) ) ; - if ( w >= 0 && w < IO_MASK_SIZE ) { - mask[w] |= m ; - } -} - -/* this is slightly different from in tools dir since it returns result as argument, not function */ -/* definition of IO_MASK_SIZE comes from build and must be uniform with frame/module_domain_type.F and - version of this function in tools dir */ -void -GET_MASK ( unsigned int * mask , int *e , int * retval ) -{ - int w ; - unsigned int m, n ; - - w = *e / (8*sizeof(int)-1) ; /* 8 is number of bits per byte */ - if ( w >= 0 && w < IO_MASK_SIZE ) { - m = mask[w] ; - n = ( 1 << *e % (8*sizeof(int)-1) ) ;; - *retval = ( (m & n) != 0 ) ; - } else { - *retval = 0 ; - } -} - -#ifdef WRAP_MALLOC -# ifndef WRAP_MALLOC_ALIGNMENT -# define WRAP_MALLOC_ALIGNMENT 128 -# endif -# define _XOPEN_SOURCE 600 -# include -void *malloc(size_t size) -{ - void *tmp; - if (posix_memalign(&tmp, WRAP_MALLOC_ALIGNMENT, size) == 0) - return tmp; - else { - errno = ENOMEM; - return NULL; - } -} -#endif - -#ifndef DM_PARALLEL -# ifndef CRAY -# ifdef NOUNDERSCORE -# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock -# else -# ifdef F2CSTYLE -# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock__ -# else -# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock_ -# endif -# endif -# endif -# if !defined(MS_SUA) && !defined(_WIN32) -# include -int RSL_INTERNAL_MICROCLOCK () -{ - struct timeval tb ; - struct timezone tzp ; - int isec ; /* seconds */ - int usec ; /* microseconds */ - int msecs ; - gettimeofday( &tb, &tzp ) ; - isec = tb.tv_sec ; - usec = tb.tv_usec ; - msecs = 1000000 * isec + usec ; - return(msecs) ; -} -# endif -#endif - diff --git a/libsrc/wrflib/streams.h b/libsrc/wrflib/streams.h deleted file mode 100644 index 645b02d855..0000000000 --- a/libsrc/wrflib/streams.h +++ /dev/null @@ -1,16 +0,0 @@ -#ifndef MAX_HISTORY -# define MAX_HISTORY 12 -#endif -#ifndef IWORDSIZE -# define IWORDSIZE 4 -#endif -#define HISTORY_STREAM 0 -#define INPUT_STREAM ((HISTORY_STREAM)+(MAX_HISTORY)) -#if 0 - max streams is MAX_HISTORY plus equal number of input streams plus 1 restart + 1 boundary -#endif -#define MAX_STREAMS (2*(MAX_HISTORY)+2) -#define BOUNDARY_STREAM (2*(MAX_HISTORY)+1) -#define RESTART_STREAM (2*(MAX_HISTORY)+2) -#define IO_MASK_SIZE ((MAX_STREAMS)/(IWORDSIZE*8)+1) - diff --git a/libsrc/wrflib/transpose.code b/libsrc/wrflib/transpose.code deleted file mode 100644 index 746be42fcb..0000000000 --- a/libsrc/wrflib/transpose.code +++ /dev/null @@ -1,40 +0,0 @@ - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 - -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - DFIELD = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = DFIELD - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - - return diff --git a/libsrc/wrflib/wrf_io.F90.orig b/libsrc/wrflib/wrf_io.F90.orig deleted file mode 100644 index 4288b98e68..0000000000 --- a/libsrc/wrflib/wrf_io.F90.orig +++ /dev/null @@ -1,3685 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - -module wrf_data - - integer , parameter :: FATAL = 1 - integer , parameter :: WARN = 1 - integer , parameter :: WrfDataHandleMax = 99 - integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS -#if(WRF_CHEM == 1) - integer , parameter :: MaxVars = 10000 -#else - integer , parameter :: MaxVars = 3000 -#endif - integer , parameter :: MaxTimes = 10000 - integer , parameter :: DateStrLen = 19 - integer , parameter :: VarNameLen = 31 - integer , parameter :: NO_DIM = 0 - integer , parameter :: NVarDims = 4 - integer , parameter :: NMDVarDims = 2 - character (8) , parameter :: NO_NAME = 'NULL' - character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' - -#include "wrf_io_flags.h" - - character (256) :: msg - logical :: WrfIOnotInitialized = .true. - - type :: wrf_data_handle - character (255) :: FileName - integer :: FileStatus - integer :: Comm - integer :: NCID - logical :: Free - logical :: Write - character (5) :: TimesName - integer :: TimeIndex - integer :: CurrentTime !Only used for read - integer :: NumberTimes !Only used for read - character (DateStrLen), pointer :: Times(:) - integer :: TimesVarID - integer , pointer :: DimLengths(:) - integer , pointer :: DimIDs(:) - character (31) , pointer :: DimNames(:) - integer :: DimUnlimID - character (9) :: DimUnlimName - integer , dimension(NVarDims) :: DimID - integer , dimension(NVarDims) :: Dimension - integer , pointer :: MDVarIDs(:) - integer , pointer :: MDVarDimLens(:) - character (80) , pointer :: MDVarNames(:) - integer , pointer :: VarIDs(:) - integer , pointer :: VarDimLens(:,:) - character (VarNameLen), pointer :: VarNames(:) - integer :: CurrentVariable !Only used for read - integer :: NumVars -! first_operation is set to .TRUE. when a new handle is allocated -! or when open-for-write or open-for-read are committed. It is set -! to .FALSE. when the first field is read or written. - logical :: first_operation - logical :: R4OnOutput - logical :: nofill - logical :: use_netcdf_classic - end type wrf_data_handle - type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) -end module wrf_data - -module ext_ncd_support_routines - - implicit none - -CONTAINS - -subroutine allocHandle(DataHandle,DH,Comm,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(out) :: DataHandle - type(wrf_data_handle),pointer :: DH - integer ,intent(IN) :: Comm - integer ,intent(out) :: Status - integer :: i - integer :: stat - - do i=1,WrfDataHandleMax - if(WrfDataHandles(i)%Free) then - DH => WrfDataHandles(i) - DataHandle = i - allocate(DH%Times(MaxTimes), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimLengths(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimIDs(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimNames(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarDimLens(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - exit - endif - if(i==WrfDataHandleMax) then - Status = WRF_WARN_TOO_MANY_FILES - write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) 'Did you call ext_ncd_ioinit?' - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - DH%Free =.false. - DH%Comm = Comm - DH%Write =.false. - DH%first_operation = .TRUE. - DH%R4OnOutput = .false. - DH%nofill = .false. - Status = WRF_NO_ERR -end subroutine allocHandle - -subroutine deallocHandle(DataHandle, Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN - if(.NOT. WrfDataHandles(DataHandle)%Free) then - DH => WrfDataHandles(DataHandle) - deallocate(DH%Times, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimLengths, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - DH%Free =.TRUE. - endif - ENDIF - Status = WRF_NO_ERR -end subroutine deallocHandle - -subroutine GetDH(DataHandle,DH,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - type(wrf_data_handle) ,pointer :: DH - integer ,intent(out) :: Status - - if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - DH => WrfDataHandles(DataHandle) - if(DH%Free) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - Status = WRF_NO_ERR - return -end subroutine GetDH - -subroutine DateCheck(Date,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Date - integer ,intent(out) :: Status - - if(len(Date) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - else - Status = WRF_NO_ERR - endif - return -end subroutine DateCheck - -subroutine GetName(Element,Var,Name,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Name - integer ,intent(out) :: Status - character (VarNameLen) :: VarName - character (1) :: c - integer :: i - integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - - VarName = Var - Name = 'MD___'//trim(Element)//VarName - do i=1,len(Name) - c=Name(i:i) - if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) - if(c=='-'.or.c==':') Name(i:i)='_' - enddo - Status = WRF_NO_ERR - return -end subroutine GetName - -subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: TimeIndex - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VStart(2) - integer :: VCount(2) - integer :: stat - integer :: i - - DH => WrfDataHandles(DataHandle) - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - Status = WRF_WARN_DATESTR_ERROR - write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(IO == 'write') then - TimeIndex = DH%TimeIndex - if(TimeIndex <= 0) then - TimeIndex = 1 - elseif(DateStr == DH%Times(TimeIndex)) then - Status = WRF_NO_ERR - return - else - TimeIndex = TimeIndex +1 - if(TimeIndex > MaxTimes) then - Status = WRF_WARN_TIME_EOF - write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - DH%TimeIndex = TimeIndex - DH%Times(TimeIndex) = DateStr - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = DateStrLen - VCount(2) = 1 - stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - Status = WRF_NO_ERR - TimeIndex = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - return -end subroutine GetTimeIndex - -subroutine GetDim(MemoryOrder,NDim,Status) - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(out) :: NDim - integer ,intent(out) :: Status - character*3 :: MemOrd - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') - NDim = 3 - case ('xy','yx','xs','xe','ys','ye','cc') - NDim = 2 - case ('z','c') - NDim = 1 - case ('0') ! NDim=0 for scalars. TBH: 20060502 - NDim = 0 - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine GetDim - -#ifdef USE_NETCDF4_FEATURES -subroutine set_chunking(MemoryOrder,need_chunking) - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - logical ,intent(out) :: need_chunking - character*3 :: MemOrd - - call LowerCase(MemoryOrder,MemOrd) - if(len(MemOrd) >= 2) then - select case (MemOrd) - case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') - need_chunking = .true. - case ('xy','yx') - need_chunking = .true. - case default - need_chunking = .false. - return - end select - endif -end subroutine set_chunking -#endif - -subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) - integer ,intent(in) :: NDim - integer ,dimension(*),intent(in) :: Start,End - integer ,intent(out) :: i1,i2,j1,j2,k1,k2 - - i1=1 - i2=1 - j1=1 - j2=1 - k1=1 - k2=1 - if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502 - i1 = Start(1) - i2 = End (1) - if(NDim == 1) return - j1 = Start(2) - j2 = End (2) - if(NDim == 2) return - k1 = Start(3) - k2 = End (3) - return -end subroutine GetIndices - -logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(in) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - logical zero_length - - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - zero_length = .false. - select case (MemOrd) - case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy','yzx') - zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1 - case ('xy','yx','xyz','yxz') - zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1 - case ('zxy','zyx') - zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1 - case default - Status = WRF_WARN_BAD_MEMORYORDER - ZeroLengthHorzDim = .true. - return - end select - Status = WRF_NO_ERR - ZeroLengthHorzDim = zero_length - return -end function ZeroLengthHorzDim - -subroutine ExtOrder(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(inout) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy') - Vector(2) = temp(3) - Vector(3) = temp(2) - case ('yxz') - Vector(1) = temp(2) - Vector(2) = temp(1) - case ('yzx') - Vector(1) = temp(3) - Vector(2) = temp(1) - Vector(3) = temp(2) - case ('zxy') - Vector(1) = temp(2) - Vector(2) = temp(3) - Vector(3) = temp(1) - case ('zyx') - Vector(1) = temp(3) - Vector(3) = temp(1) - case ('yx') - Vector(1) = temp(2) - Vector(2) = temp(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrder - -subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - character*(*),dimension(*) ,intent(in) :: Vector - character(80),dimension(NVarDims),intent(out) :: ROVector - integer ,intent(out) :: Status - integer :: NDim - character*3 :: MemOrd - - call GetDim(MemoryOrder,NDim,Status) - ROVector(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy') - ROVector(2) = Vector(3) - ROVector(3) = Vector(2) - case ('yxz') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case ('yzx') - ROVector(1) = Vector(3) - ROVector(2) = Vector(1) - ROVector(3) = Vector(2) - case ('zxy') - ROVector(1) = Vector(2) - ROVector(2) = Vector(3) - ROVector(3) = Vector(1) - case ('zyx') - ROVector(1) = Vector(3) - ROVector(3) = Vector(1) - case ('yx') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrderStr - - -subroutine LowerCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - integer :: i,N - - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) - enddo - return -end subroutine LowerCase - -subroutine UpperCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') - integer :: i,N - - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) - enddo - return -end subroutine UpperCase - -subroutine netcdf_err(err,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: err - integer ,intent(out) :: Status - character(len=80) :: errmsg - integer :: stat - - if( err==NF_NOERR )then - Status = WRF_NO_ERR - else - errmsg = NF_STRERROR(err) - write(msg,*) 'NetCDF error: ',errmsg - call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_WARN_NETCDF - endif - return -end subroutine netcdf_err - -subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder & - ,FieldType,NCID,VarID,XField,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer,dimension(NVarDims),intent(in) :: Length - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: FieldType - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer,dimension(*) ,intent(inout) :: XField - integer ,intent(out) :: Status - integer :: TimeIndex - integer :: NDim - integer,dimension(NVarDims) :: VStart - integer,dimension(NVarDims) :: VCount -! include 'wrf_io_flags.h' - - call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' Bad time index for DateStr = ',DateStr - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - VStart(:) = 1 - VCount(:) = 1 - VStart(1:NDim) = 1 - VCount(1:NDim) = Length(1:NDim) - VStart(NDim+1) = TimeIndex - VCount(NDim+1) = 1 - - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN - call ext_ncd_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_DOUBLE) THEN - call ext_ncd_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_INTEGER) THEN - call ext_ncd_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_LOGICAL) THEN - call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - if(Status /= WRF_NO_ERR) return - ELSE - write(6,*) 'WARNING---- some missing calls commented out' - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - END IF - - return -end subroutine FieldIO - -subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) -!jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2) - integer ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - -#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - - case ('xzy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,k,j)) -#include "transpose.code" - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,j,k)) -#include "transpose.code" - case ('yxz') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - case ('zxy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,i,j)) -#include "transpose.code" - case ('yzx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,k,i)) -#include "transpose.code" - case ('zyx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,j,i)) -#include "transpose.code" - case ('yx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - end select - return -end subroutine Transpose - -subroutine reorder (MemoryOrder,MemO) - character*(*) ,intent(in) :: MemoryOrder - character*3 ,intent(out) :: MemO - character*3 :: MemOrd - integer :: N,i,i1,i2,i3 - - MemO = MemoryOrder - N = len_trim(MemoryOrder) - if(N == 1) return - call lowercase(MemoryOrder,MemOrd) -! never invert the boundary codes - select case ( MemOrd ) - case ( 'xsz','xez','ysz','yez' ) - return - case default - continue - end select - i1 = 1 - i3 = 1 - do i=2,N - if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i - if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i - enddo - if(N == 2) then - i2=i3 - else - i2 = 6-i1-i3 - endif - MemO(1:1) = MemoryOrder(i1:i1) - MemO(2:2) = MemoryOrder(i2:i2) - if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) - if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then - MemO(1:N-1) = MemO(2:N) - MemO(N:N ) = MemoryOrder(i1:i1) - endif - return -end subroutine reorder - -! Returns .TRUE. iff it is OK to write time-independent domain metadata to the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, first_output, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - first_output = ncd_is_first_operation( DataHandle ) - retval = .NOT. dryrun .AND. first_output - ENDIF - ncd_ok_to_put_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_put_dom_ti - -! Returns .TRUE. iff it is OK to read time-independent domain metadata from the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - retval = .NOT. dryrun - ENDIF - ncd_ok_to_get_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_get_dom_ti - -! Returns .TRUE. iff nothing has been read from or written to the file -! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned. -LOGICAL FUNCTION ncd_is_first_operation( DataHandle ) - USE wrf_data - INCLUDE 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - TYPE(wrf_data_handle) ,POINTER :: DH - INTEGER :: Status - LOGICAL :: retval - CALL GetDH( DataHandle, DH, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - retval = DH%first_operation - ENDIF - ncd_is_first_operation = retval - RETURN -END FUNCTION ncd_is_first_operation - -subroutine upgrade_filename(FileName) - implicit none - - character*(*), intent(inout) :: FileName - integer :: i - - do i = 1, len(trim(FileName)) - if(FileName(i:i) == '-') then - FileName(i:i) = '_' - else if(FileName(i:i) == ':') then - FileName(i:i) = '_' - endif - enddo - -end subroutine upgrade_filename - -end module ext_ncd_support_routines - -subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - - use ext_ncd_support_routines - - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - real*8 ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) - real*4 ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - -!#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - - case ('xzy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,k,j)) -#include "transpose.code" - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,j,k)) -#include "transpose.code" - case ('yxz') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - case ('zxy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,i,j)) -#include "transpose.code" - case ('yzx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,k,i)) -#include "transpose.code" - case ('zyx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,j,i)) -#include "transpose.code" - case ('yx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - end select - return -end subroutine TransposeToR4 - -subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), INTENT(IN) :: DatasetName - integer , INTENT(IN) :: Comm1, Comm2 - character *(*), INTENT(IN) :: SysDepInfo - integer , INTENT(OUT) :: DataHandle - integer , INTENT(OUT) :: Status - DataHandle = 0 ! dummy setting to quiet warning message - CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status ) - IF ( Status .EQ. WRF_NO_ERR ) THEN - CALL ext_ncd_open_for_read_commit( DataHandle, Status ) - ENDIF - return -end subroutine ext_ncd_open_for_read - -!ends training phase; switches internal flag to enable input -!must be paired with call to ext_ncd_open_for_read_begin -subroutine ext_ncd_open_for_read_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer, intent(in) :: DataHandle - integer, intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_READ - DH%first_operation = .TRUE. - Status = WRF_NO_ERR - return -end subroutine ext_ncd_open_for_read_commit - -subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(INOUT) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - -#ifdef USE_NETCDF4_FEATURES - integer :: open_mode -#endif - - !call upgrade_filename(FileName) - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - - stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = trim(FileName) - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_read_begin - -subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(INOUT) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - -#ifdef USE_NETCDF4_FEATURES - integer :: open_mode -#endif - - !call upgrade_filename(FileName) - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_OPEN(FileName, NF_WRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE - DH%FileName = trim(FileName) - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_update - - -SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(inout) :: FileName - integer ,intent(in) :: Comm - integer ,intent(in) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - character (7) :: Buffer - integer :: VDimIDs(2) - -#ifdef USE_NETCDF4_FEATURES - integer :: create_mode - integer, parameter :: cache_size = 32, & - cache_nelem = 37, & - cache_preemption = 100 -#endif - - !call upgrade_filename(FileName) - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - DH%TimeIndex = 0 - DH%Times = ZeroDate -#ifdef USE_NETCDF4_FEATURES -! create_mode = IOR(nf_netcdf4, nf_classic_model) - if ( DH%use_netcdf_classic ) then - write(msg,*) 'output will be in classic NetCDF format' - call wrf_debug ( WARN , TRIM(msg)) -#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT - stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID) -#else - stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) -#endif - else - create_mode = nf_netcdf4 - stat = NF_CREATE(FileName, create_mode, DH%NCID) - stat = NF_SET_CHUNK_CACHE(cache_size, cache_nelem, cache_preemption) - endif -#else -#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT - stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID) -#else - stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) -#endif -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = trim(FileName) - stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%VarNames (1:MaxVars) = NO_NAME - DH%MDVarNames(1:MaxVars) = NO_NAME - do i=1,MaxDims - write(Buffer,FMT="('DIM',i4.4)") i - DH%DimNames (i) = Buffer - DH%DimLengths(i) = NO_DIM - enddo - DH%DimNames(1) = 'DateStrLen' - stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VDimIDs(1) = DH%DimIDs(1) - VDimIDs(2) = DH%DimUnlimID - stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(1) = DateStrLen - - if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then - DH%R4OnOutput = .true. - end if -!toggle on nofill mode - if (index(SysDepInfo,'NOFILL=.TRUE.') /= 0) then - DH%nofill = .true. - end if - - return -end subroutine ext_ncd_open_for_write_begin - -!stub -!opens a file for writing or coupler datastream for sending messages. -!no training phase for this version of the open stmt. -subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, & - SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), intent(in) ::DatasetName - integer , intent(in) ::Comm1, Comm2 - character *(*), intent(in) ::SysDepInfo - integer , intent(out) :: DataHandle - integer , intent(out) :: Status - Status=WRF_WARN_NOOP - DataHandle = 0 ! dummy setting to quiet warning message - return -end subroutine ext_ncd_open_for_write - -SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - integer :: oldmode ! for nf_set_fill, not used - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if ( DH%nofill ) then - Status = NF_SET_FILL(DH%NCID,NF_NOFILL, oldmode ) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' from NF_SET_FILL ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - write(msg,*) 'Information: NOFILL being set for writing to ',TRIM(DH%FileName) - call wrf_debug ( WARN , TRIM(msg)) - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - DH%first_operation = .TRUE. - return -end subroutine ext_ncd_open_for_write_commit - -subroutine ext_ncd_ioclose(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_CLOSE - write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - - stat = NF_CLOSE(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - CALL deallocHandle( DataHandle, Status ) - DH%Free=.true. - return -end subroutine ext_ncd_ioclose - -subroutine ext_ncd_iosync( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_SYNC(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - return -end subroutine ext_ncd_iosync - - - -subroutine ext_ncd_redef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - return -end subroutine ext_ncd_redef - -subroutine ext_ncd_enddef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - return -end subroutine ext_ncd_enddef - -subroutine ext_ncd_ioinit(SysDepInfo, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - CHARACTER*(*), INTENT(IN) :: SysDepInfo - INTEGER ,INTENT(INOUT) :: Status - - WrfIOnotInitialized = .false. - WrfDataHandles(1:WrfDataHandleMax)%Free = .true. - WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' - WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' - WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED - if(trim(SysDepInfo) == "use_netcdf_classic" ) then - WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .true. - else - WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .false. - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_ioinit - - -subroutine ext_ncd_inquiry (Inquiry, Result, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - character *(*), INTENT(IN) :: Inquiry - character *(*), INTENT(OUT) :: Result - integer ,INTENT(INOUT) :: Status - SELECT CASE (Inquiry) - CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ") - Result='ALLOW' - CASE ("OPEN_READ","OPEN_COMMIT_WRITE") - Result='REQUIRE' - CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO") - Result='NO' - CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS") - Result='YES' - CASE ("MEDIUM") - Result ='FILE' - CASE DEFAULT - Result = 'No Result for that inquiry!' - END SELECT - Status=WRF_NO_ERR - return -end subroutine ext_ncd_inquiry - - - - -subroutine ext_ncd_ioexit(Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer , INTENT(INOUT) ::Status - integer :: error - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,WrfDataHandleMax - CALL deallocHandle( i , stat ) - enddo - return -end subroutine ext_ncd_ioexit - -subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real,intent(out) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCOunt -#define TYPE_BUFFER real,allocatable :: Buffer(:) -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_ATT_REAL -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_real - -subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_integer - -subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8,intent(out) :: Data(*) -#define TYPE_BUFFER real*8,allocatable :: Buffer(:) -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_ATT_DOUBLE -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_double - -subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_logical - -subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef TYPE_BUFFER -#undef NF_TYPE -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*),intent(out) :: Data -#define TYPE_COUNT -#define TYPE_OUTCOUNT -#define TYPE_BUFFER -#define NF_TYPE NF_CHAR -#define CHAR_TYPE -#include "ext_ncd_get_dom_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_dom_ti_char - -subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_REAL -#define ARGS NF_FLOAT,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_real - -subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_integer - -subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_DOUBLE -#define ARGS NF_DOUBLE,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_double - -subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Buffer -#define LOG -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_logical - -subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*),intent(in) :: Data -#define TYPE_COUNT integer,parameter :: Count=1 -#define NF_ROUTINE NF_PUT_ATT_TEXT -#define ARGS len_trim(Data),Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_char - -subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_REAL -#define ARGS NF_FLOAT,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_real - -subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_REAL -#define NF_TYPE NF_FLOAT -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_real - -subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_DOUBLE -#define ARGS NF_DOUBLE,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_double - -subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_DOUBLE -#define NF_TYPE NF_DOUBLE -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_double - -subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_integer - -subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_INT -#define NF_TYPE NF_INT -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_integer - -subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define LOG -#define ARGS NF_INT,Count,Buffer -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_logical - -subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_INT -#define NF_TYPE NF_INT -#define LOG -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_logical - -subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(in) :: Data -#define TYPE_COUNT -#define NF_ROUTINE NF_PUT_ATT_TEXT -#define ARGS len_trim(Data),trim(Data) -#define CHAR_TYPE -#include "ext_ncd_put_var_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_put_var_ti_char - -subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(in) :: Data -#define TYPE_COUNT -#define NF_ROUTINE NF_PUT_VARA_TEXT -#define NF_TYPE NF_CHAR -#define LENGTH len(Data) -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_char - -subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(out) :: Data(*) -#define TYPE_BUFFER real ,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_ATT_REAL -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_real - -subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(out) :: Data(*) -#define TYPE_BUFFER real -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_VARA_REAL -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_real - -subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(out) :: Data(*) -#define TYPE_BUFFER real*8 ,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_ATT_DOUBLE -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_double - -subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(out) :: Data(*) -#define TYPE_BUFFER real*8 -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_VARA_DOUBLE -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_double - -subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_integer - -subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_VARA_INT -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_integer - -subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_logical - -subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_VARA_INT -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_logical - -subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(out) :: Data -#define TYPE_BUFFER -#define TYPE_COUNT integer :: Count = 1 -#define TYPE_OUTCOUNT -#define NF_TYPE NF_CHAR -#define NF_ROUTINE NF_GET_ATT_TEXT -#define COPY -#define CHAR_TYPE -#include "ext_ncd_get_var_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_var_ti_char - -subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(out) :: Data -#define TYPE_BUFFER character (80) -#define TYPE_COUNT integer :: Count = 1 -#define TYPE_OUTCOUNT -#define NF_TYPE NF_CHAR -#define NF_ROUTINE NF_GET_VARA_TEXT -#define LENGTH Len1 -#define CHAR_TYPE -#include "ext_ncd_get_var_td.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_var_td_char - -subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_real - -subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_integer - -subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_double - -subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_logical - -subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Data - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_put_dom_td_char - -subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_real - -subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_integer - -subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_double - -subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_logical - -subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(out) :: Data - integer ,intent(out) :: Status - call ext_ncd_get_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_get_dom_td_char - -subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldTypeIn, & - Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(inout) :: Field(*) - integer ,intent(in) :: FieldTypeIn - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) ,dimension(*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - integer :: FieldType - character (3) :: MemoryOrder - type(wrf_data_handle) ,pointer :: DH - integer :: NCID - integer :: NDim - character (VarNameLen) :: VarName - character (3) :: MemO - character (3) :: UCMemO - integer :: VarID - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - character(80),dimension(NVarDims) :: RODimNames - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(:,:,:,:),allocatable :: XField - integer :: stat - integer :: NVar - integer :: i,j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - integer :: XType - integer :: di - character (80) :: NullName - logical :: NotFound - -#ifdef USE_NETCDF4_FEATURES - integer, parameter :: cache_size = 32000000 - integer,dimension(NVarDims) :: chunks - logical :: need_chunking - integer :: compression_level - integer :: block_size -#endif - - MemoryOrder = trim(adjustl(MemoryOrdIn)) - NullName=char(0) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NCID = DH%NCID - -#ifdef USE_NETCDF4_FEATURES -if ( .not. DH%use_netcdf_classic ) then - call set_chunking(MemoryOrder,need_chunking) - compression_level = 2 -else - need_chunking = .false. -endif -#endif - - if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then - FieldType = WRF_REAL - else - FieldType = FieldTypeIn - end if - - write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var) - -!jm 010827 Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - - IF ( ZeroLengthHorzDim(MemoryOrder,Length,Status) ) THEN - write(msg,*)'ext_ncd_write_field: zero length dimension in ',TRIM(Var),'. Ignoring' - call wrf_debug ( WARN , TRIM(msg)) - return - ENDIF - - call ExtOrder(MemoryOrder,Length,Status) - call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(DH%VarNames(NVar) == VarName ) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%VarNames(NVar) == NO_NAME) then - DH%VarNames(NVar) = VarName - DH%NumVars = NVar - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - do j = 1,NDim - if(RODimNames(j) == NullName .or. RODimNames(j) == '') then - do i=1,MaxDims - if(DH%DimLengths(i) == Length(j)) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else !look for input name and check if already defined - NotFound = .true. - do i=1,MaxDims - if (DH%DimNames(i) == RODimNames(j)) then - if (DH%DimLengths(i) == Length(j)) then - NotFound = .false. - exit - else - Status = WRF_WARN_DIMNAME_REDEFINED - write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED by var ', & - TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', __FILE__ ,' line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - enddo - if (NotFound) then - do i=1,MaxDims - if (DH%DimLengths(i) == NO_DIM) then - DH%DimNames(i) = RODimNames(j) - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - endif - VDimIDs(j) = DH%DimIDs(i) - DH%VarDimLens(j,NVar) = Length(j) - enddo - VDimIDs(NDim+1) = DH%DimUnlimID - - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN - XType = NF_FLOAT - ELSE IF (FieldType == WRF_DOUBLE) THEN - Xtype = NF_DOUBLE - ELSE IF (FieldType == WRF_INTEGER) THEN - XType = NF_INT - ELSE IF (FieldType == WRF_LOGICAL) THEN - XType = NF_INT - ELSE - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - END IF - - stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - -#ifdef USE_NETCDF4_FEATURES - if(need_chunking) then - chunks(1:NDim) = Length(1:NDim) - chunks(NDim+1) = 1 - chunks(1) = (Length(1) + 1)/2 - chunks(2) = (Length(2) + 1)/2 - - block_size = 1 - do i = 1, NDim - block_size = block_size * chunks(i) - end do - - do while (block_size > cache_size) - chunks(1) = (chunks(1) + 1)/2 - chunks(2) = (chunks(2) + 1)/2 - - block_size = 1 - do i = 1, NDim - block_size = block_size * chunks(i) - end do - end do - -! write(unit=0, fmt='(2x, 3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ -! write(unit=0, fmt='(2x, 3a)') TRIM(VarName),':' -! write(unit=0, fmt='(10x, 2(a,i6))') 'length 1 = ', Length(1), ', chunk 1 = ', chunks(1) -! write(unit=0, fmt='(10x, 2(a,i6))') 'length 2 = ', Length(2), ', chunk 2 = ', chunks(2) -! write(unit=0, fmt='(10x, 2(a,i6))') 'length NDim+1 = ', Length(NDim+1), ', chunk NDim+1 = ', chunks(NDim+1) -! write(unit=0, fmt='(10x, a,i6)') 'compression_level = ', compression_level - - stat = NF_DEF_VAR_CHUNKING(NCID, VarID, NF_CHUNKED, chunks(1:NDim+1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF def chunking error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - - stat = NF_DEF_VAR_DEFLATE(NCID, VarID, 1, 1, compression_level) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF def compression error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif -#endif - - DH%VarIDs(NVar) = VarID - stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call reorder(MemoryOrder,MemO) - call uppercase(MemO,UCMemO) - stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - VarID = DH%VarIDs(NVar) - do j=1,NDim - if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then - Status = WRF_WARN_WRTLEN_NE_DRRUNLEN - write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |', & - VarName,'| dim ',j,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar) - call wrf_debug ( WARN , TRIM(msg)) - return -!jm 010825 elseif(DomainStart(j) < MemoryStart(j)) then - elseif(PatchStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning DIMENSION ERROR for |',VarName, & - '| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2) - call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2) - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then - call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - else - call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - end if - call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_write_field - -subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & - IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(out) :: Field(*) - integer ,intent(in) :: FieldType - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) , dimension (*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - character (3) :: MemoryOrder - character (NF_MAX_NAME) :: dimname - type(wrf_data_handle) ,pointer :: DH - integer :: NDim - integer :: NCID - character (VarNameLen) :: VarName - integer :: VarID - integer ,dimension(NVarDims) :: VCount - integer ,dimension(NVarDims) :: VStart - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - integer ,dimension(NVarDims) :: MemS - integer ,dimension(NVarDims) :: MemE - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(NVarDims) :: StoredLen - integer ,dimension(:,:,:,:) ,allocatable :: XField - integer :: NVar - integer :: j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - character (VarNameLen) :: Name - integer :: XType - integer :: StoredDim - integer :: NAtts - integer :: Len - integer :: stat - integer :: di - integer :: FType - - MemoryOrder = trim(adjustl(MemoryOrdIn)) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', & - TRIM(Var),'| in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), & - '| in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then -! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return. -! Status = WRF_WARN_DRYRUN_READ -! write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ -! call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_NO_ERR - RETURN - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - NCID = DH%NCID - -!jm Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - call ExtOrder(MemoryOrder,Length,Status) - stat = NF_INQ_VARID(NCID,VarName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname ',Varname - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif -! allow coercion between double and single prec real -!jm if(FieldType /= Ftype) then - if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then - if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else if(FieldType /= Ftype) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - ELSE IF (FieldType == WRF_DOUBLE) THEN -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - ELSE IF (FieldType == WRF_INTEGER) THEN - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - ELSE IF (FieldType == WRF_LOGICAL) THEN - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - ELSE - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - END IF - - if(Status /= WRF_NO_ERR) then - call wrf_debug ( WARN , TRIM(msg)) - return - endif - ! NDim=0 for scalars. Handle read of old NDim=1 files. TBH: 20060502 - IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN - stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - IF ( dimname(1:10) == 'ext_scalar' ) THEN - NDim = 1 - Length(1) = 1 - ENDIF - ENDIF - if(StoredDim /= NDim+1) then - Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM - write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr) - call wrf_debug ( FATAL , msg) - write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1 - call wrf_debug ( FATAL , msg) - return - endif - do j=1,NDim - stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(Length(j) > StoredLen(j)) then - Status = WRF_WARN_READ_PAST_EOF - write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j) - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Length(j) <= 0) then - Status = WRF_WARN_ZERO_LENGTH_READ - write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DomainStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), & - ') < MemoryStart (',MemoryStart(j),') in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) -! return - endif - enddo - - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2) -!jm call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2) - call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2) - - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_read_field - -subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(inout) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - !call upgrade_filename(FileName) - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - FileStatus = WRF_FILE_NOT_OPENED - return - endif - if(trim(FileName) /= trim(DH%FileName)) then - FileStatus = WRF_FILE_NOT_OPENED - else - FileStatus = DH%FileStatus - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_opened - -subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - FileStatus = WRF_FILE_NOT_OPENED - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - FileName = trim(DH%FileName) - FileStatus = DH%FileStatus - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_filename - -subroutine ext_ncd_set_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: i - - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - DH%CurrentTime = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - return - endif - enddo - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_set_time - -subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - if(DH%CurrentTime >= DH%NumberTimes) then - Status = WRF_WARN_TIME_EOF - return - endif - DH%CurrentTime = DH%CurrentTime +1 - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'DH%FileStatus ',DH%FileStatus - call wrf_debug ( FATAL , msg) - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_time - -subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - if(DH%CurrentTime.GT.0) then - DH%CurrentTime = DH%CurrentTime -1 - endif - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_previous_time - -subroutine ext_ncd_get_next_var(DataHandle, VarName, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: VarName - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - character (80) :: Name - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - - DH%CurrentVariable = DH%CurrentVariable +1 - if(DH%CurrentVariable > DH%NumVars) then - Status = WRF_WARN_VAR_EOF - return - endif - VarName = DH%VarNames(DH%CurrentVariable) - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_var - -subroutine ext_ncd_end_of_frame(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - return -end subroutine ext_ncd_end_of_frame - -! NOTE: For scalar variables NDim is set to zero and DomainStart and -! NOTE: DomainEnd are left unmodified. -subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Name - integer ,intent(out) :: NDim - character*(*) ,intent(out) :: MemoryOrder - character*(*) :: Stagger ! Dummy for now - integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd - integer ,intent(out) :: WrfType - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VarID - integer ,dimension(NVarDims) :: VDimIDs - integer :: j - integer :: stat - integer :: XType - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_INQ_VARID(DH%NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - select case (XType) - case (NF_BYTE) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_CHAR) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_SHORT) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_INT) - if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_FLOAT) - if(WrfType /= WRF_REAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_DOUBLE) - if(WrfType /= WRF_DOUBLE) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case default - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - end select - - stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - do j = 1, NDim - DomainStart(j) = 1 - stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_info - -subroutine ext_ncd_warning_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - - SELECT CASE (Code) - CASE (0) - ReturnString='No error' - Status=WRF_NO_ERR - return - CASE (-1) - ReturnString= 'File not found (or file is incomplete)' - Status=WRF_NO_ERR - return - CASE (-2) - ReturnString='Metadata not found' - Status=WRF_NO_ERR - return - CASE (-3) - ReturnString= 'Timestamp not found' - Status=WRF_NO_ERR - return - CASE (-4) - ReturnString= 'No more timestamps' - Status=WRF_NO_ERR - return - CASE (-5) - ReturnString= 'Variable not found' - Status=WRF_NO_ERR - return - CASE (-6) - ReturnString= 'No more variables for the current time' - Status=WRF_NO_ERR - return - CASE (-7) - ReturnString= 'Too many open files' - Status=WRF_NO_ERR - return - CASE (-8) - ReturnString= 'Data type mismatch' - Status=WRF_NO_ERR - return - CASE (-9) - ReturnString= 'Attempt to write read-only file' - Status=WRF_NO_ERR - return - CASE (-10) - ReturnString= 'Attempt to read write-only file' - Status=WRF_NO_ERR - return - CASE (-11) - ReturnString= 'Attempt to access unopened file' - Status=WRF_NO_ERR - return - CASE (-12) - ReturnString= 'Attempt to do 2 trainings for 1 variable' - Status=WRF_NO_ERR - return - CASE (-13) - ReturnString= 'Attempt to read past EOF' - Status=WRF_NO_ERR - return - CASE (-14) - ReturnString= 'Bad data handle' - Status=WRF_NO_ERR - return - CASE (-15) - ReturnString= 'Write length not equal to training length' - Status=WRF_NO_ERR - return - CASE (-16) - ReturnString= 'More dimensions requested than training' - Status=WRF_NO_ERR - return - CASE (-17) - ReturnString= 'Attempt to read more data than exists' - Status=WRF_NO_ERR - return - CASE (-18) - ReturnString= 'Input dimensions inconsistent' - Status=WRF_NO_ERR - return - CASE (-19) - ReturnString= 'Input MemoryOrder not recognized' - Status=WRF_NO_ERR - return - CASE (-20) - ReturnString= 'A dimension name with 2 different lengths' - Status=WRF_NO_ERR - return - CASE (-21) - ReturnString= 'String longer than provided storage' - Status=WRF_NO_ERR - return - CASE (-22) - ReturnString= 'Function not supportable' - Status=WRF_NO_ERR - return - CASE (-23) - ReturnString= 'Package implements this routine as NOOP' - Status=WRF_NO_ERR - return - -!netcdf-specific warning messages - CASE (-1007) - ReturnString= 'Bad data type' - Status=WRF_NO_ERR - return - CASE (-1008) - ReturnString= 'File not committed' - Status=WRF_NO_ERR - return - CASE (-1009) - ReturnString= 'File is opened for reading' - Status=WRF_NO_ERR - return - CASE (-1011) - ReturnString= 'Attempt to write metadata after open commit' - Status=WRF_NO_ERR - return - CASE (-1010) - ReturnString= 'I/O not initialized' - Status=WRF_NO_ERR - return - CASE (-1012) - ReturnString= 'Too many variables requested' - Status=WRF_NO_ERR - return - CASE (-1013) - ReturnString= 'Attempt to close file during a dry run' - Status=WRF_NO_ERR - return - CASE (-1014) - ReturnString= 'Date string not 19 characters in length' - Status=WRF_NO_ERR - return - CASE (-1015) - ReturnString= 'Attempt to read zero length words' - Status=WRF_NO_ERR - return - CASE (-1016) - ReturnString= 'Data type not found' - Status=WRF_NO_ERR - return - CASE (-1017) - ReturnString= 'Badly formatted date string' - Status=WRF_NO_ERR - return - CASE (-1018) - ReturnString= 'Attempt at read during a dry run' - Status=WRF_NO_ERR - return - CASE (-1019) - ReturnString= 'Attempt to get zero words' - Status=WRF_NO_ERR - return - CASE (-1020) - ReturnString= 'Attempt to put zero length words' - Status=WRF_NO_ERR - return - CASE (-1021) - ReturnString= 'NetCDF error' - Status=WRF_NO_ERR - return - CASE (-1022) - ReturnString= 'Requested length <= 1' - Status=WRF_NO_ERR - return - CASE (-1023) - ReturnString= 'More data available than requested' - Status=WRF_NO_ERR - return - CASE (-1024) - ReturnString= 'New date less than previous date' - Status=WRF_NO_ERR - return - - CASE DEFAULT - ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this warning code.' - Status=WRF_NO_ERR - END SELECT - - return -end subroutine ext_ncd_warning_str - -!returns message string for all WRF and netCDF warning/error status codes -!Other i/o packages must provide their own routines to return their own status messages -subroutine ext_ncd_error_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - - SELECT CASE (Code) - CASE (-100) - ReturnString= 'Allocation Error' - Status=WRF_NO_ERR - return - CASE (-101) - ReturnString= 'Deallocation Error' - Status=WRF_NO_ERR - return - CASE (-102) - ReturnString= 'Bad File Status' - Status=WRF_NO_ERR - return - CASE (-1004) - ReturnString= 'Variable on disk is not 3D' - Status=WRF_NO_ERR - return - CASE (-1005) - ReturnString= 'Metadata on disk is not 1D' - Status=WRF_NO_ERR - return - CASE (-1006) - ReturnString= 'Time dimension too small' - Status=WRF_NO_ERR - return - CASE DEFAULT - ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this error code.' - Status=WRF_NO_ERR - END SELECT - - return -end subroutine ext_ncd_error_str diff --git a/libsrc/wrflib/wrf_io.f90 b/libsrc/wrflib/wrf_io.f90 deleted file mode 100644 index 278249138e..0000000000 --- a/libsrc/wrflib/wrf_io.f90 +++ /dev/null @@ -1,8169 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - -module wrf_data - - integer , parameter :: FATAL = 1 - integer , parameter :: WARN = 1 - integer , parameter :: WrfDataHandleMax = 99 - integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS - - - - integer , parameter :: MaxVars = 3000 - - integer , parameter :: MaxTimes = 10000 - integer , parameter :: DateStrLen = 19 - integer , parameter :: VarNameLen = 31 - integer , parameter :: NO_DIM = 0 - integer , parameter :: NVarDims = 4 - integer , parameter :: NMDVarDims = 2 - character (8) , parameter :: NO_NAME = 'NULL' - character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' - integer, parameter :: WRF_FILE_NOT_OPENED = 100 - integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 - integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 - integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 - integer, parameter :: WRF_REAL = 104 - integer, parameter :: WRF_DOUBLE = 105 - integer, parameter :: WRF_FLOAT=WRF_REAL - integer, parameter :: WRF_INTEGER = 106 - integer, parameter :: WRF_LOGICAL = 107 - integer, parameter :: WRF_COMPLEX = 108 - integer, parameter :: WRF_DOUBLE_COMPLEX = 109 - integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 -! This bit is for backwards compatibility with old variants of these flags -! that are still being used in io_grib1 and io_phdf5. It should be removed! - integer, parameter :: WRF_FILE_OPENED_AND_COMMITTED = 102 - character (256) :: msg - logical :: WrfIOnotInitialized = .true. - type :: wrf_data_handle - character (255) :: FileName - integer :: FileStatus - integer :: Comm - integer :: NCID - logical :: Free - logical :: Write - character (5) :: TimesName - integer :: TimeIndex - integer :: CurrentTime !Only used for read - integer :: NumberTimes !Only used for read - character (DateStrLen), pointer :: Times(:) - integer :: TimesVarID - integer , pointer :: DimLengths(:) - integer , pointer :: DimIDs(:) - character (31) , pointer :: DimNames(:) - integer :: DimUnlimID - character (9) :: DimUnlimName - integer , dimension(NVarDims) :: DimID - integer , dimension(NVarDims) :: Dimension - integer , pointer :: MDVarIDs(:) - integer , pointer :: MDVarDimLens(:) - character (80) , pointer :: MDVarNames(:) - integer , pointer :: VarIDs(:) - integer , pointer :: VarDimLens(:,:) - character (VarNameLen), pointer :: VarNames(:) - integer :: CurrentVariable !Only used for read - integer :: NumVars -! first_operation is set to .TRUE. when a new handle is allocated -! or when open-for-write or open-for-read are committed. It is set -! to .FALSE. when the first field is read or written. - logical :: first_operation - logical :: R4OnOutput - logical :: nofill - logical :: use_netcdf_classic - end type wrf_data_handle - type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) -end module wrf_data -module ext_ncd_support_routines - implicit none -CONTAINS -subroutine allocHandle(DataHandle,DH,Comm,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(out) :: DataHandle - type(wrf_data_handle),pointer :: DH - integer ,intent(IN) :: Comm - integer ,intent(out) :: Status - integer :: i - integer :: stat - do i=1,WrfDataHandleMax - if(WrfDataHandles(i)%Free) then - DH => WrfDataHandles(i) - DataHandle = i - allocate(DH%Times(MaxTimes), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 124 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimLengths(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 131 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimIDs(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimNames(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 145 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarDimLens(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 159 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 166 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 173 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 187 - call wrf_debug ( FATAL , msg) - return - endif - exit - endif - if(i==WrfDataHandleMax) then - Status = WRF_WARN_TOO_MANY_FILES - write(msg,*) 'Warning TOO MANY FILES in ',"wrf_io.F90",', line', 195 - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) 'Did you call ext_ncd_ioinit?' - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - DH%Free =.false. - DH%Comm = Comm - DH%Write =.false. - DH%first_operation = .TRUE. - DH%R4OnOutput = .false. - DH%nofill = .false. - Status = WRF_NO_ERR -end subroutine allocHandle -subroutine deallocHandle(DataHandle, Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN - if(.NOT. WrfDataHandles(DataHandle)%Free) then - DH => WrfDataHandles(DataHandle) - deallocate(DH%Times, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 226 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimLengths, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 233 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 240 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 247 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 254 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 261 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 268 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 275 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 282 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 289 - call wrf_debug ( FATAL , msg) - return - endif - DH%Free =.TRUE. - endif - ENDIF - Status = WRF_NO_ERR -end subroutine deallocHandle -subroutine GetDH(DataHandle,DH,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - type(wrf_data_handle) ,pointer :: DH - integer ,intent(out) :: Status - if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - DH => WrfDataHandles(DataHandle) - if(DH%Free) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - Status = WRF_NO_ERR - return -end subroutine GetDH -subroutine DateCheck(Date,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Date - integer ,intent(out) :: Status - if(len(Date) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - else - Status = WRF_NO_ERR - endif - return -end subroutine DateCheck - -subroutine GetName(Element,Var,Name,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Name - integer ,intent(out) :: Status - character (VarNameLen) :: VarName - character (1) :: c - integer :: i - integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - - VarName = Var - Name = 'MD___' - do i=1,len(Name) - c=Name(i:i) - if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) - if(c=='-'.or.c==':') Name(i:i)='_' - enddo - Status = WRF_NO_ERR - return -end subroutine GetName - -subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: TimeIndex - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VStart(2) - integer :: VCount(2) - integer :: stat - integer :: i - - DH => WrfDataHandles(DataHandle) - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - Status = WRF_WARN_DATESTR_ERROR - write(msg,*) 'Warning DATE STRING ERROR in ',"wrf_io.F90",', line', 375 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(IO == 'write') then - TimeIndex = DH%TimeIndex - if(TimeIndex <= 0) then - TimeIndex = 1 - elseif(DateStr == DH%Times(TimeIndex)) then - Status = WRF_NO_ERR - return - else - TimeIndex = TimeIndex +1 - if(TimeIndex > MaxTimes) then - Status = WRF_WARN_TIME_EOF - write(msg,*) 'Warning TIME EOF in ',"wrf_io.F90",', line', 390 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - DH%TimeIndex = TimeIndex - DH%Times(TimeIndex) = DateStr - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = DateStrLen - VCount(2) = 1 - stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 404 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - Status = WRF_NO_ERR - TimeIndex = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"wrf_io.F90",', line', 417 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - return -end subroutine GetTimeIndex - -subroutine GetDim(MemoryOrder,NDim,Status) - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(out) :: NDim - integer ,intent(out) :: Status - character*3 :: MemOrd - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') - NDim = 3 - case ('xy','yx','xs','xe','ys','ye','cc') - NDim = 2 - case ('z','c') - NDim = 1 - case ('0') ! NDim=0 for scalars. TBH: 20060502 - NDim = 0 - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine GetDim -subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) - integer ,intent(in) :: NDim - integer ,dimension(*),intent(in) :: Start,End - integer ,intent(out) :: i1,i2,j1,j2,k1,k2 - i1=1 - i2=1 - j1=1 - j2=1 - k1=1 - k2=1 - if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502 - i1 = Start(1) - i2 = End (1) - if(NDim == 1) return - j1 = Start(2) - j2 = End (2) - if(NDim == 2) return - k1 = Start(3) - k2 = End (3) - return -end subroutine GetIndices -logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(in) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - logical zero_length - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - zero_length = .false. - select case (MemOrd) - case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy','yzx') - zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1 - case ('xy','yx','xyz','yxz') - zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1 - case ('zxy','zyx') - zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1 - case default - Status = WRF_WARN_BAD_MEMORYORDER - ZeroLengthHorzDim = .true. - return - end select - Status = WRF_NO_ERR - ZeroLengthHorzDim = zero_length - return -end function ZeroLengthHorzDim -subroutine ExtOrder(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(inout) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy') - Vector(2) = temp(3) - Vector(3) = temp(2) - case ('yxz') - Vector(1) = temp(2) - Vector(2) = temp(1) - case ('yzx') - Vector(1) = temp(3) - Vector(2) = temp(1) - Vector(3) = temp(2) - case ('zxy') - Vector(1) = temp(2) - Vector(2) = temp(3) - Vector(3) = temp(1) - case ('zyx') - Vector(1) = temp(3) - Vector(3) = temp(1) - case ('yx') - Vector(1) = temp(2) - Vector(2) = temp(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrder -subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - character*(*),dimension(*) ,intent(in) :: Vector - character(80),dimension(NVarDims),intent(out) :: ROVector - integer ,intent(out) :: Status - integer :: NDim - character*3 :: MemOrd - call GetDim(MemoryOrder,NDim,Status) - ROVector(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy') - ROVector(2) = Vector(3) - ROVector(3) = Vector(2) - case ('yxz') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case ('yzx') - ROVector(1) = Vector(3) - ROVector(2) = Vector(1) - ROVector(3) = Vector(2) - case ('zxy') - ROVector(1) = Vector(2) - ROVector(2) = Vector(3) - ROVector(3) = Vector(1) - case ('zyx') - ROVector(1) = Vector(3) - ROVector(3) = Vector(1) - case ('yx') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrderStr -subroutine LowerCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - integer :: i,N - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) - enddo - return -end subroutine LowerCase -subroutine UpperCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') - integer :: i,N - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) - enddo - return -end subroutine UpperCase -subroutine netcdf_err(err,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: err - integer ,intent(out) :: Status - character(len=80) :: errmsg - integer :: stat - if( err==NF_NOERR )then - Status = WRF_NO_ERR - else - errmsg = NF_STRERROR(err) - write(msg,*) 'NetCDF error: ',errmsg - call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_WARN_NETCDF - endif - return -end subroutine netcdf_err -subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder & - ,FieldType,NCID,VarID,XField,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer,dimension(NVarDims),intent(in) :: Length - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: FieldType - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer,dimension(*) ,intent(inout) :: XField - integer ,intent(out) :: Status - integer :: TimeIndex - integer :: NDim - integer,dimension(NVarDims) :: VStart - integer,dimension(NVarDims) :: VCount -! include 'wrf_io_flags.h' - call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning in ',"wrf_io.F90",', line', 704 - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' Bad time index for DateStr = ',DateStr - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - VStart(:) = 1 - VCount(:) = 1 - VStart(1:NDim) = 1 - VCount(1:NDim) = Length(1:NDim) - VStart(NDim+1) = TimeIndex - VCount(NDim+1) = 1 - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN - call ext_ncd_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_DOUBLE) THEN - call ext_ncd_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_INTEGER) THEN - call ext_ncd_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_LOGICAL) THEN - call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - if(Status /= WRF_NO_ERR) return - ELSE - write(6,*) 'WARNING---- some missing calls commented out' - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 731 - call wrf_debug ( WARN , TRIM(msg)) - return - END IF - return -end subroutine FieldIO -subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) -!jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2) - integer ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - case ('xzy') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yxz') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('zxy') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yzx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('zyx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - end select - return -end subroutine Transpose -subroutine reorder (MemoryOrder,MemO) - character*(*) ,intent(in) :: MemoryOrder - character*3 ,intent(out) :: MemO - character*3 :: MemOrd - integer :: N,i,i1,i2,i3 - MemO = MemoryOrder - N = len_trim(MemoryOrder) - if(N == 1) return - call lowercase(MemoryOrder,MemOrd) -! never invert the boundary codes - select case ( MemOrd ) - case ( 'xsz','xez','ysz','yez' ) - return - case default - continue - end select - i1 = 1 - i3 = 1 - do i=2,N - if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i - if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i - enddo - if(N == 2) then - i2=i3 - else - i2 = 6-i1-i3 - endif - MemO(1:1) = MemoryOrder(i1:i1) - MemO(2:2) = MemoryOrder(i2:i2) - if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) - if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then - MemO(1:N-1) = MemO(2:N) - MemO(N:N ) = MemoryOrder(i1:i1) - endif - return -end subroutine reorder -! Returns .TRUE. iff it is OK to write time-independent domain metadata to the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, first_output, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & - ', line', 846 - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - first_output = ncd_is_first_operation( DataHandle ) - retval = .NOT. dryrun .AND. first_output - ENDIF - ncd_ok_to_put_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_put_dom_ti -! Returns .TRUE. iff it is OK to read time-independent domain metadata from the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & - ', line', 872 - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - retval = .NOT. dryrun - ENDIF - ncd_ok_to_get_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_get_dom_ti -! Returns .TRUE. iff nothing has been read from or written to the file -! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned. -LOGICAL FUNCTION ncd_is_first_operation( DataHandle ) - USE wrf_data - INCLUDE 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - TYPE(wrf_data_handle) ,POINTER :: DH - INTEGER :: Status - LOGICAL :: retval - CALL GetDH( DataHandle, DH, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & - ', line', 895 - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - retval = DH%first_operation - ENDIF - ncd_is_first_operation = retval - RETURN -END FUNCTION ncd_is_first_operation -subroutine upgrade_filename(FileName) - implicit none - character*(*), intent(inout) :: FileName - integer :: i - do i = 1, len(trim(FileName)) - if(FileName(i:i) == '-') then - FileName(i:i) = '_' - else if(FileName(i:i) == ':') then - FileName(i:i) = '_' - endif - enddo -end subroutine upgrade_filename -end module ext_ncd_support_routines -subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - use ext_ncd_support_routines - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - real*8 ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) - real*4 ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) -!#define A-A1+1+(A2-A1+1)*((B-B1)+(C-C1)*(B2-B1+1)) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - case ('xzy') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yxz') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('zxy') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yzx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('zyx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - end select - return -end subroutine TransposeToR4 -subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), INTENT(IN) :: DatasetName - integer , INTENT(IN) :: Comm1, Comm2 - character *(*), INTENT(IN) :: SysDepInfo - integer , INTENT(OUT) :: DataHandle - integer , INTENT(OUT) :: Status - DataHandle = 0 ! dummy setting to quiet warning message - CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status ) - IF ( Status .EQ. WRF_NO_ERR ) THEN - CALL ext_ncd_open_for_read_commit( DataHandle, Status ) - ENDIF - return -end subroutine ext_ncd_open_for_read -!ends training phase; switches internal flag to enable input -!must be paired with call to ext_ncd_open_for_read_begin -subroutine ext_ncd_open_for_read_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer, intent(in) :: DataHandle - integer, intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1013 - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1019 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_READ - DH%first_operation = .TRUE. - Status = WRF_NO_ERR - return -end subroutine ext_ncd_open_for_read_commit -subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(INOUT) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - !call upgrade_filename(FileName) - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1064 - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 1070 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1078 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1085 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1092 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 1098 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1105 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',"wrf_io.F90",', line', 1111 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1118 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',"wrf_io.F90",', line', 1124 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1133 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1140 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1149 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = trim(FileName) - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_read_begin -subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(INOUT) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - !call upgrade_filename(FileName) - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1204 - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 1210 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_OPEN(FileName, NF_WRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1217 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1224 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1231 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 1237 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1244 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',"wrf_io.F90",', line', 1250 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1257 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',"wrf_io.F90",', line', 1263 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1272 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1279 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1288 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE - DH%FileName = trim(FileName) - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_update -SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(inout) :: FileName - integer ,intent(in) :: Comm - integer ,intent(in) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - character (7) :: Buffer - integer :: VDimIDs(2) - !call upgrade_filename(FileName) - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1338 - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1344 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - DH%TimeIndex = 0 - DH%Times = ZeroDate - stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1374 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = trim(FileName) - stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1383 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%VarNames (1:MaxVars) = NO_NAME - DH%MDVarNames(1:MaxVars) = NO_NAME - do i=1,MaxDims - write(Buffer,FMT="('DIM',i4.4)") i - DH%DimNames (i) = Buffer - DH%DimLengths(i) = NO_DIM - enddo - DH%DimNames(1) = 'DateStrLen' - stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1398 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VDimIDs(1) = DH%DimIDs(1) - VDimIDs(2) = DH%DimUnlimID - stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1407 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(1) = DateStrLen - if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then - DH%R4OnOutput = .true. - end if -!toggle on nofill mode - if (index(SysDepInfo,'NOFILL=.TRUE.') /= 0) then - DH%nofill = .true. - end if - return -end subroutine ext_ncd_open_for_write_begin -!stub -!opens a file for writing or coupler datastream for sending messages. -!no training phase for this version of the open stmt. -subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, & - SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), intent(in) ::DatasetName - integer , intent(in) ::Comm1, Comm2 - character *(*), intent(in) ::SysDepInfo - integer , intent(out) :: DataHandle - integer , intent(out) :: Status - Status=WRF_WARN_NOOP - DataHandle = 0 ! dummy setting to quiet warning message - return -end subroutine ext_ncd_open_for_write -SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - integer :: oldmode ! for nf_set_fill, not used - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1459 - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',"wrf_io.F90",', line', 1465 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if ( DH%nofill ) then - Status = NF_SET_FILL(DH%NCID,NF_NOFILL, oldmode ) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' from NF_SET_FILL ',"wrf_io.F90",', line', 1472 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - write(msg,*) 'Information: NOFILL being set for writing to ',TRIM(DH%FileName) - call wrf_debug ( WARN , TRIM(msg)) - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',"wrf_io.F90",', line', 1482 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - DH%first_operation = .TRUE. - return -end subroutine ext_ncd_open_for_write_commit -subroutine ext_ncd_ioclose(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',"wrf_io.F90",', line', 1504 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',"wrf_io.F90",', line', 1510 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_CLOSE - write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',"wrf_io.F90",', line', 1514 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',"wrf_io.F90",', line', 1524 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_CLOSE(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_ioclose ',"wrf_io.F90",', line', 1532 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - CALL deallocHandle( DataHandle, Status ) - DH%Free=.true. - return -end subroutine ext_ncd_ioclose -subroutine ext_ncd_iosync( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_iosync ',"wrf_io.F90",', line', 1554 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_iosync ',"wrf_io.F90",', line', 1560 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ext_ncd_iosync ',"wrf_io.F90",', line', 1564 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',"wrf_io.F90",', line', 1572 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_SYNC(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_iosync ',"wrf_io.F90",', line', 1579 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - return -end subroutine ext_ncd_iosync -subroutine ext_ncd_redef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1601 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 1607 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 1611 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',"wrf_io.F90",', line', 1619 - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 1623 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1630 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - return -end subroutine ext_ncd_redef -subroutine ext_ncd_enddef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1651 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 1657 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 1661 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',"wrf_io.F90",', line', 1667 - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 1671 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1678 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - return -end subroutine ext_ncd_enddef -subroutine ext_ncd_ioinit(SysDepInfo, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - CHARACTER*(*), INTENT(IN) :: SysDepInfo - INTEGER ,INTENT(INOUT) :: Status - WrfIOnotInitialized = .false. - WrfDataHandles(1:WrfDataHandleMax)%Free = .true. - WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' - WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' - WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED - if(trim(SysDepInfo) == "use_netcdf_classic" ) then - WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .true. - else - WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .false. - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_ioinit -subroutine ext_ncd_inquiry (Inquiry, Result, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - character *(*), INTENT(IN) :: Inquiry - character *(*), INTENT(OUT) :: Result - integer ,INTENT(INOUT) :: Status - SELECT CASE (Inquiry) - CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ") - Result='ALLOW' - CASE ("OPEN_READ","OPEN_COMMIT_WRITE") - Result='REQUIRE' - CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO") - Result='NO' - CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS") - Result='YES' - CASE ("MEDIUM") - Result ='FILE' - CASE DEFAULT - Result = 'No Result for that inquiry!' - END SELECT - Status=WRF_NO_ERR - return -end subroutine ext_ncd_inquiry -subroutine ext_ncd_ioexit(Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer , INTENT(INOUT) ::Status - integer :: error - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1749 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,WrfDataHandleMax - CALL deallocHandle( i , stat ) - enddo - return -end subroutine ext_ncd_ioexit -subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - real,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCOunt - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - real,allocatable :: Buffer(:) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_FLOAT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 116 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_REAL (DH%NCID,NF_GLOBAL,Element,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_real -subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - integer,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCOunt - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - integer,allocatable :: Buffer(:) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 116 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_INT (DH%NCID,NF_GLOBAL,Element,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_integer -subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - real*8,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCOunt - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - real*8,allocatable :: Buffer(:) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_DOUBLE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 116 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_double -subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - logical,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCOunt - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - integer,allocatable :: Buffer(:) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 116 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_INT (DH%NCID,NF_GLOBAL,Element,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_logical -subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*),intent(out) :: Data - - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - Data = '' - stat = NF_GET_ATT_TEXT(DH%NCID,NF_GLOBAL,Element,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_char -subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - real ,intent(in) :: Data(*) - integer,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - stat = NF_PUT_ATT_REAL (DH%NCID,NF_GLOBAL,Element,NF_FLOAT,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_PUT_ATT_REAL (DH%NCID,NF_GLOBAL,Element,NF_FLOAT,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_real -subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - integer,intent(in) :: Data(*) - integer,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_integer -subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - real*8 ,intent(in) :: Data(*) - integer,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - stat = NF_PUT_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,NF_DOUBLE,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_PUT_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,NF_DOUBLE,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_double -subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - logical,intent(in) :: Data(*) - integer,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 77 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 92 - call wrf_debug ( FATAL , msg) - return - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 119 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 135 - call wrf_debug ( FATAL , msg) - return - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_logical -subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*),intent(in) :: Data - integer,parameter :: Count=1 - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - stat = NF_PUT_ATT_TEXT (DH%NCID,NF_GLOBAL,Element,len_trim(Data),Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_PUT_ATT_TEXT (DH%NCID,NF_GLOBAL,Element,len_trim(Data),Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_char -subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_PUT_ATT_REAL(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_FLOAT,Count,Data ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 124 - call wrf_debug ( WARN , msg) - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_real -subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == Count) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = Count - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = Count - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_FLOAT,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(Count > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Count - VCount(2) = 1 - stat = NF_PUT_VARA_REAL (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_real -subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - real*8 ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_PUT_ATT_DOUBLE(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_DOUBLE,Count,Data ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 124 - call wrf_debug ( WARN , msg) - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_double -subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - real*8,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == Count) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = Count - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = Count - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_DOUBLE,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(Count > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Count - VCount(2) = 1 - stat = NF_PUT_VARA_DOUBLE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_double -subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_PUT_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_INT,Count,Data ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 124 - call wrf_debug ( WARN , msg) - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_integer -subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == Count) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = Count - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = Count - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_INT,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(Count > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Count - VCount(2) = 1 - stat = NF_PUT_VARA_INT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_integer -subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 99 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_PUT_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_INT,Count,Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 124 - call wrf_debug ( WARN , msg) - endif - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 132 - call wrf_debug ( FATAL , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_logical -subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == Count) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = Count - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = Count - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_INT,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(Count > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Count - VCount(2) = 1 - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 196 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_PUT_VARA_INT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 212 - call wrf_debug ( FATAL , msg) - return - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_logical -subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(in) :: Data - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - if(len_trim(Data).le.0) then - stat = NF_PUT_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element),len_trim(null),null) - else - stat = NF_PUT_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element), len_trim(Data),trim(Data) ) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 124 - call wrf_debug ( WARN , msg) - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_char -subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - character*(*) ,intent(in) :: Data - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(len(Data) < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == len(Data)) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),len(Data),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = len(Data) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = len(Data) - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_CHAR,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(len(Data) > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(len(Data) < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = len(Data) - VCount(2) = 1 - stat = NF_PUT_VARA_TEXT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_char -subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - real ,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - real ,allocatable :: Buffer(:) - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_FLOAT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 128 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_REAL(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 155 - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_real -subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - real ,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - real ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_FLOAT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = min(Count,Len1) - VCount(2) = 1 - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_VARA_REAL (NCID,VarID,VStart,VCount,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 209 - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_real -subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - real*8 ,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - real*8 ,allocatable :: Buffer(:) - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_DOUBLE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 128 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_DOUBLE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 155 - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_double -subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - real*8 ,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - real*8 ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_DOUBLE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = min(Count,Len1) - VCount(2) = 1 - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_VARA_DOUBLE (NCID,VarID,VStart,VCount,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 209 - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_double -subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - integer,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - integer,allocatable :: Buffer(:) - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 128 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 155 - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_integer -subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = min(Count,Len1) - VCount(2) = 1 - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_VARA_INT (NCID,VarID,VStart,VCount,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 209 - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_integer -subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - logical,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - integer,allocatable :: Buffer(:) - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 128 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 155 - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_logical -subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - logical,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = min(Count,Len1) - VCount(2) = 1 - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_VARA_INT (NCID,VarID,VStart,VCount,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 209 - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_logical -subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Data - integer :: Count = 1 - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - if(XLen > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 137 - call wrf_debug ( WARN , msg) - return - endif - stat = NF_GET_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element), Data ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_char -subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Data - integer :: Count = 1 - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - character (80) ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Len1 - VCount(2) = 1 - if(Len1 > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 189 - call wrf_debug ( WARN , msg) - return - endif - Data = '' - stat = NF_GET_VARA_TEXT (NCID,VarID,VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_char -subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_real -subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_integer -subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_double -subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_logical -subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Data - integer ,intent(out) :: Status - call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_put_dom_td_char -subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_real -subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_integer -subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_double -subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_logical -subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(out) :: Data - integer ,intent(out) :: Status - call ext_ncd_get_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_get_dom_td_char -subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldTypeIn, & - Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(inout) :: Field(*) - integer ,intent(in) :: FieldTypeIn - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) ,dimension(*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - integer :: FieldType - character (3) :: MemoryOrder - type(wrf_data_handle) ,pointer :: DH - integer :: NCID - integer :: NDim - character (VarNameLen) :: VarName - character (3) :: MemO - character (3) :: UCMemO - integer :: VarID - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - character(80),dimension(NVarDims) :: RODimNames - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(:,:,:,:),allocatable :: XField - integer :: stat - integer :: NVar - integer :: i,j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - integer :: XType - integer :: di - character (80) :: NullName - logical :: NotFound - MemoryOrder = trim(adjustl(MemoryOrdIn)) - NullName=char(0) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',"wrf_io.F90",', line', 2482 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',"wrf_io.F90",', line', 2489 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 2496 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NCID = DH%NCID - if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then - FieldType = WRF_REAL - else - FieldType = FieldTypeIn - end if - write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var) -!jm 010827 Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - IF ( ZeroLengthHorzDim(MemoryOrder,Length,Status) ) THEN - write(msg,*)'ext_ncd_write_field: zero length dimension in ',TRIM(Var),'. Ignoring' - call wrf_debug ( WARN , TRIM(msg)) - return - ENDIF - call ExtOrder(MemoryOrder,Length,Status) - call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 2533 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) 'Warning WRITE READ ONLY FILE in ',"wrf_io.F90",', line', 2537 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(DH%VarNames(NVar) == VarName ) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',"wrf_io.F90",', line', 2543 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%VarNames(NVar) == NO_NAME) then - DH%VarNames(NVar) = VarName - DH%NumVars = NVar - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) 'Warning TOO MANY VARIABLES in ',"wrf_io.F90",', line', 2552 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - do j = 1,NDim - if(RODimNames(j) == NullName .or. RODimNames(j) == '') then - do i=1,MaxDims - if(DH%DimLengths(i) == Length(j)) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2566 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',"wrf_io.F90",', line', 2574 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else !look for input name and check if already defined - NotFound = .true. - do i=1,MaxDims - if (DH%DimNames(i) == RODimNames(j)) then - if (DH%DimLengths(i) == Length(j)) then - NotFound = .false. - exit - else - Status = WRF_WARN_DIMNAME_REDEFINED - write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED by var ', & - TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', "wrf_io.F90" ,' line', 2589 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - enddo - if (NotFound) then - do i=1,MaxDims - if (DH%DimLengths(i) == NO_DIM) then - DH%DimNames(i) = RODimNames(j) - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2602 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',"wrf_io.F90",', line', 2610 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - endif - VDimIDs(j) = DH%DimIDs(i) - DH%VarDimLens(j,NVar) = Length(j) - enddo - VDimIDs(NDim+1) = DH%DimUnlimID - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN - XType = NF_FLOAT - ELSE IF (FieldType == WRF_DOUBLE) THEN - Xtype = NF_DOUBLE - ELSE IF (FieldType == WRF_INTEGER) THEN - XType = NF_INT - ELSE IF (FieldType == WRF_LOGICAL) THEN - XType = NF_INT - ELSE - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 2633 - call wrf_debug ( WARN , TRIM(msg)) - return - END IF - stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',"wrf_io.F90",', line', 2641 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%VarIDs(NVar) = VarID - stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',"wrf_io.F90",', line', 2697 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call reorder(MemoryOrder,MemO) - call uppercase(MemO,UCMemO) - stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',"wrf_io.F90",', line', 2706 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) 'Warning VARIABLE NOT FOUND in ',"wrf_io.F90",', line', 2716 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - VarID = DH%VarIDs(NVar) - do j=1,NDim - if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then - Status = WRF_WARN_WRTLEN_NE_DRRUNLEN - write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |', & - VarName,'| dim ',j,' in ',"wrf_io.F90",', line', 2726 - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar) - call wrf_debug ( WARN , TRIM(msg)) - return -!jm 010825 elseif(DomainStart(j) < MemoryStart(j)) then - elseif(PatchStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning DIMENSION ERROR for |',VarName, & - '| in ',"wrf_io.F90",', line', 2735 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2) - call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2) - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 2749 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then - call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - else - call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - end if - call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 2765 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 2772 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 2778 - call wrf_debug ( FATAL , TRIM(msg)) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_write_field -subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & - IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(out) :: Field(*) - integer ,intent(in) :: FieldType - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) , dimension (*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - character (3) :: MemoryOrder - character (NF_MAX_NAME) :: dimname - type(wrf_data_handle) ,pointer :: DH - integer :: NDim - integer :: NCID - character (VarNameLen) :: VarName - integer :: VarID - integer ,dimension(NVarDims) :: VCount - integer ,dimension(NVarDims) :: VStart - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - integer ,dimension(NVarDims) :: MemS - integer ,dimension(NVarDims) :: MemE - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(NVarDims) :: StoredLen - integer ,dimension(:,:,:,:) ,allocatable :: XField - integer :: NVar - integer :: j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - character (VarNameLen) :: Name - integer :: XType - integer :: StoredDim - integer :: NAtts - integer :: Len - integer :: stat - integer :: di - integer :: FType - MemoryOrder = trim(adjustl(MemoryOrdIn)) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', & - TRIM(Var),'| in ext_ncd_read_field ',"wrf_io.F90",', line', 2842 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), & - '| in ext_ncd_read_field ',"wrf_io.F90",', line', 2849 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',"wrf_io.F90",', line', 2856 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 2862 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then -! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return. -! Status = WRF_WARN_DRYRUN_READ -! write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 2867 -! call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_NO_ERR - RETURN - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 2873 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - NCID = DH%NCID -!jm Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - call ExtOrder(MemoryOrder,Length,Status) - stat = NF_INQ_VARID(NCID,VarName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2884,' Varname ',Varname - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2891 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2898 - call wrf_debug ( WARN , TRIM(msg)) - return - endif -! allow coercion between double and single prec real -!jm if(FieldType /= Ftype) then - if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then - if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 2907 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else if(FieldType /= Ftype) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 2913 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning REAL TYPE MISMATCH in ',"wrf_io.F90",', line', 2923 - endif - ELSE IF (FieldType == WRF_DOUBLE) THEN -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',"wrf_io.F90",', line', 2929 - endif - ELSE IF (FieldType == WRF_INTEGER) THEN - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',"wrf_io.F90",', line', 2934 - endif - ELSE IF (FieldType == WRF_LOGICAL) THEN - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',"wrf_io.F90",', line', 2939 - endif - ELSE - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 2943 - END IF - if(Status /= WRF_NO_ERR) then - call wrf_debug ( WARN , TRIM(msg)) - return - endif - ! NDim=0 for scalars. Handle read of old NDim=1 files. TBH: 20060502 - IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN - stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2955 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - IF ( dimname(1:10) == 'ext_scalar' ) THEN - NDim = 1 - Length(1) = 1 - ENDIF - ENDIF - if(StoredDim /= NDim+1) then - Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM - write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr) - call wrf_debug ( FATAL , msg) - write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1 - call wrf_debug ( FATAL , msg) - return - endif - do j=1,NDim - stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2976 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(Length(j) > StoredLen(j)) then - Status = WRF_WARN_READ_PAST_EOF - write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j) - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Length(j) <= 0) then - Status = WRF_WARN_ZERO_LENGTH_READ - write(msg,*) 'Warning ZERO LENGTH READ in ',"wrf_io.F90",', line', 2987 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DomainStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), & - ') < MemoryStart (',MemoryStart(j),') in ',"wrf_io.F90",', line', 2993 - call wrf_debug ( WARN , TRIM(msg)) -! return - endif - enddo - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2) -!jm call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2) - call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2) - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 3010 - call wrf_debug ( FATAL , msg) - return - endif - call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3017 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 3027 - call wrf_debug ( FATAL , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3033 - call wrf_debug ( FATAL , msg) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_read_field -subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(inout) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - !call upgrade_filename(FileName) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - FileStatus = WRF_FILE_NOT_OPENED - return - endif - if(trim(FileName) /= trim(DH%FileName)) then - FileStatus = WRF_FILE_NOT_OPENED - else - FileStatus = DH%FileStatus - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_opened -subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - FileStatus = WRF_FILE_NOT_OPENED - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3080 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - FileName = trim(DH%FileName) - FileStatus = DH%FileStatus - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_filename -subroutine ext_ncd_set_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: i - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR in ',"wrf_io.F90",', line', 3103 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3109 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3115 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 3119 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3123 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - DH%CurrentTime = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - return - endif - enddo - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3140 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_set_time -subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3158 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3164 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3168 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3172 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - if(DH%CurrentTime >= DH%NumberTimes) then - Status = WRF_WARN_TIME_EOF - return - endif - DH%CurrentTime = DH%CurrentTime +1 - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'DH%FileStatus ',DH%FileStatus - call wrf_debug ( FATAL , msg) - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3187 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_time -subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3205 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3211 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3215 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3219 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - if(DH%CurrentTime.GT.0) then - DH%CurrentTime = DH%CurrentTime -1 - endif - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3230 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_previous_time -subroutine ext_ncd_get_next_var(DataHandle, VarName, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: VarName - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - character (80) :: Name - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3251 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3257 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3261 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3265 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - DH%CurrentVariable = DH%CurrentVariable +1 - if(DH%CurrentVariable > DH%NumVars) then - Status = WRF_WARN_VAR_EOF - return - endif - VarName = DH%VarNames(DH%CurrentVariable) - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3278 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_var -subroutine ext_ncd_end_of_frame(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - call GetDH(DataHandle,DH,Status) - return -end subroutine ext_ncd_end_of_frame -! NOTE: For scalar variables NDim is set to zero and DomainStart and -! NOTE: DomainEnd are left unmodified. -subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Name - integer ,intent(out) :: NDim - character*(*) ,intent(out) :: MemoryOrder - character*(*) :: Stagger ! Dummy for now - integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd - integer ,intent(out) :: WrfType - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VarID - integer ,dimension(NVarDims) :: VDimIDs - integer :: j - integer :: stat - integer :: XType - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3323 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3329 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3334 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3339 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_INQ_VARID(DH%NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3346 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3353 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3360 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - select case (XType) - case (NF_BYTE) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3367 - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_CHAR) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3372 - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_SHORT) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3377 - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_INT) - if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3383 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_FLOAT) - if(WrfType /= WRF_REAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3390 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_DOUBLE) - if(WrfType /= WRF_DOUBLE) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3397 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case default - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 3403 - call wrf_debug ( WARN , TRIM(msg)) - return - end select - stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3411 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',"wrf_io.F90",', line', 3417 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3424 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - do j = 1, NDim - DomainStart(j) = 1 - stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3433 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3440 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_info -subroutine ext_ncd_warning_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - SELECT CASE (Code) - CASE (0) - ReturnString='No error' - Status=WRF_NO_ERR - return - CASE (-1) - ReturnString= 'File not found (or file is incomplete)' - Status=WRF_NO_ERR - return - CASE (-2) - ReturnString='Metadata not found' - Status=WRF_NO_ERR - return - CASE (-3) - ReturnString= 'Timestamp not found' - Status=WRF_NO_ERR - return - CASE (-4) - ReturnString= 'No more timestamps' - Status=WRF_NO_ERR - return - CASE (-5) - ReturnString= 'Variable not found' - Status=WRF_NO_ERR - return - CASE (-6) - ReturnString= 'No more variables for the current time' - Status=WRF_NO_ERR - return - CASE (-7) - ReturnString= 'Too many open files' - Status=WRF_NO_ERR - return - CASE (-8) - ReturnString= 'Data type mismatch' - Status=WRF_NO_ERR - return - CASE (-9) - ReturnString= 'Attempt to write read-only file' - Status=WRF_NO_ERR - return - CASE (-10) - ReturnString= 'Attempt to read write-only file' - Status=WRF_NO_ERR - return - CASE (-11) - ReturnString= 'Attempt to access unopened file' - Status=WRF_NO_ERR - return - CASE (-12) - ReturnString= 'Attempt to do 2 trainings for 1 variable' - Status=WRF_NO_ERR - return - CASE (-13) - ReturnString= 'Attempt to read past EOF' - Status=WRF_NO_ERR - return - CASE (-14) - ReturnString= 'Bad data handle' - Status=WRF_NO_ERR - return - CASE (-15) - ReturnString= 'Write length not equal to training length' - Status=WRF_NO_ERR - return - CASE (-16) - ReturnString= 'More dimensions requested than training' - Status=WRF_NO_ERR - return - CASE (-17) - ReturnString= 'Attempt to read more data than exists' - Status=WRF_NO_ERR - return - CASE (-18) - ReturnString= 'Input dimensions inconsistent' - Status=WRF_NO_ERR - return - CASE (-19) - ReturnString= 'Input MemoryOrder not recognized' - Status=WRF_NO_ERR - return - CASE (-20) - ReturnString= 'A dimension name with 2 different lengths' - Status=WRF_NO_ERR - return - CASE (-21) - ReturnString= 'String longer than provided storage' - Status=WRF_NO_ERR - return - CASE (-22) - ReturnString= 'Function not supportable' - Status=WRF_NO_ERR - return - CASE (-23) - ReturnString= 'Package implements this routine as NOOP' - Status=WRF_NO_ERR - return -!netcdf-specific warning messages - CASE (-1007) - ReturnString= 'Bad data type' - Status=WRF_NO_ERR - return - CASE (-1008) - ReturnString= 'File not committed' - Status=WRF_NO_ERR - return - CASE (-1009) - ReturnString= 'File is opened for reading' - Status=WRF_NO_ERR - return - CASE (-1011) - ReturnString= 'Attempt to write metadata after open commit' - Status=WRF_NO_ERR - return - CASE (-1010) - ReturnString= 'I/O not initialized' - Status=WRF_NO_ERR - return - CASE (-1012) - ReturnString= 'Too many variables requested' - Status=WRF_NO_ERR - return - CASE (-1013) - ReturnString= 'Attempt to close file during a dry run' - Status=WRF_NO_ERR - return - CASE (-1014) - ReturnString= 'Date string not 19 characters in length' - Status=WRF_NO_ERR - return - CASE (-1015) - ReturnString= 'Attempt to read zero length words' - Status=WRF_NO_ERR - return - CASE (-1016) - ReturnString= 'Data type not found' - Status=WRF_NO_ERR - return - CASE (-1017) - ReturnString= 'Badly formatted date string' - Status=WRF_NO_ERR - return - CASE (-1018) - ReturnString= 'Attempt at read during a dry run' - Status=WRF_NO_ERR - return - CASE (-1019) - ReturnString= 'Attempt to get zero words' - Status=WRF_NO_ERR - return - CASE (-1020) - ReturnString= 'Attempt to put zero length words' - Status=WRF_NO_ERR - return - CASE (-1021) - ReturnString= 'NetCDF error' - Status=WRF_NO_ERR - return - CASE (-1022) - ReturnString= 'Requested length <= 1' - Status=WRF_NO_ERR - return - CASE (-1023) - ReturnString= 'More data available than requested' - Status=WRF_NO_ERR - return - CASE (-1024) - ReturnString= 'New date less than previous date' - Status=WRF_NO_ERR - return - CASE DEFAULT - ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this warning code.' - Status=WRF_NO_ERR - END SELECT - return -end subroutine ext_ncd_warning_str -!returns message string for all WRF and netCDF warning/error status codes -!Other i/o packages must provide their own routines to return their own status messages -subroutine ext_ncd_error_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - SELECT CASE (Code) - CASE (-100) - ReturnString= 'Allocation Error' - Status=WRF_NO_ERR - return - CASE (-101) - ReturnString= 'Deallocation Error' - Status=WRF_NO_ERR - return - CASE (-102) - ReturnString= 'Bad File Status' - Status=WRF_NO_ERR - return - CASE (-1004) - ReturnString= 'Variable on disk is not 3D' - Status=WRF_NO_ERR - return - CASE (-1005) - ReturnString= 'Metadata on disk is not 1D' - Status=WRF_NO_ERR - return - CASE (-1006) - ReturnString= 'Time dimension too small' - Status=WRF_NO_ERR - return - CASE DEFAULT - ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this error code.' - Status=WRF_NO_ERR - END SELECT - return -end subroutine ext_ncd_error_str diff --git a/libsrc/wrflib/wrf_io_flags.h b/libsrc/wrflib/wrf_io_flags.h deleted file mode 100644 index 2048aff665..0000000000 --- a/libsrc/wrflib/wrf_io_flags.h +++ /dev/null @@ -1,15 +0,0 @@ - integer, parameter :: WRF_FILE_NOT_OPENED = 100 - integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 - integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 - integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 - integer, parameter :: WRF_REAL = 104 - integer, parameter :: WRF_DOUBLE = 105 - integer, parameter :: WRF_FLOAT=WRF_REAL - integer, parameter :: WRF_INTEGER = 106 - integer, parameter :: WRF_LOGICAL = 107 - integer, parameter :: WRF_COMPLEX = 108 - integer, parameter :: WRF_DOUBLE_COMPLEX = 109 - integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 -! This bit is for backwards compatibility with old variants of these flags -! that are still being used in io_grib1 and io_phdf5. It should be removed! - integer, parameter :: WRF_FILE_OPENED_AND_COMMITTED = 102 diff --git a/libsrc/wrflib/wrf_status_codes.h b/libsrc/wrflib/wrf_status_codes.h deleted file mode 100644 index 059d9ea719..0000000000 --- a/libsrc/wrflib/wrf_status_codes.h +++ /dev/null @@ -1,133 +0,0 @@ - -!WRF Error and Warning messages (1-999) -!All i/o package-specific status codes you may want to add must be handled by your package (see below) -! WRF handles these and netCDF messages only - integer, parameter :: WRF_NO_ERR = 0 !no error - integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete - integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found - integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found - integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps - integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found - integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time - integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files - integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch - integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file - integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file - integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file - integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable - integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF - integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle - integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length - integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training - integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists - integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent - integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized - integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths - integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage - integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable - integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP - -!Fatal errors - integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error - integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error - integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status - - -!Package specific errors (1000+) -!Netcdf status codes -!WRF will accept status codes of 1000+, but it is up to the package to handle -! and return the status to the user. - - integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 - integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 - integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 - integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 - integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 - integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 - integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 - integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 - integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 - integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 - integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 - integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 - integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 - integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 - integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 - integer, parameter :: WRF_WARN_NETCDF = -1021 - integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 - integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 - integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 - -! For HDF5 only - integer, parameter :: WRF_HDF5_ERR_FILE = -200 - integer, parameter :: WRF_HDF5_ERR_MD = -201 - integer, parameter :: WRF_HDF5_ERR_TIME = -202 - integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 - integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 - integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 - integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 - integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 - integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 - integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 - integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 - integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 - integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 - integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 - integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 - integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 - integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 - integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 - integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 - integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 - integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 - integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 - - integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 - integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 - integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 - integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 - integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 - integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 - - integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 - integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 - integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 - - integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 - integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 - integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 - integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 - integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 - integer, parameter :: WRF_HDF5_ERR_GROUP = -308 - - integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 - integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 - integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 - integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 - integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 - - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 - - integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 -