/[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.42 by mlosch, Thu May 22 12:21:19 2008 UTC revision 1.43 by jmc, Thu Jan 21 01:48:05 2010 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3          
4  #include "MNC_OPTIONS.h"  #include "MNC_OPTIONS.h"
5          
6    C--  File mnc_cw_readwrite.template: template for routines to Read/Write
7    C                               "RX" type variables from/to NetCDF file.
8    C--   Contents
9    C--   o MNC_CW_RX_W_S
10    C--   o MNC_CW_RX_W
11    C--   o MNC_CW_RX_W_OFFSET
12    C--   o MNC_CW_RX_R_S
13    C--   o MNC_CW_RX_R
14    C--   o MNC_CW_RX_R_TF
15    
16  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
17  CBOP 0  CBOP 0
18  C !ROUTINE: MNC_CW_RX_W_S  C !ROUTINE: MNC_CW_RX_W_S
19    
20  C !INTERFACE:  C !INTERFACE:
21        SUBROUTINE MNC_CW_RX_W_S(        SUBROUTINE MNC_CW_RX_W_S(
22       I     stype,       I     stype,
23       I     fbname, bi,bj,       I     fbname, bi,bj,
24       I     vtype,       I     vtype,
25       I     var,       I     var,
26       I     myThid )       I     myThid )
27    
28  C     !DESCRIPTION:  C     !DESCRIPTION:
29  C     A scalar version of MNC_CW_RX_W() for compilers that cannot  C     A scalar version of MNC_CW_RX_W() for compilers that cannot
30  C     gracefully handle the conversion on their own.  C     gracefully handle the conversion on their own.
31          
32  C     !USES:  C     !USES:
33        implicit none        implicit none
34    
# Line 41  C !ROUTINE: MNC_CW_RX_W Line 51  C !ROUTINE: MNC_CW_RX_W
51    
52  C !INTERFACE:  C !INTERFACE:
53        SUBROUTINE MNC_CW_RX_W(        SUBROUTINE MNC_CW_RX_W(
54       I     stype,       I     stype,
55       I     fbname, bi,bj,       I     fbname, bi,bj,
56       I     vtype,       I     vtype,
57       I     var,       I     var,
58       I     myThid )       I     myThid )
59    
60  C     !DESCRIPTION:  C     !DESCRIPTION:
61  C     A scalar version of MNC_CW_RX_W() for compilers that cannot  C     A scalar version of MNC_CW_RX_W() for compilers that cannot
62  C     gracefully handle the conversion on their own.  C     gracefully handle the conversion on their own.
63          
64  C     !USES:  C     !USES:
65        implicit none        implicit none
66    
# Line 65  CEOP Line 75  CEOP
75        DO i = 1,9        DO i = 1,9
76          offsets(i) = 0          offsets(i) = 0
77        ENDDO        ENDDO
78        CALL MNC_CW_RX_W_OFFSET(stype,fbname,bi,bj,vtype, var,        CALL MNC_CW_RX_W_OFFSET(stype,fbname,bi,bj,vtype, var,
79       &     offsets, myThid)       &     offsets, myThid)
80    
81        RETURN        RETURN
# Line 77  C !ROUTINE: MNC_CW_RX_W_OFFSET Line 87  C !ROUTINE: MNC_CW_RX_W_OFFSET
87    
88  C !INTERFACE:  C !INTERFACE:
89        SUBROUTINE MNC_CW_RX_W_OFFSET(        SUBROUTINE MNC_CW_RX_W_OFFSET(
90       I     stype,       I     stype,
91       I     fbname, bi,bj,       I     fbname, bi,bj,
92       I     vtype,       I     vtype,
93       I     var,       I     var,
94       I     offsets,       I     offsets,
95       I     myThid )       I     myThid )
96    
97  C     !DESCRIPTION:  C     !DESCRIPTION:
98  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,
99  C     depending upon the tile indicies.  C     depending upon the tile indicies.
100          
101  C     !USES:  C     !USES:
102        implicit none        implicit none
103  #include "netcdf.inc"  #include "netcdf.inc"
# Line 106  C     !INPUT PARAMETERS: Line 116  C     !INPUT PARAMETERS:
116  CEOP  CEOP
117    
118  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
119        integer i,j,k, indv,nvf,nvl, n1,n2, igrid, ntot, indu        integer i,j,k, indv,nvf,nvl, n1,n2, igrid, indu
120        integer bis,bie, bjs,bje, uniq_tnum, uniq_fnum, nfname, iseq        integer bis,bie, bjs,bje, uniq_tnum, nfname, iseq
121        integer fid, idv, indvids, ndim, indf, err, nf        integer fid, idv, indvids, ndim, indf, err, nf
122        integer lbi,lbj, bidim,bjdim, unlim_sz, kr        integer lbi,lbj, bidim,bjdim, unlim_sz, kr
123        integer p(9),s(9),e(9), dimnc(9)        integer p(9),s(9),e(9), dimnc(9)
# Line 126  C     !LOCAL VARIABLES: Line 136  C     !LOCAL VARIABLES:
136        REAL*4  resh_r( MNC_MAX_BUFF )        REAL*4  resh_r( MNC_MAX_BUFF )
137        INTEGER resh_i( MNC_MAX_BUFF )        INTEGER resh_i( MNC_MAX_BUFF )
138        LOGICAL write_attributes, use_missing        LOGICAL write_attributes, use_missing
139    #ifdef MNC_WRITE_OLDNAMES
140          integer ntot
141    #endif
142  #ifdef HAVE_STAT  #ifdef HAVE_STAT
143        integer ntotenc, ncenc, nbytes, fs_isdone        integer ntotenc, ncenc, nbytes, fs_isdone
144        character*(200) cenc        character*(200) cenc
# Line 149  C     group (or base) name Line 162  C     group (or base) name
162        fg2 = ILNBLNK(fbname)        fg2 = ILNBLNK(fbname)
163        CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)        CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
164        IF (indfg .LT. 1) THEN        IF (indfg .LT. 1) THEN
165          write(msgbuf,'(3a)')          write(msgbuf,'(3a)')
166       &       'MNC_CW_RX_W ERROR: file group name ''',       &       'MNC_CW_RX_W ERROR: file group name ''',
167       &       fbname(fg1:fg2), ''' is not defined'       &       fbname(fg1:fg2), ''' is not defined'
168          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
169          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
# Line 164  C     Check that the Variable Type exist Line 177  C     Check that the Variable Type exist
177        nvl = ILNBLNK(vtype)        nvl = ILNBLNK(vtype)
178        CALL MNC_GET_IND(MNC_MAX_ID, vtype, mnc_cw_vname, indv, myThid)        CALL MNC_GET_IND(MNC_MAX_ID, vtype, mnc_cw_vname, indv, myThid)
179        IF (indv .LT. 1) THEN        IF (indv .LT. 1) THEN
180          write(msgbuf,'(3a)') 'MNC_CW_RX_W ERROR: vtype ''',          write(msgbuf,'(3a)') 'MNC_CW_RX_W ERROR: vtype ''',
181       &       vtype(nvf:nvl), ''' is not defined'       &       vtype(nvf:nvl), ''' is not defined'
182          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
183          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
184        ENDIF        ENDIF
185        igrid = mnc_cw_vgind(indv)        igrid = mnc_cw_vgind(indv)
186    
187  C     Set the bi,bj indicies  C     Set the bi,bj indicies
188        bis = bi        bis = bi
189        bie = bi        bie = bi
190        IF (bi .LT. 1) THEN        IF (bi .LT. 1) THEN
# Line 206  C         Create the file name Line 219  C         Create the file name
219            ntot = ntot + 1            ntot = ntot + 1
220            fname(ntot:ntot) = '.'            fname(ntot:ntot) = '.'
221            IF ( mnc_use_name_ni0 ) THEN            IF ( mnc_use_name_ni0 ) THEN
222              write(fname((ntot+1):(ntot+17)),'(i10.10,a1,i6.6)')              write(fname((ntot+1):(ntot+17)),'(i10.10,a1,i6.6)')
223       &           nIter0,'.',uniq_tnum       &           nIter0,'.',uniq_tnum
224              write(fname((ntot+18):(ntot+25)),'(a1,i4.4,a3)')              write(fname((ntot+18):(ntot+25)),'(a1,i4.4,a3)')
225       &           '.', iseq, '.nc'       &           '.', iseq, '.nc'
226              nfname = ntot + 25              nfname = ntot + 25
227            ELSE            ELSE
228              write(fname((ntot+1):(ntot+14)),'(i4.4,a1,i6.6,a3)')              write(fname((ntot+1):(ntot+14)),'(i4.4,a1,i6.6,a3)')
229       &           iseq,'.',uniq_tnum, '.nc'       &           iseq,'.',uniq_tnum, '.nc'
230              nfname = ntot + 14              nfname = ntot + 14
231            ENDIF            ENDIF
# Line 233  C           Leave off the myIter value e Line 246  C           Leave off the myIter value e
246       &           tmpnm(1:k),'.nc'       &           tmpnm(1:k),'.nc'
247            ELSE            ELSE
248  C           We have an error--bad flag value  C           We have an error--bad flag value
249              write(msgbuf,'(4a)')              write(msgbuf,'(4a)')
250       &           'MNC_CW_RX_W ERROR: bad mnc_cw_cit(1,...) ',       &           'MNC_CW_RX_W ERROR: bad mnc_cw_cit(1,...) ',
251       &           'flag value for base name ''', fbname(fg1:fg2),       &           'flag value for base name ''', fbname(fg1:fg2),
252       &           ''''       &           ''''
253              CALL print_error(msgbuf, mythid)              CALL print_error(msgbuf, mythid)
254              STOP 'ABNORMAL END: S/R MNC_CW_RX_W'              STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
# Line 297  C               we are all done writing Line 310  C               we are all done writing
310                  mnc_cw_fgis(indfg) = iseq                  mnc_cw_fgis(indfg) = iseq
311  #else  #else
312                  IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN                  IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN
313                    write(msgbuf,'(5a)')                    write(msgbuf,'(5a)')
314       &            'MNC_CW_RX_W ERROR: output file for base name ''',       &            'MNC_CW_RX_W ERROR: output file for base name ''',
315       &            fbname(fg1:fg2), ''' is about to exceed the max ',       &            fbname(fg1:fg2), ''' is about to exceed the max ',
316       &            'file size and is NOT ALLOWED an iteration value ',       &            'file size and is NOT ALLOWED an iteration value ',
# Line 305  C               we are all done writing Line 318  C               we are all done writing
318                    CALL print_error(msgbuf, mythid)                    CALL print_error(msgbuf, mythid)
319                    STOP 'ABNORMAL END: S/R MNC_CW_RX_W'                    STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
320                  ELSEIF (mnc_cw_cit(3,mnc_cw_fgci(indfg)) .LT. 0) THEN                  ELSEIF (mnc_cw_cit(3,mnc_cw_fgci(indfg)) .LT. 0) THEN
321                    write(msgbuf,'(5a)')                    write(msgbuf,'(5a)')
322       &            'MNC_CW_RX_W ERROR: output file for base name ''',       &            'MNC_CW_RX_W ERROR: output file for base name ''',
323       &            fbname(fg1:fg2), ''' is about to exceed the max ',       &            fbname(fg1:fg2), ''' is about to exceed the max ',
324       &            'file size and no next-iter has been specified--',       &            'file size and no next-iter has been specified--',
# Line 318  C               DO NOT BUMP THE CURRENT Line 331  C               DO NOT BUMP THE CURRENT
331  C               GROUP SINCE THIS IS ONLY GROWTH TO AVOID FILE SIZE  C               GROUP SINCE THIS IS ONLY GROWTH TO AVOID FILE SIZE
332  C               LIMITS FOR THIS ONE BASENAME GROUP, NOT GROWTH OF THE  C               LIMITS FOR THIS ONE BASENAME GROUP, NOT GROWTH OF THE
333  C               ENTIRE CITER GROUP !!!  C               ENTIRE CITER GROUP !!!
334  C               mnc_cw_cit(2,mnc_cw_fgci(indfg))  C               mnc_cw_cit(2,mnc_cw_fgci(indfg))
335  C               &   = mnc_cw_cit(3,mnc_cw_fgci(indfg))  C               &   = mnc_cw_cit(3,mnc_cw_fgci(indfg))
336  C               mnc_cw_cit(3,mnc_cw_fgci(indfg)) = -1  C               mnc_cw_cit(3,mnc_cw_fgci(indfg)) = -1
337  #endif  #endif
# Line 343  C         local copy of them Line 356  C         local copy of them
356              ENDIF              ENDIF
357    
358  C           Add the coordinate variables  C           Add the coordinate variables
359              CALL MNC_DIM_INIT_ALL_CV(fname,              CALL MNC_DIM_INIT_ALL_CV(fname,
360       &           mnc_cw_dn(i,igrid), dimnc(i), 'Y', lbi,lbj, myThid)       &           mnc_cw_dn(i,igrid), dimnc(i), 'Y', lbi,lbj, myThid)
361    
362            ENDDO            ENDDO
363    
364  C         Ensure that the "grid" is defined  C         Ensure that the "grid" is defined
365            CALL MNC_GRID_INIT(fname, mnc_cw_gname(igrid),            CALL MNC_GRID_INIT(fname, mnc_cw_gname(igrid),
366       &        mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)       &        mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)
367    
368  C         Ensure that the variable is defined  C         Ensure that the variable is defined
# Line 376  C           exist in this file, so we ne Line 389  C           exist in this file, so we ne
389              j = 2 + 3*(i - 1)              j = 2 + 3*(i - 1)
390              IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vtype) THEN              IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vtype) THEN
391                idv = mnc_fv_ids(indf,j+1)                idv = mnc_fv_ids(indf,j+1)
392                indvids = mnc_fd_ind(indf, mnc_f_info(indf,                indvids = mnc_fd_ind(indf, mnc_f_info(indf,
393       &             (mnc_fv_ids(indf,j+2) + 1)) )       &             (mnc_fv_ids(indf,j+2) + 1)) )
394                GOTO 30                GOTO 30
395              ENDIF              ENDIF
396            ENDDO            ENDDO
397            write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',            write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',
398       &         'cannot reference variable ''', vtype, ''''       &         'cannot reference variable ''', vtype, ''''
399            CALL print_error(msgbuf, mythid)            CALL print_error(msgbuf, mythid)
400            STOP 'ABNORMAL END: package MNC'            STOP 'ABNORMAL END: package MNC'
# Line 429  C         the unlimited dimension offset Line 442  C         the unlimited dimension offset
442                e(i) = mnc_cw_ie(i,igrid)                e(i) = mnc_cw_ie(i,igrid)
443              ENDIF              ENDIF
444  C           Check for the unlimited dimension  C           Check for the unlimited dimension
445              IF ((i .EQ. ndim)              IF ((i .EQ. ndim)
446       &           .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN       &           .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
447                IF (indu .GT. 0) THEN                IF (indu .GT. 0) THEN
448  C               Use the indu value  C               Use the indu value
# Line 453  C               Use the current unlimite Line 466  C               Use the current unlimite
466              s(bjdim) = lbj              s(bjdim) = lbj
467              e(bjdim) = lbj              e(bjdim) = lbj
468            ENDIF            ENDIF
469              
470  C         Check the offsets  C         Check the offsets
471            DO i = 1,9            DO i = 1,9
472              IF (offsets(i) .GT. 0) THEN              IF (offsets(i) .GT. 0) THEN
# Line 466  C         Check the offsets Line 479  C         Check the offsets
479            IF (write_attributes) THEN            IF (write_attributes) THEN
480  C           Add the per-variable attributes  C           Add the per-variable attributes
481              DO i = 1,mnc_cw_vnat(1,indv)              DO i = 1,mnc_cw_vnat(1,indv)
482                CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,                CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,
483       &             mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)       &             mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)
484              ENDDO              ENDDO
485              DO i = 1,mnc_cw_vnat(2,indv)              DO i = 1,mnc_cw_vnat(2,indv)
486                CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,                CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,
487       &             mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)       &             mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)
488              ENDDO              ENDDO
489              DO i = 1,mnc_cw_vnat(3,indv)              DO i = 1,mnc_cw_vnat(3,indv)
490                CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,                CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,
491       &             mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)       &             mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)
492              ENDDO              ENDDO
493            ENDIF            ENDIF
# Line 503  C         Handle missing values Line 516  C         Handle missing values
516              ENDIF              ENDIF
517            ENDIF            ENDIF
518            IF (write_attributes .AND. use_missing) THEN            IF (write_attributes .AND. use_missing) THEN
519              write(msgbuf,'(4a)') 'writing attribute ''missing_value''',              write(msgbuf,'(4a)') 'writing attribute ''missing_value''',
520       &           ' within file ''', fname(1:nfname), ''''       &           ' within file ''', fname(1:nfname), ''''
521              IF (stype(1:1) .EQ. 'D') THEN              IF (stype(1:1) .EQ. 'D') THEN
522                err = NF_PUT_ATT_DOUBLE(fid, idv, 'missing_value',                err = NF_PUT_ATT_DOUBLE(fid, idv, 'missing_value',
523       &             NF_DOUBLE, 1, dvm(2))       &             NF_DOUBLE, 1, dvm(2))
524              ELSEIF (stype(1:1) .EQ. 'R') THEN              ELSEIF (stype(1:1) .EQ. 'R') THEN
525                err = NF_PUT_ATT_REAL(fid, idv, 'missing_value',                err = NF_PUT_ATT_REAL(fid, idv, 'missing_value',
526       &             NF_FLOAT, 1, rvm(2))       &             NF_FLOAT, 1, rvm(2))
527              ELSEIF (stype(1:1) .EQ. 'I') THEN              ELSEIF (stype(1:1) .EQ. 'I') THEN
528                err = NF_PUT_ATT_INT(fid, idv, 'missing_value',                err = NF_PUT_ATT_INT(fid, idv, 'missing_value',
529       &             NF_INT, 1, ivm(2))       &             NF_INT, 1, ivm(2))
530              ENDIF              ENDIF
531              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)              CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
532  CMLC     it may be better to use the attribute _FillValue, or both  CMLC     it may be better to use the attribute _FillValue, or both
533  CML            write(msgbuf,'(4a)') 'writing attribute ''_FillValue''',  CML            write(msgbuf,'(4a)') 'writing attribute ''_FillValue''',
534  CML     &           ' within file ''', fname(1:nfname), ''''  CML     &           ' within file ''', fname(1:nfname), ''''
535  CML            IF (stype(1:1) .EQ. 'D') THEN  CML            IF (stype(1:1) .EQ. 'D') THEN
536  CML              err = NF_PUT_ATT_DOUBLE(fid, idv, '_FillValue',  CML              err = NF_PUT_ATT_DOUBLE(fid, idv, '_FillValue',
537  CML     &             NF_DOUBLE, 1, dvm(2))  CML     &             NF_DOUBLE, 1, dvm(2))
538  CML            ELSEIF (stype(1:1) .EQ. 'R') THEN  CML            ELSEIF (stype(1:1) .EQ. 'R') THEN
539  CML              err = NF_PUT_ATT_REAL(fid, idv, '_FillValue',  CML              err = NF_PUT_ATT_REAL(fid, idv, '_FillValue',
540  CML     &             NF_FLOAT, 1, rvm(2))  CML     &             NF_FLOAT, 1, rvm(2))
541  CML            ELSEIF (stype(1:1) .EQ. 'I') THEN  CML            ELSEIF (stype(1:1) .EQ. 'I') THEN
542  CML              err = NF_PUT_ATT_INT(fid, idv, '_FillValue',  CML              err = NF_PUT_ATT_INT(fid, idv, '_FillValue',
543  CML     &             NF_INT, 1, ivm(2))  CML     &             NF_INT, 1, ivm(2))
544  CML            ENDIF  CML            ENDIF
545  CML            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)  CML            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
# Line 534  CML            CALL MNC_HANDLE_ERR(err, Line 547  CML            CALL MNC_HANDLE_ERR(err,
547    
548            CALL MNC_FILE_ENDDEF(fname, myThid)            CALL MNC_FILE_ENDDEF(fname, myThid)
549    
550            write(msgbuf,'(5a)') 'writing variable type ''',            write(msgbuf,'(5a)') 'writing variable type ''',
551       &         vtype(nvf:nvl), ''' within file ''',       &         vtype(nvf:nvl), ''' within file ''',
552       &         fname(1:nfname), ''''       &         fname(1:nfname), ''''
553    
554  C         DO i = 1,9  C         DO i = 1,9
555  C         write(*,*) 'i,p(i),s(i),e(i),udo(i),offsets(i) = ',  C         write(*,*) 'i,p(i),s(i),e(i),udo(i),offsets(i) = ',
556  C         &        i,p(i),s(i),e(i),udo(i),offsets(i)  C         &        i,p(i),s(i),e(i),udo(i),offsets(i)
557  C         ENDDO  C         ENDDO
558    
# Line 622  C         Write the variable one vector Line 635  C         Write the variable one vector
635          ENDIF          ENDIF
636    
637        ELSE        ELSE
638            
639          IF (stype(1:1) .EQ. 'D') THEN          IF (stype(1:1) .EQ. 'D') THEN
640            DO j1 = s(1),e(1)            DO j1 = s(1),e(1)
641              k1 = k2 + j1              k1 = k2 + j1
# Line 659  C         Write the variable one vector Line 672  C         Write the variable one vector
672  C         Sync the file  C         Sync the file
673            err = NF_SYNC(fid)            err = NF_SYNC(fid)
674            nf = ILNBLNK( fname )            nf = ILNBLNK( fname )
675            write(msgbuf,'(3a)') 'sync for file ''', fname(1:nf),            write(msgbuf,'(3a)') 'sync for file ''', fname(1:nf),
676       &         ''' in S/R MNC_CW_RX_W'       &         ''' in S/R MNC_CW_RX_W'
677            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
678    
# Line 670  C         Sync the file Line 683  C         Sync the file
683    
684        RETURN        RETURN
685        END        END
686          
687    
688  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
689  CBOP 0  CBOP 0
690  C !ROUTINE: MNC_CW_RX_R_S  C !ROUTINE: MNC_CW_RX_R_S
691    
692  C !INTERFACE:  C !INTERFACE:
693        SUBROUTINE MNC_CW_RX_R_S(        SUBROUTINE MNC_CW_RX_R_S(
694       I     stype,       I     stype,
695       I     fbname, bi,bj,       I     fbname, bi,bj,
696       I     vtype,       I     vtype,
697       I     var,       I     var,
698       I     myThid )       I     myThid )
699    
700  C     !DESCRIPTION:  C     !DESCRIPTION:
701  C     A scalar version of MNC_CW_RX_R() for compilers that cannot  C     A scalar version of MNC_CW_RX_R() for compilers that cannot
702  C     gracefully handle the conversion on their own.  C     gracefully handle the conversion on their own.
703          
704  C     !USES:  C     !USES:
705        implicit none        implicit none
706    
# Line 710  CBOP 0 Line 723  CBOP 0
723  C !ROUTINE: MNC_CW_RX_R  C !ROUTINE: MNC_CW_RX_R
724    
725  C !INTERFACE:  C !INTERFACE:
726        SUBROUTINE MNC_CW_RX_R(        SUBROUTINE MNC_CW_RX_R(
727       I     stype,       I     stype,
728       I     fbname, bi,bj,       I     fbname, bi,bj,
729       I     vtype,       I     vtype,
730       I     var,       I     var,
731       I     myThid )       I     myThid )
732    
733  C     !DESCRIPTION:  C     !DESCRIPTION:
734  C     A simple wrapper for the old version of this routine.  The new  C     A simple wrapper for the old version of this routine.  The new
735  C     version includes the isvar argument which, for backwards  C     version includes the isvar argument which, for backwards
736  C     compatibility, is set to false here.  C     compatibility, is set to false here.
737          
738  C     !USES:  C     !USES:
739        implicit none        implicit none
740    
# Line 747  CBOP 0 Line 760  CBOP 0
760  C !ROUTINE: MNC_CW_RX_R  C !ROUTINE: MNC_CW_RX_R
761    
762  C !INTERFACE:  C !INTERFACE:
763        SUBROUTINE MNC_CW_RX_R_TF(        SUBROUTINE MNC_CW_RX_R_TF(
764       I     stype,       I     stype,
765       I     fbname, bi,bj,       I     fbname, bi,bj,
766       I     vtype,       I     vtype,
767       I     var,       I     var,
768       B     isvar,       B     isvar,
769       I     myThid )       I     myThid )
770    
771  C     !DESCRIPTION:  C     !DESCRIPTION:
# Line 761  C     depending upon the tile indicies. Line 774  C     depending upon the tile indicies.
774  C     variable does not exist, then isvar is set to false and the  C     variable does not exist, then isvar is set to false and the
775  C     program continues normally.  This allows one to gracefully handle  C     program continues normally.  This allows one to gracefully handle
776  C     the case of reading variables that might or might not exist.  C     the case of reading variables that might or might not exist.
777          
778  C     !USES:  C     !USES:
779        implicit none        implicit none
780  #include "netcdf.inc"  #include "netcdf.inc"
# Line 789  C     integer f_sNx,f_sNy, alen, atype, Line 802  C     integer f_sNx,f_sNy, alen, atype,
802        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
803        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
804        character*(MNC_MAX_PATH) fname        character*(MNC_MAX_PATH) fname
       character*(MNC_MAX_PATH) fname_zs  
