/[MITgcm]/MITgcm/pkg/mnc/mnc_cw_readwrite.template
ViewVC logotype

Contents of /MITgcm/pkg/mnc/mnc_cw_readwrite.template

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph

Revision 1.38 - (show annotations) (download)
Fri Aug 4 14:57:36 2006 UTC (17 years, 9 months ago) by edhill
Branch: MAIN
Changes since 1.37: +9 -3 lines 
overload the meaning of negative bi,bj values so that they specify
  "use the -bi,-bj values to compute the tile number but do not use
  the bi,bj values for offsets when reading" -- this allows one to
  "fake" the writing of per-tile information when no actual bi,bj
  values exist
1 C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_cw_readwrite.template,v 1.37 2006/03/10 16:09:31 edhill Exp $
2 C $Name: $
3
4 #include "MNC_OPTIONS.h"
5
6 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7 CBOP 0
8 C !ROUTINE: MNC_CW_RX_W_S
9
10 C !INTERFACE:
11 SUBROUTINE MNC_CW_RX_W_S(
12 I stype,
13 I fbname, bi,bj,
14 I vtype,
15 I var,
16 I myThid )
17
18 C !DESCRIPTION:
19 C A scalar version of MNC_CW_RX_W() for compilers that cannot
20 C gracefully handle the conversion on their own.
21
22 C !USES:
23 implicit none
24
25 C !INPUT PARAMETERS:
26 integer myThid, bi,bj
27 character*(*) stype, fbname, vtype
28 __V var
29 __V var_arr(1)
30 CEOP
31
32 var_arr(1) = var
33 CALL MNC_CW_RX_W(stype,fbname,bi,bj,vtype, var_arr, myThid)
34
35 RETURN
36 END
37
38 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
39 CBOP 0
40 C !ROUTINE: MNC_CW_RX_W
41
42 C !INTERFACE:
43 SUBROUTINE MNC_CW_RX_W(
44 I stype,
45 I fbname, bi,bj,
46 I vtype,
47 I var,
48 I myThid )
49
50 C !DESCRIPTION:
51 C A scalar version of MNC_CW_RX_W() for compilers that cannot
52 C gracefully handle the conversion on their own.
53
54 C !USES:
55 implicit none
56
57 C !INPUT PARAMETERS:
58 integer myThid, bi,bj
59 character*(*) stype, fbname, vtype
60 __V var(*)
61 INTEGER offsets(9)
62 CEOP
63 INTEGER i
64
65 DO i = 1,9
66 offsets(i) = 0
67 ENDDO
68 CALL MNC_CW_RX_W_OFFSET(stype,fbname,bi,bj,vtype, var,
69 & offsets, myThid)
70
71 RETURN
72 END
73
74 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
75 CBOP 0
76 C !ROUTINE: MNC_CW_RX_W_OFFSET
77
78 C !INTERFACE:
79 SUBROUTINE MNC_CW_RX_W_OFFSET(
80 I stype,
81 I fbname, bi,bj,
82 I vtype,
83 I var,
84 I offsets,
85 I myThid )
86
87 C !DESCRIPTION:
88 C This subroutine writes one variable to a file or a file group,
89 C depending upon the tile indicies.
90
91 C !USES:
92 implicit none
93 #include "netcdf.inc"
94 #include "mnc_common.h"
95 #include "SIZE.h"
96 #include "MNC_BUFF.h"
97 #include "EEPARAMS.h"
98 #include "PARAMS.h"
99 #include "MNC_PARAMS.h"
100
101 C !INPUT PARAMETERS:
102 integer myThid, bi,bj
103 character*(*) stype, fbname, vtype
104 __V var(*)
105 INTEGER offsets(*)
106 CEOP
107
108 C !LOCAL VARIABLES:
109 integer i,j,k, indv,nvf,nvl, n1,n2, igrid, ntot, indu
110 integer bis,bie, bjs,bje, uniq_tnum, uniq_fnum, nfname, iseq
111 integer fid, idv, indvids, ndim, indf, err, nf
112 integer lbi,lbj, bidim,bjdim, unlim_sz, kr
113 integer p(9),s(9),e(9), dimnc(9)
114 integer vstart(9),vcount(9), udo(9)
115 integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
116 integer indfg, fg1,fg2, npath
117 character*(MAX_LEN_MBUF) msgbuf
118 character*(MNC_MAX_PATH) fname
119 character*(MNC_MAX_PATH) path_fname
120 character*(MNC_MAX_PATH) tmpnm
121 character*(MNC_MAX_PATH) bpath
122 REAL*8 dval, dvm(2)
123 REAL*4 rval, rvm(2)
124 INTEGER ival, ivm(2), irv
125 REAL*8 resh_d( MNC_MAX_BUFF )
126 REAL*4 resh_r( MNC_MAX_BUFF )
127 INTEGER resh_i( MNC_MAX_BUFF )
128 LOGICAL write_attributes, use_missing
129 #ifdef HAVE_STAT
130 integer ntotenc, ncenc, nbytes, fs_isdone
131 character*(200) cenc
132 integer ienc(200)
133 REAL*8 fsnu
134 #endif
135
136 C Functions
137 integer IFNBLNK, ILNBLNK
138
139 C Only do I/O if I am the master thread
140 _BEGIN_MASTER( myThid )
141
142 DO i = 1,MNC_MAX_PATH
143 bpath(i:i) = ' '
144 ENDDO
145
146 C Get the current index for the unlimited dimension from the file
147 C group (or base) name
148 fg1 = IFNBLNK(fbname)
149 fg2 = ILNBLNK(fbname)
150 CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
151 IF (indfg .LT. 1) THEN
152 write(msgbuf,'(3a)')
153 & 'MNC_CW_RX_W ERROR: file group name ''',
154 & fbname(fg1:fg2), ''' is not defined'
155 CALL print_error(msgbuf, mythid)
156 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
157 ENDIF
158 indu = mnc_cw_fgud(indfg)
159 iseq = mnc_cw_fgis(indfg)
160 C write(*,*) 'indu,iseq = ', indu, iseq
161
162 C Check that the Variable Type exists
163 nvf = IFNBLNK(vtype)
164 nvl = ILNBLNK(vtype)
165 CALL MNC_GET_IND(MNC_MAX_ID, vtype, mnc_cw_vname, indv, myThid)
166 IF (indv .LT. 1) THEN
167 write(msgbuf,'(3a)') 'MNC_CW_RX_W ERROR: vtype ''',
168 & vtype(nvf:nvl), ''' is not defined'
169 CALL print_error(msgbuf, mythid)
170 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
171 ENDIF
172 igrid = mnc_cw_vgind(indv)
173
174 C Set the bi,bj indicies
175 bis = bi
176 bie = bi
177 IF (bi .EQ. 0) THEN
178 bis = 1
179 bie = nSx
180 ELSEIF (bi .LT. 0) THEN
181 bis = -bi
182 bie = -bi
183 ENDIF
184 bjs = bj
185 bje = bj
186 IF (bj .EQ. 0) THEN
187 bjs = 1
188 bje = nSy
189 ELSEIF (bj .LT. 0) THEN
190 bjs = -bj
191 bje = -bj
192 ENDIF
193
194 DO lbj = bjs,bje
195 DO lbi = bis,bie
196
197 #ifdef HAVE_STAT
198 fs_isdone = 0
199 #endif
200 10 CONTINUE
201
202 C Create the file name
203 CALL MNC_CW_GET_TILE_NUM(lbi,lbj, uniq_tnum, myThid)
204 fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
205 n1 = IFNBLNK(fbname)
206 n2 = ILNBLNK(fbname)
207
208 #ifdef MNC_WRITE_OLDNAMES
209
210 ntot = n2 - n1 + 1
211 fname(1:ntot) = fbname(n1:n2)
212 ntot = ntot + 1
213 fname(ntot:ntot) = '.'
214 IF ( mnc_use_name_ni0 ) THEN
215 write(fname((ntot+1):(ntot+17)),'(i10.10,a1,i6.6)')
216 & nIter0,'.',uniq_tnum
217 write(fname((ntot+18):(ntot+25)),'(a1,i4.4,a3)')
218 & '.', iseq, '.nc'
219 nfname = ntot + 25
220 ELSE
221 write(fname((ntot+1):(ntot+14)),'(i4.4,a1,i6.6,a3)')
222 & iseq,'.',uniq_tnum, '.nc'
223 nfname = ntot + 14
224 ENDIF
225
226 #else
227
228 CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)
229 k = ILNBLNK(tmpnm)
230 IF ( mnc_cw_cit(1,mnc_cw_fgci(indfg)) .GT. -1 ) THEN
231 j = mnc_cw_cit(2,mnc_cw_fgci(indfg))
232 IF ( mnc_cw_fgis(indfg) .GT. j )
233 & j = mnc_cw_fgis(indfg)
234 write(fname,'(a,a1,i10.10,a2,a,a3)') fbname(n1:n2),
235 & '.', j, '.t', tmpnm(1:k), '.nc'
236 ELSEIF ( mnc_cw_cit(1,mnc_cw_fgci(indfg)) .EQ. -1 ) THEN
237 C Leave off the myIter value entirely
238 write(fname,'(a,a2,a,a3)') fbname(n1:n2), '.t',
239 & tmpnm(1:k),'.nc'
240 ELSE
241 C We have an error--bad flag value
242 write(msgbuf,'(4a)')
243 & 'MNC_CW_RX_W ERROR: bad mnc_cw_cit(1,...) ',
244 & 'flag value for base name ''', fbname(fg1:fg2),
245 & ''''
246 CALL print_error(msgbuf, mythid)
247 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
248 ENDIF
249 nfname = ILNBLNK(fname)
250
251 #endif
252
253 C Add the path to the file name
254 IF (mnc_use_outdir) THEN
255 path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
256 npath = ILNBLNK(mnc_out_path)
257 path_fname(1:npath) = mnc_out_path(1:npath)
258 path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
259 fname(1:MNC_MAX_PATH) = path_fname(1:MNC_MAX_PATH)
260 nfname = npath + nfname
261 ENDIF
262
263 C Append to an existing or create a new file
264 CALL MNC_CW_FILE_AORC(fname,indf, lbi,lbj,uniq_tnum, myThid)
265 fid = mnc_f_info(indf,2)
266
267 #ifdef HAVE_STAT
268 IF ((mnc_cw_fgig(indfg) .EQ. 1)
269 & .AND. (fs_isdone .EQ. 0)) THEN
270 C Decide whether to append to the existing or create a new
271 C file based on the byte count per unlimited dimension
272 ncenc = 70
273 cenc(1:26) = 'abcdefghijklmnopqrstuvwxyz'
274 cenc(27:52) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
275 cenc(53:70) = '0123456789_.,+-=/~'
276 k = nfname
277 IF (k .GT. 200) k = 200
278 ntotenc = 0
279 DO i = 1,k
280 DO j = 1,ncenc
281 IF (fname(i:i) .EQ. cenc(j:j)) THEN
282 ntotenc = ntotenc + 1
283 ienc(ntotenc) = j
284 GOTO 20
285 ENDIF
286 ENDDO
287 20 CONTINUE
288 ENDDO
289 CALL mncfsize(ntotenc, ienc, nbytes)
290 IF (nbytes .GT. 0) THEN
291 CALL MNC_DIM_UNLIM_SIZE(fname, unlim_sz, myThid)
292 fsnu = (1.0 _d 0 + 1.0 _d 0 / DBLE(unlim_sz))
293 & * DBLE(nbytes)
294 IF (fsnu .GT. mnc_max_fsize) THEN
295 C Delete the now-full fname from the lookup tables since
296 C we are all done writing to it.
297 CALL MNC_FILE_CLOSE(fname, myThid)
298 indu = 1
299 mnc_cw_fgud(indfg) = 1
300
301 #ifdef MNC_WRITE_OLDNAMES
302 iseq = iseq + 1
303 mnc_cw_fgis(indfg) = iseq
304 #else
305 IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN
306 write(msgbuf,'(5a)')
307 & 'MNC_CW_RX_W ERROR: output file for base name ''',
308 & fbname(fg1:fg2), ''' is about to exceed the max ',
309 & 'file size and is NOT ALLOWED an iteration value ',
310 & 'within its file name'
311 CALL print_error(msgbuf, mythid)
312 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
313 ELSEIF (mnc_cw_cit(3,mnc_cw_fgci(indfg)) .LT. 0) THEN
314 write(msgbuf,'(5a)')
315 & 'MNC_CW_RX_W ERROR: output file for base name ''',
316 & fbname(fg1:fg2), ''' is about to exceed the max ',
317 & 'file size and no next-iter has been specified--',
318 & 'please see the MNC CITER functions'
319 CALL print_error(msgbuf, mythid)
320 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
321 ENDIF
322 mnc_cw_fgis(indfg) = mnc_cw_cit(3,mnc_cw_fgci(indfg))
323 C DO NOT BUMP THE CURRENT ITER FOR ALL FILES IN THIS CITER
324 C GROUP SINCE THIS IS ONLY GROWTH TO AVOID FILE SIZE
325 C LIMITS FOR THIS ONE BASENAME GROUP, NOT GROWTH OF THE
326 C ENTIRE CITER GROUP !!!
327 C mnc_cw_cit(2,mnc_cw_fgci(indfg))
328 C & = mnc_cw_cit(3,mnc_cw_fgci(indfg))
329 C mnc_cw_cit(3,mnc_cw_fgci(indfg)) = -1
330 #endif
331 fs_isdone = 1
332 GOTO 10
333
334 ENDIF
335 ENDIF
336 ENDIF
337 #endif /* HAVE_STAT */
338
339 C Ensure that all the NetCDF dimensions are defined and create a
340 C local copy of them
341 DO i = 1,9
342 dimnc(i) = 1
343 ENDDO
344 DO i = 1,mnc_cw_ndim(igrid)
345 IF (mnc_cw_dims(i,igrid) .EQ. -1) THEN
346 dimnc(i) = -1
347 ELSE
348 dimnc(i) = mnc_cw_ie(i,igrid) - mnc_cw_is(i,igrid) + 1
349 ENDIF
350
351 C Add the coordinate variables
352 CALL MNC_DIM_INIT_ALL_CV(fname,
353 & mnc_cw_dn(i,igrid), dimnc(i), 'Y', lbi,lbj, myThid)
354
355 ENDDO
356
357 C Ensure that the "grid" is defined
358 CALL MNC_GRID_INIT(fname, mnc_cw_gname(igrid),
359 & mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)
360
361 C Ensure that the variable is defined
362 irv = 0
363 IF (stype(1:1) .EQ. 'D')
364 & CALL MNC_VAR_INIT_DBL(
365 & fname, mnc_cw_gname(igrid), vtype, irv, myThid)
366 IF (stype(1:1) .EQ. 'R')
367 & CALL MNC_VAR_INIT_REAL(
368 & fname, mnc_cw_gname(igrid), vtype, irv, myThid)
369 IF (stype(1:1) .EQ. 'I')
370 & CALL MNC_VAR_INIT_INT(
371 & fname, mnc_cw_gname(igrid), vtype, irv, myThid)
372
373 IF (irv .GT. 0) THEN
374 C Return value indicates that the variable did not previously
375 C exist in this file, so we need to write all the attributes
376 write_attributes = .TRUE.
377 ELSE
378 write_attributes = .FALSE.
379 ENDIF
380
381 DO i = 1,mnc_fv_ids(indf,1)
382 j = 2 + 3*(i - 1)
383 IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vtype) THEN
384 idv = mnc_fv_ids(indf,j+1)
385 indvids = mnc_fd_ind(indf, mnc_f_info(indf,
386 & (mnc_fv_ids(indf,j+2) + 1)) )
387 GOTO 30
388 ENDIF
389 ENDDO
390 write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',
391 & 'cannot reference variable ''', vtype, ''''
392 CALL print_error(msgbuf, mythid)
393 STOP 'ABNORMAL END: package MNC'
394 30 CONTINUE
395
396 C Check for bi,bj indicies
397 bidim = mnc_cw_vbij(1,indv)
398 bjdim = mnc_cw_vbij(2,indv)
399 CEH3 write(*,*) 'bidim,bjdim = ', bidim,bjdim
400
401 C Set the dimensions for the in-memory array
402 ndim = mnc_cw_ndim(igrid)
403 k = mnc_cw_dims(1,igrid)
404 IF (k .GT. 0) THEN
405 p(1) = k
406 ELSE
407 p(1) = 1
408 ENDIF
409 DO i = 2,9
410 k = mnc_cw_dims(i,igrid)
411 IF (k .LT. 1) THEN
412 k = 1
413 ENDIF
414 IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
415 p(i) = nSx * p(i-1)
416 ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
417 p(i) = nSy * p(i-1)
418 ELSE
419 p(i) = k * p(i-1)
420 ENDIF
421 IF (offsets(i) .GT. 0) THEN
422 k = 1
423 p(i) = k * p(i-1)
424 ENDIF
425 ENDDO
426
427 C Set starting and ending indicies for the in-memory array and
428 C the unlimited dimension offset for the NetCDF array
429 DO i = 1,9
430 udo(i) = 0
431 s(i) = 1
432 e(i) = 1
433 IF (i .LE. ndim) THEN
434 s(i) = mnc_cw_is(i,igrid)
435 e(i) = mnc_cw_ie(i,igrid)
436 ENDIF
437 C Check for the unlimited dimension
438 IF ((i .EQ. ndim)
439 & .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
440 IF (indu .GT. 0) THEN
441 C Use the indu value
442 udo(i) = indu - 1
443 ELSEIF (indu .EQ. -1) THEN
444 C Append one to the current unlimited dim size
445 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
446 udo(i) = unlim_sz
447 ELSE
448 C Use the current unlimited dim size
449 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
450 udo(i) = unlim_sz - 1
451 ENDIF
452 ENDIF
453 ENDDO
454 IF (bidim .GT. 0) THEN
455 s(bidim) = lbi
456 e(bidim) = lbi
457 ENDIF
458 IF (bjdim .GT. 0) THEN
459 s(bjdim) = lbj
460 e(bjdim) = lbj
461 ENDIF
462
463 C Check the offsets
464 DO i = 1,9
465 IF (offsets(i) .GT. 0) THEN
466 udo(i) = udo(i) + offsets(i) - 1
467 s(i) = 1
468 e(i) = 1
469 ENDIF
470 ENDDO
471
472 IF (write_attributes) THEN
473 C Add the per-variable attributes
474 DO i = 1,mnc_cw_vnat(1,indv)
475 CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,
476 & mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)
477 ENDDO
478 DO i = 1,mnc_cw_vnat(2,indv)
479 CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,
480 & mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)
481 ENDDO
482 DO i = 1,mnc_cw_vnat(3,indv)
483 CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,
484 & mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)
485 ENDDO
486 ENDIF
487
488 C Handle missing values
489 use_missing = .FALSE.
490 IF (mnc_cw_vfmv(indv) .EQ. 0) THEN
491 use_missing = .FALSE.
492 ELSE
493 IF (mnc_cw_vfmv(indv) .EQ. 1) THEN
494 use_missing = .TRUE.
495 dvm(1) = mnc_def_dmv(1)
496 dvm(2) = mnc_def_dmv(2)
497 rvm(1) = mnc_def_rmv(1)
498 rvm(2) = mnc_def_rmv(2)
499 ivm(1) = mnc_def_imv(1)
500 ivm(2) = mnc_def_imv(2)
501 ELSEIF (mnc_cw_vfmv(indv) .EQ. 2) THEN
502 use_missing = .TRUE.
503 dvm(1) = mnc_cw_vmvd(1,indv)
504 dvm(2) = mnc_cw_vmvd(2,indv)
505 rvm(1) = mnc_cw_vmvr(1,indv)
506 rvm(2) = mnc_cw_vmvr(2,indv)
507 ivm(1) = mnc_cw_vmvi(1,indv)
508 ivm(2) = mnc_cw_vmvi(2,indv)
509 ENDIF
510 ENDIF
511 IF (write_attributes .AND. use_missing) THEN
512 write(msgbuf,'(4a)') 'writing attribute ''missing_value''',
513 & ' within file ''', fname(1:nfname), ''''
514 IF (stype(1:1) .EQ. 'D') THEN
515 err = NF_PUT_ATT_DOUBLE(fid, idv, 'missing_value',
516 & NF_DOUBLE, 1, dvm(2))
517 ELSEIF (stype(1:1) .EQ. 'R') THEN
518 err = NF_PUT_ATT_REAL(fid, idv, 'missing_value',
519 & NF_FLOAT, 1, dvm(2))
520 ELSEIF (stype(1:1) .EQ. 'I') THEN
521 err = NF_PUT_ATT_INT(fid, idv, 'missing_value',
522 & NF_INT, 1, ivm(2))
523 ENDIF
524 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
525 ENDIF
526
527 CALL MNC_FILE_ENDDEF(fname, myThid)
528
529 write(msgbuf,'(5a)') 'writing variable type ''',
530 & vtype(nvf:nvl), ''' within file ''',
531 & fname(1:nfname), ''''
532
533 C DO i = 1,9
534 C write(*,*) 'i,p(i),s(i),e(i),udo(i),offsets(i) = ',
535 C & i,p(i),s(i),e(i),udo(i),offsets(i)
536 C ENDDO
537
538 C Write the variable one vector at a time
539 DO j7 = s(7),e(7)
540 k7 = (j7 - 1)*p(6)
541 vstart(7) = udo(7) + j7 - s(7) + 1
542 vcount(7) = 1
543 DO j6 = s(6),e(6)
544 k6 = (j6 - 1)*p(5) + k7
545 vstart(6) = udo(6) + j6 - s(6) + 1
546 vcount(6) = 1
547 DO j5 = s(5),e(5)
548 k5 = (j5 - 1)*p(4) + k6
549 vstart(5) = udo(5) + j5 - s(5) + 1
550 vcount(5) = 1
551 DO j4 = s(4),e(4)
552 k4 = (j4 - 1)*p(3) + k5
553 vstart(4) = udo(4) + j4 - s(4) + 1
554 vcount(4) = 1
555 DO j3 = s(3),e(3)
556 k3 = (j3 - 1)*p(2) + k4
557 vstart(3) = udo(3) + j3 - s(3) + 1
558 vcount(3) = 1
559 DO j2 = s(2),e(2)
560 k2 = (j2 - 1)*p(1) + k3
561 vstart(2) = udo(2) + j2 - s(2) + 1
562 vcount(2) = 1
563
564 kr = 0
565 vstart(1) = udo(1) + 1
566 vcount(1) = e(1) - s(1) + 1
567
568 IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
569 write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
570 & '--please increase to at least ',
571 & vcount(1), ' in ''MNC_BUFF.h'''
572 CALL PRINT_ERROR(msgBuf , 1)
573 STOP 'ABNORMAL END: S/R MNC_CW_RX_W_OFFSET'
574 ENDIF
575
576 IF (use_missing) THEN
577
578 IF (stype(1:1) .EQ. 'D') THEN
579 DO j1 = s(1),e(1)
580 k1 = k2 + j1
581 kr = kr + 1
582 dval = var(k1)
583 IF (dval .EQ. dvm(1)) THEN
584 resh_d(kr) = dvm(2)
585 ELSE
586 resh_d(kr) = dval
587 ENDIF
588 ENDDO
589 err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
590 ELSEIF (stype(1:1) .EQ. 'R') THEN
591 DO j1 = s(1),e(1)
592 k1 = k2 + j1
593 kr = kr + 1
594 rval = var(k1)
595 IF (rval .EQ. rvm(1)) THEN
596 resh_r(kr) = rvm(2)
597 ELSE
598 resh_r(kr) = rval
599 ENDIF
600 ENDDO
601 err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
602 ELSEIF (stype(1:1) .EQ. 'I') THEN
603 DO j1 = s(1),e(1)
604 k1 = k2 + j1
605 kr = kr + 1
606 ival = MNC2I( var(k1) )
607 IF (ival .EQ. ivm(1)) THEN
608 resh_i(kr) = ivm(2)
609 ELSE
610 resh_i(kr) = ival
611 ENDIF
612 ENDDO
613 err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
614 ENDIF
615
616 ELSE
617
618 IF (stype(1:1) .EQ. 'D') THEN
619 DO j1 = s(1),e(1)
620 k1 = k2 + j1
621 kr = kr + 1
622 resh_d(kr) = var(k1)
623 ENDDO
624 err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
625 ELSEIF (stype(1:1) .EQ. 'R') THEN
626 DO j1 = s(1),e(1)
627 k1 = k2 + j1
628 kr = kr + 1
629 resh_r(kr) = var(k1)
630 ENDDO
631 err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
632 ELSEIF (stype(1:1) .EQ. 'I') THEN
633 DO j1 = s(1),e(1)
634 k1 = k2 + j1
635 kr = kr + 1
636 resh_i(kr) = MNC2I( var(k1) )
637 ENDDO
638 err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
639 ENDIF
640
641 ENDIF
642 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
643
644 ENDDO
645 ENDDO
646 ENDDO
647 ENDDO
648 ENDDO
649 ENDDO
650
651 C Sync the file
652 err = NF_SYNC(fid)
653 nf = ILNBLNK( fname )
654 write(msgbuf,'(3a)') 'sync for file ''', fname(1:nf),
655 & ''' in S/R MNC_CW_RX_W'
656 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
657
658 ENDDO
659 ENDDO
660
661 _END_MASTER( myThid )
662
663 RETURN
664 END
665
666
667 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
668 CBOP 0
669 C !ROUTINE: MNC_CW_RX_R_S
670
671 C !INTERFACE:
672 SUBROUTINE MNC_CW_RX_R_S(
673 I stype,
674 I fbname, bi,bj,
675 I vtype,
676 I var,
677 I myThid )
678
679 C !DESCRIPTION:
680 C A scalar version of MNC_CW_RX_R() for compilers that cannot
681 C gracefully handle the conversion on their own.
682
683 C !USES:
684 implicit none
685
686 C !INPUT PARAMETERS:
687 integer myThid, bi,bj
688 character*(*) stype, fbname, vtype
689 __V var
690 __V var_arr(1)
691 CEOP
692 var_arr(1) = var
693
694 CALL MNC_CW_RX_R(stype,fbname,bi,bj,vtype, var_arr, myThid)
695
696 RETURN
697 END
698
699
700 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
701 CBOP 0
702 C !ROUTINE: MNC_CW_RX_R
703
704 C !INTERFACE:
705 SUBROUTINE MNC_CW_RX_R(
706 I stype,
707 I fbname, bi,bj,
708 I vtype,
709 I var,
710 I myThid )
711
712 C !DESCRIPTION:
713 C This subroutine reads one variable from a file or a file group,
714 C depending upon the tile indicies.
715
716 C !USES:
717 implicit none
718 #include "netcdf.inc"
719 #include "mnc_common.h"
720 #include "SIZE.h"
721 #include "MNC_BUFF.h"
722 #include "EEPARAMS.h"
723 #include "PARAMS.h"
724 #include "MNC_PARAMS.h"
725
726 C !INPUT PARAMETERS:
727 integer myThid, bi,bj
728 character*(*) stype, fbname, vtype
729 __V var(*)
730 CEOP
731
732 C !LOCAL VARIABLES:
733 integer i,k, nvf,nvl, n1,n2, igrid, ntot, indu
734 integer bis,bie, bjs,bje, uniq_tnum,uniq_fnum, nfname, fid, idv
735 integer ndim, err, lbi,lbj, bidim,bjdim, unlim_sz, kr
736 integer ind_vt, npath, unlid, f_or_t, ixoff,iyoff
737 C integer f_sNx,f_sNy, alen, atype, ind_fv_ids, ierr, indf
738 integer p(9),s(9),e(9), vstart(9),vcount(9), udo(9)
739 integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
740 character*(MAX_LEN_MBUF) msgbuf
741 character*(MNC_MAX_PATH) fname
742 character*(MNC_MAX_PATH) fname_zs
743 character*(MNC_MAX_PATH) tmpnm
744 character*(MNC_MAX_PATH) path_fname
745 character*(MNC_MAX_PATH) bpath
746 integer indfg, fg1,fg2
747 REAL*8 resh_d( MNC_MAX_BUFF )
748 REAL*4 resh_r( MNC_MAX_BUFF )
749 INTEGER resh_i( MNC_MAX_BUFF )
750
751 C Functions
752 integer IFNBLNK, ILNBLNK
753
754 C Only do I/O if I am the master thread
755 _BEGIN_MASTER( myThid )
756
757 DO i = 1,MNC_MAX_PATH
758 bpath(i:i) = ' '
759 ENDDO
760
761 C Get the current index for the unlimited dimension from the file
762 C group (or base) name
763 fg1 = IFNBLNK(fbname)
764 fg2 = ILNBLNK(fbname)
765 CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
766 IF (indfg .LT. 1) THEN
767 write(msgbuf,'(3a)')
768 & 'MNC_CW_RX_W ERROR: file group name ''',
769 & fbname(fg1:fg2), ''' is not defined'
770 CALL print_error(msgbuf, mythid)
771 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
772 ENDIF
773 indu = mnc_cw_fgud(indfg)
774
775 C Check that the Variable Type exists
776 nvf = IFNBLNK(vtype)
777 nvl = ILNBLNK(vtype)
778 CALL MNC_GET_IND( MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt, myThid)
779 IF (ind_vt .LT. 1) THEN
780 write(msgbuf,'(3a)') 'MNC_CW_RX_R ERROR: vtype ''',
781 & vtype(nvf:nvl), ''' is not defined'
782 CALL print_error(msgbuf, mythid)
783 STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
784 ENDIF
785 igrid = mnc_cw_vgind(ind_vt)
786
787 C Check for bi,bj indicies
788 bidim = mnc_cw_vbij(1,ind_vt)
789 bjdim = mnc_cw_vbij(2,ind_vt)
790
791 C Set the bi,bj indicies
792 bis = bi
793 bie = bi
794 IF (bi .LT. 1) THEN
795 bis = 1
796 bie = nSx
797 ENDIF
798 bjs = bj
799 bje = bj
800 IF (bj .LT. 1) THEN
801 bjs = 1
802 bje = nSy
803 ENDIF
804
805 DO lbj = bjs,bje
806 DO lbi = bis,bie
807
808 C Create the file name
809 CALL MNC_CW_GET_TILE_NUM( lbi,lbj, uniq_tnum, myThid)
810 fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
811
812 #ifdef MNC_READ_OLDNAMES
813
814 n1 = IFNBLNK(fbname)
815 n2 = ILNBLNK(fbname)
816 ntot = n2 - n1 + 1
817 fname(1:ntot) = fbname(n1:n2)
818 ntot = ntot + 1
819 fname(ntot:ntot) = '.'
820 write(fname((ntot+1):(ntot+9)),'(i6.6,a3)') uniq_tnum, '.nc'
821 nfname = ntot+9
822
823 C Add the path to the file name
824 IF (mnc_use_indir) THEN
825 path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
826 npath = ILNBLNK(mnc_indir_str)
827 path_fname(1:npath) = mnc_indir_str(1:npath)
828 path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
829 fname(1:MNC_MAX_PATH) = path_fname(1:MNC_MAX_PATH)
830 nfname = npath + nfname
831 ENDIF
832
833 WRITE(fname_zs,'(2a,i4.4,a1,i6.6,a3)')
834 & mnc_indir_str(1:npath), fbname(n1:n2),
835 & 0, '.', uniq_tnum, '.nc'
836
837 C The steps are:
838 C (1) open the file in a READ-ONLY mode,
839 C (2) get the var id for the current variable,
840 C (3) read the data, and then
841 C (4) close the file--theres no need to keep it open!
842
843 write(msgbuf,'(4a)') 'MNC_CW_RX_R: cannot open',
844 & ' file ''', fname(1:nfname), ''' in read-only mode'
845 err = NF_OPEN(fname, NF_NOWRITE, fid)
846 IF ( err .NE. NF_NOERR ) THEN
847 C If the initial open fails, try again using a name with a
848 C zero sequence number inserted
849 err = NF_OPEN(fname_zs, NF_NOWRITE, fid)
850 ENDIF
851 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
852
853 write(msgbuf,'(5a)')
854 & 'MNC_CW_RX_R: cannot get id for variable ''',
855 & vtype(nvf:nvl), '''in file ''', fname(1:nfname), ''''
856 err = NF_INQ_VARID(fid, vtype, idv)
857 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
858 f_or_t = 0
859
860 #else
861
862 C The sequence for PER-FACE and PER-TILE is:
863 C (1) check whether a PER-FACE file exists
864 C . (a) if only one face is used for the entire domain,
865 C . then omit the face index from the file name
866 C . (b) if the PER-FACE file exists and is somehow faulty,
867 C . then we die with an error message
868 C (2) if no PER-FACE file exists, then use a PER-TILE file
869
870 C Create the PER-FACE file name
871 n1 = IFNBLNK(fbname)
872 n2 = ILNBLNK(fbname)
873 C Add an iteraton count to the file name if its requested
874 IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN
875 WRITE(fname,'(a,a1)') fbname(n1:n2), '.'
876 ELSE
877 WRITE(fname,'(a,a1,i10.10,a1)') fbname(n1:n2), '.',
878 & mnc_cw_cit(2,mnc_cw_fgci(indfg)), '.'
879 ENDIF
880 ntot = ILNBLNK(fname)
881 path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
882 npath = ILNBLNK(mnc_indir_str)
883 C Add the face index
884 CALL MNC_CW_GET_FACE_NUM( lbi,lbj, uniq_fnum, myThid)
885 IF ( uniq_fnum .EQ. -1 ) THEN
886 C There is only one face
887 WRITE(path_fname,'(2a,a2)')
888 & mnc_indir_str(1:npath), fname(1:ntot), 'nc'
889 ELSE
890 CALL MNC_PSNCM(tmpnm, uniq_fnum, MNC_DEF_FMNC)
891 k = ILNBLNK(tmpnm)
892 WRITE(path_fname,'(2a,a1,a,a3)')
893 & mnc_indir_str(1:npath), fname(1:ntot), 'f',
894 & tmpnm(1:k), '.nc'
895 ENDIF
896
897 C Try to open the PER-FACE file
898 C WRITE(*,*) 'trying: "', path_fname, '"'
899 err = NF_OPEN(path_fname, NF_NOWRITE, fid)
900 IF ( err .EQ. NF_NOERR ) THEN
901 f_or_t = 1
902 ELSE
903
904 C Create the PER-TILE file name
905 CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)
906 k = ILNBLNK(tmpnm)
907 path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
908 WRITE(path_fname,'(2a,a1,a,a3)')
909 & mnc_indir_str(1:npath), fname(1:ntot), 't',
910 & tmpnm(1:k), '.nc'
911 C WRITE(*,*) 'trying: "', path_fname, '"'
912 err = NF_OPEN(path_fname, NF_NOWRITE, fid)
913 IF ( err .EQ. NF_NOERR ) THEN
914 f_or_t = 0
915 ELSE
916 k = ILNBLNK(path_fname)
917 write(msgbuf,'(4a)')
918 & 'MNC_CW_RX_R: cannot open either a per-face or a ',
919 & 'per-tile file: last try was ''', path_fname(1:k),
920 & ''''
921 CALL print_error(msgbuf, mythid)
922 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
923 ENDIF
924
925 ENDIF
926
927 ntot = ILNBLNK(path_fname)
928 write(msgbuf,'(5a)')
929 & 'MNC_CW_RX_R: cannot get netCDF id for variable ''',
930 & vtype(nvf:nvl), ''' in file ''', path_fname(1:ntot),
931 & ''''
932 err = NF_INQ_VARID(fid, vtype, idv)
933 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
934
935 k = ILNBLNK(path_fname)
936 fname(1:k) = path_fname(1:k)
937 nfname = k
938
939 #endif
940
941 IF ( f_or_t .EQ. 1 ) THEN
942
943 C write(msgbuf,'(2a)')
944 C & 'MNC_CW_RX_R: per-face reads are not yet ',
945 C & 'implemented -- so pester Ed to finish them'
946 C CALL print_error(msgbuf, mythid)
947 C STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
948
949 C Get the X,Y PER-FACE offsets
950 CALL MNC_CW_GET_XYFO(lbi,lbj, ixoff,iyoff, myThid)
951
952 ENDIF
953
954 C WRITE(*,*) 'f_or_t = ',f_or_t
955
956 C Check that the current sNy,sNy values and the in-file values
957 C are compatible and WARN (only warn) if not
958 C f_sNx = -1
959 C f_sNy = -1
960 C err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)
961 C IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
962 C err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
963 C CALL MNC_HANDLE_ERR(err,
964 C & 'reading attribute ''sNx'' in S/R MNC_CW_RX_R',
965 C & myThid)
966 C ENDIF
967 C err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
968 C IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
969 C err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
970 C CALL MNC_HANDLE_ERR(err,
971 C & 'reading attribute ''sNy'' in S/R MNC_CW_RX_R',
972 C & myThid)
973 C ENDIF
974 C IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
975 C write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',
976 C & 'attributes ''sNx'' and ''sNy'' within the file ''',
977 C & fname(1:nfname), ''' do not exist or do not match ',
978 C & 'the current sizes within the model'
979 C CALL print_error(msgbuf, mythid)
980 C ENDIF
981
982 C Check that the in-memory variable and the in-file variables
983 C are of compatible sizes
984 C ires = 1
985 C CALL MNC_CHK_VTYP_R_NCVAR( ind_vt,
986 C & indf, ind_fv_ids, indu, ires)
987 C IF (ires .LT. 0) THEN
988 C write(msgbuf,'(7a)') 'MNC_CW_RX_R WARNING: the sizes ',
989 C & 'of the in-program variable ''', vtype(nvf:nvl),
990 C & ''' and the corresponding variable within file ''',
991 C & fname(1:nfname), ''' are not compatible -- please ',
992 C & 'check the sizes'
993 C CALL print_error(msgbuf, mythid)
994 C STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
995 C ENDIF
996
997 C Check for bi,bj indicies
998 bidim = mnc_cw_vbij(1,ind_vt)
999 bjdim = mnc_cw_vbij(2,ind_vt)
1000
1001 C Set the dimensions for the in-memory array
1002 ndim = mnc_cw_ndim(igrid)
1003 k = mnc_cw_dims(1,igrid)
1004 IF (k .GT. 0) THEN
1005 p(1) = k
1006 ELSE
1007 p(1) = 1
1008 ENDIF
1009 DO i = 2,9
1010 k = mnc_cw_dims(i,igrid)
1011 IF (k .LT. 1) THEN
1012 k = 1
1013 ENDIF
1014 IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
1015 p(i) = nSx * p(i-1)
1016 ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
1017 p(i) = nSy * p(i-1)
1018 ELSE
1019 p(i) = k * p(i-1)
1020 ENDIF
1021 ENDDO
1022
1023 C Set starting and ending indicies for the in-memory array and
1024 C the unlimited dimension offset for the NetCDF array
1025 DO i = 1,9
1026 udo(i) = 0
1027 s(i) = 1
1028 e(i) = 1
1029 IF (i .LE. ndim) THEN
1030 s(i) = mnc_cw_is(i,igrid)
1031 e(i) = mnc_cw_ie(i,igrid)
1032
1033 IF ( f_or_t .EQ. 1 ) THEN
1034 C Add the per-face X,Y offsets to the udo offset vector
1035 C since they accomplish the same thing
1036 IF ( mnc_cw_dn(i,igrid)(1:1) .EQ. 'X' ) THEN
1037 udo(i) = ixoff - 1
1038 ELSEIF ( mnc_cw_dn(i,igrid)(1:1) .EQ. 'Y' ) THEN
1039 udo(i) = iyoff - 1
1040 ENDIF
1041 ENDIF
1042
1043 ENDIF
1044 C Check for the unlimited dimension
1045 IF ((i .EQ. ndim)
1046 & .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
1047 IF (indu .GT. 0) THEN
1048 C Use the indu value
1049 udo(i) = indu - 1
1050 ELSE
1051 C We need the current unlim dim size
1052 write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
1053 & 'unlim dim id within file ''',
1054 & fname(1:nfname), ''''
1055 err = NF_INQ_UNLIMDIM(fid, unlid)
1056 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1057 write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
1058 & 'unlim dim size within file ''',
1059 & fname(1:nfname), ''''
1060 err = NF_INQ_DIMLEN(fid, unlid, unlim_sz)
1061 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1062 udo(i) = unlim_sz
1063 ENDIF
1064 ENDIF
1065 ENDDO
1066 IF (bidim .GT. 0) THEN
1067 s(bidim) = lbi
1068 e(bidim) = lbi
1069 ENDIF
1070 IF (bjdim .GT. 0) THEN
1071 s(bjdim) = lbj
1072 e(bjdim) = lbj
1073 ENDIF
1074
1075 C DO i = 9,1,-1
1076 C write(*,*) 'i,p(i),s(i),e(i) = ', i,': ',p(i),s(i),e(i)
1077 C ENDDO
1078
1079 write(msgbuf,'(5a)') 'reading variable type ''',
1080 & vtype(nvf:nvl), ''' within file ''',
1081 & fname(1:nfname), ''''
1082
1083 C Read the variable one vector at a time
1084 DO j7 = s(7),e(7)
1085 k7 = (j7 - 1)*p(6)
1086 vstart(7) = udo(7) + j7 - s(7) + 1
1087 vcount(7) = 1
1088 DO j6 = s(6),e(6)
1089 k6 = (j6 - 1)*p(5) + k7
1090 vstart(6) = udo(6) + j6 - s(6) + 1
1091 vcount(6) = 1
1092 DO j5 = s(5),e(5)
1093 k5 = (j5 - 1)*p(4) + k6
1094 vstart(5) = udo(5) + j5 - s(5) + 1
1095 vcount(5) = 1
1096 DO j4 = s(4),e(4)
1097 k4 = (j4 - 1)*p(3) + k5
1098 vstart(4) = udo(4) + j4 - s(4) + 1
1099 vcount(4) = 1
1100 DO j3 = s(3),e(3)
1101 k3 = (j3 - 1)*p(2) + k4
1102 vstart(3) = udo(3) + j3 - s(3) + 1
1103 vcount(3) = 1
1104 DO j2 = s(2),e(2)
1105 k2 = (j2 - 1)*p(1) + k3
1106 vstart(2) = udo(2) + j2 - s(2) + 1
1107 vcount(2) = 1
1108
1109 kr = 0
1110 vstart(1) = udo(1) + 1
1111 vcount(1) = e(1) - s(1) + 1
1112
1113 IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
1114 write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
1115 & '--please increase to at least ',
1116 & vcount(1), ' in ''MNC_BUFF.h'''
1117 CALL PRINT_ERROR(msgBuf , 1)
1118 STOP 'ABNORMAL END: S/R MNC_CW_RX_R_OFFSET'
1119 ENDIF
1120
1121 IF (stype(1:1) .EQ. 'D') THEN
1122 err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
1123 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1124 DO j1 = s(1),e(1)
1125 k1 = k2 + j1
1126 kr = kr + 1
1127 var(k1) = MNCI2( resh_d(kr) )
1128 ENDDO
1129 ENDIF
1130 IF (stype(1:1) .EQ. 'R') THEN
1131 err = NF_GET_VARA_REAL(fid, idv, vstart, vcount, resh_r)
1132 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1133 DO j1 = s(1),e(1)
1134 k1 = k2 + j1
1135 kr = kr + 1
1136 var(k1) = MNCI2( resh_r(kr) )
1137 ENDDO
1138 ENDIF
1139 IF (stype(1:1) .EQ. 'I') THEN
1140 err = NF_GET_VARA_INT(fid, idv, vstart, vcount, resh_i)
1141 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1142 DO j1 = s(1),e(1)
1143 k1 = k2 + j1
1144 kr = kr + 1
1145 var(k1) = resh_i(kr)
1146 ENDDO
1147 ENDIF
1148
1149
1150 ENDDO
1151 ENDDO
1152 ENDDO
1153 ENDDO
1154 ENDDO
1155 ENDDO
1156
1157 C Close the file
1158 C CALL MNC_FILE_CLOSE(fname, myThid)
1159 err = NF_CLOSE(fid)
1160 write(msgbuf,'(3a)') 'MNC_CW_RX_R: cannot close file ''',
1161 & fname(1:nfname), ''''
1162 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1163
1164
1165 C End the lbj,lbi loops
1166 ENDDO
1167 ENDDO
1168
1169 _END_MASTER( myThid )
1170
1171 RETURN
1172 END
1173
1174 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
1175
1176 CEH3 ;;; Local Variables: ***
1177 CEH3 ;;; mode:fortran ***
1178 CEH3 ;;; End: ***
  ViewVC Help
Powered by ViewVC 1.1.22