source: trunk/WRF.COMMON/WRFV3/external/io_netcdf/ext_ncd_get_var_td.code

Last change on this file was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 7.8 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.