805        character*(MNC_MAX_PATH) tmpnm        character*(MNC_MAX_PATH) tmpnm
806        character*(MNC_MAX_PATH) path_fname        character*(MNC_MAX_PATH) path_fname
807        character*(MNC_MAX_PATH) bpath        character*(MNC_MAX_PATH) bpath
# Line 797  C     integer f_sNx,f_sNy, alen, atype, Line 809  C     integer f_sNx,f_sNy, alen, atype,
809        REAL*8  resh_d( MNC_MAX_BUFF )        REAL*8  resh_d( MNC_MAX_BUFF )
810        REAL*4  resh_r( MNC_MAX_BUFF )        REAL*4  resh_r( MNC_MAX_BUFF )
811        INTEGER resh_i( MNC_MAX_BUFF )        INTEGER resh_i( MNC_MAX_BUFF )
812    #ifdef MNC_READ_OLDNAMES
813          character*(MNC_MAX_PATH) fname_zs
814    #endif
815    
816  C     Functions  C     Functions
817        integer IFNBLNK, ILNBLNK        integer IFNBLNK, ILNBLNK
# Line 814  C     group (or base) name Line 829  C     group (or base) name
829        fg2 = ILNBLNK(fbname)        fg2 = ILNBLNK(fbname)
830        CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)        CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
831        IF (indfg .LT. 1) THEN        IF (indfg .LT. 1) THEN
832          write(msgbuf,'(3a)')          write(msgbuf,'(3a)')
833       &       'MNC_CW_RX_W ERROR: file group name ''',       &       'MNC_CW_RX_W ERROR: file group name ''',
834       &       fbname(fg1:fg2), ''' is not defined'       &       fbname(fg1:fg2), ''' is not defined'
835          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
836          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
# Line 827  C     Check that the Variable Type exist Line 842  C     Check that the Variable Type exist
842        nvl = ILNBLNK(vtype)        nvl = ILNBLNK(vtype)
843        CALL MNC_GET_IND( MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt, myThid)        CALL MNC_GET_IND( MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt, myThid)
844        IF (ind_vt .LT. 1) THEN        IF (ind_vt .LT. 1) THEN
845          write(msgbuf,'(3a)') 'MNC_CW_RX_R ERROR: vtype ''',          write(msgbuf,'(3a)') 'MNC_CW_RX_R ERROR: vtype ''',
846       &       vtype(nvf:nvl), ''' is not defined'       &       vtype(nvf:nvl), ''' is not defined'
847          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
848          STOP 'ABNORMAL END: S/R MNC_CW_RX_R'          STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
# Line 880  C         Add the path to the file name Line 895  C         Add the path to the file name
895              nfname = npath + nfname              nfname = npath + nfname
896            ENDIF            ENDIF
897    
898            WRITE(fname_zs,'(2a,i4.4,a1,i6.6,a3)')            WRITE(fname_zs,'(2a,i4.4,a1,i6.6,a3)')
899       &         mnc_indir_str(1:npath), fbname(n1:n2),       &         mnc_indir_str(1:npath), fbname(n1:n2),
900       &         0, '.', uniq_tnum, '.nc'       &         0, '.', uniq_tnum, '.nc'
901    
902  C         The steps are:  C         The steps are:
# Line 890  C         (2) get the var id for the cur Line 905  C         (2) get the var id for the cur
905  C         (3) read the data, and then  C         (3) read the data, and then
906  C         (4) close the file--theres no need to keep it open!  C         (4) close the file--theres no need to keep it open!
907    
908            write(msgbuf,'(4a)') 'MNC_CW_RX_R: cannot open',            write(msgbuf,'(4a)') 'MNC_CW_RX_R: cannot open',
909       &         ' file ''', fname(1:nfname), ''' in read-only mode'       &         ' file ''', fname(1:nfname), ''' in read-only mode'
910            err = NF_OPEN(fname, NF_NOWRITE, fid)            err = NF_OPEN(fname, NF_NOWRITE, fid)
911            IF ( err .NE. NF_NOERR ) THEN            IF ( err .NE. NF_NOERR ) THEN
# Line 900  C           zero sequence number inserte Line 915  C           zero sequence number inserte
915            ENDIF            ENDIF
916            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
917    
918            write(msgbuf,'(5a)')            write(msgbuf,'(5a)')
919       &         'MNC_CW_RX_R: cannot get id for variable ''',       &         'MNC_CW_RX_R: cannot get id for variable ''',
920       &         vtype(nvf:nvl), '''in file ''', fname(1:nfname), ''''       &         vtype(nvf:nvl), '''in file ''', fname(1:nfname), ''''
921            err = NF_INQ_VARID(fid, vtype, idv)            err = NF_INQ_VARID(fid, vtype, idv)
922            IF ( isvar .AND. ( err .NE. NF_NOERR ) ) THEN            IF ( isvar .AND. ( err .NE. NF_NOERR ) ) THEN
# Line 939  C         Add the face index Line 954  C         Add the face index
954            CALL MNC_CW_GET_FACE_NUM( lbi,lbj, uniq_fnum, myThid)            CALL MNC_CW_GET_FACE_NUM( lbi,lbj, uniq_fnum, myThid)
955            IF ( uniq_fnum .EQ. -1 ) THEN            IF ( uniq_fnum .EQ. -1 ) THEN
956  C           There is only one face  C           There is only one face
957              WRITE(path_fname,'(2a,a2)')              WRITE(path_fname,'(2a,a2)')
958       &           mnc_indir_str(1:npath), fname(1:ntot), 'nc'       &           mnc_indir_str(1:npath), fname(1:ntot), 'nc'
959            ELSE            ELSE
960              CALL MNC_PSNCM(tmpnm, uniq_fnum, MNC_DEF_FMNC)              CALL MNC_PSNCM(tmpnm, uniq_fnum, MNC_DEF_FMNC)
961              k = ILNBLNK(tmpnm)              k = ILNBLNK(tmpnm)
962              WRITE(path_fname,'(2a,a1,a,a3)')              WRITE(path_fname,'(2a,a1,a,a3)')
963       &           mnc_indir_str(1:npath), fname(1:ntot), 'f',       &           mnc_indir_str(1:npath), fname(1:ntot), 'f',
964       &           tmpnm(1:k), '.nc'       &           tmpnm(1:k), '.nc'
965            ENDIF            ENDIF
# Line 960  C           Create the PER-TILE file nam Line 975  C           Create the PER-TILE file nam
975              CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)              CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)
976              k = ILNBLNK(tmpnm)              k = ILNBLNK(tmpnm)
977              path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)              path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
978              WRITE(path_fname,'(2a,a1,a,a3)')              WRITE(path_fname,'(2a,a1,a,a3)')
979       &           mnc_indir_str(1:npath), fname(1:ntot), 't',       &           mnc_indir_str(1:npath), fname(1:ntot), 't',
980       &           tmpnm(1:k), '.nc'       &           tmpnm(1:k), '.nc'
981  C           WRITE(*,*) 'trying: "', path_fname, '"'  C           WRITE(*,*) 'trying: "', path_fname, '"'
# Line 969  C           WRITE(*,*) 'trying: "', path Line 984  C           WRITE(*,*) 'trying: "', path
984                f_or_t = 0                f_or_t = 0
985              ELSE              ELSE
986                k = ILNBLNK(path_fname)                k = ILNBLNK(path_fname)
987                write(msgbuf,'(4a)')                write(msgbuf,'(4a)')
988       &             'MNC_CW_RX_R: cannot open either a per-face or a ',       &             'MNC_CW_RX_R: cannot open either a per-face or a ',
989       &             'per-tile file: last try was ''', path_fname(1:k),       &             'per-tile file: last try was ''', path_fname(1:k),
990       &             ''''       &             ''''
# Line 980  C           WRITE(*,*) 'trying: "', path Line 995  C           WRITE(*,*) 'trying: "', path
995            ENDIF            ENDIF
996    
997            ntot = ILNBLNK(path_fname)            ntot = ILNBLNK(path_fname)
998            write(msgbuf,'(5a)')            write(msgbuf,'(5a)')
999       &         'MNC_CW_RX_R: cannot get netCDF id for variable ''',       &         'MNC_CW_RX_R: cannot get netCDF id for variable ''',
1000       &         vtype(nvf:nvl), ''' in file ''', path_fname(1:ntot),       &         vtype(nvf:nvl), ''' in file ''', path_fname(1:ntot),
1001       &         ''''       &         ''''
# Line 1000  C           WRITE(*,*) 'trying: "', path Line 1015  C           WRITE(*,*) 'trying: "', path
1015    
1016            IF ( f_or_t .EQ. 1 ) THEN            IF ( f_or_t .EQ. 1 ) THEN
1017    
1018  C           write(msgbuf,'(2a)')  C           write(msgbuf,'(2a)')
1019  C           &           'MNC_CW_RX_R: per-face reads are not yet ',  C           &           'MNC_CW_RX_R: per-face reads are not yet ',
1020  C           &           'implemented -- so pester Ed to finish them'  C           &           'implemented -- so pester Ed to finish them'
1021  C           CALL print_error(msgbuf, mythid)  C           CALL print_error(msgbuf, mythid)
1022  C           STOP 'ABNORMAL END: S/R MNC_CW_RX_W'  C           STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
1023                
1024  C           Get the X,Y PER-FACE offsets  C           Get the X,Y PER-FACE offsets
1025              CALL MNC_CW_GET_XYFO(lbi,lbj, ixoff,iyoff, myThid)              CALL MNC_CW_GET_XYFO(lbi,lbj, ixoff,iyoff, myThid)
1026    
# Line 1020  C           f_sNy = -1 Line 1035  C           f_sNy = -1
1035  C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)  C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)
1036  C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN  C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
1037  C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)  C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
1038  C             CALL MNC_HANDLE_ERR(err,  C             CALL MNC_HANDLE_ERR(err,
1039  C      &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R',  C      &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R',
1040  C      &           myThid)  C      &           myThid)
1041  C           ENDIF  C           ENDIF
1042  C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)  C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
1043  C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN  C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
1044  C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)  C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
1045  C             CALL MNC_HANDLE_ERR(err,  C             CALL MNC_HANDLE_ERR(err,
1046  C      &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R',  C      &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R',
1047  C      &           myThid)  C      &           myThid)
1048  C           ENDIF  C           ENDIF
1049  C           IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN  C           IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
1050  C             write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',  C             write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',
1051  C      &           'attributes ''sNx'' and ''sNy'' within the file ''',  C      &           'attributes ''sNx'' and ''sNy'' within the file ''',
1052  C      &           fname(1:nfname), ''' do not exist or do not match ',  C      &           fname(1:nfname), ''' do not exist or do not match ',
1053  C      &           'the current sizes within the model'  C      &           'the current sizes within the model'
1054  C             CALL print_error(msgbuf, mythid)  C             CALL print_error(msgbuf, mythid)
# Line 1042  C           ENDIF Line 1057  C           ENDIF
1057  C         Check that the in-memory variable and the in-file variables  C         Check that the in-memory variable and the in-file variables
1058  C         are of compatible sizes  C         are of compatible sizes
1059  C           ires = 1  C           ires = 1
1060  C           CALL MNC_CHK_VTYP_R_NCVAR( ind_vt,  C           CALL MNC_CHK_VTYP_R_NCVAR( ind_vt,
1061  C      &         indf, ind_fv_ids, indu, ires)  C      &         indf, ind_fv_ids, indu, ires)
1062  C           IF (ires .LT. 0) THEN  C           IF (ires .LT. 0) THEN
1063  C             write(msgbuf,'(7a)') 'MNC_CW_RX_R WARNING: the sizes ',  C             write(msgbuf,'(7a)') 'MNC_CW_RX_R WARNING: the sizes ',
1064  C      &           'of the in-program variable ''', vtype(nvf:nvl),  C      &           'of the in-program variable ''', vtype(nvf:nvl),
1065  C      &           ''' and the corresponding variable within file ''',  C      &           ''' and the corresponding variable within file ''',
1066  C      &           fname(1:nfname), ''' are not compatible -- please ',  C      &           fname(1:nfname), ''' are not compatible -- please ',
1067  C      &           'check the sizes'  C      &           'check the sizes'
# Line 1102  C               since they accomplish th Line 1117  C               since they accomplish th
1117    
1118              ENDIF              ENDIF
1119  C           Check for the unlimited dimension  C           Check for the unlimited dimension
1120              IF ((i .EQ. ndim)              IF ((i .EQ. ndim)
1121       &           .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN       &           .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
1122                IF (indu .GT. 0) THEN                IF (indu .GT. 0) THEN
1123  C               Use the indu value  C               Use the indu value
# Line 1110  C               Use the indu value Line 1125  C               Use the indu value
1125                ELSE                ELSE
1126  C               We need the current unlim dim size  C               We need the current unlim dim size
1127                  write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',                  write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
1128       &               'unlim dim id within file ''',       &               'unlim dim id within file ''',
1129       &               fname(1:nfname), ''''       &               fname(1:nfname), ''''
1130                  err = NF_INQ_UNLIMDIM(fid, unlid)                  err = NF_INQ_UNLIMDIM(fid, unlid)
1131                  CALL MNC_HANDLE_ERR(err, msgbuf, myThid)                  CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1132                  write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',                  write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
1133       &               'unlim dim size within file ''',       &               'unlim dim size within file ''',
1134       &               fname(1:nfname), ''''       &               fname(1:nfname), ''''
1135                  err = NF_INQ_DIMLEN(fid, unlid, unlim_sz)                  err = NF_INQ_DIMLEN(fid, unlid, unlim_sz)
1136                  CALL MNC_HANDLE_ERR(err, msgbuf, myThid)                  CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
# Line 1135  C               We need the current unli Line 1150  C               We need the current unli
1150  C     DO i = 9,1,-1  C     DO i = 9,1,-1
1151  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)
1152  C     ENDDO  C     ENDDO
1153              
1154            write(msgbuf,'(5a)') 'reading variable type ''',            write(msgbuf,'(5a)') 'reading variable type ''',
1155       &         vtype(nvf:nvl), ''' within file ''',       &         vtype(nvf:nvl), ''' within file ''',
1156       &         fname(1:nfname), ''''       &         fname(1:nfname), ''''
1157    
1158  C         Read the variable one vector at a time  C         Read the variable one vector at a time
# Line 1206  C         Read the variable one vector a Line 1221  C         Read the variable one vector a
1221          ENDDO          ENDDO
1222        ENDIF        ENDIF
1223    
1224    
1225                      ENDDO                      ENDDO
1226                    ENDDO                    ENDDO
1227                  ENDDO                  ENDDO
# Line 1217  C         Read the variable one vector a Line 1232  C         Read the variable one vector a
1232  C         Close the file  C         Close the file
1233  C         CALL MNC_FILE_CLOSE(fname, myThid)  C         CALL MNC_FILE_CLOSE(fname, myThid)
1234            err = NF_CLOSE(fid)            err = NF_CLOSE(fid)
1235            write(msgbuf,'(3a)') 'MNC_CW_RX_R:  cannot close file ''',            write(msgbuf,'(3a)') 'MNC_CW_RX_R:  cannot close file ''',
1236       &         fname(1:nfname), ''''       &         fname(1:nfname), ''''
1237            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
1238    
Legend:
Removed from v.1.42  
changed lines
  Added in v.1.43
  ViewVC Help
Powered by ViewVC 1.1.22