external/io_netcdf/ext_ncd_get_var_td.code

   1 !*------------------------------------------------------------------------------
   2 !*  Standard Disclaimer
   3 !*
   4 !*  Forecast Systems Laboratory
   5 !*  NOAA/OAR/ERL/FSL
   6 !*  325 Broadway
   7 !*  Boulder, CO     80303
   8 !*
   9 !*  AVIATION DIVISION
  10 !*  ADVANCED COMPUTING BRANCH
  11 !*  SMS/NNT Version: 2.0.0
  12 !*
  13 !*  This software and its documentation are in the public domain and
  14 !*  are furnished "as is".  The United States government, its
  15 !*  instrumentalities, officers, employees, and agents make no
  16 !*  warranty, express or implied, as to the usefulness of the software
  17 !*  and documentation for any purpose.  They assume no
  18 !*  responsibility (1) for the use of the software and documentation;
  19 !*  or (2) to provide technical support to users.
  20 !*
  21 !*  Permission to use, copy, modify, and distribute this software is
  22 !*  hereby granted, provided that this disclaimer notice appears in
  23 !*  all copies.  All modifications to this software must be clearly
  24 !*  documented, and are solely the responsibility of the agent making
  25 !*  the modification.  If significant modifications or enhancements
  26 !*  are made to this software, the SMS Development team
  27 !*  (sms-info@fsl.noaa.gov) should be notified.
  28 !*
  29 !*----------------------------------------------------------------------------
  30 !*
  31 !*  WRF NetCDF I/O
  32 !   Author:  Jacques Middlecoff jacquesm@fsl.noaa.gov
  33 !*  Date:    October 6, 2000
  34 !*
  35 !*----------------------------------------------------------------------------
  36
  37   use wrf_data
  38   use ext_ncd_support_routines
  39   implicit none
  40   include 'netcdf.inc'
  41   include 'wrf_status_codes.h'
  42   integer               ,intent(in)     :: DataHandle
  43   character*(*)         ,intent(in)     :: Element
  44   character (DateStrLen),intent(in)     :: DateStr
  45   character*(*)         ,intent(in)     :: Var
  46   TYPE_DATA
  47   TYPE_COUNT
  48   TYPE_OUTCOUNT
  49   integer               ,intent(out)    :: Status
  50   type(wrf_data_handle) ,pointer        :: DH
  51   character (VarNameLen)                :: VarName
  52   character (40+len(Element))           :: Name
  53   character (40+len(Element))           :: FName
  54   integer                               :: stat
  55   TYPE_BUFFER           ,allocatable    :: Buffer(:)
  56   integer                               :: i
  57   integer                               :: VDims (2)
  58   integer                               :: VStart(2)
  59   integer                               :: VCount(2)
  60   integer                               :: NVar
  61   integer                               :: TimeIndex
  62   integer                               :: NCID
  63   integer                               :: DimIDs(2)
  64   integer                               :: VarID
  65   integer                               :: XType
  66   integer                               :: NDims
  67   integer                               :: NAtts
  68   integer                               :: Len1
  69
  70   if(Count <= 0) then
  71     Status = WRF_WARN_ZERO_LENGTH_GET
  72     write(msg,*) &
  73 'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  74     call wrf_debug ( WARN , msg)
  75     return
  76   endif
  77   VarName = Var
  78   call DateCheck(DateStr,Status)
  79   if(Status /= WRF_NO_ERR) then
  80     write(msg,*) &
  81 'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  82     call wrf_debug ( WARN , msg)
  83     return
  84   endif
  85   call GetDH(DataHandle,DH,Status)
  86   if(Status /= WRF_NO_ERR) then
  87     write(msg,*) &
  88 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  89     call wrf_debug ( WARN , msg)
  90     return
  91   endif
  92   NCID = DH%NCID
  93   call GetName(Element, VarName, Name, Status)
  94   if(Status /= WRF_NO_ERR) then
  95     write(msg,*) &
  96 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  97     call wrf_debug ( WARN , msg)
  98     return
  99   endif
 100   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
 101     Status = WRF_WARN_FILE_NOT_OPENED
 102     write(msg,*) &
 103 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 104     call wrf_debug ( WARN , msg)
 105   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
 106     Status = WRF_WARN_DRYRUN_READ
 107     write(msg,*) &
 108 'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 109     call wrf_debug ( WARN , msg)
 110   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
 111     Status = WRF_WARN_READ_WONLY_FILE
 112     write(msg,*) &
 113 'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 114     call wrf_debug ( WARN , msg)
 115   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
 116     stat = NF_INQ_VARID(NCID,Name,VarID)
 117     call netcdf_err(stat,Status)
 118     if(Status /= WRF_NO_ERR) then
 119       write(msg,*) &
 120 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 121       call wrf_debug ( WARN , msg)
 122       return
 123     endif
 124     stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts)
 125     call netcdf_err(stat,Status)
 126     if(Status /= WRF_NO_ERR) then
 127       write(msg,*) &
 128 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 129       call wrf_debug ( WARN , msg)
 130       return
 131     endif
 132     if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then
 133       if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then
 134         Status = WRF_WARN_TYPE_MISMATCH
 135         write(msg,*) &
 136 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 137         call wrf_debug ( WARN , msg)
 138         return
 139       endif
 140     else
 141       if(XType /= NF_TYPE) then
 142         Status = WRF_WARN_TYPE_MISMATCH
 143         write(msg,*) &
 144 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 145         call wrf_debug ( WARN , msg)
 146         return
 147       endif
 148     endif
 149     if(NDims /= NMDVarDims) then
 150       Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D
 151       write(msg,*) &
 152 'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 153       call wrf_debug ( FATAL , msg)
 154       return
 155     endif
 156     stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1)
 157     call netcdf_err(stat,Status)
 158     if(Status /= WRF_NO_ERR) then
 159       write(msg,*) &
 160 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' DimIDs(1) ',DimIDs(1)
 161       call wrf_debug ( WARN , msg)
 162       return
 163     endif
 164     call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
 165     if(Status /= WRF_NO_ERR) then
 166       write(msg,*) &
 167 'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 168       call wrf_debug ( WARN , msg)
 169       return
 170     endif
 171     VStart(1) = 1
 172     VStart(2) = TimeIndex
 173     VCount(1) = LENGTH
 174     VCount(2) = 1
 175 #ifndef CHAR_TYPE
 176     allocate(Buffer(VCount(1)), STAT=stat)
 177     if(stat/= 0) then
 178       Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 179       write(msg,*) &
 180 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 181       call wrf_debug ( FATAL , msg)
 182       return
 183     endif
 184     stat = NF_ROUTINE (NCID,VarID,VStart,VCount,Buffer)
 185 #else
 186     if(Len1 > len(Data)) then
 187       Status = WRF_WARN_CHARSTR_GT_LENDATA
 188       write(msg,*) &
 189 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 190       call wrf_debug ( WARN , msg)
 191       return
 192     endif
 193     Data = ''
 194     stat = NF_GET_VARA_TEXT (NCID,VarID,VStart,VCount,Data)
 195 #endif
 196     call netcdf_err(stat,Status)
 197     if(Status /= WRF_NO_ERR) then
 198       write(msg,*) &
 199 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 200       call wrf_debug ( WARN , msg)
 201       return
 202     endif
 203 #ifndef CHAR_TYPE
 204     COPY
 205     deallocate(Buffer, STAT=stat)
 206     if(stat/= 0) then
 207       Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 208       write(msg,*) &
 209 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 210       call wrf_debug ( FATAL , msg)
 211       return
 212     endif
 213     if(Len1 > Count) then
 214       OutCount = Count
 215       Status = WRF_WARN_MORE_DATA_IN_FILE
 216     else
 217       OutCount = Len1
 218       Status = WRF_NO_ERR
 219     endif
 220 #endif
 221   else
 222     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 223     write(msg,*) &
 224 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 225     call wrf_debug ( FATAL , msg)
 226   endif
 227   return