/[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.26 by edhill, Fri Dec 17 04:50:05 2004 UTC revision 1.41 by mlosch, Thu May 22 08:29:59 2008 UTC
# Line 93  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_SIZE.h"  #include "MNC_BUFF.h"
97  #include "EEPARAMS.h"  #include "EEPARAMS.h"
98  #include "PARAMS.h"  #include "PARAMS.h"
99  #include "MNC_PARAMS.h"  #include "MNC_PARAMS.h"
# Line 107  CEOP Line 107  CEOP
107    
108  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
109        integer i,j,k, indv,nvf,nvl, n1,n2, igrid, ntot, indu        integer i,j,k, indv,nvf,nvl, n1,n2, igrid, ntot, indu
110        integer bis,bie, bjs,bje, uniq_tnum, nfname, iseq        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, nf
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)
114        integer vstart(9),vcount(9), udo(9)        integer vstart(9),vcount(9), udo(9)
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          character*(MNC_MAX_PATH) tmpnm
121          character*(MNC_MAX_PATH) bpath
122          REAL*8  dval, dvm(2)
123          REAL*4  rval, rvm(2)
124          INTEGER ival, ivm(2), irv
125        REAL*8  resh_d( MNC_MAX_BUFF )        REAL*8  resh_d( MNC_MAX_BUFF )
126        REAL*4  resh_r( MNC_MAX_BUFF )        REAL*4  resh_r( MNC_MAX_BUFF )
127        INTEGER resh_i( MNC_MAX_BUFF )        INTEGER resh_i( MNC_MAX_BUFF )
128          LOGICAL write_attributes, use_missing
129  #ifdef HAVE_STAT  #ifdef HAVE_STAT
130        integer ntotenc, ncenc, nbytes, fs_isdone        integer ntotenc, ncenc, nbytes, fs_isdone
131        character*(200) cenc        character*(200) cenc
# Line 133  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 185  C     Set the bi,bj indicies Line 195  C     Set the bi,bj indicies
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+14)),'(i4.4,a1,i6.6,a3)')            IF ( mnc_use_name_ni0 ) THEN
209       &         iseq,'.',uniq_tnum, '.nc'              write(fname((ntot+1):(ntot+17)),'(i10.10,a1,i6.6)')
210            nfname = ntot + 14       &           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    
# Line 241  C           file based on the byte count Line 289  C           file based on the byte count
289  C               Delete the now-full fname from the lookup tables since  C               Delete the now-full fname from the lookup tables since
290  C               we are all done writing to it.  C               we are all done writing to it.
291                  CALL MNC_FILE_CLOSE(fname, myThid)                  CALL MNC_FILE_CLOSE(fname, myThid)
                 iseq = iseq + 1  
292                  indu = 1                  indu = 1
293                  mnc_cw_fgud(indfg) = 1                  mnc_cw_fgud(indfg) = 1
294    
295    #ifdef MNC_WRITE_OLDNAMES
296                    iseq = iseq + 1
297                  mnc_cw_fgis(indfg) = iseq                  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                  fs_isdone = 1
326                  GOTO 10                  GOTO 10
327    
328                ENDIF                ENDIF
329              ENDIF              ENDIF
330            ENDIF            ENDIF
# Line 263  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
             CALL MNC_DIM_INIT(fname,  
      &           mnc_cw_dn(i,igrid), dimnc(i), myThid)  
