/[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.17 by edhill, Fri Apr 2 16:12:48 2004 UTC revision 1.36 by edhill, Fri Mar 10 05:50:23 2006 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  CBOP 0  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  C !ROUTINE: MNC_CW_RX_W
41    
42  C !INTERFACE:  C !INTERFACE:
# Line 16  C !INTERFACE: Line 48  C !INTERFACE:
48       I     myThid )       I     myThid )
49    
50  C     !DESCRIPTION:  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,  C     This subroutine writes one variable to a file or a file group,
89  C     depending upon the tile indicies.  C     depending upon the tile indicies.
90                
# Line 24  C     !USES: Line 93  C     !USES:
93  #include "netcdf.inc"  #include "netcdf.inc"
94  #include "mnc_common.h"  #include "mnc_common.h"
95  #include "SIZE.h"  #include "SIZE.h"
96    #include "MNC_BUFF.h"
97  #include "EEPARAMS.h"  #include "EEPARAMS.h"
98  #include "PARAMS.h"  #include "PARAMS.h"
99    #include "MNC_PARAMS.h"
100    
101  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
102        integer myThid, bi,bj, indu        integer myThid, bi,bj
103        character*(*) stype, fbname, vtype        character*(*) stype, fbname, vtype
104        __V var(*)        __V var(*)
105          INTEGER offsets(*)
106  CEOP  CEOP
107    
108  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
109        integer i,j,k, indv,nvf,nvl, n1,n2, igrid, ntot        integer i,j,k, indv,nvf,nvl, n1,n2, igrid, ntot, indu
110        integer bis,bie, bjs,bje, uniq_tnum, nfname        integer bis,bie, bjs,bje, uniq_tnum, uniq_fnum, nfname, iseq
111        integer fid, idv, indvids, ndim, indf, err        integer fid, idv, indvids, ndim, indf, err
112        integer lbi,lbj, bidim,bjdim, unlim_sz, kr        integer lbi,lbj, bidim,bjdim, unlim_sz, kr
113        integer p(9),s(9),e(9), dimnc(9)        integer p(9),s(9),e(9), dimnc(9)
# Line 43  C     !LOCAL VARIABLES: Line 115  C     !LOCAL VARIABLES:
115        integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7        integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
116        integer indfg, fg1,fg2, npath        integer indfg, fg1,fg2, npath
117        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
118        character*(MNC_MAX_CHAR) fname        character*(MNC_MAX_PATH) fname
119        character*(MNC_MAX_CHAR) path_fname        character*(MNC_MAX_PATH) path_fname
120        REAL*8  resh_d( sNx + 2*OLx + sNy + 2*OLy )        character*(MNC_MAX_PATH) tmpnm
121        REAL*4  resh_r( sNx + 2*OLx + sNy + 2*OLy )        character*(MNC_MAX_PATH) bpath
122        INTEGER resh_i( sNx + 2*OLx + sNy + 2*OLy )        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  C     Functions
137        integer IFNBLNK, ILNBLNK        integer IFNBLNK, ILNBLNK
# Line 55  C     Functions Line 139  C     Functions
139  C     Only do I/O if I am the master thread  C     Only do I/O if I am the master thread
140        _BEGIN_MASTER( myThid )        _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  C     Get the current index for the unlimited dimension from the file
147  C     group (or base) name  C     group (or base) name
148        fg1 = IFNBLNK(fbname)        fg1 = IFNBLNK(fbname)
# Line 68  C     group (or base) name Line 156  C     group (or base) name
156          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
157        ENDIF        ENDIF
158        indu = mnc_cw_fgud(indfg)        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  C     Check that the Variable Type exists
163        nvf = IFNBLNK(vtype)        nvf = IFNBLNK(vtype)
# Line 98  C     Set the bi,bj indicies Line 188  C     Set the bi,bj indicies
188        DO lbj = bjs,bje        DO lbj = bjs,bje
189          DO lbi = bis,bie          DO lbi = bis,bie
190    
191    #ifdef HAVE_STAT
192              fs_isdone = 0
193    #endif
194     10       CONTINUE
195    
196  C         Create the file name  C         Create the file name
197            CALL MNC_CW_GET_TILE_NUM(lbi,lbj, uniq_tnum, myThid)            CALL MNC_CW_GET_TILE_NUM(lbi,lbj, uniq_tnum, myThid)
198            fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)            fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
199            n1 = IFNBLNK(fbname)            n1 = IFNBLNK(fbname)
200            n2 = ILNBLNK(fbname)            n2 = ILNBLNK(fbname)
201    
202    #ifdef MNC_WRITE_OLDNAMES
203    
204            ntot = n2 - n1 + 1            ntot = n2 - n1 + 1
205            fname(1:ntot) = fbname(n1:n2)            fname(1:ntot) = fbname(n1:n2)
206            ntot = ntot + 1            ntot = ntot + 1
207            fname(ntot:ntot) = '.'            fname(ntot:ntot) = '.'
208            write(fname((ntot+1):(ntot+9)),'(i6.6,a3)') uniq_tnum, '.nc'            IF ( mnc_use_name_ni0 ) THEN
209            nfname = ntot+9              write(fname((ntot+1):(ntot+17)),'(i10.10,a1,i6.6)')
210         &           nIter0,'.',uniq_tnum
211                write(fname((ntot+18):(ntot+25)),'(a1,i4.4,a3)')
212         &           '.', iseq, '.nc'
213                nfname = ntot + 25
214              ELSE
215                write(fname((ntot+1):(ntot+14)),'(i4.4,a1,i6.6,a3)')
216         &           iseq,'.',uniq_tnum, '.nc'
217                nfname = ntot + 14
218              ENDIF
219    
220    #else
221    
222              CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)
223              k = ILNBLNK(tmpnm)
224              IF ( mnc_cw_cit(1,mnc_cw_fgci(indfg)) .GT. -1 ) THEN
225                j = mnc_cw_cit(2,mnc_cw_fgci(indfg))
226                IF ( mnc_cw_fgis(indfg) .GT. j )
227         &           j = mnc_cw_fgis(indfg)
228                write(fname,'(a,a1,i10.10,a2,a,a3)') fbname(n1:n2),
229         &           '.', j, '.t', tmpnm(1:k), '.nc'
230              ELSEIF ( mnc_cw_cit(1,mnc_cw_fgci(indfg)) .EQ. -1 ) THEN
231    C           Leave off the myIter value entirely
232                write(fname,'(a,a2,a,a3)') fbname(n1:n2), '.t',
233         &           tmpnm(1:k),'.nc'
234              ELSE
235    C           We have an error--bad flag value
236                write(msgbuf,'(4a)')
237         &           'MNC_CW_RX_W ERROR: bad mnc_cw_cit(1,...) ',
238         &           'flag value for base name ''', fbname(fg1:fg2),
239         &           ''''
240                CALL print_error(msgbuf, mythid)
241                STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
242              ENDIF
243              nfname = ILNBLNK(fname)
244    
245    #endif
246    
247  C         Add the path to the file name  C         Add the path to the file name
248            IF (mnc_use_outdir) THEN            IF (mnc_use_outdir) THEN
249              path_fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)              path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
250              npath = ILNBLNK(mnc_out_path)              npath = ILNBLNK(mnc_out_path)
251              path_fname(1:npath) = mnc_out_path(1:npath)              path_fname(1:npath) = mnc_out_path(1:npath)
252              path_fname((npath+1):(npath+nfname)) = fname(1:nfname)              path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
253              fname(1:MNC_MAX_CHAR) = path_fname(1:MNC_MAX_CHAR)              fname(1:MNC_MAX_PATH) = path_fname(1:MNC_MAX_PATH)
254              nfname = npath + nfname              nfname = npath + nfname
255            ENDIF            ENDIF
256    
257  C         Append to an existing or create a new file  C         Append to an existing or create a new file
258            CALL MNC_CW_FILE_AORC(fname, indf, myThid)            CALL MNC_CW_FILE_AORC(fname,indf, lbi,lbj,uniq_tnum, myThid)
259            fid = mnc_f_info(indf,2)            fid = mnc_f_info(indf,2)
260    
261    #ifdef HAVE_STAT
262              IF ((mnc_cw_fgig(indfg) .EQ. 1)
263         &         .AND. (fs_isdone .EQ. 0)) THEN
264    C           Decide whether to append to the existing or create a new
265    C           file based on the byte count per unlimited dimension
266                ncenc = 70
267                cenc(1:26)  = 'abcdefghijklmnopqrstuvwxyz'
268                cenc(27:52) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
269                cenc(53:70) = '0123456789_.,+-=/~'
270                k = nfname
271                IF (k .GT. 200)  k = 200
272                ntotenc = 0
273                DO i = 1,k
274                  DO j = 1,ncenc
275                    IF (fname(i:i) .EQ. cenc(j:j)) THEN
276                      ntotenc = ntotenc + 1
277                      ienc(ntotenc) = j
278                      GOTO 20
279                    ENDIF
280                  ENDDO
281     20           CONTINUE
282                ENDDO
283                CALL mncfsize(ntotenc, ienc, nbytes)
284                IF (nbytes .GT. 0) THEN
285                  CALL MNC_DIM_UNLIM_SIZE(fname, unlim_sz, myThid)
286                  fsnu = (1.0 _d 0 + 1.0 _d 0 / DBLE(unlim_sz))
287         &             * DBLE(nbytes)
288                  IF (fsnu .GT. mnc_max_fsize) THEN
289    C               Delete the now-full fname from the lookup tables since
290    C               we are all done writing to it.
291                    CALL MNC_FILE_CLOSE(fname, myThid)
292                    indu = 1
293                    mnc_cw_fgud(indfg) = 1
294    
295    #ifdef MNC_WRITE_OLDNAMES
296                    iseq = iseq + 1
297                    mnc_cw_fgis(indfg) = iseq
298    #else
299                    IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN
300                      write(msgbuf,'(5a)')
301         &            'MNC_CW_RX_W ERROR: output file for base name ''',
302         &            fbname(fg1:fg2), ''' is about to exceed the max ',
303         &            'file size and is NOT ALLOWED an iteration value ',
304         &            'within its file name'
305                      CALL print_error(msgbuf, mythid)
306                      STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
307                    ELSEIF (mnc_cw_cit(3,mnc_cw_fgci(indfg)) .LT. 0) THEN
308                      write(msgbuf,'(5a)')
309         &            'MNC_CW_RX_W ERROR: output file for base name ''',
310         &            fbname(fg1:fg2), ''' is about to exceed the max ',
311         &            'file size and no next-iter has been specified--',
312         &            'please see the MNC CITER functions'
313                      CALL print_error(msgbuf, mythid)
314                      STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
315                    ENDIF
316                    mnc_cw_fgis(indfg) = mnc_cw_cit(3,mnc_cw_fgci(indfg))
317    C               DO NOT BUMP THE CURRENT ITER FOR ALL FILES IN THIS CITER
318    C               GROUP SINCE THIS IS ONLY GROWTH TO AVOID FILE SIZE
319    C               LIMITS FOR THIS ONE BASENAME GROUP, NOT GROWTH OF THE
320    C               ENTIRE CITER GROUP !!!
321    C               mnc_cw_cit(2,mnc_cw_fgci(indfg))
322    C               &   = mnc_cw_cit(3,mnc_cw_fgci(indfg))
323    C               mnc_cw_cit(3,mnc_cw_fgci(indfg)) = -1
324    #endif
325                    fs_isdone = 1
326                    GOTO 10
327    
328                  ENDIF
329                ENDIF
330              ENDIF
331    #endif  /*  HAVE_STAT  */
332    
333  C         Ensure that all the NetCDF dimensions are defined and create a  C         Ensure that all the NetCDF dimensions are defined and create a
334  C         local copy of them  C         local copy of them
335            DO i = 1,9            DO i = 1,9
# Line 135  C         local copy of them Line 341  C         local copy of them
341              ELSE              ELSE
342                dimnc(i) = mnc_cw_ie(i,igrid) - mnc_cw_is(i,igrid) + 1                dimnc(i) = mnc_cw_ie(i,igrid) - mnc_cw_is(i,igrid) + 1
343              ENDIF              ENDIF
344              CALL MNC_DIM_INIT(fname,  
345       &           mnc_cw_dn(i,igrid), dimnc(i), myThid)  C           Add the coordinate variables
346                CALL MNC_DIM_INIT_ALL_CV(fname,
347         &           mnc_cw_dn(i,igrid), dimnc(i), 'Y', lbi,lbj, myThid)
348    
349            ENDDO            ENDDO
350    
351  C         Ensure that the "grid" is defined  C         Ensure that the "grid" is defined
# Line 144  C         Ensure that the "grid" is defi Line 353  C         Ensure that the "grid" is defi
353       &        mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)       &        mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)
354    
355  C         Ensure that the variable is defined  C         Ensure that the variable is defined
356              irv = 0
357            IF (stype(1:1) .EQ. 'D')            IF (stype(1:1) .EQ. 'D')
358       &         CALL MNC_VAR_INIT_DBL(       &         CALL MNC_VAR_INIT_DBL(
359       &         fname, mnc_cw_gname(igrid), vtype, myThid)       &         fname, mnc_cw_gname(igrid), vtype, irv, myThid)
360            IF (stype(1:1) .EQ. 'R')            IF (stype(1:1) .EQ. 'R')
361       &         CALL MNC_VAR_INIT_REAL(       &         CALL MNC_VAR_INIT_REAL(
362       &         fname, mnc_cw_gname(igrid), vtype, myThid)       &         fname, mnc_cw_gname(igrid), vtype, irv, myThid)
363            IF (stype(1:1) .EQ. 'I')            IF (stype(1:1) .EQ. 'I')
364       &         CALL MNC_VAR_INIT_INT(       &         CALL MNC_VAR_INIT_INT(
365       &         fname, mnc_cw_gname(igrid), vtype, myThid)       &         fname, mnc_cw_gname(igrid), vtype, irv, myThid)
366    
367              IF (irv .GT. 0) THEN
368    C           Return value indicates that the variable did not previously
369    C           exist in this file, so we need to write all the attributes
370                write_attributes = .TRUE.
371              ELSE
372                write_attributes = .FALSE.
373              ENDIF
374    
375            DO i = 1,mnc_fv_ids(indf,1)            DO i = 1,mnc_fv_ids(indf,1)
376              j = 2 + 3*(i - 1)              j = 2 + 3*(i - 1)
# Line 160  C         Ensure that the variable is de Line 378  C         Ensure that the variable is de
378                idv = mnc_fv_ids(indf,j+1)                idv = mnc_fv_ids(indf,j+1)
379                indvids = mnc_fd_ind(indf, mnc_f_info(indf,                indvids = mnc_fd_ind(indf, mnc_f_info(indf,
380       &             (mnc_fv_ids(indf,j+2) + 1)) )       &             (mnc_fv_ids(indf,j+2) + 1)) )
381                GOTO 10                GOTO 30
382              ENDIF              ENDIF
383            ENDDO            ENDDO
384            write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',            write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',
385       &         'cannot reference variable ''', vtype, ''''       &         'cannot reference variable ''', vtype, ''''
386            CALL print_error(msgbuf, mythid)            CALL print_error(msgbuf, mythid)
387            STOP 'ABNORMAL END: package MNC'            STOP 'ABNORMAL END: package MNC'
388   10       CONTINUE   30       CONTINUE
389    
390  C         Check for bi,bj indicies  C         Check for bi,bj indicies
391            bidim = mnc_cw_vbij(1,indv)            bidim = mnc_cw_vbij(1,indv)
# Line 194  C         Set the dimensions for the in- Line 412  C         Set the dimensions for the in-
412              ELSE              ELSE
413                p(i) = k * p(i-1)                p(i) = k * p(i-1)
414              ENDIF              ENDIF
415                IF (offsets(i) .GT. 0) THEN
416                  k = 1
417                  p(i) = k * p(i-1)
418                ENDIF
419            ENDDO            ENDDO
420    
421  C         Set starting and ending indicies for the in-memory array and  C         Set starting and ending indicies for the in-memory array and
# Line 231  C               Use the current unlimite Line 453  C               Use the current unlimite
453              s(bjdim) = lbj              s(bjdim) = lbj
454              e(bjdim) = lbj              e(bjdim) = lbj
455            ENDIF            ENDIF
456  CEH3      DO i = 1,9            
457  CEH3        write(*,*) 'i,p(i),s(i),e(i) = ', i,p(i),s(i),e(i)  C         Check the offsets
458  CEH3      ENDDO            DO i = 1,9
459                IF (offsets(i) .GT. 0) THEN
460  C         Add the global attributes                udo(i) = udo(i) + offsets(i) - 1
461            CALL MNC_CW_SET_GATTR( fname, lbi,lbj, uniq_tnum, myThid)                s(i) = 1
462                  e(i) = 1
463  C         Add the per-variable attributes              ENDIF
           DO i = 1,mnc_cw_vnat(1,indv)  
             CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,  
      &           mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)  
           ENDDO  
           DO i = 1,mnc_cw_vnat(2,indv)  
             CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,  
      &           mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)  
           ENDDO  
           DO i = 1,mnc_cw_vnat(3,indv)  
             CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,  
      &           mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)  
464            ENDDO            ENDDO
465    
466              IF (write_attributes) THEN
467    C           Add the per-variable attributes
468                DO i = 1,mnc_cw_vnat(1,indv)
469                  CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,
470         &             mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)
471                ENDDO
472                DO i = 1,mnc_cw_vnat(2,indv)
473                  CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,
474         &             mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)
475                ENDDO
476                DO i = 1,mnc_cw_vnat(3,indv)
477                  CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,
478         &             mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)
479                ENDDO
480              ENDIF
481    
482    C         Handle missing values
483              use_missing = .FALSE.
484              IF (mnc_cw_vfmv(indv) .EQ. 0) THEN
485                use_missing = .FALSE.
486              ELSE
487                IF (mnc_cw_vfmv(indv) .EQ. 1) THEN
488                  use_missing = .TRUE.
489                  dvm(1)  = mnc_def_dmv(1)
490                  dvm(2)  = mnc_def_dmv(2)
491                  rvm(1)  = mnc_def_rmv(1)
492                  rvm(2)  = mnc_def_rmv(2)
493                  ivm(1)  = mnc_def_imv(1)
494                  ivm(2)  = mnc_def_imv(2)
495                ELSEIF (mnc_cw_vfmv(indv) .EQ. 2) THEN
496                  use_missing = .TRUE.
497                  dvm(1)  = mnc_cw_vmvd(1,indv)
498                  dvm(2)  = mnc_cw_vmvd(2,indv)
499                  rvm(1)  = mnc_cw_vmvr(1,indv)
500                  rvm(2)  = mnc_cw_vmvr(2,indv)
501                  ivm(1)  = mnc_cw_vmvi(1,indv)
502                  ivm(2)  = mnc_cw_vmvi(2,indv)
503                ENDIF
504              ENDIF
505              IF (write_attributes .AND. use_missing) THEN
506                write(msgbuf,'(4a)') 'writing attribute ''missing_value''',
507         &           ' within file ''', fname(1:nfname), ''''
508                IF (stype(1:1) .EQ. 'D') THEN
509                  err = NF_PUT_ATT_DOUBLE(fid, idv, 'missing_value',
510         &             NF_DOUBLE, 1, dvm(2))
511                ELSEIF (stype(1:1) .EQ. 'R') THEN
512                  err = NF_PUT_ATT_REAL(fid, idv, 'missing_value',
513         &             NF_FLOAT, 1, dvm(2))
514                ELSEIF (stype(1:1) .EQ. 'I') THEN
515                  err = NF_PUT_ATT_INT(fid, idv, 'missing_value',
516         &             NF_INT, 1, ivm(2))
517                ENDIF
518                CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
519              ENDIF
520    
521            CALL MNC_FILE_ENDDEF(fname, myThid)            CALL MNC_FILE_ENDDEF(fname, myThid)
522    
523            write(msgbuf,'(5a)') 'writing variable type ''',            write(msgbuf,'(5a)') 'writing variable type ''',
524       &         vtype(nvf:nvl), ''' within file ''',       &         vtype(nvf:nvl), ''' within file ''',
525       &         fname(1:nfname), ''''       &         fname(1:nfname), ''''
526    
527    C         DO i = 1,9
528    C         write(*,*) 'i,p(i),s(i),e(i),udo(i),offsets(i) = ',
529    C         &        i,p(i),s(i),e(i),udo(i),offsets(i)
530    C         ENDDO
531    
532  C         Write the variable one vector at a time  C         Write the variable one vector at a time
533            DO j7 = s(7),e(7)            DO j7 = s(7),e(7)
534              k7 = (j7 - 1)*p(6)              k7 = (j7 - 1)*p(6)
# Line 288  C         Write the variable one vector Line 559  C         Write the variable one vector
559        vstart(1) = udo(1) + 1        vstart(1) = udo(1) + 1
560        vcount(1) = e(1) - s(1) + 1        vcount(1) = e(1) - s(1) + 1
561    
562        IF (stype(1:1) .EQ. 'D') THEN        IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
563          DO j1 = s(1),e(1)          write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
564            k1 = k2 + j1       &       '--please increase to at least ',
565            kr = kr + 1       &       vcount(1), ' in ''MNC_BUFF.h'''
566            resh_d(kr) = var(k1)          CALL PRINT_ERROR(msgBuf , 1)
567          ENDDO          STOP 'ABNORMAL END: S/R MNC_CW_RX_W_OFFSET'
         err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)  
       ENDIF  
       IF (stype(1:1) .EQ. 'R') THEN  
         DO j1 = s(1),e(1)  
           k1 = k2 + j1  
           kr = kr + 1  
           resh_r(kr) = var(k1)  
         ENDDO  
         err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)  
       ENDIF  
       IF (stype(1:1) .EQ. 'I') THEN  
         DO j1 = s(1),e(1)  
           k1 = k2 + j1  
           kr = kr + 1  
           resh_i(kr) = var(k1)  
         ENDDO  
         err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)  
