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 'wrf_status_codes.h' |
---|
41 | # include "pnetcdf.inc" |
---|
42 | integer ,intent(in) :: DataHandle |
---|
43 | character*(*) ,intent(in) :: Element |
---|
44 | character*(*) ,intent(in) :: Var |
---|
45 | TYPE_DATA |
---|
46 | TYPE_COUNT |
---|
47 | TYPE_OUTCOUNT |
---|
48 | integer ,intent(out) :: Status |
---|
49 | type(wrf_data_handle) ,pointer :: DH |
---|
50 | integer :: XLen |
---|
51 | integer(KIND=MPI_OFFSET_KIND) :: XLen_offset |
---|
52 | TYPE_BUFFER |
---|
53 | character (VarNameLen) :: VarName |
---|
54 | integer :: stat |
---|
55 | integer :: NVar |
---|
56 | integer :: XType |
---|
57 | |
---|
58 | if(Count <= 0) then |
---|
59 | Status = WRF_WARN_ZERO_LENGTH_GET |
---|
60 | write(msg,*) & |
---|
61 | 'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
62 | call wrf_debug ( WARN , msg) |
---|
63 | return |
---|
64 | endif |
---|
65 | VarName = Var |
---|
66 | call GetDH(DataHandle,DH,Status) |
---|
67 | if(Status /= WRF_NO_ERR) then |
---|
68 | write(msg,*) & |
---|
69 | 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
70 | call wrf_debug ( WARN , msg) |
---|
71 | return |
---|
72 | endif |
---|
73 | if(DH%FileStatus == WRF_FILE_NOT_OPENED) then |
---|
74 | Status = WRF_WARN_FILE_NOT_OPENED |
---|
75 | write(msg,*) & |
---|
76 | 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
77 | call wrf_debug ( WARN , msg) |
---|
78 | elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then |
---|
79 | Status = WRF_WARN_DRYRUN_READ |
---|
80 | write(msg,*) & |
---|
81 | 'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
82 | call wrf_debug ( WARN , msg) |
---|
83 | elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then |
---|
84 | Status = WRF_WARN_READ_WONLY_FILE |
---|
85 | write(msg,*) & |
---|
86 | 'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
87 | call wrf_debug ( WARN , msg) |
---|
88 | elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then |
---|
89 | do NVar=1,DH%NumVars |
---|
90 | if(DH%VarNames(NVar) == VarName) then |
---|
91 | exit |
---|
92 | elseif(NVar == DH%NumVars) then |
---|
93 | Status = WRF_WARN_VAR_NF |
---|
94 | write(msg,*) & |
---|
95 | 'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
96 | call wrf_debug ( WARN , msg) |
---|
97 | return |
---|
98 | endif |
---|
99 | enddo |
---|
100 | XLen_offset = i2offset(XLen) |
---|
101 | stat = NFMPI_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen_offset) |
---|
102 | XLen = XLen_offset |
---|
103 | call netcdf_err(stat,Status) |
---|
104 | if(Status /= WRF_NO_ERR) then |
---|
105 | write(msg,*) & |
---|
106 | 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element |
---|
107 | call wrf_debug ( WARN , msg) |
---|
108 | endif |
---|
109 | if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then |
---|
110 | if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then |
---|
111 | Status = WRF_WARN_TYPE_MISMATCH |
---|
112 | write(msg,*) & |
---|
113 | 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
114 | call wrf_debug ( WARN , msg) |
---|
115 | return |
---|
116 | endif |
---|
117 | else |
---|
118 | if(XType /= NF_TYPE) then |
---|
119 | Status = WRF_WARN_TYPE_MISMATCH |
---|
120 | write(msg,*) & |
---|
121 | 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
122 | call wrf_debug ( WARN , msg) |
---|
123 | return |
---|
124 | endif |
---|
125 | endif |
---|
126 | #ifndef CHAR_TYPE |
---|
127 | allocate(Buffer(XLen), STAT=stat) |
---|
128 | if(stat/= 0) then |
---|
129 | Status = WRF_ERR_FATAL_ALLOCATION_ERROR |
---|
130 | write(msg,*) & |
---|
131 | 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
132 | call wrf_debug ( FATAL , msg) |
---|
133 | return |
---|
134 | endif |
---|
135 | stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) |
---|
136 | #else |
---|
137 | if(XLen > len(Data)) then |
---|
138 | Status = WRF_WARN_CHARSTR_GT_LENDATA |
---|
139 | write(msg,*) & |
---|
140 | 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
141 | call wrf_debug ( WARN , msg) |
---|
142 | return |
---|
143 | endif |
---|
144 | stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Data ) |
---|
145 | #endif |
---|
146 | call netcdf_err(stat,Status) |
---|
147 | if(Status /= WRF_NO_ERR) then |
---|
148 | write(msg,*) & |
---|
149 | 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element |
---|
150 | call wrf_debug ( WARN , msg) |
---|
151 | endif |
---|
152 | COPY |
---|
153 | #ifndef CHAR_TYPE |
---|
154 | deallocate(Buffer, STAT=stat) |
---|
155 | if(stat/= 0) then |
---|
156 | Status = WRF_ERR_FATAL_DEALLOCATION_ERR |
---|
157 | write(msg,*) & |
---|
158 | 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
159 | call wrf_debug ( FATAL , msg) |
---|
160 | return |
---|
161 | endif |
---|
162 | if(XLen > Count) then |
---|
163 | OutCount = Count |
---|
164 | Status = WRF_WARN_MORE_DATA_IN_FILE |
---|
165 | else |
---|
166 | OutCount = XLen |
---|
167 | Status = WRF_NO_ERR |
---|
168 | endif |
---|
169 | #endif |
---|
170 | else |
---|
171 | Status = WRF_ERR_FATAL_BAD_FILE_STATUS |
---|
172 | write(msg,*) & |
---|
173 | 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ |
---|
174 | call wrf_debug ( FATAL , msg) |
---|
175 | return |
---|
176 | endif |
---|
177 | return |
---|