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