external/io_pnetcdf/ext_pnc_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_pnc
  38   use ext_pnc_support_routines
  39   implicit none
  40 #  include "pnetcdf.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(KIND=MPI_OFFSET_KIND)         :: VStart(2)
  59   integer(KIND=MPI_OFFSET_KIND)         :: 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(KIND=MPI_OFFSET_KIND)         :: Len1_okind
  69   integer                               :: Len1
  70
  71   if(Count <= 0) then
  72     Status = WRF_WARN_ZERO_LENGTH_GET
  73     write(msg,*) &
  74 'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  75     call wrf_debug ( WARN , msg)
  76     return
  77   endif
  78   VarName = Var
  79   call DateCheck(DateStr,Status)
  80   if(Status /= WRF_NO_ERR) then
  81     write(msg,*) &
  82 'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  83     call wrf_debug ( WARN , msg)
  84     return
  85   endif
  86   call GetDH(DataHandle,DH,Status)
  87   if(Status /= WRF_NO_ERR) then
  88     write(msg,*) &
  89 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  90     call wrf_debug ( WARN , msg)
  91     return
  92   endif
  93   NCID = DH%NCID
  94   call GetName(Element, VarName, Name, Status)
  95   if(Status /= WRF_NO_ERR) then
  96     write(msg,*) &
  97 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  98     call wrf_debug ( WARN , msg)
  99     return
 100   endif
 101   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
 102     Status = WRF_WARN_FILE_NOT_OPENED
 103     write(msg,*) &
 104 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 105     call wrf_debug ( WARN , msg)
 106   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
 107     Status = WRF_WARN_DRYRUN_READ
 108     write(msg,*) &
 109 'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 110     call wrf_debug ( WARN , msg)
 111   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
 112     Status = WRF_WARN_READ_WONLY_FILE
 113     write(msg,*) &
 114 'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 115     call wrf_debug ( WARN , msg)
 116   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
 117     stat = NFMPI_INQ_VARID(NCID,Name,VarID)
 118     call netcdf_err(stat,Status)
 119     if(Status /= WRF_NO_ERR) then
 120       write(msg,*) &
 121 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 122       call wrf_debug ( WARN , msg)
 123       return
 124     endif
 125     stat = NFMPI_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts)
 126     call netcdf_err(stat,Status)
 127     if(Status /= WRF_NO_ERR) then
 128       write(msg,*) &
 129 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 130       call wrf_debug ( WARN , msg)
 131       return
 132     endif
 133     if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then
 134       if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then
 135         Status = WRF_WARN_TYPE_MISMATCH
 136         write(msg,*) &
 137 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 138         call wrf_debug ( WARN , msg)
 139         return
 140       endif
 141     else
 142       if(XType /= NF_TYPE) then
 143         Status = WRF_WARN_TYPE_MISMATCH
 144         write(msg,*) &
 145 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 146         call wrf_debug ( WARN , msg)
 147         return
 148       endif
 149     endif
 150     if(NDims /= NMDVarDims) then
 151       Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D
 152       write(msg,*) &
 153 'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 154       call wrf_debug ( FATAL , msg)
 155       return
 156     endif
 157     stat = NFMPI_INQ_DIMLEN(NCID,DimIDs(1),Len1_okind)
 158     call netcdf_err(stat,Status)
 159     if(Status /= WRF_NO_ERR) then
 160       write(msg,*) &
 161 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' DimIDs(1) ',DimIDs(1)
 162       call wrf_debug ( WARN , msg)
 163       return
 164     endif
 165     Len1 = Len1_okind
 166     call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
 167     if(Status /= WRF_NO_ERR) then
 168       write(msg,*) &
 169 'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 170       call wrf_debug ( WARN , msg)
 171       return
 172     endif
 173     VStart(1) = 1
 174     VStart(2) = TimeIndex
 175     VCount(1) = LENGTH
 176     VCount(2) = 1
 177 #ifndef CHAR_TYPE
 178     allocate(Buffer(VCount(1)), STAT=stat)
 179     if(stat/= 0) then
 180       Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 181       write(msg,*) &
 182 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 183       call wrf_debug ( FATAL , msg)
 184       return
 185     endif
 186     stat = NF_ROUTINE (NCID,VarID,VStart,VCount,Buffer)
 187 #else
 188     if(Len1 > len(Data)) then
 189       Status = WRF_WARN_CHARSTR_GT_LENDATA
 190       write(msg,*) &
 191 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 192       call wrf_debug ( WARN , msg)
 193       return
 194     endif
 195     Data = ''
 196     stat = NFMPI_GET_VARA_TEXT_ALL (NCID,VarID,VStart,VCount,Data)
 197 #endif
 198     call netcdf_err(stat,Status)
 199     if(Status /= WRF_NO_ERR) then
 200       write(msg,*) &
 201 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 202       call wrf_debug ( WARN , msg)
 203       return
 204     endif
 205 #ifndef CHAR_TYPE
 206     COPY
 207     deallocate(Buffer, STAT=stat)
 208     if(stat/= 0) then
 209       Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 210       write(msg,*) &
 211 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 212       call wrf_debug ( FATAL , msg)
 213       return
 214     endif
 215     if(Len1 > Count) then
 216       OutCount = Count
 217       Status = WRF_WARN_MORE_DATA_IN_FILE
 218     else
 219       OutCount = Len1
 220       Status = WRF_NO_ERR
 221     endif
 222 #endif
 223   else
 224     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 225     write(msg,*) &
 226 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 227     call wrf_debug ( FATAL , msg)
 228   endif
 229   return