344    
345  C           Add the coordinate variables  C           Add the coordinate variables
346  C           CALL MNC_CW_ADD_CVAR(fname, mnc_cw_dn(i,igrid),              CALL MNC_DIM_INIT_ALL_CV(fname,
347  C                                dimnc(i), myThid)       &           mnc_cw_dn(i,igrid), dimnc(i), 'Y', lbi,lbj, myThid)
348    
349            ENDDO            ENDDO
350    
# Line 277  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 378  C         Check the offsets Line 463  C         Check the offsets
463              ENDIF              ENDIF
464            ENDDO            ENDDO
465    
466  C         Add the per-variable attributes            IF (write_attributes) THEN
467            DO i = 1,mnc_cw_vnat(1,indv)  C           Add the per-variable attributes
468              CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,              DO i = 1,mnc_cw_vnat(1,indv)
469       &           mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)                CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,
470            ENDDO       &             mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)
471            DO i = 1,mnc_cw_vnat(2,indv)              ENDDO
472              CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,              DO i = 1,mnc_cw_vnat(2,indv)
473       &           mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)                CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,
474            ENDDO       &             mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)
475            DO i = 1,mnc_cw_vnat(3,indv)              ENDDO
476              CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,              DO i = 1,mnc_cw_vnat(3,indv)
477       &           mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)                CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,
478            ENDDO       &             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, rvm(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    CMLC     it may be better to use the attribute _FillValue, or both
520    CML            write(msgbuf,'(4a)') 'writing attribute ''_FillValue''',
521    CML     &           ' within file ''', fname(1:nfname), ''''
522    CML            IF (stype(1:1) .EQ. 'D') THEN
523    CML              err = NF_PUT_ATT_DOUBLE(fid, idv, '_FillValue',
524    CML     &             NF_DOUBLE, 1, dvm(2))
525    CML            ELSEIF (stype(1:1) .EQ. 'R') THEN
526    CML              err = NF_PUT_ATT_REAL(fid, idv, '_FillValue',
527    CML     &             NF_FLOAT, 1, rvm(2))
528    CML            ELSEIF (stype(1:1) .EQ. 'I') THEN
529    CML              err = NF_PUT_ATT_INT(fid, idv, '_FillValue',
530    CML     &             NF_INT, 1, ivm(2))
531    CML            ENDIF
532    CML            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
533              ENDIF
534    
535            CALL MNC_FILE_ENDDEF(fname, myThid)            CALL MNC_FILE_ENDDEF(fname, myThid)
536    
# Line 436  C         Write the variable one vector Line 576  C         Write the variable one vector
576        IF (vcount(1) .GT. MNC_MAX_BUFF) THEN        IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
577          write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',          write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
578       &       '--please increase to at least ',       &       '--please increase to at least ',
579       &       vcount(1), ' in ''MNC_SIZE.h'''       &       vcount(1), ' in ''MNC_BUFF.h'''
580          CALL PRINT_ERROR(msgBuf , 1)          CALL PRINT_ERROR(msgBuf , 1)
581          STOP 'ABNORMAL END: S/R MNC_CW_RX_W_OFFSET'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W_OFFSET'
582        ENDIF        ENDIF
583    
584        IF (stype(1:1) .EQ. 'D') THEN        IF (use_missing) THEN
         DO j1 = s(1),e(1)  
           k1 = k2 + j1  
           kr = kr + 1  
           resh_d(kr) = var(k1)  
         ENDDO  
         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)  
       ENDIF  