568        ENDIF        ENDIF
569    
570          IF (use_missing) THEN
571    
572            IF (stype(1:1) .EQ. 'D') THEN
573              DO j1 = s(1),e(1)
574                k1 = k2 + j1
575                kr = kr + 1
576                dval = var(k1)
577                IF (dval .EQ. dvm(1)) THEN
578                  resh_d(kr) = dvm(2)
579                ELSE
580                  resh_d(kr) = dval
581                ENDIF
582              ENDDO
583              err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
584            ELSEIF (stype(1:1) .EQ. 'R') THEN
585              DO j1 = s(1),e(1)
586                k1 = k2 + j1
587                kr = kr + 1
588                rval = var(k1)
589                IF (rval .EQ. rvm(1)) THEN
590                  resh_r(kr) = rvm(2)
591                ELSE
592                  resh_r(kr) = rval
593                ENDIF
594              ENDDO
595              err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
596            ELSEIF (stype(1:1) .EQ. 'I') THEN
597              DO j1 = s(1),e(1)
598                k1 = k2 + j1
599                kr = kr + 1
600                ival = MNC2I( var(k1) )
601                IF (ival .EQ. ivm(1)) THEN
602                  resh_i(kr) = ivm(2)
603                ELSE
604                  resh_i(kr) = ival
605                ENDIF
606              ENDDO
607              err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
608            ENDIF
609    
610          ELSE
611            
612            IF (stype(1:1) .EQ. 'D') THEN
613              DO j1 = s(1),e(1)
614                k1 = k2 + j1
615                kr = kr + 1
616                resh_d(kr) = var(k1)
617              ENDDO
618              err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
619            ELSEIF (stype(1:1) .EQ. 'R') THEN
620              DO j1 = s(1),e(1)
621                k1 = k2 + j1
622                kr = kr + 1
623                resh_r(kr) = var(k1)
624              ENDDO
625              err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
626            ELSEIF (stype(1:1) .EQ. 'I') THEN
627              DO j1 = s(1),e(1)
628                k1 = k2 + j1
629                kr = kr + 1
630                resh_i(kr) = MNC2I( var(k1) )
631              ENDDO
632              err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
633            ENDIF
634    
635          ENDIF
636        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
637    
638                      ENDDO                      ENDDO
# Line 339  C         Sync the file Line 659  C         Sync the file
659    
660  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
661  CBOP 0  CBOP 0
662    C !ROUTINE: MNC_CW_RX_R_S
663    
664    C !INTERFACE:
665          SUBROUTINE MNC_CW_RX_R_S(
666         I     stype,
667         I     fbname, bi,bj,
668         I     vtype,
669         I     var,
670         I     myThid )
671    
672    C     !DESCRIPTION:
673    C     A scalar version of MNC_CW_RX_R() for compilers that cannot
674    C     gracefully handle the conversion on their own.
675          
676    C     !USES:
677          implicit none
678    
679    C     !INPUT PARAMETERS:
680          integer myThid, bi,bj
681          character*(*) stype, fbname, vtype
682          __V var
683          __V var_arr(1)
684    CEOP
685          var_arr(1) = var
686    
687          CALL MNC_CW_RX_R(stype,fbname,bi,bj,vtype, var_arr, myThid)
688    
689          RETURN
690          END
691    
692    
693    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
694    CBOP 0
695  C !ROUTINE: MNC_CW_RX_R  C !ROUTINE: MNC_CW_RX_R
696    
697  C !INTERFACE:  C !INTERFACE:
# Line 358  C     !USES: Line 711  C     !USES:
711  #include "netcdf.inc"  #include "netcdf.inc"
712  #include "mnc_common.h"  #include "mnc_common.h"
713  #include "SIZE.h"  #include "SIZE.h"
714    #include "MNC_BUFF.h"
715  #include "EEPARAMS.h"  #include "EEPARAMS.h"
716  #include "PARAMS.h"  #include "PARAMS.h"
717    #include "MNC_PARAMS.h"
718    
719  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
720        integer myThid, bi,bj, indu        integer myThid, bi,bj
721        character*(*) stype, fbname, vtype        character*(*) stype, fbname, vtype
722        __V var(*)        __V var(*)
723  CEOP  CEOP
724    
725  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
726        integer i,k, nvf,nvl, n1,n2, igrid, ntot        integer i,k, nvf,nvl, n1,n2, igrid, ntot, indu
727        integer bis,bie, bjs,bje, uniq_tnum, nfname, fid, idv        integer bis,bie, bjs,bje, uniq_tnum,uniq_fnum, nfname, fid, idv
728        integer ndim, indf, err, lbi,lbj, bidim,bjdim, unlim_sz, kr        integer ndim, err, lbi,lbj, bidim,bjdim, unlim_sz, kr
729        integer ind_fv_ids, ind_vt, ierr, atype, alen        integer ind_vt, npath, unlid, f_or_t, ixoff,iyoff
730        integer f_sNx,f_sNy, npath  C     integer f_sNx,f_sNy, alen, atype, ind_fv_ids, ierr, indf
731        integer p(9),s(9),e(9), vstart(9),vcount(9), udo(9)        integer p(9),s(9),e(9), vstart(9),vcount(9), udo(9)
732        integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7        integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
733        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
734        character*(MNC_MAX_CHAR) fname        character*(MNC_MAX_PATH) fname
735        character*(MNC_MAX_CHAR) path_fname        character*(MNC_MAX_PATH) fname_zs
736          character*(MNC_MAX_PATH) tmpnm
737          character*(MNC_MAX_PATH) path_fname
738          character*(MNC_MAX_PATH) bpath
739        integer indfg, fg1,fg2        integer indfg, fg1,fg2
740        REAL*8  resh_d( sNx + 2*OLx + sNy + 2*OLy )        REAL*8  resh_d( MNC_MAX_BUFF )
741        REAL*4  resh_r( sNx + 2*OLx + sNy + 2*OLy )        REAL*4  resh_r( MNC_MAX_BUFF )
742        INTEGER resh_i( sNx + 2*OLx + sNy + 2*OLy )        INTEGER resh_i( MNC_MAX_BUFF )
743    
744  C     Functions  C     Functions
745        integer IFNBLNK, ILNBLNK        integer IFNBLNK, ILNBLNK
# Line 389  C     Functions Line 747  C     Functions
747  C     Only do I/O if I am the master thread  C     Only do I/O if I am the master thread
748        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
749    
750          DO i = 1,MNC_MAX_PATH
751            bpath(i:i) = ' '
752          ENDDO
753    
754  C     Get the current index for the unlimited dimension from the file  C     Get the current index for the unlimited dimension from the file
755  C     group (or base) name  C     group (or base) name
756        fg1 = IFNBLNK(fbname)        fg1 = IFNBLNK(fbname)
# Line 438  C     Set the bi,bj indicies Line 800  C     Set the bi,bj indicies
800    
801  C         Create the file name  C         Create the file name
802            CALL MNC_CW_GET_TILE_NUM( lbi,lbj, uniq_tnum, myThid)            CALL MNC_CW_GET_TILE_NUM( lbi,lbj, uniq_tnum, myThid)
803            fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)            fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
804    
805    #ifdef MNC_READ_OLDNAMES
806    
807            n1 = IFNBLNK(fbname)            n1 = IFNBLNK(fbname)
808            n2 = ILNBLNK(fbname)            n2 = ILNBLNK(fbname)
809            ntot = n2 - n1 + 1            ntot = n2 - n1 + 1
# Line 450  C         Create the file name Line 815  C         Create the file name
815    
816  C         Add the path to the file name  C         Add the path to the file name
817            IF (mnc_use_indir) THEN            IF (mnc_use_indir) THEN
818              path_fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)              path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
819              npath = ILNBLNK(mnc_indir_str)              npath = ILNBLNK(mnc_indir_str)
820              path_fname(1:npath) = mnc_indir_str(1:npath)              path_fname(1:npath) = mnc_indir_str(1:npath)
821              path_fname((npath+1):(npath+nfname)) = fname(1:nfname)              path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
822              fname(1:MNC_MAX_CHAR) = path_fname(1:MNC_MAX_CHAR)              fname(1:MNC_MAX_PATH) = path_fname(1:MNC_MAX_PATH)
823              nfname = npath + nfname              nfname = npath + nfname
824            ENDIF            ENDIF
825    
826  C         Open the existing file            WRITE(fname_zs,'(2a,i4.4,a1,i6.6,a3)')
827            CALL MNC_FILE_TRY_READ( fname, ierr, indf, myThid)       &         mnc_indir_str(1:npath), fbname(n1:n2),
828         &         0, '.', uniq_tnum, '.nc'
829    
830    C         The steps are:
831    C         (1) open the file in a READ-ONLY mode,
832    C         (2) get the var id for the current variable,
833    C         (3) read the data, and then
834    C         (4) close the file--theres no need to keep it open!
835    
836              write(msgbuf,'(4a)') 'MNC_CW_RX_R: cannot open',
837         &         ' file ''', fname(1:nfname), ''' in read-only mode'
838              err = NF_OPEN(fname, NF_NOWRITE, fid)
839              IF ( err .NE. NF_NOERR ) THEN
840    C           If the initial open fails, try again using a name with a
841    C           zero sequence number inserted
842                err = NF_OPEN(fname_zs, NF_NOWRITE, fid)
843              ENDIF
844              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
845    
846              write(msgbuf,'(5a)')
847         &         'MNC_CW_RX_R: cannot get id for variable ''',
848         &         vtype(nvf:nvl), '''in file ''', fname(1:nfname), ''''
849              err = NF_INQ_VARID(fid, vtype, idv)
850              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
851              f_or_t = 0
852    
853  C         Check that the variable (VType) is defined within the file  #else
854            CALL MNC_GET_FVINDS( fname, vtype, indf, ind_fv_ids, myThid)  
855            IF ((indf .LT. 1) .OR. (ind_fv_ids .LT. 1)) THEN  C         The sequence for PER-FACE and PER-TILE is:
856              write(msgbuf,'(4a)') 'MNC_CW_RX_R ERROR: vtype ''',  C         (1) check whether a PER-FACE file exists
857       &           vtype(nvf:nvl), ''' is not defined within file ''',  C         .   (a) if only one face is used for the entire domain,
858       &           fname(1:nfname)  C         .       then omit the face index from the file name
859              CALL print_error(msgbuf, mythid)  C         .   (b) if the PER-FACE file exists and is somehow faulty,
860              STOP 'ABNORMAL END: S/R MNC_CW_RX_R'  C         .       then we die with an error message
861    C         (2) if no PER-FACE file exists, then use a PER-TILE file
862    
863    C         Create the PER-FACE file name
864              n1 = IFNBLNK(fbname)
865              n2 = ILNBLNK(fbname)
866    C         Add an iteraton count to the file name if its requested
867              IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN
868                WRITE(fname,'(a,a1)') fbname(n1:n2), '.'
869              ELSE
870                WRITE(fname,'(a,a1,i10.10,a1)') fbname(n1:n2), '.',
871         &            mnc_cw_cit(2,mnc_cw_fgci(indfg)), '.'
872            ENDIF            ENDIF
873            fid = mnc_f_info(indf,2)            ntot = ILNBLNK(fname)
874            idv = mnc_fv_ids(indf,ind_fv_ids+1)            path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
875              npath = ILNBLNK(mnc_indir_str)
876    C         Add the face index
877              CALL MNC_CW_GET_FACE_NUM( lbi,lbj, uniq_fnum, myThid)
878              IF ( uniq_fnum .EQ. -1 ) THEN
879    C           There is only one face
880                WRITE(path_fname,'(2a,a2)')
881         &           mnc_indir_str(1:npath), fname(1:ntot), 'nc'
882              ELSE
883                CALL MNC_PSNCM(tmpnm, uniq_fnum, MNC_DEF_FMNC)
884                k = ILNBLNK(tmpnm)
885                WRITE(path_fname,'(2a,a1,a,a3)')
886         &           mnc_indir_str(1:npath), fname(1:ntot), 'f',
887         &           tmpnm(1:k), '.nc'
888              ENDIF
889    
890    C         Try to open the PER-FACE file
891    C         WRITE(*,*) 'trying: "', path_fname, '"'
892              err = NF_OPEN(path_fname, NF_NOWRITE, fid)
893              IF ( err .EQ. NF_NOERR ) THEN
894                f_or_t = 1
895              ELSE
896    
897    C           Create the PER-TILE file name
898                CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)
899                k = ILNBLNK(tmpnm)
900                path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
901                WRITE(path_fname,'(2a,a1,a,a3)')
902         &           mnc_indir_str(1:npath), fname(1:ntot), 't',
903         &           tmpnm(1:k), '.nc'
904    C           WRITE(*,*) 'trying: "', path_fname, '"'
905                err = NF_OPEN(path_fname, NF_NOWRITE, fid)
906                IF ( err .EQ. NF_NOERR ) THEN
907                  f_or_t = 0
908                ELSE
909                  k = ILNBLNK(path_fname)
910                  write(msgbuf,'(4a)')
911         &             'MNC_CW_RX_R: cannot open either a per-face or a ',
912         &             'per-tile file: last try was ''', path_fname(1:k),
913         &             ''''
914                  CALL print_error(msgbuf, mythid)
915                  STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
916                ENDIF
917    
918              ENDIF
919    
920              ntot = ILNBLNK(path_fname)
921              write(msgbuf,'(5a)')
922         &         'MNC_CW_RX_R: cannot get netCDF id for variable ''',
923         &         vtype(nvf:nvl), ''' in file ''', path_fname(1:ntot),
924         &         ''''
925              err = NF_INQ_VARID(fid, vtype, idv)
926              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
927    
928              k = ILNBLNK(path_fname)
929              fname(1:k) = path_fname(1:k)
930              nfname = k
931    
932    #endif
933    
934              IF ( f_or_t .EQ. 1 ) THEN
935    
936    C           write(msgbuf,'(2a)')
937    C           &           'MNC_CW_RX_R: per-face reads are not yet ',
938    C           &           'implemented -- so pester Ed to finish them'
939    C           CALL print_error(msgbuf, mythid)
940    C           STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
941                
942    C           Get the X,Y PER-FACE offsets
943                CALL MNC_CW_GET_XYFO(lbi,lbj, ixoff,iyoff, myThid)
944    
945              ENDIF
946    
947    C         WRITE(*,*) 'f_or_t = ',f_or_t
948    
949  C         Check that the current sNy,sNy values and the in-file values  C         Check that the current sNy,sNy values and the in-file values
950  C         are compatible and WARN (only warn) if not  C         are compatible and WARN (only warn) if not
951            f_sNx = -1  C           f_sNx = -1
952            f_sNy = -1  C           f_sNy = -1
953            err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)  C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)
954            IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN  C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
955              err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)  C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
956              CALL MNC_HANDLE_ERR(err,  C             CALL MNC_HANDLE_ERR(err,
957       &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R',  C      &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R',
958       &           myThid)  C      &           myThid)
959            ENDIF  C           ENDIF
960            err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)  C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
961            IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN  C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
962              err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)  C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
963              CALL MNC_HANDLE_ERR(err,  C             CALL MNC_HANDLE_ERR(err,
964       &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R',  C      &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R',
965       &           myThid)  C      &           myThid)
966            ENDIF  C           ENDIF
967            IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN  C           IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
968              write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',  C             write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',
969       &           'attributes ''sNx'' and ''sNy'' within the file ''',  C      &           'attributes ''sNx'' and ''sNy'' within the file ''',
970       &           fname(1:nfname), ''' do not exist or do not match ',  C      &           fname(1:nfname), ''' do not exist or do not match ',
971       &           'the current sizes within the model'  C      &           'the current sizes within the model'
972              CALL print_error(msgbuf, mythid)  C             CALL print_error(msgbuf, mythid)
973            ENDIF  C           ENDIF
974    
975  C         Check that the in-memory variable and the in-file variables  C         Check that the in-memory variable and the in-file variables
976  C         are of compatible sizes  C         are of compatible sizes
# Line 549  C         the unlimited dimension offset Line 1022  C         the unlimited dimension offset
1022              IF (i .LE. ndim) THEN              IF (i .LE. ndim) THEN
1023                s(i) = mnc_cw_is(i,igrid)                s(i) = mnc_cw_is(i,igrid)
1024                e(i) = mnc_cw_ie(i,igrid)                e(i) = mnc_cw_ie(i,igrid)
1025    
1026                  IF ( f_or_t .EQ. 1 ) THEN
1027    C               Add the per-face X,Y offsets to the udo offset vector
1028    C               since they accomplish the same thing
1029                    IF ( mnc_cw_dn(i,igrid)(1:1) .EQ. 'X' ) THEN
1030                      udo(i) = ixoff - 1
1031                    ELSEIF ( mnc_cw_dn(i,igrid)(1:1) .EQ. 'Y' ) THEN
1032                      udo(i) = iyoff - 1
1033                    ENDIF
1034                  ENDIF
1035    
1036              ENDIF              ENDIF
1037  C           Check for the unlimited dimension  C           Check for the unlimited dimension
1038              IF ((i .EQ. ndim)              IF ((i .EQ. ndim)
# Line 556  C           Check for the unlimited dime Line 1040  C           Check for the unlimited dime
1040                IF (indu .GT. 0) THEN                IF (indu .GT. 0) THEN
1041  C               Use the indu value  C               Use the indu value
1042                  udo(i) = indu - 1                  udo(i) = indu - 1
               ELSEIF (indu .EQ. -1) THEN  
 C               Append one to the current unlimited dim size  
                 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)  
                 udo(i) = unlim_sz  
1043                ELSE                ELSE
1044  C               Use the current unlimited dim size  C               We need the current unlim dim size
1045                  CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)                  write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
1046                  udo(i) = unlim_sz - 1       &               'unlim dim id within file ''',
1047         &               fname(1:nfname), ''''
1048                    err = NF_INQ_UNLIMDIM(fid, unlid)
1049                    CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1050                    write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
1051         &               'unlim dim size within file ''',
1052         &               fname(1:nfname), ''''
1053                    err = NF_INQ_DIMLEN(fid, unlid, unlim_sz)
1054                    CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1055                    udo(i) = unlim_sz
1056                ENDIF                ENDIF
1057              ENDIF              ENDIF
1058            ENDDO            ENDDO
# Line 580  C     DO i = 9,1,-1 Line 1069  C     DO i = 9,1,-1
1069  C     write(*,*) 'i,p(i),s(i),e(i) = ', i,': ',p(i),s(i),e(i)  C     write(*,*) 'i,p(i),s(i),e(i) = ', i,': ',p(i),s(i),e(i)
1070  C     ENDDO  C     ENDDO
1071                        
           CALL MNC_FILE_ENDDEF(fname, myThid)  
   
1072            write(msgbuf,'(5a)') 'reading variable type ''',            write(msgbuf,'(5a)') 'reading variable type ''',
1073       &         vtype(nvf:nvl), ''' within file ''',       &         vtype(nvf:nvl), ''' within file ''',
1074       &         fname(1:nfname), ''''       &         fname(1:nfname), ''''
# Line 615  C         Read the variable one vector a Line 1102  C         Read the variable one vector a
1102        kr = 0        kr = 0
1103        vstart(1) = udo(1) + 1        vstart(1) = udo(1) + 1
1104        vcount(1) = e(1) - s(1) + 1        vcount(1) = e(1) - s(1) + 1
1105          
1106          IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
1107            write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
1108         &       '--please increase to at least ',
1109         &       vcount(1), ' in ''MNC_BUFF.h'''
1110            CALL PRINT_ERROR(msgBuf , 1)
1111            STOP 'ABNORMAL END: S/R MNC_CW_RX_R_OFFSET'
1112          ENDIF
1113    
1114        IF (stype(1:1) .EQ. 'D') THEN        IF (stype(1:1) .EQ. 'D') THEN
1115          err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)          err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
1116          CALL MNC_HANDLE_ERR(err, msgbuf, myThid)          CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1117          DO j1 = s(1),e(1)          DO j1 = s(1),e(1)
1118            k1 = k2 + j1            k1 = k2 + j1
1119            kr = kr + 1            kr = kr + 1
1120            var(k1) = resh_d(kr)            var(k1) = MNCI2( resh_d(kr) )
1121          ENDDO          ENDDO
1122        ENDIF        ENDIF
1123        IF (stype(1:1) .EQ. 'R') THEN        IF (stype(1:1) .EQ. 'R') THEN
# Line 631  C         Read the variable one vector a Line 1126  C         Read the variable one vector a
1126          DO j1 = s(1),e(1)          DO j1 = s(1),e(1)
1127            k1 = k2 + j1            k1 = k2 + j1
1128            kr = kr + 1            kr = kr + 1
1129            var(k1) = resh_r(kr)            var(k1) = MNCI2( resh_r(kr) )
1130          ENDDO          ENDDO
1131        ENDIF        ENDIF
1132        IF (stype(1:1) .EQ. 'I') THEN        IF (stype(1:1) .EQ. 'I') THEN
# Line 644  C         Read the variable one vector a Line 1139  C         Read the variable one vector a
1139          ENDDO          ENDDO
1140        ENDIF        ENDIF
1141    
         
1142    
1143                      ENDDO                      ENDDO
1144                    ENDDO                    ENDDO
# Line 654  C         Read the variable one vector a Line 1148  C         Read the variable one vector a
1148            ENDDO            ENDDO
1149    
1150  C         Close the file  C         Close the file
1151            CALL MNC_FILE_CLOSE(fname, myThid)  C         CALL MNC_FILE_CLOSE(fname, myThid)
1152              err = NF_CLOSE(fid)
1153              write(msgbuf,'(3a)') 'MNC_CW_RX_R:  cannot close file ''',
1154         &         fname(1:nfname), ''''
1155              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1156    
1157    
1158  C         End the lbj,lbi loops  C         End the lbj,lbi loops
1159          ENDDO          ENDDO
Legend:
Removed from v.1.17  
changed lines
  Added in v.1.36
  ViewVC Help
Powered by ViewVC 1.1.22