1 |
C $Header: $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "MNC_OPTIONS.h" |
5 |
|
6 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
7 |
CBOP 1 |
8 |
C !ROUTINE: MNC_HANDLE_ERR |
9 |
|
10 |
C !INTERFACE: |
11 |
SUBROUTINE MNC_HANDLE_ERR( status, msg, myThid ) |
12 |
|
13 |
C !DESCRIPTION: |
14 |
C Convenience function for handling all MNC and NetCDF library |
15 |
C errors. |
16 |
|
17 |
C !USES: |
18 |
implicit none |
19 |
#include "EEPARAMS.h" |
20 |
#include "netcdf.inc" |
21 |
|
22 |
C !DESCRIPTION: |
23 |
C Create an MNC grid within a NetCDF file context. |
24 |
|
25 |
C !USES: |
26 |
INTEGER myThid, status |
27 |
character*(*) msg |
28 |
CEOP |
29 |
|
30 |
C !LOCAL VARIABLES: |
31 |
integer i,lenm |
32 |
character*(MAX_LEN_MBUF) msgbuf |
33 |
|
34 |
C Functions |
35 |
integer ILNBLNK |
36 |
|
37 |
DO i = 1,MAX_LEN_MBUF |
38 |
msgbuf(i:i) = ' ' |
39 |
ENDDO |
40 |
|
41 |
IF ( status .NE. NF_NOERR ) THEN |
42 |
write(msgbuf,'(2a)') 'NetCDF ERROR: ' |
43 |
lenm = ILNBLNK(msgbuf) |
44 |
print *, msgbuf(1:lenm) |
45 |
CALL print_error(msgbuf(1:lenm), mythid) |
46 |
print *, '===' |
47 |
print *, NF_STRERROR(status) |
48 |
print *, '===' |
49 |
lenm = ILNBLNK(msg) |
50 |
lenm = MIN(lenm,MAX_LEN_MBUF-11) |
51 |
write(msgbuf,'(2a)') 'MNC ERROR: ', msg(1:lenm) |
52 |
lenm = ILNBLNK(msgbuf) |
53 |
print *, msgbuf(1:lenm) |
54 |
CALL print_error(msgbuf(1:lenm), mythid) |
55 |
stop 'ABNORMAL END: package MNC' |
56 |
ENDIF |
57 |
RETURN |
58 |
END |
59 |
|
60 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
61 |
CBOP 1 |
62 |
C !ROUTINE: MNC_GET_IND |
63 |
|
64 |
C !INTERFACE: |
65 |
SUBROUTINE MNC_GET_IND( |
66 |
I NT, |
67 |
I aname, |
68 |
I name_list, |
69 |
O ind, |
70 |
I myThid ) |
71 |
|
72 |
C !DESCRIPTION: |
73 |
C Get the index of the specified name. |
74 |
|
75 |
C !USES: |
76 |
implicit none |
77 |
#include "EEPARAMS.h" |
78 |
|
79 |
C !INPUT PARAMETERS: |
80 |
integer myThid, nt |
81 |
character*(*) aname |
82 |
character*(*) name_list(NT) |
83 |
CEOP |
84 |
|
85 |
C !LOCAL VARIABLES: |
86 |
integer n, i, nf, ind, lenm |
87 |
character*(MAX_LEN_MBUF) msgbuf |
88 |
|
89 |
C Functions |
90 |
integer ILNBLNK |
91 |
|
92 |
C Check that aname contains a valid name |
93 |
n = ILNBLNK( aname ) |
94 |
IF ( n .LT. 1 ) THEN |
95 |
write(msgbuf,'(a)') |
96 |
& 'MNC_GET_IND: an invalid (empty) name was specified' |
97 |
lenm = ILNBLNK(msgbuf) |
98 |
CALL print_error(msgbuf(1:lenm), myThid) |
99 |
stop 'ABNORMAL END: S/R MNC_GET_IND' |
100 |
ENDIF |
101 |
|
102 |
C Search for the index |
103 |
DO i=1,NT |
104 |
nf = ILNBLNK( name_list(i) ) |
105 |
IF ( nf .EQ. n ) THEN |
106 |
IF ( name_list(i)(1:n) .EQ. aname(1:n) ) THEN |
107 |
ind = i |
108 |
GOTO 10 |
109 |
ENDIF |
110 |
ENDIF |
111 |
ENDDO |
112 |
ind = -1 |
113 |
10 CONTINUE |
114 |
RETURN |
115 |
END |
116 |
|
117 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
118 |
CBOP 1 |
119 |
C !ROUTINE: MNC_GET_NEXT_EMPTY_IND |
120 |
|
121 |
C !INTERFACE: |
122 |
SUBROUTINE MNC_GET_NEXT_EMPTY_IND( |
123 |
I NT, |
124 |
I name_list, |
125 |
I var_symb, |
126 |
O ind, |
127 |
I myThid ) |
128 |
|
129 |
C !DESCRIPTION: |
130 |
C Get the index of the next empty entry. |
131 |
|
132 |
C !USES: |
133 |
implicit none |
134 |
#include "EEPARAMS.h" |
135 |
|
136 |
C !INPUT PARAMETERS: |
137 |
integer myThid, nt |
138 |
character*(*) name_list(NT) |
139 |
character*(*) var_symb |
140 |
CEOP |
141 |
|
142 |
C !LOCAL VARIABLES: |
143 |
integer n, i, ind |
144 |
character*(MAX_LEN_MBUF) msgbuf |
145 |
|
146 |
C Functions |
147 |
integer ILNBLNK |
148 |
|
149 |
|
150 |
C Search for the index |
151 |
DO i=1,NT |
152 |
n = ILNBLNK( name_list(i) ) |
153 |
IF ( n .EQ. 0 ) THEN |
154 |
ind = i |
155 |
GOTO 10 |
156 |
ENDIF |
157 |
ENDDO |
158 |
|
159 |
C If this is code is reached, we have exceeded the array size |
160 |
write(msgbuf,'(a,i6,a)') |
161 |
& 'MNC_GET_NEXT_EMPTY_IND: array size ', nt, |
162 |
& ' exceeded' |
163 |
CALL print_error( msgbuf, myThid ) |
164 |
n = ILNBLNK( var_symb ) |
165 |
write(msgbuf,'(a,a,a)') |
166 |
& 'MNC_GET_NEXT_EMPTY_IND: occurred within the ''', |
167 |
& var_symb(1:n), ''' array' |
168 |
CALL print_error( msgbuf, myThid ) |
169 |
stop 'ABNORMAL END: S/R MNC_GET_NEXT_EMPTY_IND' |
170 |
|
171 |
10 CONTINUE |
172 |
RETURN |
173 |
END |
174 |
|
175 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
176 |
CBOP 1 |
177 |
C !ROUTINE: MNC_GET_FVINDS |
178 |
|
179 |
C !INTERFACE: |
180 |
SUBROUTINE MNC_GET_FVINDS( |
181 |
I fname, |
182 |
I vname, |
183 |
O indf, |
184 |
O ind_fv_ids, |
185 |
I myThid ) |
186 |
|
187 |
C !DESCRIPTION: |
188 |
C Get the variable indicies. |
189 |
|
190 |
C !USES: |
191 |
implicit none |
192 |
#include "MNC_COMMON.h" |
193 |
#include "netcdf.inc" |
194 |
|
195 |
C !INPUT PARAMETERS: |
196 |
INTEGER myThid, fid, indf, ind_fv_ids |
197 |
character*(*) fname |
198 |
character*(*) vname |
199 |
CEOP |
200 |
|
201 |
C !LOCAL VARIABLES: |
202 |
integer i,j,k, n, lenv |
203 |
|
204 |
C Functions |
205 |
integer ILNBLNK |
206 |
|
207 |
C Strip trailing spaces |
208 |
lenv = ILNBLNK(vname) |
209 |
|
210 |
C Check that the file exists |
211 |
CALL MNC_GET_IND(MNC_MAX_FID, fname, mnc_f_names, indf, myThid) |
212 |
IF (indf .LT. 1) THEN |
213 |
ind_fv_ids = -1 |
214 |
RETURN |
215 |
ENDIF |
216 |
fid = mnc_f_info(indf,2) |
217 |
|
218 |
C Find the vID |
219 |
DO i = 1,mnc_fv_ids(indf,1) |
220 |
k = 2 + 3*(i - 1) |
221 |
j = mnc_fv_ids(indf,k) |
222 |
n = ILNBLNK(mnc_v_names(j)) |
223 |
IF ( n.EQ.lenv ) THEN |
224 |
IF ( mnc_v_names(j)(1:n).EQ.vname(1:n) ) THEN |
225 |
ind_fv_ids = k |
226 |
GOTO 10 |
227 |
ENDIF |
228 |
ENDIF |
229 |
ENDDO |
230 |
ind_fv_ids = -1 |
231 |
10 CONTINUE |
232 |
|
233 |
RETURN |
234 |
END |
235 |
|
236 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
237 |
|
238 |
C Here, we determine whether the dimensions (sizes) of a specific |
239 |
C variable within the MNC low-level look-up tables matches the |
240 |
C dimensions of a Variable Type defined within the upper-level CW |
241 |
C layer. |
242 |
C |
243 |
C Return values: |
244 |
C . YES ==> ires > 0 |
245 |
C . NO ==> ires < 0 |
246 |
|
247 |
SUBROUTINE MNC_CHK_VTYP_R_NCVAR( |
248 |
I ind_vt, |
249 |
I indf, |
250 |
I ind_fv_ids, |
251 |
I indu, |
252 |
O ires, |
253 |
I myThid ) |
254 |
|
255 |
implicit none |
256 |
#include "MNC_COMMON.h" |
257 |
#include "EEPARAMS.h" |
258 |
|
259 |
C Arguments |
260 |
INTEGER myThid, ind_vt, indf, ind_fv_ids, indu, ires |
261 |
|
262 |
C Functions |
263 |
integer ILNBLNK |
264 |
|
265 |
C Locals |
266 |
integer ii,k, ind_cw_g, ig,ids,ide,nint, indd, cw_len, nk |
267 |
integer ndim_vt, ncgt,ncvr,ncvf, npb, sz_min |
268 |
character*1 ch |
269 |
character*(MAX_LEN_MBUF) pbuf, msgbuf |
270 |
|
271 |
ires = -1 |
272 |
|
273 |
C grid indicies for the internal (as-read-from-the-file) data |
274 |
ig = mnc_fv_ids(indf,ind_fv_ids+2) |
275 |
ids = mnc_f_info(indf,ig+1) |
276 |
ide = mnc_f_info(indf,ig+2) |
277 |
nint = ids - ide + 1 |
278 |
|
279 |
ind_cw_g = mnc_cw_vgind(ind_vt) |
280 |
ncgt = ILNBLNK(mnc_cw_gname(ind_cw_g)) |
281 |
ncvr = ILNBLNK(mnc_v_names(mnc_fv_ids(indf,ind_fv_ids))) |
282 |
ncvf = ILNBLNK(mnc_f_names(indf)) |
283 |
write(pbuf,'(7a)') 'MNC_CHK_VTYP_R_NCVAR WARNING: var ''', |
284 |
& mnc_v_names(mnc_fv_ids(indf,ind_fv_ids))(1:ncvr), |
285 |
& ''' within file ''', mnc_f_names(indf)(1:ncvf), |
286 |
& ''' does not satisy the size needed by GType ''', |
287 |
& mnc_cw_gname(ind_cw_g)(1:ncgt), '''' |
288 |
npb = ILNBLNK(pbuf) |
289 |
ndim_vt = mnc_cw_ndim(ind_cw_g) |
290 |
nk = nint |
291 |
IF (ndim_vt .LT. nk) nk = ndim_vt |
292 |
IF (nint .NE. ndim_vt) THEN |
293 |
write(msgbuf,'(2a)') pbuf(1:npb), ' -- too few dims' |
294 |
CALL print_error(msgbuf, myThid) |
295 |
ENDIF |
296 |
|
297 |
C Check that the necessary size exists along each dimension |
298 |
DO k = 1,nk |
299 |
ii = ids + (k - 1) |
300 |
sz_min = mnc_cw_dims(k,ind_cw_g) |
301 |
IF (sz_min .EQ. -1) sz_min = indu |
302 |
indd = mnc_fd_ind(indf,ii) |
303 |
IF (mnc_d_size(indd) .LT. sz_min) THEN |
304 |
write(msgbuf,'(2a,i3,a,i3,a,i3)') pbuf(1:npb), ': dim #', |
305 |
& k, ' is too small: ', mnc_d_size(indd), ' vs ', |
306 |
& mnc_cw_ie(k,ind_cw_g) |
307 |
CALL print_error(msgbuf, myThid) |
308 |
RETURN |
309 |
ENDIF |
310 |
ENDDO |
311 |
|
312 |
C Reaching this point means all tests passed |
313 |
ires = 1 |
314 |
|
315 |
RETURN |
316 |
END |
317 |
|
318 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
319 |
CBOP 1 |
320 |
C !ROUTINE: MNC_PSNCM |
321 |
|
322 |
C !INTERFACE: |
323 |
SUBROUTINE MNC_PSNCM( |
324 |
O ostring, |
325 |
I ival, n ) |
326 |
|
327 |
C !DESCRIPTION: |
328 |
C Print a zero-padded integer to a String with an N-Character |
329 |
C Minimum length |
330 |
|
331 |
IMPLICIT NONE |
332 |
|
333 |
C !INPUT PARAMETERS: |
334 |
C ostring :: String to contain formatted output |
335 |
CHARACTER*(*) ostring |
336 |
INTEGER ival, n |
337 |
CEOP |
338 |
|
339 |
C !LOCAL VARIABLES: |
340 |
INTEGER i, lens, nmin |
341 |
CHARACTER*(25) tmp |
342 |
|
343 |
lens = LEN(ostring) |
344 |
DO i = 1,lens |
345 |
ostring(i:i) = ' ' |
346 |
ENDDO |
347 |
WRITE(tmp,'(I25.25)') ival |
348 |
DO i = 1,25 |
349 |
IF (tmp(i:i) .NE. '0') THEN |
350 |
nmin = 26 - i |
351 |
GOTO 200 |
352 |
ENDIF |
353 |
ENDDO |
354 |
200 CONTINUE |
355 |
IF (nmin .LT. n) nmin = n |
356 |
ostring(1:nmin) = tmp((26-nmin):25) |
357 |
|
358 |
C |
359 |
RETURN |
360 |
END |
361 |
|
362 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
363 |
|