/[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.27 - (show annotations) (download)
Fri Dec 17 21:28:25 2004 UTC (19 years, 4 months ago) by edhill
Branch: MAIN
CVS Tags: checkpoint57b_post
Changes since 1.26: +5 -5 lines 
 o add CF-style coordinate variables to MNC
   - just a first cut:  numbers are meaningless on the cubesphere and
     missing along the T axis but otherwise it works!
1 C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_cw_readwrite.template,v 1.26 2004/12/17 04:50:05 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_SIZE.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, nfname, iseq
111 integer fid, idv, indvids, ndim, indf, err
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_CHAR) fname
119 character*(MNC_MAX_CHAR) path_fname
120 REAL*8 resh_d( MNC_MAX_BUFF )
121 REAL*4 resh_r( MNC_MAX_BUFF )
122 INTEGER resh_i( MNC_MAX_BUFF )
123 #ifdef HAVE_STAT
124 integer ntotenc, ncenc, nbytes, fs_isdone
125 character*(200) cenc
126 integer ienc(200)
127 REAL*8 fsnu
128 #endif
129
130 C Functions
131 integer IFNBLNK, ILNBLNK
132
133 C Only do I/O if I am the master thread
134 _BEGIN_MASTER( myThid )
135
136 C Get the current index for the unlimited dimension from the file
137 C group (or base) name
138 fg1 = IFNBLNK(fbname)
139 fg2 = ILNBLNK(fbname)
140 CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
141 IF (indfg .LT. 1) THEN
142 write(msgbuf,'(3a)')
143 & 'MNC_CW_RX_W ERROR: file group name ''',
144 & fbname(fg1:fg2), ''' is not defined'
145 CALL print_error(msgbuf, mythid)
146 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
147 ENDIF
148 indu = mnc_cw_fgud(indfg)
149 iseq = mnc_cw_fgis(indfg)
150 C write(*,*) 'indu,iseq = ', indu, iseq
151
152 C Check that the Variable Type exists
153 nvf = IFNBLNK(vtype)
154 nvl = ILNBLNK(vtype)
155 CALL MNC_GET_IND(MNC_MAX_ID, vtype, mnc_cw_vname, indv, myThid)
156 IF (indv .LT. 1) THEN
157 write(msgbuf,'(3a)') 'MNC_CW_RX_W ERROR: vtype ''',
158 & vtype(nvf:nvl), ''' is not defined'
159 CALL print_error(msgbuf, mythid)
160 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
161 ENDIF
162 igrid = mnc_cw_vgind(indv)
163
164 C Set the bi,bj indicies
165 bis = bi
166 bie = bi
167 IF (bi .LT. 1) THEN
168 bis = 1
169 bie = nSx
170 ENDIF
171 bjs = bj
172 bje = bj
173 IF (bj .LT. 1) THEN
174 bjs = 1
175 bje = nSy
176 ENDIF
177
178 DO lbj = bjs,bje
179 DO lbi = bis,bie
180
181 #ifdef HAVE_STAT
182 fs_isdone = 0
183 #endif
184 10 CONTINUE
185
186 C Create the file name
187 CALL MNC_CW_GET_TILE_NUM(lbi,lbj, uniq_tnum, myThid)
188 fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
189 n1 = IFNBLNK(fbname)
190 n2 = ILNBLNK(fbname)
191 ntot = n2 - n1 + 1
192 fname(1:ntot) = fbname(n1:n2)
193 ntot = ntot + 1
194 fname(ntot:ntot) = '.'
195 write(fname((ntot+1):(ntot+14)),'(i4.4,a1,i6.6,a3)')
196 & iseq,'.',uniq_tnum, '.nc'
197 nfname = ntot + 14
198
199 C Add the path to the file name
200 IF (mnc_use_outdir) THEN
201 path_fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
202 npath = ILNBLNK(mnc_out_path)
203 path_fname(1:npath) = mnc_out_path(1:npath)
204 path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
205 fname(1:MNC_MAX_CHAR) = path_fname(1:MNC_MAX_CHAR)
206 nfname = npath + nfname
207 ENDIF
208
209 C Append to an existing or create a new file
210 CALL MNC_CW_FILE_AORC(fname,indf, lbi,lbj,uniq_tnum, myThid)
211 fid = mnc_f_info(indf,2)
212
213 #ifdef HAVE_STAT
214 IF ((mnc_cw_fgig(indfg) .EQ. 1)
215 & .AND. (fs_isdone .EQ. 0)) THEN
216 C Decide whether to append to the existing or create a new
217 C file based on the byte count per unlimited dimension
218 ncenc = 70
219 cenc(1:26) = 'abcdefghijklmnopqrstuvwxyz'
220 cenc(27:52) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
221 cenc(53:70) = '0123456789_.,+-=/~'
222 k = nfname
223 IF (k .GT. 200) k = 200
224 ntotenc = 0
225 DO i = 1,k
226 DO j = 1,ncenc
227 IF (fname(i:i) .EQ. cenc(j:j)) THEN
228 ntotenc = ntotenc + 1
229 ienc(ntotenc) = j
230 GOTO 20
231 ENDIF
232 ENDDO
233 20 CONTINUE
234 ENDDO
235 CALL mncfsize(ntotenc, ienc, nbytes)
236 IF (nbytes .GT. 0) THEN
237 CALL MNC_DIM_UNLIM_SIZE(fname, unlim_sz, myThid)
238 fsnu = (1.0 _d 0 + 1.0 _d 0 / DBLE(unlim_sz))
239 & * DBLE(nbytes)
240 IF (fsnu .GT. mnc_max_fsize) THEN
241 C Delete the now-full fname from the lookup tables since
242 C we are all done writing to it.
243 CALL MNC_FILE_CLOSE(fname, myThid)
244 iseq = iseq + 1
245 indu = 1
246 mnc_cw_fgud(indfg) = 1
247 mnc_cw_fgis(indfg) = iseq
248 fs_isdone = 1
249 GOTO 10
250 ENDIF
251 ENDIF
252 ENDIF
253 #endif /* HAVE_STAT */
254
255 C Ensure that all the NetCDF dimensions are defined and create a
256 C local copy of them
257 DO i = 1,9
258 dimnc(i) = 1
259 ENDDO
260 DO i = 1,mnc_cw_ndim(igrid)
261 IF (mnc_cw_dims(i,igrid) .EQ. -1) THEN
262 dimnc(i) = -1
263 ELSE
264 dimnc(i) = mnc_cw_ie(i,igrid) - mnc_cw_is(i,igrid) + 1
265 ENDIF
266 C CALL MNC_DIM_INIT(fname,
267 C & mnc_cw_dn(i,igrid), dimnc(i), myThid)
268
269 C Add the coordinate variables
270 CALL MNC_DIM_INIT_ALL_CV(fname,
271 & mnc_cw_dn(i,igrid), dimnc(i), 'Y', lbi,lbj, myThid)
272
273 ENDDO
274
275 C Ensure that the "grid" is defined
276 CALL MNC_GRID_INIT(fname, mnc_cw_gname(igrid),
277 & mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)
278
279 C Ensure that the variable is defined
280 IF (stype(1:1) .EQ. 'D')
281 & CALL MNC_VAR_INIT_DBL(
282 & fname, mnc_cw_gname(igrid), vtype, myThid)
283 IF (stype(1:1) .EQ. 'R')
284 & CALL MNC_VAR_INIT_REAL(
285 & fname, mnc_cw_gname(igrid), vtype, myThid)
286 IF (stype(1:1) .EQ. 'I')
287 & CALL MNC_VAR_INIT_INT(
288 & fname, mnc_cw_gname(igrid), vtype, myThid)
289
290 DO i = 1,mnc_fv_ids(indf,1)
291 j = 2 + 3*(i - 1)
292 IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vtype) THEN
293 idv = mnc_fv_ids(indf,j+1)
294 indvids = mnc_fd_ind(indf, mnc_f_info(indf,
295 & (mnc_fv_ids(indf,j+2) + 1)) )
296 GOTO 30
297 ENDIF
298 ENDDO
299 write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',
300 & 'cannot reference variable ''', vtype, ''''
301 CALL print_error(msgbuf, mythid)
302 STOP 'ABNORMAL END: package MNC'
303 30 CONTINUE
304
305 C Check for bi,bj indicies
306 bidim = mnc_cw_vbij(1,indv)
307 bjdim = mnc_cw_vbij(2,indv)
308 CEH3 write(*,*) 'bidim,bjdim = ', bidim,bjdim
309
310 C Set the dimensions for the in-memory array
311 ndim = mnc_cw_ndim(igrid)
312 k = mnc_cw_dims(1,igrid)
313 IF (k .GT. 0) THEN
314 p(1) = k
315 ELSE
316 p(1) = 1
317 ENDIF
318 DO i = 2,9
319 k = mnc_cw_dims(i,igrid)
320 IF (k .LT. 1) THEN
321 k = 1
322 ENDIF
323 IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
324 p(i) = nSx * p(i-1)
325 ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
326 p(i) = nSy * p(i-1)
327 ELSE
328 p(i) = k * p(i-1)
329 ENDIF
330 IF (offsets(i) .GT. 0) THEN
331 k = 1
332 p(i) = k * p(i-1)
333 ENDIF
334 ENDDO
335
336 C Set starting and ending indicies for the in-memory array and
337 C the unlimited dimension offset for the NetCDF array
338 DO i = 1,9
339 udo(i) = 0
340 s(i) = 1
341 e(i) = 1
342 IF (i .LE. ndim) THEN
343 s(i) = mnc_cw_is(i,igrid)
344 e(i) = mnc_cw_ie(i,igrid)
345 ENDIF
346 C Check for the unlimited dimension
347 IF ((i .EQ. ndim)
348 & .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
349 IF (indu .GT. 0) THEN
350 C Use the indu value
351 udo(i) = indu - 1
352 ELSEIF (indu .EQ. -1) THEN
353 C Append one to the current unlimited dim size
354 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
355 udo(i) = unlim_sz
356 ELSE
357 C Use the current unlimited dim size
358 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
359 udo(i) = unlim_sz - 1
360 ENDIF
361 ENDIF
362 ENDDO
363 IF (bidim .GT. 0) THEN
364 s(bidim) = lbi
365 e(bidim) = lbi
366 ENDIF
367 IF (bjdim .GT. 0) THEN
368 s(bjdim) = lbj
369 e(bjdim) = lbj
370 ENDIF
371
372 C Check the offsets
373 DO i = 1,9
374 IF (offsets(i) .GT. 0) THEN
375 udo(i) = udo(i) + offsets(i) - 1
376 s(i) = 1
377 e(i) = 1
378 ENDIF
379 ENDDO
380
381 C Add the per-variable attributes
382 DO i = 1,mnc_cw_vnat(1,indv)
383 CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,
384 & mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)
385 ENDDO
386 DO i = 1,mnc_cw_vnat(2,indv)
387 CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,
388 & mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)
389 ENDDO
390 DO i = 1,mnc_cw_vnat(3,indv)
391 CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,
392 & mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)
393 ENDDO
394
395 CALL MNC_FILE_ENDDEF(fname, myThid)
396
397 write(msgbuf,'(5a)') 'writing variable type ''',
398 & vtype(nvf:nvl), ''' within file ''',
399 & fname(1:nfname), ''''
400
401 C DO i = 1,9
402 C write(*,*) 'i,p(i),s(i),e(i),udo(i),offsets(i) = ',
403 C & i,p(i),s(i),e(i),udo(i),offsets(i)
404 C ENDDO
405
406 C Write the variable one vector at a time
407 DO j7 = s(7),e(7)
408 k7 = (j7 - 1)*p(6)
409 vstart(7) = udo(7) + j7 - s(7) + 1
410 vcount(7) = 1
411 DO j6 = s(6),e(6)
412 k6 = (j6 - 1)*p(5) + k7
413 vstart(6) = udo(6) + j6 - s(6) + 1
414 vcount(6) = 1
415 DO j5 = s(5),e(5)
416 k5 = (j5 - 1)*p(4) + k6
417 vstart(5) = udo(5) + j5 - s(5) + 1
418 vcount(5) = 1
419 DO j4 = s(4),e(4)
420 k4 = (j4 - 1)*p(3) + k5
421 vstart(4) = udo(4) + j4 - s(4) + 1
422 vcount(4) = 1
423 DO j3 = s(3),e(3)
424 k3 = (j3 - 1)*p(2) + k4
425 vstart(3) = udo(3) + j3 - s(3) + 1
426 vcount(3) = 1
427 DO j2 = s(2),e(2)
428 k2 = (j2 - 1)*p(1) + k3
429 vstart(2) = udo(2) + j2 - s(2) + 1
430 vcount(2) = 1
431
432 kr = 0
433 vstart(1) = udo(1) + 1
434 vcount(1) = e(1) - s(1) + 1
435
436 IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
437 write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
438 & '--please increase to at least ',
439 & vcount(1), ' in ''MNC_SIZE.h'''
440 CALL PRINT_ERROR(msgBuf , 1)
441 STOP 'ABNORMAL END: S/R MNC_CW_RX_W_OFFSET'
442 ENDIF
443
444 IF (stype(1:1) .EQ. 'D') THEN
445 DO j1 = s(1),e(1)
446 k1 = k2 + j1
447 kr = kr + 1
448 resh_d(kr) = var(k1)
449 ENDDO
450 err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
451 ENDIF
452 IF (stype(1:1) .EQ. 'R') THEN
453 DO j1 = s(1),e(1)
454 k1 = k2 + j1
455 kr = kr + 1
456 resh_r(kr) = var(k1)
457 ENDDO
458 err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
459 ENDIF
460 IF (stype(1:1) .EQ. 'I') THEN
461 DO j1 = s(1),e(1)
462 k1 = k2 + j1
463 kr = kr + 1
464 resh_i(kr) = var(k1)
465 ENDDO
466 err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
467 ENDIF
468
469 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
470
471 ENDDO
472 ENDDO
473 ENDDO
474 ENDDO
475 ENDDO
476 ENDDO
477
478 C Sync the file
479 err = NF_SYNC(fid)
480 write(msgbuf,'(3a)') 'sync for file ''', fname,
481 & ''' in S/R MNC_CW_RX_W'
482 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
483
484 ENDDO
485 ENDDO
486
487 _END_MASTER( myThid )
488
489 RETURN
490 END
491
492
493 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
494 CBOP 0
495 C !ROUTINE: MNC_CW_RX_R_S
496
497 C !INTERFACE:
498 SUBROUTINE MNC_CW_RX_R_S(
499 I stype,
500 I fbname, bi,bj,
501 I vtype,
502 I var,
503 I myThid )
504
505 C !DESCRIPTION:
506 C A scalar version of MNC_CW_RX_R() for compilers that cannot
507 C gracefully handle the conversion on their own.
508
509 C !USES:
510 implicit none
511
512 C !INPUT PARAMETERS:
513 integer myThid, bi,bj
514 character*(*) stype, fbname, vtype
515 __V var
516 __V var_arr(1)
517 CEOP
518 var_arr(1) = var
519
520 CALL MNC_CW_RX_R(stype,fbname,bi,bj,vtype, var_arr, myThid)
521
522 RETURN
523 END
524
525
526 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
527 CBOP 0
528 C !ROUTINE: MNC_CW_RX_R
529
530 C !INTERFACE:
531 SUBROUTINE MNC_CW_RX_R(
532 I stype,
533 I fbname, bi,bj,
534 I vtype,
535 I var,
536 I myThid )
537
538 C !DESCRIPTION:
539 C This subroutine reads one variable from a file or a file group,
540 C depending upon the tile indicies.
541
542 C !USES:
543 implicit none
544 #include "netcdf.inc"
545 #include "mnc_common.h"
546 #include "SIZE.h"
547 #include "MNC_SIZE.h"
548 #include "EEPARAMS.h"
549 #include "PARAMS.h"
550 #include "MNC_PARAMS.h"
551
552 C !INPUT PARAMETERS:
553 integer myThid, bi,bj
554 character*(*) stype, fbname, vtype
555 __V var(*)
556 CEOP
557
558 C !LOCAL VARIABLES:
559 integer i,k, nvf,nvl, n1,n2, igrid, ntot, indu
560 integer bis,bie, bjs,bje, uniq_tnum, nfname, fid, idv
561 integer ndim, indf, err, lbi,lbj, bidim,bjdim, unlim_sz, kr
562 integer ind_fv_ids, ind_vt, ierr, atype, alen
563 integer f_sNx,f_sNy, npath
564 integer p(9),s(9),e(9), vstart(9),vcount(9), udo(9)
565 integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
566 character*(MAX_LEN_MBUF) msgbuf
567 character*(MNC_MAX_CHAR) fname
568 character*(MNC_MAX_CHAR) path_fname
569 integer indfg, fg1,fg2
570 REAL*8 resh_d( MNC_MAX_BUFF )
571 REAL*4 resh_r( MNC_MAX_BUFF )
572 INTEGER resh_i( MNC_MAX_BUFF )
573
574 C Functions
575 integer IFNBLNK, ILNBLNK
576
577 C Only do I/O if I am the master thread
578 _BEGIN_MASTER( myThid )
579
580 C Get the current index for the unlimited dimension from the file
581 C group (or base) name
582 fg1 = IFNBLNK(fbname)
583 fg2 = ILNBLNK(fbname)
584 CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
585 IF (indfg .LT. 1) THEN
586 write(msgbuf,'(3a)')
587 & 'MNC_CW_RX_W ERROR: file group name ''',
588 & fbname(fg1:fg2), ''' is not defined'
589 CALL print_error(msgbuf, mythid)
590 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
591 ENDIF
592 indu = mnc_cw_fgud(indfg)
593
594 C Check that the Variable Type exists
595 nvf = IFNBLNK(vtype)
596 nvl = ILNBLNK(vtype)
597 CALL MNC_GET_IND( MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt, myThid)
598 IF (ind_vt .LT. 1) THEN
599 write(msgbuf,'(3a)') 'MNC_CW_RX_R ERROR: vtype ''',
600 & vtype(nvf:nvl), ''' is not defined'
601 CALL print_error(msgbuf, mythid)
602 STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
603 ENDIF
604 igrid = mnc_cw_vgind(ind_vt)
605
606 C Check for bi,bj indicies
607 bidim = mnc_cw_vbij(1,ind_vt)
608 bjdim = mnc_cw_vbij(2,ind_vt)
609
610 C Set the bi,bj indicies
611 bis = bi
612 bie = bi
613 IF (bi .LT. 1) THEN
614 bis = 1
615 bie = nSx
616 ENDIF
617 bjs = bj
618 bje = bj
619 IF (bj .LT. 1) THEN
620 bjs = 1
621 bje = nSy
622 ENDIF
623
624 DO lbj = bjs,bje
625 DO lbi = bis,bie
626
627 C Create the file name
628 CALL MNC_CW_GET_TILE_NUM( lbi,lbj, uniq_tnum, myThid)
629 fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
630 n1 = IFNBLNK(fbname)
631 n2 = ILNBLNK(fbname)
632 ntot = n2 - n1 + 1
633 fname(1:ntot) = fbname(n1:n2)
634 ntot = ntot + 1
635 fname(ntot:ntot) = '.'
636 write(fname((ntot+1):(ntot+9)),'(i6.6,a3)') uniq_tnum, '.nc'
637 nfname = ntot+9
638
639 C Add the path to the file name
640 IF (mnc_use_indir) THEN
641 path_fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
642 npath = ILNBLNK(mnc_indir_str)
643 path_fname(1:npath) = mnc_indir_str(1:npath)
644 path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
645 fname(1:MNC_MAX_CHAR) = path_fname(1:MNC_MAX_CHAR)
646 nfname = npath + nfname
647 ENDIF
648
649 C Open the existing file
650 CALL MNC_FILE_TRY_READ( fname, ierr, indf, myThid)
651
652 C Check that the variable (VType) is defined within the file
653 CALL MNC_GET_FVINDS( fname, vtype, indf, ind_fv_ids, myThid)
654 IF ((indf .LT. 1) .OR. (ind_fv_ids .LT. 1)) THEN
655 write(msgbuf,'(4a)') 'MNC_CW_RX_R ERROR: vtype ''',
656 & vtype(nvf:nvl), ''' is not defined within file ''',
657 & fname(1:nfname)
658 CALL print_error(msgbuf, mythid)
659 STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
660 ENDIF
661 fid = mnc_f_info(indf,2)
662 idv = mnc_fv_ids(indf,ind_fv_ids+1)
663
664 C Check that the current sNy,sNy values and the in-file values
665 C are compatible and WARN (only warn) if not
666 f_sNx = -1
667 f_sNy = -1
668 err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)
669 IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
670 err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
671 CALL MNC_HANDLE_ERR(err,
672 & 'reading attribute ''sNx'' in S/R MNC_CW_RX_R',
673 & myThid)
674 ENDIF
675 err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
676 IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
677 err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
678 CALL MNC_HANDLE_ERR(err,
679 & 'reading attribute ''sNy'' in S/R MNC_CW_RX_R',
680 & myThid)
681 ENDIF
682 IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
683 write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',
684 & 'attributes ''sNx'' and ''sNy'' within the file ''',
685 & fname(1:nfname), ''' do not exist or do not match ',
686 & 'the current sizes within the model'
687 CALL print_error(msgbuf, mythid)
688 ENDIF
689
690 C Check that the in-memory variable and the in-file variables
691 C are of compatible sizes
692 C ires = 1
693 C CALL MNC_CHK_VTYP_R_NCVAR( ind_vt,
694 C & indf, ind_fv_ids, indu, ires)
695 C IF (ires .LT. 0) THEN
696 C write(msgbuf,'(7a)') 'MNC_CW_RX_R WARNING: the sizes ',
697 C & 'of the in-program variable ''', vtype(nvf:nvl),
698 C & ''' and the corresponding variable within file ''',
699 C & fname(1:nfname), ''' are not compatible -- please ',
700 C & 'check the sizes'
701 C CALL print_error(msgbuf, mythid)
702 C STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
703 C ENDIF
704
705 C Check for bi,bj indicies
706 bidim = mnc_cw_vbij(1,ind_vt)
707 bjdim = mnc_cw_vbij(2,ind_vt)
708
709 C Set the dimensions for the in-memory array
710 ndim = mnc_cw_ndim(igrid)
711 k = mnc_cw_dims(1,igrid)
712 IF (k .GT. 0) THEN
713 p(1) = k
714 ELSE
715 p(1) = 1
716 ENDIF
717 DO i = 2,9
718 k = mnc_cw_dims(i,igrid)
719 IF (k .LT. 1) THEN
720 k = 1
721 ENDIF
722 IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
723 p(i) = nSx * p(i-1)
724 ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
725 p(i) = nSy * p(i-1)
726 ELSE
727 p(i) = k * p(i-1)
728 ENDIF
729 ENDDO
730
731 C Set starting and ending indicies for the in-memory array and
732 C the unlimited dimension offset for the NetCDF array
733 DO i = 1,9
734 udo(i) = 0
735 s(i) = 1
736 e(i) = 1
737 IF (i .LE. ndim) THEN
738 s(i) = mnc_cw_is(i,igrid)
739 e(i) = mnc_cw_ie(i,igrid)
740 ENDIF
741 C Check for the unlimited dimension
742 IF ((i .EQ. ndim)
743 & .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
744 IF (indu .GT. 0) THEN
745 C Use the indu value
746 udo(i) = indu - 1
747 ELSEIF (indu .EQ. -1) THEN
748 C Append one to the current unlimited dim size
749 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
750 udo(i) = unlim_sz
751 ELSE
752 C Use the current unlimited dim size
753 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
754 udo(i) = unlim_sz - 1
755 ENDIF
756 ENDIF
757 ENDDO
758 IF (bidim .GT. 0) THEN
759 s(bidim) = lbi
760 e(bidim) = lbi
761 ENDIF
762 IF (bjdim .GT. 0) THEN
763 s(bjdim) = lbj
764 e(bjdim) = lbj
765 ENDIF
766
767 C DO i = 9,1,-1
768 C write(*,*) 'i,p(i),s(i),e(i) = ', i,': ',p(i),s(i),e(i)
769 C ENDDO
770
771 CALL MNC_FILE_ENDDEF(fname, myThid)
772
773 write(msgbuf,'(5a)') 'reading variable type ''',
774 & vtype(nvf:nvl), ''' within file ''',
775 & fname(1:nfname), ''''
776
777 C Read the variable one vector at a time
778 DO j7 = s(7),e(7)
779 k7 = (j7 - 1)*p(6)
780 vstart(7) = udo(7) + j7 - s(7) + 1
781 vcount(7) = 1
782 DO j6 = s(6),e(6)
783 k6 = (j6 - 1)*p(5) + k7
784 vstart(6) = udo(6) + j6 - s(6) + 1
785 vcount(6) = 1
786 DO j5 = s(5),e(5)
787 k5 = (j5 - 1)*p(4) + k6
788 vstart(5) = udo(5) + j5 - s(5) + 1
789 vcount(5) = 1
790 DO j4 = s(4),e(4)
791 k4 = (j4 - 1)*p(3) + k5
792 vstart(4) = udo(4) + j4 - s(4) + 1
793 vcount(4) = 1
794 DO j3 = s(3),e(3)
795 k3 = (j3 - 1)*p(2) + k4
796 vstart(3) = udo(3) + j3 - s(3) + 1
797 vcount(3) = 1
798 DO j2 = s(2),e(2)
799 k2 = (j2 - 1)*p(1) + k3
800 vstart(2) = udo(2) + j2 - s(2) + 1
801 vcount(2) = 1
802
803 kr = 0
804 vstart(1) = udo(1) + 1
805 vcount(1) = e(1) - s(1) + 1
806
807 IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
808 write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
809 & '--please increase to at least ',
810 & vcount(1), ' in ''MNC_SIZE.h'''
811 CALL PRINT_ERROR(msgBuf , 1)
812 STOP 'ABNORMAL END: S/R MNC_CW_RX_R_OFFSET'
813 ENDIF
814
815 IF (stype(1:1) .EQ. 'D') THEN
816 err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
817 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
818 DO j1 = s(1),e(1)
819 k1 = k2 + j1
820 kr = kr + 1
821 var(k1) = resh_d(kr)
822 ENDDO
823 ENDIF
824 IF (stype(1:1) .EQ. 'R') THEN
825 err = NF_GET_VARA_REAL(fid, idv, vstart, vcount, resh_r)
826 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
827 DO j1 = s(1),e(1)
828 k1 = k2 + j1
829 kr = kr + 1
830 var(k1) = resh_r(kr)
831 ENDDO
832 ENDIF
833 IF (stype(1:1) .EQ. 'I') THEN
834 err = NF_GET_VARA_INT(fid, idv, vstart, vcount, resh_i)
835 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
836 DO j1 = s(1),e(1)
837 k1 = k2 + j1
838 kr = kr + 1
839 var(k1) = resh_i(kr)
840 ENDDO
841 ENDIF
842
843
844
845 ENDDO
846 ENDDO
847 ENDDO
848 ENDDO
849 ENDDO
850 ENDDO
851
852 C Close the file
853 CALL MNC_FILE_CLOSE(fname, myThid)
854
855 C End the lbj,lbi loops
856 ENDDO
857 ENDDO
858
859 _END_MASTER( myThid )
860
861 RETURN
862 END
863
864 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
865
866 CEH3 ;;; Local Variables: ***
867 CEH3 ;;; mode:fortran ***
868 CEH3 ;;; End: ***
  ViewVC Help
Powered by ViewVC 1.1.22