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

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

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

Revision 1.18 - (hide annotations) (download)
Fri Sep 10 12:19:30 2004 UTC (19 years, 9 months ago) by edhill
Branch: MAIN
CVS Tags: checkpoint55c_post, checkpoint55d_pre, checkpoint55b_post, checkpoint55, checkpoint54f_post, checkpoint55e_post, checkpoint55a_post, checkpoint55d_post
Changes since 1.17: +3 -1 lines 
 o overhaul of IO so that we now have flags for MDSIO and/or MNC
   - all verification tests compile and run with linux_ia32_g77
   - defaults are compatible with current input files--nothing
     should change if you were not previously using MNC
   - MNC output has been added in numerous places (eg. timeave)
     but there are still a few writes not yet do-able with MNC
     (this is in progress)
   - flags now allow for either/or/both use of MDSIO and MNC and
     documentation will soon follow
   - numerous small formatting cleanups for ProTeX
1 edhill 1.18 C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_cw_readwrite.template,v 1.17 2004/04/02 16:12:48 edhill Exp $
2 edhill 1.1 C $Name: $
3    
4     #include "MNC_OPTIONS.h"
5    
6     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7 edhill 1.17 CBOP 0
8 edhill 1.15 C !ROUTINE: MNC_CW_RX_W
9 edhill 1.1
10 edhill 1.15 C !INTERFACE:
11 edhill 1.14 SUBROUTINE MNC_CW_RX_W(
12     I stype,
13 edhill 1.1 I fbname, bi,bj,
14     I vtype,
15 edhill 1.9 I var,
16     I myThid )
17 edhill 1.1
18 edhill 1.15 C !DESCRIPTION:
19     C This subroutine writes one variable to a file or a file group,
20     C depending upon the tile indicies.
21    
22     C !USES:
23 edhill 1.1 implicit none
24     #include "netcdf.inc"
25     #include "mnc_common.h"
26 edhill 1.12 #include "SIZE.h"
27 edhill 1.1 #include "EEPARAMS.h"
28 edhill 1.12 #include "PARAMS.h"
29 edhill 1.18 #include "MNC_PARAMS.h"
30 edhill 1.2
31 edhill 1.15 C !INPUT PARAMETERS:
32 edhill 1.1 integer myThid, bi,bj, indu
33 edhill 1.14 character*(*) stype, fbname, vtype
34 edhill 1.6 __V var(*)
35 edhill 1.17 CEOP
36 edhill 1.1
37 edhill 1.15 C !LOCAL VARIABLES:
38 edhill 1.3 integer i,j,k, indv,nvf,nvl, n1,n2, igrid, ntot
39 edhill 1.15 integer bis,bie, bjs,bje, uniq_tnum, nfname
40 edhill 1.16 integer fid, idv, indvids, ndim, indf, err
41 edhill 1.15 integer lbi,lbj, bidim,bjdim, unlim_sz, kr
42     integer p(9),s(9),e(9), dimnc(9)
43     integer vstart(9),vcount(9), udo(9)
44 edhill 1.3 integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
45 edhill 1.11 integer indfg, fg1,fg2, npath
46 edhill 1.1 character*(MAX_LEN_MBUF) msgbuf
47     character*(MNC_MAX_CHAR) fname
48 edhill 1.11 character*(MNC_MAX_CHAR) path_fname
49 edhill 1.14 REAL*8 resh_d( sNx + 2*OLx + sNy + 2*OLy )
50     REAL*4 resh_r( sNx + 2*OLx + sNy + 2*OLy )
51     INTEGER resh_i( sNx + 2*OLx + sNy + 2*OLy )
52 edhill 1.17
53 edhill 1.15 C Functions
54     integer IFNBLNK, ILNBLNK
55 edhill 1.1
56     C Only do I/O if I am the master thread
57     _BEGIN_MASTER( myThid )
58    
59 edhill 1.10 C Get the current index for the unlimited dimension from the file
60     C group (or base) name
61     fg1 = IFNBLNK(fbname)
62     fg2 = ILNBLNK(fbname)
63     CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
64     IF (indfg .LT. 1) THEN
65     write(msgbuf,'(3a)')
66 edhill 1.14 & 'MNC_CW_RX_W ERROR: file group name ''',
67 edhill 1.10 & fbname(fg1:fg2), ''' is not defined'
68     CALL print_error(msgbuf, mythid)
69 edhill 1.14 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
70 edhill 1.10 ENDIF
71     indu = mnc_cw_fgud(indfg)
72    
73 edhill 1.1 C Check that the Variable Type exists
74     nvf = IFNBLNK(vtype)
75     nvl = ILNBLNK(vtype)
76 edhill 1.9 CALL MNC_GET_IND(MNC_MAX_ID, vtype, mnc_cw_vname, indv, myThid)
77 edhill 1.2 IF (indv .LT. 1) THEN
78 edhill 1.14 write(msgbuf,'(3a)') 'MNC_CW_RX_W ERROR: vtype ''',
79 edhill 1.2 & vtype(nvf:nvl), ''' is not defined'
80 edhill 1.1 CALL print_error(msgbuf, mythid)
81 edhill 1.14 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
82 edhill 1.1 ENDIF
83 edhill 1.2 igrid = mnc_cw_vgind(indv)
84 edhill 1.1
85 edhill 1.5 C Set the bi,bj indicies
86 edhill 1.2 bis = bi
87     bie = bi
88 edhill 1.1 IF (bi .LT. 1) THEN
89     bis = 1
90     bie = nSx
91     ENDIF
92 edhill 1.2 bjs = bj
93     bje = bj
94 edhill 1.1 IF (bj .LT. 1) THEN
95     bjs = 1
96     bje = nSy
97     ENDIF
98    
99 edhill 1.2 DO lbj = bjs,bje
100     DO lbi = bis,bie
101 edhill 1.1
102     C Create the file name
103 edhill 1.9 CALL MNC_CW_GET_TILE_NUM(lbi,lbj, uniq_tnum, myThid)
104 edhill 1.1 fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
105     n1 = IFNBLNK(fbname)
106     n2 = ILNBLNK(fbname)
107     ntot = n2 - n1 + 1
108     fname(1:ntot) = fbname(n1:n2)
109     ntot = ntot + 1
110     fname(ntot:ntot) = '.'
111     write(fname((ntot+1):(ntot+9)),'(i6.6,a3)') uniq_tnum, '.nc'
112 edhill 1.2 nfname = ntot+9
113    
114 edhill 1.11 C Add the path to the file name
115 edhill 1.12 IF (mnc_use_outdir) THEN
116     path_fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
117     npath = ILNBLNK(mnc_out_path)
118     path_fname(1:npath) = mnc_out_path(1:npath)
119 edhill 1.13 path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
120 edhill 1.12 fname(1:MNC_MAX_CHAR) = path_fname(1:MNC_MAX_CHAR)
121 edhill 1.13 nfname = npath + nfname
122 edhill 1.12 ENDIF
123 edhill 1.11
124 edhill 1.2 C Append to an existing or create a new file
125 edhill 1.9 CALL MNC_CW_FILE_AORC(fname, indf, myThid)
126 edhill 1.2 fid = mnc_f_info(indf,2)
127    
128 edhill 1.3 C Ensure that all the NetCDF dimensions are defined and create a
129     C local copy of them
130 edhill 1.2 DO i = 1,9
131     dimnc(i) = 1
132     ENDDO
133     DO i = 1,mnc_cw_ndim(igrid)
134 edhill 1.3 IF (mnc_cw_dims(i,igrid) .EQ. -1) THEN
135     dimnc(i) = -1
136     ELSE
137     dimnc(i) = mnc_cw_ie(i,igrid) - mnc_cw_is(i,igrid) + 1
138     ENDIF
139 edhill 1.9 CALL MNC_DIM_INIT(fname,
140     & mnc_cw_dn(i,igrid), dimnc(i), myThid)
141 edhill 1.2 ENDDO
142    
143     C Ensure that the "grid" is defined
144 edhill 1.9 CALL MNC_GRID_INIT(fname, mnc_cw_gname(igrid),
145     & mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)
146 edhill 1.2
147     C Ensure that the variable is defined
148 edhill 1.14 IF (stype(1:1) .EQ. 'D')
149     & CALL MNC_VAR_INIT_DBL(
150     & fname, mnc_cw_gname(igrid), vtype, myThid)
151     IF (stype(1:1) .EQ. 'R')
152     & CALL MNC_VAR_INIT_REAL(
153     & fname, mnc_cw_gname(igrid), vtype, myThid)
154     IF (stype(1:1) .EQ. 'I')
155     & CALL MNC_VAR_INIT_INT(
156     & fname, mnc_cw_gname(igrid), vtype, myThid)
157    
158 edhill 1.2 DO i = 1,mnc_fv_ids(indf,1)
159     j = 2 + 3*(i - 1)
160     IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vtype) THEN
161     idv = mnc_fv_ids(indf,j+1)
162     indvids = mnc_fd_ind(indf, mnc_f_info(indf,
163     & (mnc_fv_ids(indf,j+2) + 1)) )
164     GOTO 10
165     ENDIF
166     ENDDO
167 edhill 1.14 write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',
168 edhill 1.2 & 'cannot reference variable ''', vtype, ''''
169     CALL print_error(msgbuf, mythid)
170 edhill 1.5 STOP 'ABNORMAL END: package MNC'
171 edhill 1.2 10 CONTINUE
172    
173 edhill 1.3 C Check for bi,bj indicies
174     bidim = mnc_cw_vbij(1,indv)
175     bjdim = mnc_cw_vbij(2,indv)
176 edhill 1.4 CEH3 write(*,*) 'bidim,bjdim = ', bidim,bjdim
177 edhill 1.3
178 edhill 1.2 C Set the dimensions for the in-memory array
179     ndim = mnc_cw_ndim(igrid)
180 edhill 1.3 k = mnc_cw_dims(1,igrid)
181     IF (k .GT. 0) THEN
182     p(1) = k
183     ELSE
184     p(1) = 1
185     ENDIF
186 edhill 1.2 DO i = 2,9
187 edhill 1.3 k = mnc_cw_dims(i,igrid)
188     IF (k .LT. 1) THEN
189     k = 1
190     ENDIF
191     IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
192     p(i) = nSx * p(i-1)
193     ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
194     p(i) = nSy * p(i-1)
195     ELSE
196     p(i) = k * p(i-1)
197     ENDIF
198 edhill 1.2 ENDDO
199    
200 edhill 1.3 C Set starting and ending indicies for the in-memory array and
201     C the unlimited dimension offset for the NetCDF array
202 edhill 1.2 DO i = 1,9
203 edhill 1.3 udo(i) = 0
204     s(i) = 1
205     e(i) = 1
206     IF (i .LE. ndim) THEN
207     s(i) = mnc_cw_is(i,igrid)
208     e(i) = mnc_cw_ie(i,igrid)
209     ENDIF
210     C Check for the unlimited dimension
211     IF ((i .EQ. ndim)
212     & .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
213     IF (indu .GT. 0) THEN
214     C Use the indu value
215     udo(i) = indu - 1
216     ELSEIF (indu .EQ. -1) THEN
217     C Append one to the current unlimited dim size
218 edhill 1.9 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
219 edhill 1.3 udo(i) = unlim_sz
220 edhill 1.2 ELSE
221 edhill 1.3 C Use the current unlimited dim size
222 edhill 1.9 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
223 edhill 1.3 udo(i) = unlim_sz - 1
224 edhill 1.2 ENDIF
225     ENDIF
226     ENDDO
227 edhill 1.3 IF (bidim .GT. 0) THEN
228     s(bidim) = lbi
229     e(bidim) = lbi
230     ENDIF
231     IF (bjdim .GT. 0) THEN
232     s(bjdim) = lbj
233     e(bjdim) = lbj
234     ENDIF
235 edhill 1.4 CEH3 DO i = 1,9
236     CEH3 write(*,*) 'i,p(i),s(i),e(i) = ', i,p(i),s(i),e(i)
237     CEH3 ENDDO
238 edhill 1.3
239     C Add the global attributes
240 edhill 1.9 CALL MNC_CW_SET_GATTR( fname, lbi,lbj, uniq_tnum, myThid)
241 edhill 1.3
242     C Add the per-variable attributes
243     DO i = 1,mnc_cw_vnat(1,indv)
244 edhill 1.9 CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,
245     & mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)
246 edhill 1.3 ENDDO
247     DO i = 1,mnc_cw_vnat(2,indv)
248 edhill 1.9 CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,
249     & mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)
250 edhill 1.3 ENDDO
251     DO i = 1,mnc_cw_vnat(3,indv)
252 edhill 1.9 CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,
253     & mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)
254 edhill 1.3 ENDDO
255 edhill 1.2
256 edhill 1.9 CALL MNC_FILE_ENDDEF(fname, myThid)
257 edhill 1.2
258 edhill 1.8 write(msgbuf,'(5a)') 'writing variable type ''',
259     & vtype(nvf:nvl), ''' within file ''',
260     & fname(1:nfname), ''''
261    
262 edhill 1.2 C Write the variable one vector at a time
263 edhill 1.3 DO j7 = s(7),e(7)
264 edhill 1.4 k7 = (j7 - 1)*p(6)
265 edhill 1.3 vstart(7) = udo(7) + j7 - s(7) + 1
266     vcount(7) = 1
267     DO j6 = s(6),e(6)
268 edhill 1.4 k6 = (j6 - 1)*p(5) + k7
269 edhill 1.3 vstart(6) = udo(6) + j6 - s(6) + 1
270     vcount(6) = 1
271     DO j5 = s(5),e(5)
272 edhill 1.4 k5 = (j5 - 1)*p(4) + k6
273 edhill 1.3 vstart(5) = udo(5) + j5 - s(5) + 1
274     vcount(5) = 1
275     DO j4 = s(4),e(4)
276 edhill 1.4 k4 = (j4 - 1)*p(3) + k5
277 edhill 1.3 vstart(4) = udo(4) + j4 - s(4) + 1
278     vcount(4) = 1
279     DO j3 = s(3),e(3)
280 edhill 1.4 k3 = (j3 - 1)*p(2) + k4
281 edhill 1.3 vstart(3) = udo(3) + j3 - s(3) + 1
282     vcount(3) = 1
283     DO j2 = s(2),e(2)
284 edhill 1.4 k2 = (j2 - 1)*p(1) + k3
285 edhill 1.3 vstart(2) = udo(2) + j2 - s(2) + 1
286     vcount(2) = 1
287 edhill 1.1
288 edhill 1.3 kr = 0
289     vstart(1) = udo(1) + 1
290     vcount(1) = e(1) - s(1) + 1
291 edhill 1.2
292 edhill 1.14 IF (stype(1:1) .EQ. 'D') THEN
293     DO j1 = s(1),e(1)
294     k1 = k2 + j1
295     kr = kr + 1
296     resh_d(kr) = var(k1)
297     ENDDO
298     err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
299     ENDIF
300     IF (stype(1:1) .EQ. 'R') THEN
301     DO j1 = s(1),e(1)
302     k1 = k2 + j1
303     kr = kr + 1
304     resh_r(kr) = var(k1)
305     ENDDO
306     err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
307     ENDIF
308     IF (stype(1:1) .EQ. 'I') THEN
309     DO j1 = s(1),e(1)
310     k1 = k2 + j1
311     kr = kr + 1
312     resh_i(kr) = var(k1)
313     ENDDO
314     err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
315     ENDIF
316 edhill 1.1
317 edhill 1.9 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
318 edhill 1.8
319 edhill 1.3 ENDDO
320     ENDDO
321 edhill 1.2 ENDDO
322     ENDDO
323     ENDDO
324     ENDDO
325    
326     C Sync the file
327     err = NF_SYNC(fid)
328     write(msgbuf,'(3a)') 'sync for file ''', fname,
329 edhill 1.14 & ''' in S/R MNC_CW_RX_W'
330 edhill 1.9 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
331 edhill 1.5
332     ENDDO
333     ENDDO
334    
335     _END_MASTER( myThid )
336    
337     RETURN
338     END
339    
340    
341     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
342 edhill 1.17 CBOP 0
343 edhill 1.15 C !ROUTINE: MNC_CW_RX_R
344 edhill 1.5
345 edhill 1.15 C !INTERFACE:
346 edhill 1.14 SUBROUTINE MNC_CW_RX_R(
347     I stype,
348 edhill 1.5 I fbname, bi,bj,
349     I vtype,
350 edhill 1.9 I var,
351     I myThid )
352 edhill 1.5
353 edhill 1.15 C !DESCRIPTION:
354     C This subroutine reads one variable from a file or a file group,
355     C depending upon the tile indicies.
356    
357     C !USES:
358 edhill 1.17 implicit none
359 edhill 1.5 #include "netcdf.inc"
360     #include "mnc_common.h"
361 edhill 1.13 #include "SIZE.h"
362 edhill 1.5 #include "EEPARAMS.h"
363 edhill 1.13 #include "PARAMS.h"
364 edhill 1.18 #include "MNC_PARAMS.h"
365 edhill 1.5
366 edhill 1.15 C !INPUT PARAMETERS:
367 edhill 1.5 integer myThid, bi,bj, indu
368 edhill 1.14 character*(*) stype, fbname, vtype
369 edhill 1.6 __V var(*)
370 edhill 1.17 CEOP
371 edhill 1.5
372 edhill 1.15 C !LOCAL VARIABLES:
373 edhill 1.8 integer i,k, nvf,nvl, n1,n2, igrid, ntot
374 edhill 1.6 integer bis,bie, bjs,bje, uniq_tnum, nfname, fid, idv
375 edhill 1.5 integer ndim, indf, err, lbi,lbj, bidim,bjdim, unlim_sz, kr
376 edhill 1.6 integer ind_fv_ids, ind_vt, ierr, atype, alen
377 edhill 1.13 integer f_sNx,f_sNy, npath
378 edhill 1.6 integer p(9),s(9),e(9), vstart(9),vcount(9), udo(9)
379     integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
380 edhill 1.5 character*(MAX_LEN_MBUF) msgbuf
381     character*(MNC_MAX_CHAR) fname
382 edhill 1.13 character*(MNC_MAX_CHAR) path_fname
383 edhill 1.10 integer indfg, fg1,fg2
384 edhill 1.14 REAL*8 resh_d( sNx + 2*OLx + sNy + 2*OLy )
385     REAL*4 resh_r( sNx + 2*OLx + sNy + 2*OLy )
386     INTEGER resh_i( sNx + 2*OLx + sNy + 2*OLy )
387 edhill 1.17
388 edhill 1.15 C Functions
389     integer IFNBLNK, ILNBLNK
390 edhill 1.5
391     C Only do I/O if I am the master thread
392     _BEGIN_MASTER( myThid )
393 edhill 1.10
394     C Get the current index for the unlimited dimension from the file
395     C group (or base) name
396     fg1 = IFNBLNK(fbname)
397     fg2 = ILNBLNK(fbname)
398     CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
399     IF (indfg .LT. 1) THEN
400     write(msgbuf,'(3a)')
401 edhill 1.14 & 'MNC_CW_RX_W ERROR: file group name ''',
402 edhill 1.10 & fbname(fg1:fg2), ''' is not defined'
403     CALL print_error(msgbuf, mythid)
404 edhill 1.14 STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
405 edhill 1.10 ENDIF
406     indu = mnc_cw_fgud(indfg)
407 edhill 1.5
408     C Check that the Variable Type exists
409     nvf = IFNBLNK(vtype)
410     nvl = ILNBLNK(vtype)
411 edhill 1.9 CALL MNC_GET_IND( MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt, myThid)
412 edhill 1.7 IF (ind_vt .LT. 1) THEN
413 edhill 1.14 write(msgbuf,'(3a)') 'MNC_CW_RX_R ERROR: vtype ''',
414 edhill 1.5 & vtype(nvf:nvl), ''' is not defined'
415     CALL print_error(msgbuf, mythid)
416 edhill 1.14 STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
417 edhill 1.5 ENDIF
418     igrid = mnc_cw_vgind(ind_vt)
419    
420     C Check for bi,bj indicies
421 edhill 1.6 bidim = mnc_cw_vbij(1,ind_vt)
422     bjdim = mnc_cw_vbij(2,ind_vt)
423 edhill 1.5
424     C Set the bi,bj indicies
425     bis = bi
426     bie = bi
427     IF (bi .LT. 1) THEN
428     bis = 1
429     bie = nSx
430     ENDIF
431     bjs = bj
432     bje = bj
433     IF (bj .LT. 1) THEN
434     bjs = 1
435     bje = nSy
436     ENDIF
437    
438     DO lbj = bjs,bje
439     DO lbi = bis,bie
440    
441     C Create the file name
442 edhill 1.9 CALL MNC_CW_GET_TILE_NUM( lbi,lbj, uniq_tnum, myThid)
443 edhill 1.5 fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
444     n1 = IFNBLNK(fbname)
445     n2 = ILNBLNK(fbname)
446     ntot = n2 - n1 + 1
447     fname(1:ntot) = fbname(n1:n2)
448     ntot = ntot + 1
449     fname(ntot:ntot) = '.'
450     write(fname((ntot+1):(ntot+9)),'(i6.6,a3)') uniq_tnum, '.nc'
451     nfname = ntot+9
452 edhill 1.13
453     C Add the path to the file name
454     IF (mnc_use_indir) THEN
455     path_fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
456     npath = ILNBLNK(mnc_indir_str)
457     path_fname(1:npath) = mnc_indir_str(1:npath)
458     path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
459     fname(1:MNC_MAX_CHAR) = path_fname(1:MNC_MAX_CHAR)
460     nfname = npath + nfname
461     ENDIF
462 edhill 1.5
463     C Open the existing file
464 edhill 1.9 CALL MNC_FILE_TRY_READ( fname, ierr, indf, myThid)
465 edhill 1.5
466     C Check that the variable (VType) is defined within the file
467 edhill 1.9 CALL MNC_GET_FVINDS( fname, vtype, indf, ind_fv_ids, myThid)
468 edhill 1.5 IF ((indf .LT. 1) .OR. (ind_fv_ids .LT. 1)) THEN
469 edhill 1.14 write(msgbuf,'(4a)') 'MNC_CW_RX_R ERROR: vtype ''',
470 edhill 1.5 & vtype(nvf:nvl), ''' is not defined within file ''',
471     & fname(1:nfname)
472     CALL print_error(msgbuf, mythid)
473 edhill 1.14 STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
474 edhill 1.5 ENDIF
475     fid = mnc_f_info(indf,2)
476 edhill 1.6 idv = mnc_fv_ids(indf,ind_fv_ids+1)
477    
478     C Check that the current sNy,sNy values and the in-file values
479     C are compatible and WARN (only warn) if not
480     f_sNx = -1
481     f_sNy = -1
482     err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)
483     IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
484     err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
485 edhill 1.9 CALL MNC_HANDLE_ERR(err,
486 edhill 1.14 & 'reading attribute ''sNx'' in S/R MNC_CW_RX_R',
487 edhill 1.9 & myThid)
488 edhill 1.6 ENDIF
489     err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
490     IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
491     err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
492 edhill 1.9 CALL MNC_HANDLE_ERR(err,
493 edhill 1.14 & 'reading attribute ''sNy'' in S/R MNC_CW_RX_R',
494 edhill 1.9 & myThid)
495 edhill 1.6 ENDIF
496 edhill 1.5 IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
497 edhill 1.14 write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',
498 edhill 1.6 & 'attributes ''sNx'' and ''sNy'' within the file ''',
499     & fname(1:nfname), ''' do not exist or do not match ',
500     & 'the current sizes within the model'
501 edhill 1.5 CALL print_error(msgbuf, mythid)
502     ENDIF
503    
504 edhill 1.6 C Check that the in-memory variable and the in-file variables
505     C are of compatible sizes
506 edhill 1.8 C ires = 1
507 edhill 1.9 C CALL MNC_CHK_VTYP_R_NCVAR( ind_vt,
508 edhill 1.8 C & indf, ind_fv_ids, indu, ires)
509     C IF (ires .LT. 0) THEN
510 edhill 1.14 C write(msgbuf,'(7a)') 'MNC_CW_RX_R WARNING: the sizes ',
511 edhill 1.8 C & 'of the in-program variable ''', vtype(nvf:nvl),
512     C & ''' and the corresponding variable within file ''',
513     C & fname(1:nfname), ''' are not compatible -- please ',
514     C & 'check the sizes'
515     C CALL print_error(msgbuf, mythid)
516 edhill 1.14 C STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
517 edhill 1.8 C ENDIF
518 edhill 1.5
519 edhill 1.6 C Check for bi,bj indicies
520     bidim = mnc_cw_vbij(1,ind_vt)
521     bjdim = mnc_cw_vbij(2,ind_vt)
522    
523     C Set the dimensions for the in-memory array
524     ndim = mnc_cw_ndim(igrid)
525     k = mnc_cw_dims(1,igrid)
526     IF (k .GT. 0) THEN
527     p(1) = k
528     ELSE
529     p(1) = 1
530     ENDIF
531     DO i = 2,9
532     k = mnc_cw_dims(i,igrid)
533     IF (k .LT. 1) THEN
534     k = 1
535     ENDIF
536     IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
537     p(i) = nSx * p(i-1)
538     ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
539     p(i) = nSy * p(i-1)
540     ELSE
541     p(i) = k * p(i-1)
542     ENDIF
543     ENDDO
544    
545     C Set starting and ending indicies for the in-memory array and
546     C the unlimited dimension offset for the NetCDF array
547     DO i = 1,9
548     udo(i) = 0
549     s(i) = 1
550     e(i) = 1
551     IF (i .LE. ndim) THEN
552     s(i) = mnc_cw_is(i,igrid)
553     e(i) = mnc_cw_ie(i,igrid)
554     ENDIF
555     C Check for the unlimited dimension
556     IF ((i .EQ. ndim)
557     & .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
558     IF (indu .GT. 0) THEN
559     C Use the indu value
560     udo(i) = indu - 1
561     ELSEIF (indu .EQ. -1) THEN
562     C Append one to the current unlimited dim size
563 edhill 1.9 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
564 edhill 1.6 udo(i) = unlim_sz
565     ELSE
566     C Use the current unlimited dim size
567 edhill 1.9 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
568 edhill 1.6 udo(i) = unlim_sz - 1
569     ENDIF
570     ENDIF
571     ENDDO
572     IF (bidim .GT. 0) THEN
573     s(bidim) = lbi
574     e(bidim) = lbi
575     ENDIF
576     IF (bjdim .GT. 0) THEN
577     s(bjdim) = lbj
578     e(bjdim) = lbj
579     ENDIF
580    
581 edhill 1.8 C DO i = 9,1,-1
582     C write(*,*) 'i,p(i),s(i),e(i) = ', i,': ',p(i),s(i),e(i)
583     C ENDDO
584 edhill 1.6
585 edhill 1.9 CALL MNC_FILE_ENDDEF(fname, myThid)
586 edhill 1.6
587     write(msgbuf,'(5a)') 'reading variable type ''',
588     & vtype(nvf:nvl), ''' within file ''',
589     & fname(1:nfname), ''''
590    
591     C Read the variable one vector at a time
592     DO j7 = s(7),e(7)
593     k7 = (j7 - 1)*p(6)
594     vstart(7) = udo(7) + j7 - s(7) + 1
595     vcount(7) = 1
596     DO j6 = s(6),e(6)
597     k6 = (j6 - 1)*p(5) + k7
598     vstart(6) = udo(6) + j6 - s(6) + 1
599     vcount(6) = 1
600     DO j5 = s(5),e(5)
601     k5 = (j5 - 1)*p(4) + k6
602     vstart(5) = udo(5) + j5 - s(5) + 1
603     vcount(5) = 1
604     DO j4 = s(4),e(4)
605     k4 = (j4 - 1)*p(3) + k5
606     vstart(4) = udo(4) + j4 - s(4) + 1
607     vcount(4) = 1
608     DO j3 = s(3),e(3)
609     k3 = (j3 - 1)*p(2) + k4
610     vstart(3) = udo(3) + j3 - s(3) + 1
611     vcount(3) = 1
612     DO j2 = s(2),e(2)
613     k2 = (j2 - 1)*p(1) + k3
614     vstart(2) = udo(2) + j2 - s(2) + 1
615     vcount(2) = 1
616    
617 edhill 1.14 kr = 0
618 edhill 1.6 vstart(1) = udo(1) + 1
619     vcount(1) = e(1) - s(1) + 1
620    
621 edhill 1.14 IF (stype(1:1) .EQ. 'D') THEN
622     err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
623     CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
624     DO j1 = s(1),e(1)
625     k1 = k2 + j1
626     kr = kr + 1
627     var(k1) = resh_d(kr)
628     ENDDO
629     ENDIF
630     IF (stype(1:1) .EQ. 'R') THEN
631     err = NF_GET_VARA_REAL(fid, idv, vstart, vcount, resh_r)
632     CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
633     DO j1 = s(1),e(1)
634     k1 = k2 + j1
635     kr = kr + 1
636     var(k1) = resh_r(kr)
637     ENDDO
638     ENDIF
639     IF (stype(1:1) .EQ. 'I') THEN
640     err = NF_GET_VARA_INT(fid, idv, vstart, vcount, resh_i)
641     CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
642     DO j1 = s(1),e(1)
643     k1 = k2 + j1
644     kr = kr + 1
645     var(k1) = resh_i(kr)
646     ENDDO
647     ENDIF
648 edhill 1.6
649    
650    
651     ENDDO
652     ENDDO
653     ENDDO
654     ENDDO
655     ENDDO
656     ENDDO
657 edhill 1.8
658     C Close the file
659 edhill 1.9 CALL MNC_FILE_CLOSE(fname, myThid)
660 edhill 1.1
661 edhill 1.6 C End the lbj,lbi loops
662 edhill 1.1 ENDDO
663     ENDDO
664    
665     _END_MASTER( myThid )
666    
667     RETURN
668     END
669    
670     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
671    
672     CEH3 ;;; Local Variables: ***
673     CEH3 ;;; mode:fortran ***
674     CEH3 ;;; End: ***
  ViewVC Help
Powered by ViewVC 1.1.22