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

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

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

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