585    
586            IF (stype(1:1) .EQ. 'D') THEN
587              DO j1 = s(1),e(1)
588                k1 = k2 + j1
589                kr = kr + 1
590                dval = var(k1)
591                IF (dval .EQ. dvm(1)) THEN
592                  resh_d(kr) = dvm(2)
593                ELSE
594                  resh_d(kr) = dval
595                ENDIF
596              ENDDO
597              err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
598            ELSEIF (stype(1:1) .EQ. 'R') THEN
599              DO j1 = s(1),e(1)
600                k1 = k2 + j1
601                kr = kr + 1
602                rval = var(k1)
603                IF (rval .EQ. rvm(1)) THEN
604                  resh_r(kr) = rvm(2)
605                ELSE
606                  resh_r(kr) = rval
607                ENDIF
608              ENDDO
609              err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
610            ELSEIF (stype(1:1) .EQ. 'I') THEN
611              DO j1 = s(1),e(1)
612                k1 = k2 + j1
613                kr = kr + 1
614                ival = MNC2I( var(k1) )
615                IF (ival .EQ. ivm(1)) THEN
616                  resh_i(kr) = ivm(2)
617                ELSE
618                  resh_i(kr) = ival
619                ENDIF
620              ENDDO
621              err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
622            ENDIF
623    
624          ELSE
625            
626            IF (stype(1:1) .EQ. 'D') THEN
627              DO j1 = s(1),e(1)
628                k1 = k2 + j1
629                kr = kr + 1
630                resh_d(kr) = var(k1)
631              ENDDO
632              err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
633            ELSEIF (stype(1:1) .EQ. 'R') THEN
634              DO j1 = s(1),e(1)
635                k1 = k2 + j1
636                kr = kr + 1
637                resh_r(kr) = var(k1)
638              ENDDO
639              err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
640            ELSEIF (stype(1:1) .EQ. 'I') THEN
641              DO j1 = s(1),e(1)
642                k1 = k2 + j1
643                kr = kr + 1
644                resh_i(kr) = MNC2I( var(k1) )
645              ENDDO
646              err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
647            ENDIF
648    
649          ENDIF
650        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
651    
652                      ENDDO                      ENDDO
# Line 477  C         Write the variable one vector Line 658  C         Write the variable one vector
658    
659  C         Sync the file  C         Sync the file
660            err = NF_SYNC(fid)            err = NF_SYNC(fid)
661            write(msgbuf,'(3a)') 'sync for file ''', fname,            nf = ILNBLNK( fname )
662              write(msgbuf,'(3a)') 'sync for file ''', fname(1:nf),
663       &         ''' in S/R MNC_CW_RX_W'       &         ''' in S/R MNC_CW_RX_W'
664            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
665    
# Line 535  C !INTERFACE: Line 717  C !INTERFACE:
717       I     var,       I     var,
718       I     myThid )       I     myThid )
719    
720    C     !DESCRIPTION:
721    C     A simple wrapper for the old version of this routine.  The new
722    C     version includes the isvar argument which, for backwards
723    C     compatibility, is set to false here.
724          
725    C     !USES:
726          implicit none
727    
728    C     !INPUT PARAMETERS:
729          integer myThid, bi,bj
730          character*(*) stype, fbname, vtype
731          __V var(*)
732    CEOP
733    
734    C     !LOCAL VARIABLES:
735          LOGICAL isvar
736    
737          isvar = .FALSE.
738    
739          CALL MNC_CW_RX_R_TF(stype,fbname,bi,bj,vtype,var,isvar,myThid)
740    
741          RETURN
742          END
743    
744    
745    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
746    CBOP 0
747    C !ROUTINE: MNC_CW_RX_R
748    
749    C !INTERFACE:
750          SUBROUTINE MNC_CW_RX_R_TF(
751         I     stype,
752         I     fbname, bi,bj,
753         I     vtype,
754         I     var,
755         B     isvar,
756         I     myThid )
757    
758  C     !DESCRIPTION:  C     !DESCRIPTION:
759  C     This subroutine reads one variable from a file or a file group,  C     This subroutine reads one variable from a file or a file group,
760  C     depending upon the tile indicies.  C     depending upon the tile indicies.  If isvar is true and the
761    C     variable does not exist, then isvar is set to false and the
762    C     program continues normally.  This allows one to gracefully handle
763    C     the case of reading variables that might or might not exist.
764                
765  C     !USES:  C     !USES:
766        implicit none        implicit none
767  #include "netcdf.inc"  #include "netcdf.inc"
768  #include "mnc_common.h"  #include "mnc_common.h"
769  #include "SIZE.h"  #include "SIZE.h"
770  #include "MNC_SIZE.h"  #include "MNC_BUFF.h"
771  #include "EEPARAMS.h"  #include "EEPARAMS.h"
772  #include "PARAMS.h"  #include "PARAMS.h"
773  #include "MNC_PARAMS.h"  #include "MNC_PARAMS.h"
# Line 553  C     !INPUT PARAMETERS: Line 776  C     !INPUT PARAMETERS:
776        integer myThid, bi,bj        integer myThid, bi,bj
777        character*(*) stype, fbname, vtype        character*(*) stype, fbname, vtype
778        __V var(*)        __V var(*)
779          LOGICAL isvar
780  CEOP  CEOP
781    
782  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
783        integer i,k, nvf,nvl, n1,n2, igrid, ntot, indu        integer i,k, nvf,nvl, n1,n2, igrid, ntot, indu
784        integer bis,bie, bjs,bje, uniq_tnum, nfname, fid, idv        integer bis,bie, bjs,bje, uniq_tnum,uniq_fnum, nfname, fid, idv
785        integer ndim, indf, err, lbi,lbj, bidim,bjdim, unlim_sz, kr        integer ndim, err, lbi,lbj, bidim,bjdim, unlim_sz, kr
786        integer ind_fv_ids, ind_vt, ierr, atype, alen        integer ind_vt, npath, unlid, f_or_t, ixoff,iyoff
787        integer f_sNx,f_sNy, npath  C     integer f_sNx,f_sNy, alen, atype, ind_fv_ids, ierr, indf
788        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)
789        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
790        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
791        character*(MNC_MAX_CHAR) fname        character*(MNC_MAX_PATH) fname
792        character*(MNC_MAX_CHAR) path_fname        character*(MNC_MAX_PATH) fname_zs
793          character*(MNC_MAX_PATH) tmpnm
794          character*(MNC_MAX_PATH) path_fname
795          character*(MNC_MAX_PATH) bpath
796        integer indfg, fg1,fg2        integer indfg, fg1,fg2
797        REAL*8  resh_d( MNC_MAX_BUFF )        REAL*8  resh_d( MNC_MAX_BUFF )
798        REAL*4  resh_r( MNC_MAX_BUFF )        REAL*4  resh_r( MNC_MAX_BUFF )
# Line 577  C     Functions Line 804  C     Functions
804  C     Only do I/O if I am the master thread  C     Only do I/O if I am the master thread
805        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
806    
807          DO i = 1,MNC_MAX_PATH
808            bpath(i:i) = ' '
809          ENDDO
810    
811  C     Get the current index for the unlimited dimension from the file  C     Get the current index for the unlimited dimension from the file
812  C     group (or base) name  C     group (or base) name
813        fg1 = IFNBLNK(fbname)        fg1 = IFNBLNK(fbname)
# Line 626  C     Set the bi,bj indicies Line 857  C     Set the bi,bj indicies
857    
858  C         Create the file name  C         Create the file name
859            CALL MNC_CW_GET_TILE_NUM( lbi,lbj, uniq_tnum, myThid)            CALL MNC_CW_GET_TILE_NUM( lbi,lbj, uniq_tnum, myThid)
860            fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)            fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
861    
862    #ifdef MNC_READ_OLDNAMES
863    
864            n1 = IFNBLNK(fbname)            n1 = IFNBLNK(fbname)
865            n2 = ILNBLNK(fbname)            n2 = ILNBLNK(fbname)
866            ntot = n2 - n1 + 1            ntot = n2 - n1 + 1
# Line 638  C         Create the file name Line 872  C         Create the file name
872    
873  C         Add the path to the file name  C         Add the path to the file name
874            IF (mnc_use_indir) THEN            IF (mnc_use_indir) THEN
875              path_fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)              path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
876              npath = ILNBLNK(mnc_indir_str)              npath = ILNBLNK(mnc_indir_str)
877              path_fname(1:npath) = mnc_indir_str(1:npath)              path_fname(1:npath) = mnc_indir_str(1:npath)
878              path_fname((npath+1):(npath+nfname)) = fname(1:nfname)              path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
879              fname(1:MNC_MAX_CHAR) = path_fname(1:MNC_MAX_CHAR)              fname(1:MNC_MAX_PATH) = path_fname(1:MNC_MAX_PATH)
880              nfname = npath + nfname              nfname = npath + nfname
881            ENDIF            ENDIF
882    
883  C         Open the existing file            WRITE(fname_zs,'(2a,i4.4,a1,i6.6,a3)')
884            CALL MNC_FILE_TRY_READ( fname, ierr, indf, myThid)       &         mnc_indir_str(1:npath), fbname(n1:n2),
885         &         0, '.', uniq_tnum, '.nc'
886    
887    C         The steps are:
888    C         (1) open the file in a READ-ONLY mode,
889    C         (2) get the var id for the current variable,
890    C         (3) read the data, and then
891    C         (4) close the file--theres no need to keep it open!
892    
893              write(msgbuf,'(4a)') 'MNC_CW_RX_R: cannot open',
894         &         ' file ''', fname(1:nfname), ''' in read-only mode'
895              err = NF_OPEN(fname, NF_NOWRITE, fid)
896              IF ( err .NE. NF_NOERR ) THEN
897    C           If the initial open fails, try again using a name with a
898    C           zero sequence number inserted
899                err = NF_OPEN(fname_zs, NF_NOWRITE, fid)
900              ENDIF
901              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
902    
903  C         Check that the variable (VType) is defined within the file            write(msgbuf,'(5a)')
904            CALL MNC_GET_FVINDS( fname, vtype, indf, ind_fv_ids, myThid)       &         'MNC_CW_RX_R: cannot get id for variable ''',
905            IF ((indf .LT. 1) .OR. (ind_fv_ids .LT. 1)) THEN       &         vtype(nvf:nvl), '''in file ''', fname(1:nfname), ''''
906              write(msgbuf,'(4a)') 'MNC_CW_RX_R ERROR: vtype ''',            err = NF_INQ_VARID(fid, vtype, idv)
907       &           vtype(nvf:nvl), ''' is not defined within file ''',            IF ( isvar .AND. ( err .NE. NF_NOERR ) ) THEN
908       &           fname(1:nfname)              isvar = .FALSE.
909              CALL print_error(msgbuf, mythid)              RETURN
             STOP 'ABNORMAL END: S/R MNC_CW_RX_R'  
910            ENDIF            ENDIF
911            fid = mnc_f_info(indf,2)            isvar = .TRUE.
912            idv = mnc_fv_ids(indf,ind_fv_ids+1)            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
913              f_or_t = 0
914    
915    #else
916    
917    C         The sequence for PER-FACE and PER-TILE is:
918    C         (1) check whether a PER-FACE file exists
919    C         .   (a) if only one face is used for the entire domain,
920    C         .       then omit the face index from the file name
921    C         .   (b) if the PER-FACE file exists and is somehow faulty,
922    C         .       then we die with an error message
923    C         (2) if no PER-FACE file exists, then use a PER-TILE file
924    
925    C         Create the PER-FACE file name
926              n1 = IFNBLNK(fbname)
927              n2 = ILNBLNK(fbname)
928    C         Add an iteraton count to the file name if its requested
929              IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN
930                WRITE(fname,'(a,a1)') fbname(n1:n2), '.'
931              ELSE
932                WRITE(fname,'(a,a1,i10.10,a1)') fbname(n1:n2), '.',
933         &            mnc_cw_cit(2,mnc_cw_fgci(indfg)), '.'
934              ENDIF
935              ntot = ILNBLNK(fname)
936              path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
937              npath = ILNBLNK(mnc_indir_str)
938    C         Add the face index
939              CALL MNC_CW_GET_FACE_NUM( lbi,lbj, uniq_fnum, myThid)
940              IF ( uniq_fnum .EQ. -1 ) THEN
941    C           There is only one face
942                WRITE(path_fname,'(2a,a2)')
943         &           mnc_indir_str(1:npath), fname(1:ntot), 'nc'
944              ELSE
945                CALL MNC_PSNCM(tmpnm, uniq_fnum, MNC_DEF_FMNC)
946                k = ILNBLNK(tmpnm)
947                WRITE(path_fname,'(2a,a1,a,a3)')
948         &           mnc_indir_str(1:npath), fname(1:ntot), 'f',
949         &           tmpnm(1:k), '.nc'
950              ENDIF
951    
952    C         Try to open the PER-FACE file
953    C         WRITE(*,*) 'trying: "', path_fname, '"'
954              err = NF_OPEN(path_fname, NF_NOWRITE, fid)
955              IF ( err .EQ. NF_NOERR ) THEN
956                f_or_t = 1
957              ELSE
958    
959    C           Create the PER-TILE file name
960                CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)
961                k = ILNBLNK(tmpnm)
962                path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
963                WRITE(path_fname,'(2a,a1,a,a3)')
964         &           mnc_indir_str(1:npath), fname(1:ntot), 't',
965         &           tmpnm(1:k), '.nc'
966    C           WRITE(*,*) 'trying: "', path_fname, '"'
967                err = NF_OPEN(path_fname, NF_NOWRITE, fid)
968                IF ( err .EQ. NF_NOERR ) THEN
969                  f_or_t = 0
970                ELSE
971                  k = ILNBLNK(path_fname)
972                  write(msgbuf,'(4a)')
973         &             'MNC_CW_RX_R: cannot open either a per-face or a ',
974         &             'per-tile file: last try was ''', path_fname(1:k),
975         &             ''''
976                  CALL print_error(msgbuf, mythid)
977                  STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
978                ENDIF
979    
980              ENDIF
981    
982              ntot = ILNBLNK(path_fname)
983              write(msgbuf,'(5a)')
984         &         'MNC_CW_RX_R: cannot get netCDF id for variable ''',
985         &         vtype(nvf:nvl), ''' in file ''', path_fname(1:ntot),
986         &         ''''
987              err = NF_INQ_VARID(fid, vtype, idv)
988              IF ( isvar .AND. ( err .NE. NF_NOERR ) ) THEN
989                isvar = .FALSE.
990                RETURN
991              ENDIF
992              isvar = .TRUE.
993              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
994    
995              k = ILNBLNK(path_fname)
996              fname(1:k) = path_fname(1:k)
997              nfname = k
998    
999    #endif
1000    
1001              IF ( f_or_t .EQ. 1 ) THEN
1002    
1003    C           write(msgbuf,'(2a)')
1004    C           &           'MNC_CW_RX_R: per-face reads are not yet ',
1005    C           &           'implemented -- so pester Ed to finish them'
1006    C           CALL print_error(msgbuf, mythid)
1007    C           STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
1008                
1009    C           Get the X,Y PER-FACE offsets
1010                CALL MNC_CW_GET_XYFO(lbi,lbj, ixoff,iyoff, myThid)
1011    
1012              ENDIF
1013    
1014    C         WRITE(*,*) 'f_or_t = ',f_or_t
1015    
1016  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
1017  C         are compatible and WARN (only warn) if not  C         are compatible and WARN (only warn) if not
1018            f_sNx = -1  C           f_sNx = -1
1019            f_sNy = -1  C           f_sNy = -1
1020            err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)  C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)
1021            IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN  C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
1022              err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)  C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
1023              CALL MNC_HANDLE_ERR(err,  C             CALL MNC_HANDLE_ERR(err,
1024       &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R',  C      &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R',
1025       &           myThid)  C      &           myThid)
1026            ENDIF  C           ENDIF
1027            err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)  C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
1028            IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN  C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
1029              err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)  C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
1030              CALL MNC_HANDLE_ERR(err,  C             CALL MNC_HANDLE_ERR(err,
1031       &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R',  C      &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R',
1032       &           myThid)  C      &           myThid)
1033            ENDIF  C           ENDIF
1034            IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN  C           IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
1035              write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',  C             write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',
1036       &           'attributes ''sNx'' and ''sNy'' within the file ''',  C      &           'attributes ''sNx'' and ''sNy'' within the file ''',
1037       &           fname(1:nfname), ''' do not exist or do not match ',  C      &           fname(1:nfname), ''' do not exist or do not match ',
1038       &           'the current sizes within the model'  C      &           'the current sizes within the model'
1039              CALL print_error(msgbuf, mythid)  C             CALL print_error(msgbuf, mythid)
1040            ENDIF  C           ENDIF
1041    
1042  C         Check that the in-memory variable and the in-file variables  C         Check that the in-memory variable and the in-file variables
1043  C         are of compatible sizes  C         are of compatible sizes
# Line 737  C         the unlimited dimension offset Line 1089  C         the unlimited dimension offset
1089              IF (i .LE. ndim) THEN              IF (i .LE. ndim) THEN
1090                s(i) = mnc_cw_is(i,igrid)                s(i) = mnc_cw_is(i,igrid)
1091                e(i) = mnc_cw_ie(i,igrid)                e(i) = mnc_cw_ie(i,igrid)
1092    
1093                  IF ( f_or_t .EQ. 1 ) THEN
1094    C               Add the per-face X,Y offsets to the udo offset vector
1095    C               since they accomplish the same thing
1096                    IF ( mnc_cw_dn(i,igrid)(1:1) .EQ. 'X' ) THEN
1097                      udo(i) = ixoff - 1
1098                    ELSEIF ( mnc_cw_dn(i,igrid)(1:1) .EQ. 'Y' ) THEN
1099                      udo(i) = iyoff - 1
1100                    ENDIF
1101                  ENDIF
1102    
1103              ENDIF              ENDIF
1104  C           Check for the unlimited dimension  C           Check for the unlimited dimension
1105              IF ((i .EQ. ndim)              IF ((i .EQ. ndim)
# Line 744  C           Check for the unlimited dime Line 1107  C           Check for the unlimited dime
1107                IF (indu .GT. 0) THEN                IF (indu .GT. 0) THEN
1108  C               Use the indu value  C               Use the indu value
1109                  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  
1110                ELSE                ELSE
1111  C               Use the current unlimited dim size  C               We need the current unlim dim size
1112                  CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)                  write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
1113                  udo(i) = unlim_sz - 1       &               'unlim dim id within file ''',
1114         &               fname(1:nfname), ''''
1115                    err = NF_INQ_UNLIMDIM(fid, unlid)
1116                    CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1117                    write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
1118         &               'unlim dim size within file ''',
1119         &               fname(1:nfname), ''''
1120                    err = NF_INQ_DIMLEN(fid, unlid, unlim_sz)
1121                    CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1122                    udo(i) = unlim_sz
1123                ENDIF                ENDIF
1124              ENDIF              ENDIF
1125            ENDDO            ENDDO
# Line 768  C     DO i = 9,1,-1 Line 1136  C     DO i = 9,1,-1
1136  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)
1137  C     ENDDO  C     ENDDO
1138                        
           CALL MNC_FILE_ENDDEF(fname, myThid)  
   
1139            write(msgbuf,'(5a)') 'reading variable type ''',            write(msgbuf,'(5a)') 'reading variable type ''',
1140       &         vtype(nvf:nvl), ''' within file ''',       &         vtype(nvf:nvl), ''' within file ''',
1141       &         fname(1:nfname), ''''       &         fname(1:nfname), ''''
# Line 807  C         Read the variable one vector a Line 1173  C         Read the variable one vector a
1173        IF (vcount(1) .GT. MNC_MAX_BUFF) THEN        IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
1174          write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',          write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
1175       &       '--please increase to at least ',       &       '--please increase to at least ',
1176       &       vcount(1), ' in ''MNC_SIZE.h'''       &       vcount(1), ' in ''MNC_BUFF.h'''
1177          CALL PRINT_ERROR(msgBuf , 1)          CALL PRINT_ERROR(msgBuf , 1)
1178          STOP 'ABNORMAL END: S/R MNC_CW_RX_R_OFFSET'          STOP 'ABNORMAL END: S/R MNC_CW_RX_R_OFFSET'
1179        ENDIF        ENDIF
# Line 818  C         Read the variable one vector a Line 1184  C         Read the variable one vector a
1184          DO j1 = s(1),e(1)          DO j1 = s(1),e(1)
1185            k1 = k2 + j1            k1 = k2 + j1
1186            kr = kr + 1            kr = kr + 1
1187            var(k1) = resh_d(kr)            var(k1) = MNCI2( resh_d(kr) )
1188          ENDDO          ENDDO
1189        ENDIF        ENDIF
1190        IF (stype(1:1) .EQ. 'R') THEN        IF (stype(1:1) .EQ. 'R') THEN
# Line 827  C         Read the variable one vector a Line 1193  C         Read the variable one vector a
1193          DO j1 = s(1),e(1)          DO j1 = s(1),e(1)
1194            k1 = k2 + j1            k1 = k2 + j1
1195            kr = kr + 1            kr = kr + 1
1196            var(k1) = resh_r(kr)            var(k1) = MNCI2( resh_r(kr) )
1197          ENDDO          ENDDO
1198        ENDIF        ENDIF
1199        IF (stype(1:1) .EQ. 'I') THEN        IF (stype(1:1) .EQ. 'I') THEN
# Line 840  C         Read the variable one vector a Line 1206  C         Read the variable one vector a
1206          ENDDO          ENDDO
1207        ENDIF        ENDIF
1208    
         
1209    
1210                      ENDDO                      ENDDO
1211                    ENDDO                    ENDDO
# Line 850  C         Read the variable one vector a Line 1215  C         Read the variable one vector a
1215            ENDDO            ENDDO
1216    
1217  C         Close the file  C         Close the file
1218            CALL MNC_FILE_CLOSE(fname, myThid)  C         CALL MNC_FILE_CLOSE(fname, myThid)
1219              err = NF_CLOSE(fid)
1220              write(msgbuf,'(3a)') 'MNC_CW_RX_R:  cannot close file ''',
1221         &         fname(1:nfname), ''''
1222              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1223    
1224    
1225  C         End the lbj,lbi loops  C         End the lbj,lbi loops
1226          ENDDO          ENDDO
Legend:
Removed from v.1.26  
changed lines
  Added in v.1.41
  ViewVC Help
Powered by ViewVC 1.1.22