Back to home page

MITgcm

 
 

    


Warning, /pkg/mnc/mnc_cw_readwrite.template is written in an unsupported language. File is not indexed.

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
3623ff8097 Ed H*0001 #include "MNC_OPTIONS.h"
b6432c788b Jean*0002 
                0003 C--  File mnc_cw_readwrite.template: template for routines to Read/Write
                0004 C                               "RX" type variables from/to NetCDF file.
                0005 C--   Contents
                0006 C--   o MNC_CW_RX_W_S
                0007 C--   o MNC_CW_RX_W
                0008 C--   o MNC_CW_RX_W_OFFSET
                0009 C--   o MNC_CW_RX_R_S
                0010 C--   o MNC_CW_RX_R
                0011 C--   o MNC_CW_RX_R_TF
                0012 
3623ff8097 Ed H*0013 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0014 CBOP 0
d65cc4075b Ed H*0015 C !ROUTINE: MNC_CW_RX_W_S
                0016 
                0017 C !INTERFACE:
                0018       SUBROUTINE MNC_CW_RX_W_S(
b6432c788b Jean*0019      I     stype,
                0020      I     fbname, bi,bj,
                0021      I     vtype,
                0022      I     var,
d65cc4075b Ed H*0023      I     myThid )
                0024 
                0025 C     !DESCRIPTION:
                0026 C     A scalar version of MNC_CW_RX_W() for compilers that cannot
                0027 C     gracefully handle the conversion on their own.
b6432c788b Jean*0028 
d65cc4075b Ed H*0029 C     !USES:
                0030       implicit none
                0031 
                0032 C     !INPUT PARAMETERS:
cb356b4c5f Ed H*0033       integer myThid, bi,bj
d65cc4075b Ed H*0034       character*(*) stype, fbname, vtype
                0035       __V var
                0036       __V var_arr(1)
                0037 CEOP
                0038 
                0039       var_arr(1) = var
                0040       CALL MNC_CW_RX_W(stype,fbname,bi,bj,vtype, var_arr, myThid)
                0041 
                0042       RETURN
                0043       END
                0044 
                0045 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0046 CBOP 0
1b5fb69d21 Ed H*0047 C !ROUTINE: MNC_CW_RX_W
3623ff8097 Ed H*0048 
1b5fb69d21 Ed H*0049 C !INTERFACE:
3ca071fc35 Ed H*0050       SUBROUTINE MNC_CW_RX_W(
b6432c788b Jean*0051      I     stype,
                0052      I     fbname, bi,bj,
                0053      I     vtype,
                0054      I     var,
3f2ea2a4ed Ed H*0055      I     myThid )
3623ff8097 Ed H*0056 
1b5fb69d21 Ed H*0057 C     !DESCRIPTION:
cb356b4c5f Ed H*0058 C     A scalar version of MNC_CW_RX_W() for compilers that cannot
                0059 C     gracefully handle the conversion on their own.
b6432c788b Jean*0060 
cb356b4c5f Ed H*0061 C     !USES:
                0062       implicit none
                0063 
                0064 C     !INPUT PARAMETERS:
                0065       integer myThid, bi,bj
                0066       character*(*) stype, fbname, vtype
cbdfffbd03 Jean*0067       __V var(*)
cb356b4c5f Ed H*0068       INTEGER offsets(9)
                0069 CEOP
                0070       INTEGER i
                0071 
                0072       DO i = 1,9
                0073         offsets(i) = 0
                0074       ENDDO
b6432c788b Jean*0075       CALL MNC_CW_RX_W_OFFSET(stype,fbname,bi,bj,vtype, var,
cb356b4c5f Ed H*0076      &     offsets, myThid)
                0077 
                0078       RETURN
                0079       END
                0080 
                0081 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0082 CBOP 0
                0083 C !ROUTINE: MNC_CW_RX_W_OFFSET
                0084 
                0085 C !INTERFACE:
                0086       SUBROUTINE MNC_CW_RX_W_OFFSET(
b6432c788b Jean*0087      I     stype,
                0088      I     fbname, bi,bj,
                0089      I     vtype,
                0090      I     var,
                0091      I     offsets,
cb356b4c5f Ed H*0092      I     myThid )
                0093 
                0094 C     !DESCRIPTION:
1b5fb69d21 Ed H*0095 C     This subroutine writes one variable to a file or a file group,
                0096 C     depending upon the tile indicies.
b6432c788b Jean*0097 
1b5fb69d21 Ed H*0098 C     !USES:
3623ff8097 Ed H*0099       implicit none
                0100 #include "netcdf.inc"
07155994b8 Mart*0101 #include "MNC_COMMON.h"
b11e5981be Ed H*0102 #include "SIZE.h"
5bc9611487 Ed H*0103 #include "MNC_BUFF.h"
1a7eca6776 Ed H*0104 #include "EEPARAMS.h"
                0105 #include "PARAMS.h"
a30418b6b9 Ed H*0106 #include "MNC_PARAMS.h"
b11e5981be Ed H*0107 
1b5fb69d21 Ed H*0108 C     !INPUT PARAMETERS:
cb356b4c5f Ed H*0109       integer myThid, bi,bj
3ca071fc35 Ed H*0110       character*(*) stype, fbname, vtype
a906dd2a24 Ed H*0111       __V var(*)
cb356b4c5f Ed H*0112       INTEGER offsets(*)
e6bb5b2cc3 Ed H*0113 CEOP
3623ff8097 Ed H*0114 
1b5fb69d21 Ed H*0115 C     !LOCAL VARIABLES:
b6432c788b Jean*0116       integer i,j,k, indv,nvf,nvl, n1,n2, igrid, indu
                0117       integer bis,bie, bjs,bje, uniq_tnum, nfname, iseq
16a9213e57 Ed H*0118       integer fid, idv, indvids, ndim, indf, err, nf
1b5fb69d21 Ed H*0119       integer lbi,lbj, bidim,bjdim, unlim_sz, kr
                0120       integer p(9),s(9),e(9), dimnc(9)
                0121       integer vstart(9),vcount(9), udo(9)
ef84d10314 Ed H*0122       integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
cba009f524 Ed H*0123       integer indfg, fg1,fg2, npath
3623ff8097 Ed H*0124       character*(MAX_LEN_MBUF) msgbuf
9705a0d5c6 Ed H*0125       character*(MNC_MAX_PATH) fname
                0126       character*(MNC_MAX_PATH) path_fname
                0127       character*(MNC_MAX_PATH) tmpnm
                0128       character*(MNC_MAX_PATH) bpath
21c48a3add Ed H*0129       REAL*8  dval, dvm(2)
                0130       REAL*4  rval, rvm(2)
                0131       INTEGER ival, ivm(2), irv
7ad6cc105a Ed H*0132       REAL*8  resh_d( MNC_MAX_BUFF )
                0133       REAL*4  resh_r( MNC_MAX_BUFF )
                0134       INTEGER resh_i( MNC_MAX_BUFF )
21c48a3add Ed H*0135       LOGICAL write_attributes, use_missing
b6432c788b Jean*0136 #ifdef MNC_WRITE_OLDNAMES
                0137       integer ntot
                0138 #endif
ab11ba1276 Ed H*0139 #ifdef HAVE_STAT
                0140       integer ntotenc, ncenc, nbytes, fs_isdone
                0141       character*(200) cenc
                0142       integer ienc(200)
                0143       REAL*8  fsnu
                0144 #endif
e6bb5b2cc3 Ed H*0145 
1b5fb69d21 Ed H*0146 C     Functions
                0147       integer IFNBLNK, ILNBLNK
3623ff8097 Ed H*0148 
                0149 C     Only do I/O if I am the master thread
                0150       _BEGIN_MASTER( myThid )
                0151 
9705a0d5c6 Ed H*0152       DO i = 1,MNC_MAX_PATH
                0153         bpath(i:i) = ' '
                0154       ENDDO
                0155 
0007eca320 Ed H*0156 C     Get the current index for the unlimited dimension from the file
                0157 C     group (or base) name
                0158       fg1 = IFNBLNK(fbname)
                0159       fg2 = ILNBLNK(fbname)
                0160       CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
                0161       IF (indfg .LT. 1) THEN
b6432c788b Jean*0162         write(msgbuf,'(3a)')
                0163      &       'MNC_CW_RX_W ERROR: file group name ''',
0007eca320 Ed H*0164      &       fbname(fg1:fg2), ''' is not defined'
                0165         CALL print_error(msgbuf, mythid)
3ca071fc35 Ed H*0166         STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
0007eca320 Ed H*0167       ENDIF
                0168       indu = mnc_cw_fgud(indfg)
3a6f2e4083 Ed H*0169       iseq = mnc_cw_fgis(indfg)
ab11ba1276 Ed H*0170 C     write(*,*) 'indu,iseq = ', indu, iseq
0007eca320 Ed H*0171 
3623ff8097 Ed H*0172 C     Check that the Variable Type exists
                0173       nvf = IFNBLNK(vtype)
                0174       nvl = ILNBLNK(vtype)
3f2ea2a4ed Ed H*0175       CALL MNC_GET_IND(MNC_MAX_ID, vtype, mnc_cw_vname, indv, myThid)
b11e5981be Ed H*0176       IF (indv .LT. 1) THEN
b6432c788b Jean*0177         write(msgbuf,'(3a)') 'MNC_CW_RX_W ERROR: vtype ''',
b11e5981be Ed H*0178      &       vtype(nvf:nvl), ''' is not defined'
3623ff8097 Ed H*0179         CALL print_error(msgbuf, mythid)
3ca071fc35 Ed H*0180         STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
3623ff8097 Ed H*0181       ENDIF
b11e5981be Ed H*0182       igrid = mnc_cw_vgind(indv)
3623ff8097 Ed H*0183 
b6432c788b Jean*0184 C     Set the bi,bj indicies
b11e5981be Ed H*0185       bis = bi
                0186       bie = bi
52e2906819 Ed H*0187       IF (bi .LT. 1) THEN
3623ff8097 Ed H*0188         bis = 1
                0189         bie = nSx
                0190       ENDIF
b11e5981be Ed H*0191       bjs = bj
                0192       bje = bj
52e2906819 Ed H*0193       IF (bj .LT. 1) THEN
3623ff8097 Ed H*0194         bjs = 1
                0195         bje = nSy
                0196       ENDIF
                0197 
b11e5981be Ed H*0198       DO lbj = bjs,bje
                0199         DO lbi = bis,bie
3623ff8097 Ed H*0200 
ab11ba1276 Ed H*0201 #ifdef HAVE_STAT
                0202           fs_isdone = 0
                0203 #endif
                0204  10       CONTINUE
                0205 
3623ff8097 Ed H*0206 C         Create the file name
3f2ea2a4ed Ed H*0207           CALL MNC_CW_GET_TILE_NUM(lbi,lbj, uniq_tnum, myThid)
9705a0d5c6 Ed H*0208           fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
3623ff8097 Ed H*0209           n1 = IFNBLNK(fbname)
                0210           n2 = ILNBLNK(fbname)
5bc9611487 Ed H*0211 
                0212 #ifdef MNC_WRITE_OLDNAMES
                0213 
3623ff8097 Ed H*0214           ntot = n2 - n1 + 1
                0215           fname(1:ntot) = fbname(n1:n2)
                0216           ntot = ntot + 1
                0217           fname(ntot:ntot) = '.'
0bd3fd8d5f Ed H*0218           IF ( mnc_use_name_ni0 ) THEN
b6432c788b Jean*0219             write(fname((ntot+1):(ntot+17)),'(i10.10,a1,i6.6)')
0bd3fd8d5f Ed H*0220      &           nIter0,'.',uniq_tnum
b6432c788b Jean*0221             write(fname((ntot+18):(ntot+25)),'(a1,i4.4,a3)')
0bd3fd8d5f Ed H*0222      &           '.', iseq, '.nc'
                0223             nfname = ntot + 25
                0224           ELSE
b6432c788b Jean*0225             write(fname((ntot+1):(ntot+14)),'(i4.4,a1,i6.6,a3)')
0bd3fd8d5f Ed H*0226      &           iseq,'.',uniq_tnum, '.nc'
                0227             nfname = ntot + 14
                0228           ENDIF
b11e5981be Ed H*0229 
5bc9611487 Ed H*0230 #else
                0231 
                0232           CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)
                0233           k = ILNBLNK(tmpnm)
                0234           IF ( mnc_cw_cit(1,mnc_cw_fgci(indfg)) .GT. -1 ) THEN
18befb72fd Ed H*0235             j = mnc_cw_cit(2,mnc_cw_fgci(indfg))
                0236             IF ( mnc_cw_fgis(indfg) .GT. j )
                0237      &           j = mnc_cw_fgis(indfg)
5bc9611487 Ed H*0238             write(fname,'(a,a1,i10.10,a2,a,a3)') fbname(n1:n2),
18befb72fd Ed H*0239      &           '.', j, '.t', tmpnm(1:k), '.nc'
5bc9611487 Ed H*0240           ELSEIF ( mnc_cw_cit(1,mnc_cw_fgci(indfg)) .EQ. -1 ) THEN
                0241 C           Leave off the myIter value entirely
                0242             write(fname,'(a,a2,a,a3)') fbname(n1:n2), '.t',
                0243      &           tmpnm(1:k),'.nc'
                0244           ELSE
                0245 C           We have an error--bad flag value
b6432c788b Jean*0246             write(msgbuf,'(4a)')
5bc9611487 Ed H*0247      &           'MNC_CW_RX_W ERROR: bad mnc_cw_cit(1,...) ',
b6432c788b Jean*0248      &           'flag value for base name ''', fbname(fg1:fg2),
5bc9611487 Ed H*0249      &           ''''
                0250             CALL print_error(msgbuf, mythid)
                0251             STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
                0252           ENDIF
                0253           nfname = ILNBLNK(fname)
                0254 
                0255 #endif
                0256 
cba009f524 Ed H*0257 C         Add the path to the file name
1a7eca6776 Ed H*0258           IF (mnc_use_outdir) THEN
9705a0d5c6 Ed H*0259             path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
1a7eca6776 Ed H*0260             npath = ILNBLNK(mnc_out_path)
                0261             path_fname(1:npath) = mnc_out_path(1:npath)
3e965d0c91 Ed H*0262             path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
9705a0d5c6 Ed H*0263             fname(1:MNC_MAX_PATH) = path_fname(1:MNC_MAX_PATH)
3e965d0c91 Ed H*0264             nfname = npath + nfname
1a7eca6776 Ed H*0265           ENDIF
cba009f524 Ed H*0266 
b11e5981be Ed H*0267 C         Append to an existing or create a new file
c5f7d8f43a Ed H*0268           CALL MNC_CW_FILE_AORC(fname,indf, lbi,lbj,uniq_tnum, myThid)
b11e5981be Ed H*0269           fid = mnc_f_info(indf,2)
                0270 
ab11ba1276 Ed H*0271 #ifdef HAVE_STAT
                0272           IF ((mnc_cw_fgig(indfg) .EQ. 1)
                0273      &         .AND. (fs_isdone .EQ. 0)) THEN
c5f7d8f43a Ed H*0274 C           Decide whether to append to the existing or create a new
                0275 C           file based on the byte count per unlimited dimension
ab11ba1276 Ed H*0276             ncenc = 70
                0277             cenc(1:26)  = 'abcdefghijklmnopqrstuvwxyz'
                0278             cenc(27:52) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
                0279             cenc(53:70) = '0123456789_.,+-=/~'
                0280             k = nfname
                0281             IF (k .GT. 200)  k = 200
                0282             ntotenc = 0
                0283             DO i = 1,k
                0284               DO j = 1,ncenc
                0285                 IF (fname(i:i) .EQ. cenc(j:j)) THEN
                0286                   ntotenc = ntotenc + 1
                0287                   ienc(ntotenc) = j
                0288                   GOTO 20
                0289                 ENDIF
                0290               ENDDO
                0291  20           CONTINUE
                0292             ENDDO
                0293             CALL mncfsize(ntotenc, ienc, nbytes)
                0294             IF (nbytes .GT. 0) THEN
                0295               CALL MNC_DIM_UNLIM_SIZE(fname, unlim_sz, myThid)
                0296               fsnu = (1.0 _d 0 + 1.0 _d 0 / DBLE(unlim_sz))
                0297      &             * DBLE(nbytes)
                0298               IF (fsnu .GT. mnc_max_fsize) THEN
8bea8f5a87 Ed H*0299 C               Delete the now-full fname from the lookup tables since
                0300 C               we are all done writing to it.
                0301                 CALL MNC_FILE_CLOSE(fname, myThid)
ab11ba1276 Ed H*0302                 indu = 1
                0303                 mnc_cw_fgud(indfg) = 1
5bc9611487 Ed H*0304 
                0305 #ifdef MNC_WRITE_OLDNAMES
                0306                 iseq = iseq + 1
ab11ba1276 Ed H*0307                 mnc_cw_fgis(indfg) = iseq
5bc9611487 Ed H*0308 #else
                0309                 IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN
b6432c788b Jean*0310                   write(msgbuf,'(5a)')
5bc9611487 Ed H*0311      &            'MNC_CW_RX_W ERROR: output file for base name ''',
                0312      &            fbname(fg1:fg2), ''' is about to exceed the max ',
                0313      &            'file size and is NOT ALLOWED an iteration value ',
                0314      &            'within its file name'
                0315                   CALL print_error(msgbuf, mythid)
                0316                   STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
                0317                 ELSEIF (mnc_cw_cit(3,mnc_cw_fgci(indfg)) .LT. 0) THEN
b6432c788b Jean*0318                   write(msgbuf,'(5a)')
5bc9611487 Ed H*0319      &            'MNC_CW_RX_W ERROR: output file for base name ''',
                0320      &            fbname(fg1:fg2), ''' is about to exceed the max ',
                0321      &            'file size and no next-iter has been specified--',
                0322      &            'please see the MNC CITER functions'
                0323                   CALL print_error(msgbuf, mythid)
                0324                   STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
                0325                 ENDIF
18befb72fd Ed H*0326                 mnc_cw_fgis(indfg) = mnc_cw_cit(3,mnc_cw_fgci(indfg))
                0327 C               DO NOT BUMP THE CURRENT ITER FOR ALL FILES IN THIS CITER
                0328 C               GROUP SINCE THIS IS ONLY GROWTH TO AVOID FILE SIZE
                0329 C               LIMITS FOR THIS ONE BASENAME GROUP, NOT GROWTH OF THE
                0330 C               ENTIRE CITER GROUP !!!
b6432c788b Jean*0331 C               mnc_cw_cit(2,mnc_cw_fgci(indfg))
18befb72fd Ed H*0332 C               &   = mnc_cw_cit(3,mnc_cw_fgci(indfg))
                0333 C               mnc_cw_cit(3,mnc_cw_fgci(indfg)) = -1
5bc9611487 Ed H*0334 #endif
ab11ba1276 Ed H*0335                 fs_isdone = 1
                0336                 GOTO 10
5bc9611487 Ed H*0337 
ab11ba1276 Ed H*0338               ENDIF
                0339             ENDIF
                0340           ENDIF
                0341 #endif  /*  HAVE_STAT  */
                0342 
ef84d10314 Ed H*0343 C         Ensure that all the NetCDF dimensions are defined and create a
                0344 C         local copy of them
b11e5981be Ed H*0345           DO i = 1,9
                0346             dimnc(i) = 1
                0347           ENDDO
                0348           DO i = 1,mnc_cw_ndim(igrid)
ef84d10314 Ed H*0349             IF (mnc_cw_dims(i,igrid) .EQ. -1) THEN
                0350               dimnc(i) = -1
                0351             ELSE
                0352               dimnc(i) = mnc_cw_ie(i,igrid) - mnc_cw_is(i,igrid) + 1
                0353             ENDIF
c5f7d8f43a Ed H*0354 
                0355 C           Add the coordinate variables
b6432c788b Jean*0356             CALL MNC_DIM_INIT_ALL_CV(fname,
d77e828db7 Ed H*0357      &           mnc_cw_dn(i,igrid), dimnc(i), 'Y', lbi,lbj, myThid)
c5f7d8f43a Ed H*0358 
b11e5981be Ed H*0359           ENDDO
                0360 
                0361 C         Ensure that the "grid" is defined
b6432c788b Jean*0362           CALL MNC_GRID_INIT(fname, mnc_cw_gname(igrid),
3f2ea2a4ed Ed H*0363      &        mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)
b11e5981be Ed H*0364 
                0365 C         Ensure that the variable is defined
21c48a3add Ed H*0366           irv = 0
3ca071fc35 Ed H*0367           IF (stype(1:1) .EQ. 'D')
                0368      &         CALL MNC_VAR_INIT_DBL(
21c48a3add Ed H*0369      &         fname, mnc_cw_gname(igrid), vtype, irv, myThid)
3ca071fc35 Ed H*0370           IF (stype(1:1) .EQ. 'R')
                0371      &         CALL MNC_VAR_INIT_REAL(
21c48a3add Ed H*0372      &         fname, mnc_cw_gname(igrid), vtype, irv, myThid)
3ca071fc35 Ed H*0373           IF (stype(1:1) .EQ. 'I')
                0374      &         CALL MNC_VAR_INIT_INT(
21c48a3add Ed H*0375      &         fname, mnc_cw_gname(igrid), vtype, irv, myThid)
                0376 
                0377           IF (irv .GT. 0) THEN
                0378 C           Return value indicates that the variable did not previously
                0379 C           exist in this file, so we need to write all the attributes
                0380             write_attributes = .TRUE.
                0381           ELSE
                0382             write_attributes = .FALSE.
                0383           ENDIF
3ca071fc35 Ed H*0384 
b11e5981be Ed H*0385           DO i = 1,mnc_fv_ids(indf,1)
                0386             j = 2 + 3*(i - 1)
                0387             IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vtype) THEN
                0388               idv = mnc_fv_ids(indf,j+1)
b6432c788b Jean*0389               indvids = mnc_fd_ind(indf, mnc_f_info(indf,
b11e5981be Ed H*0390      &             (mnc_fv_ids(indf,j+2) + 1)) )
ab11ba1276 Ed H*0391               GOTO 30
b11e5981be Ed H*0392             ENDIF
                0393           ENDDO
b6432c788b Jean*0394           write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',
b11e5981be Ed H*0395      &         'cannot reference variable ''', vtype, ''''
                0396           CALL print_error(msgbuf, mythid)
8ae258cf2c Ed H*0397           STOP 'ABNORMAL END: package MNC'
ab11ba1276 Ed H*0398  30       CONTINUE
b11e5981be Ed H*0399 
ef84d10314 Ed H*0400 C         Check for bi,bj indicies
                0401           bidim = mnc_cw_vbij(1,indv)
                0402           bjdim = mnc_cw_vbij(2,indv)
119438a015 Ed H*0403 CEH3      write(*,*) 'bidim,bjdim = ', bidim,bjdim
ef84d10314 Ed H*0404 
b11e5981be Ed H*0405 C         Set the dimensions for the in-memory array
                0406           ndim = mnc_cw_ndim(igrid)
ef84d10314 Ed H*0407           k = mnc_cw_dims(1,igrid)
                0408           IF (k .GT. 0) THEN
                0409             p(1) = k
                0410           ELSE
                0411             p(1) = 1
                0412           ENDIF
b11e5981be Ed H*0413           DO i = 2,9
ef84d10314 Ed H*0414             k = mnc_cw_dims(i,igrid)
                0415             IF (k .LT. 1) THEN
                0416               k = 1
                0417             ENDIF
                0418             IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
                0419               p(i) = nSx * p(i-1)
                0420             ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
                0421               p(i) = nSy * p(i-1)
                0422             ELSE
                0423               p(i) = k * p(i-1)
                0424             ENDIF
cb356b4c5f Ed H*0425             IF (offsets(i) .GT. 0) THEN
                0426               k = 1
                0427               p(i) = k * p(i-1)
                0428             ENDIF
b11e5981be Ed H*0429           ENDDO
                0430 
ef84d10314 Ed H*0431 C         Set starting and ending indicies for the in-memory array and
                0432 C         the unlimited dimension offset for the NetCDF array
b11e5981be Ed H*0433           DO i = 1,9
ef84d10314 Ed H*0434             udo(i) = 0
                0435             s(i) = 1
                0436             e(i) = 1
                0437             IF (i .LE. ndim) THEN
                0438               s(i) = mnc_cw_is(i,igrid)
                0439               e(i) = mnc_cw_ie(i,igrid)
                0440             ENDIF
                0441 C           Check for the unlimited dimension
b6432c788b Jean*0442             IF ((i .EQ. ndim)
ef84d10314 Ed H*0443      &           .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
                0444               IF (indu .GT. 0) THEN
                0445 C               Use the indu value
                0446                 udo(i) = indu - 1
                0447               ELSEIF (indu .EQ. -1) THEN
                0448 C               Append one to the current unlimited dim size
3f2ea2a4ed Ed H*0449                 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
ef84d10314 Ed H*0450                 udo(i) = unlim_sz
b11e5981be Ed H*0451               ELSE
ef84d10314 Ed H*0452 C               Use the current unlimited dim size
3f2ea2a4ed Ed H*0453                 CALL MNC_DIM_UNLIM_SIZE( fname, unlim_sz, myThid)
ef84d10314 Ed H*0454                 udo(i) = unlim_sz - 1
b11e5981be Ed H*0455               ENDIF
                0456             ENDIF
                0457           ENDDO
ef84d10314 Ed H*0458           IF (bidim .GT. 0) THEN
                0459             s(bidim) = lbi
                0460             e(bidim) = lbi
                0461           ENDIF
                0462           IF (bjdim .GT. 0) THEN
                0463             s(bjdim) = lbj
                0464             e(bjdim) = lbj
                0465           ENDIF
b6432c788b Jean*0466 
cb356b4c5f Ed H*0467 C         Check the offsets
                0468           DO i = 1,9
                0469             IF (offsets(i) .GT. 0) THEN
                0470               udo(i) = udo(i) + offsets(i) - 1
                0471               s(i) = 1
                0472               e(i) = 1
                0473             ENDIF
                0474           ENDDO
ef84d10314 Ed H*0475 
21c48a3add Ed H*0476           IF (write_attributes) THEN
                0477 C           Add the per-variable attributes
                0478             DO i = 1,mnc_cw_vnat(1,indv)
b6432c788b Jean*0479               CALL MNC_VAR_ADD_ATTR_STR( fname, vtype,
21c48a3add Ed H*0480      &             mnc_cw_vtnm(i,indv), mnc_cw_vtat(i,indv), myThid)
                0481             ENDDO
                0482             DO i = 1,mnc_cw_vnat(2,indv)
b6432c788b Jean*0483               CALL MNC_VAR_ADD_ATTR_INT( fname, vtype,
21c48a3add Ed H*0484      &             mnc_cw_vinm(i,indv), 1, mnc_cw_viat(i,indv), myThid)
                0485             ENDDO
                0486             DO i = 1,mnc_cw_vnat(3,indv)
b6432c788b Jean*0487               CALL MNC_VAR_ADD_ATTR_DBL( fname, vtype,
21c48a3add Ed H*0488      &             mnc_cw_vdnm(i,indv), 1, mnc_cw_vdat(i,indv), myThid)
                0489             ENDDO
                0490           ENDIF
                0491 
                0492 C         Handle missing values
                0493           use_missing = .FALSE.
                0494           IF (mnc_cw_vfmv(indv) .EQ. 0) THEN
                0495             use_missing = .FALSE.
                0496           ELSE
                0497             IF (mnc_cw_vfmv(indv) .EQ. 1) THEN
                0498               use_missing = .TRUE.
                0499               dvm(1)  = mnc_def_dmv(1)
                0500               dvm(2)  = mnc_def_dmv(2)
                0501               rvm(1)  = mnc_def_rmv(1)
                0502               rvm(2)  = mnc_def_rmv(2)
                0503               ivm(1)  = mnc_def_imv(1)
                0504               ivm(2)  = mnc_def_imv(2)
                0505             ELSEIF (mnc_cw_vfmv(indv) .EQ. 2) THEN
                0506               use_missing = .TRUE.
                0507               dvm(1)  = mnc_cw_vmvd(1,indv)
                0508               dvm(2)  = mnc_cw_vmvd(2,indv)
                0509               rvm(1)  = mnc_cw_vmvr(1,indv)
                0510               rvm(2)  = mnc_cw_vmvr(2,indv)
                0511               ivm(1)  = mnc_cw_vmvi(1,indv)
                0512               ivm(2)  = mnc_cw_vmvi(2,indv)
                0513             ENDIF
                0514           ENDIF
                0515           IF (write_attributes .AND. use_missing) THEN
b6432c788b Jean*0516             write(msgbuf,'(4a)') 'writing attribute ''missing_value''',
21c48a3add Ed H*0517      &           ' within file ''', fname(1:nfname), ''''
                0518             IF (stype(1:1) .EQ. 'D') THEN
b6432c788b Jean*0519               err = NF_PUT_ATT_DOUBLE(fid, idv, 'missing_value',
21c48a3add Ed H*0520      &             NF_DOUBLE, 1, dvm(2))
                0521             ELSEIF (stype(1:1) .EQ. 'R') THEN
b6432c788b Jean*0522               err = NF_PUT_ATT_REAL(fid, idv, 'missing_value',
b6abfd6833 Mart*0523      &             NF_FLOAT, 1, rvm(2))
21c48a3add Ed H*0524             ELSEIF (stype(1:1) .EQ. 'I') THEN
b6432c788b Jean*0525               err = NF_PUT_ATT_INT(fid, idv, 'missing_value',
21c48a3add Ed H*0526      &             NF_INT, 1, ivm(2))
                0527             ENDIF
                0528             CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
b6432c788b Jean*0529 CMLC     it may be better to use the attribute _FillValue, or both
                0530 CML            write(msgbuf,'(4a)') 'writing attribute ''_FillValue''',
b6abfd6833 Mart*0531 CML     &           ' within file ''', fname(1:nfname), ''''
                0532 CML            IF (stype(1:1) .EQ. 'D') THEN
b6432c788b Jean*0533 CML              err = NF_PUT_ATT_DOUBLE(fid, idv, '_FillValue',
b6abfd6833 Mart*0534 CML     &             NF_DOUBLE, 1, dvm(2))
                0535 CML            ELSEIF (stype(1:1) .EQ. 'R') THEN
b6432c788b Jean*0536 CML              err = NF_PUT_ATT_REAL(fid, idv, '_FillValue',
b6abfd6833 Mart*0537 CML     &             NF_FLOAT, 1, rvm(2))
                0538 CML            ELSEIF (stype(1:1) .EQ. 'I') THEN
b6432c788b Jean*0539 CML              err = NF_PUT_ATT_INT(fid, idv, '_FillValue',
b6abfd6833 Mart*0540 CML     &             NF_INT, 1, ivm(2))
                0541 CML            ENDIF
                0542 CML            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
21c48a3add Ed H*0543           ENDIF
b11e5981be Ed H*0544 
3f2ea2a4ed Ed H*0545           CALL MNC_FILE_ENDDEF(fname, myThid)
b11e5981be Ed H*0546 
b6432c788b Jean*0547           write(msgbuf,'(5a)') 'writing variable type ''',
                0548      &         vtype(nvf:nvl), ''' within file ''',
efcf8593ff Ed H*0549      &         fname(1:nfname), ''''
                0550 
cb356b4c5f Ed H*0551 C         DO i = 1,9
b6432c788b Jean*0552 C         write(*,*) 'i,p(i),s(i),e(i),udo(i),offsets(i) = ',
cb356b4c5f Ed H*0553 C         &        i,p(i),s(i),e(i),udo(i),offsets(i)
                0554 C         ENDDO
                0555 
b11e5981be Ed H*0556 C         Write the variable one vector at a time
ef84d10314 Ed H*0557           DO j7 = s(7),e(7)
119438a015 Ed H*0558             k7 = (j7 - 1)*p(6)
ef84d10314 Ed H*0559             vstart(7) = udo(7) + j7 - s(7) + 1
                0560             vcount(7) = 1
                0561             DO j6 = s(6),e(6)
119438a015 Ed H*0562               k6 = (j6 - 1)*p(5) + k7
ef84d10314 Ed H*0563               vstart(6) = udo(6) + j6 - s(6) + 1
                0564               vcount(6) = 1
                0565               DO j5 = s(5),e(5)
119438a015 Ed H*0566                 k5 = (j5 - 1)*p(4) + k6
ef84d10314 Ed H*0567                 vstart(5) = udo(5) + j5 - s(5) + 1
                0568                 vcount(5) = 1
                0569                 DO j4 = s(4),e(4)
119438a015 Ed H*0570                   k4 = (j4 - 1)*p(3) + k5
ef84d10314 Ed H*0571                   vstart(4) = udo(4) + j4 - s(4) + 1
                0572                   vcount(4) = 1
                0573                   DO j3 = s(3),e(3)
119438a015 Ed H*0574                     k3 = (j3 - 1)*p(2) + k4
ef84d10314 Ed H*0575                     vstart(3) = udo(3) + j3 - s(3) + 1
                0576                     vcount(3) = 1
                0577                     DO j2 = s(2),e(2)
119438a015 Ed H*0578                       k2 = (j2 - 1)*p(1) + k3
ef84d10314 Ed H*0579                       vstart(2) = udo(2) + j2 - s(2) + 1
                0580                       vcount(2) = 1
                0581 
                0582       kr = 0
                0583       vstart(1) = udo(1) + 1
                0584       vcount(1) = e(1) - s(1) + 1
3623ff8097 Ed H*0585 
7ad6cc105a Ed H*0586       IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
                0587         write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
                0588      &       '--please increase to at least ',
5bc9611487 Ed H*0589      &       vcount(1), ' in ''MNC_BUFF.h'''
7ad6cc105a Ed H*0590         CALL PRINT_ERROR(msgBuf , 1)
                0591         STOP 'ABNORMAL END: S/R MNC_CW_RX_W_OFFSET'
                0592       ENDIF
                0593 
21c48a3add Ed H*0594       IF (use_missing) THEN
                0595 
                0596         IF (stype(1:1) .EQ. 'D') THEN
                0597           DO j1 = s(1),e(1)
                0598             k1 = k2 + j1
                0599             kr = kr + 1
                0600             dval = var(k1)
                0601             IF (dval .EQ. dvm(1)) THEN
                0602               resh_d(kr) = dvm(2)
                0603             ELSE
                0604               resh_d(kr) = dval
                0605             ENDIF
                0606           ENDDO
                0607           err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
                0608         ELSEIF (stype(1:1) .EQ. 'R') THEN
                0609           DO j1 = s(1),e(1)
                0610             k1 = k2 + j1
                0611             kr = kr + 1
                0612             rval = var(k1)
                0613             IF (rval .EQ. rvm(1)) THEN
                0614               resh_r(kr) = rvm(2)
                0615             ELSE
                0616               resh_r(kr) = rval
                0617             ENDIF
                0618           ENDDO
                0619           err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
                0620         ELSEIF (stype(1:1) .EQ. 'I') THEN
                0621           DO j1 = s(1),e(1)
                0622             k1 = k2 + j1
                0623             kr = kr + 1
                0624             ival = MNC2I( var(k1) )
                0625             IF (ival .EQ. ivm(1)) THEN
                0626               resh_i(kr) = ivm(2)
                0627             ELSE
                0628               resh_i(kr) = ival
                0629             ENDIF
                0630           ENDDO
                0631           err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
                0632         ENDIF
                0633 
                0634       ELSE
b6432c788b Jean*0635 
21c48a3add Ed H*0636         IF (stype(1:1) .EQ. 'D') THEN
                0637           DO j1 = s(1),e(1)
                0638             k1 = k2 + j1
                0639             kr = kr + 1
                0640             resh_d(kr) = var(k1)
                0641           ENDDO
                0642           err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
                0643         ELSEIF (stype(1:1) .EQ. 'R') THEN
                0644           DO j1 = s(1),e(1)
                0645             k1 = k2 + j1
                0646             kr = kr + 1
                0647             resh_r(kr) = var(k1)
                0648           ENDDO
                0649           err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
                0650         ELSEIF (stype(1:1) .EQ. 'I') THEN
                0651           DO j1 = s(1),e(1)
                0652             k1 = k2 + j1
                0653             kr = kr + 1
                0654             resh_i(kr) = MNC2I( var(k1) )
                0655           ENDDO
                0656           err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
                0657         ENDIF
3623ff8097 Ed H*0658 
21c48a3add Ed H*0659       ENDIF
3f2ea2a4ed Ed H*0660       CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
efcf8593ff Ed H*0661 
ef84d10314 Ed H*0662                     ENDDO
                0663                   ENDDO
b11e5981be Ed H*0664                 ENDDO
                0665               ENDDO
                0666             ENDDO
                0667           ENDDO
3623ff8097 Ed H*0668 
b11e5981be Ed H*0669 C         Sync the file
                0670           err = NF_SYNC(fid)
16a9213e57 Ed H*0671           nf = ILNBLNK( fname )
b6432c788b Jean*0672           write(msgbuf,'(3a)') 'sync for file ''', fname(1:nf),
3ca071fc35 Ed H*0673      &         ''' in S/R MNC_CW_RX_W'
3f2ea2a4ed Ed H*0674           CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
3623ff8097 Ed H*0675 
                0676         ENDDO
                0677       ENDDO
                0678 
                0679       _END_MASTER( myThid )
                0680 
                0681       RETURN
                0682       END
b6432c788b Jean*0683 
8ae258cf2c Ed H*0684 
                0685 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0686 CBOP 0
d65cc4075b Ed H*0687 C !ROUTINE: MNC_CW_RX_R_S
                0688 
                0689 C !INTERFACE:
b6432c788b Jean*0690       SUBROUTINE MNC_CW_RX_R_S(
                0691      I     stype,
                0692      I     fbname, bi,bj,
                0693      I     vtype,
                0694      I     var,
d65cc4075b Ed H*0695      I     myThid )
                0696 
                0697 C     !DESCRIPTION:
                0698 C     A scalar version of MNC_CW_RX_R() for compilers that cannot
                0699 C     gracefully handle the conversion on their own.
b6432c788b Jean*0700 
d65cc4075b Ed H*0701 C     !USES:
                0702       implicit none
                0703 
                0704 C     !INPUT PARAMETERS:
cb356b4c5f Ed H*0705       integer myThid, bi,bj
d65cc4075b Ed H*0706       character*(*) stype, fbname, vtype
                0707       __V var
                0708       __V var_arr(1)
                0709 CEOP
                0710       var_arr(1) = var
                0711 
                0712       CALL MNC_CW_RX_R(stype,fbname,bi,bj,vtype, var_arr, myThid)
                0713 
                0714       RETURN
                0715       END
                0716 
                0717 
                0718 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0719 CBOP 0
1b5fb69d21 Ed H*0720 C !ROUTINE: MNC_CW_RX_R
8ae258cf2c Ed H*0721 
1b5fb69d21 Ed H*0722 C !INTERFACE:
b6432c788b Jean*0723       SUBROUTINE MNC_CW_RX_R(
                0724      I     stype,
                0725      I     fbname, bi,bj,
                0726      I     vtype,
                0727      I     var,
3f2ea2a4ed Ed H*0728      I     myThid )
8ae258cf2c Ed H*0729 
b6432c788b Jean*0730 C     !DESCRIPTION:
c339ba9f47 Ed H*0731 C     A simple wrapper for the old version of this routine.  The new
                0732 C     version includes the isvar argument which, for backwards
                0733 C     compatibility, is set to false here.
b6432c788b Jean*0734 
c339ba9f47 Ed H*0735 C     !USES:
                0736       implicit none
                0737 
                0738 C     !INPUT PARAMETERS:
                0739       integer myThid, bi,bj
                0740       character*(*) stype, fbname, vtype
                0741       __V var(*)
                0742 CEOP
                0743 
                0744 C     !LOCAL VARIABLES:
                0745       LOGICAL isvar
                0746 
                0747       isvar = .FALSE.
                0748 
                0749       CALL MNC_CW_RX_R_TF(stype,fbname,bi,bj,vtype,var,isvar,myThid)
                0750 
                0751       RETURN
                0752       END
                0753 
                0754 
                0755 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0756 CBOP 0
                0757 C !ROUTINE: MNC_CW_RX_R
                0758 
                0759 C !INTERFACE:
b6432c788b Jean*0760       SUBROUTINE MNC_CW_RX_R_TF(
                0761      I     stype,
                0762      I     fbname, bi,bj,
                0763      I     vtype,
                0764      I     var,
                0765      B     isvar,
c339ba9f47 Ed H*0766      I     myThid )
                0767 
1b5fb69d21 Ed H*0768 C     !DESCRIPTION:
                0769 C     This subroutine reads one variable from a file or a file group,
c339ba9f47 Ed H*0770 C     depending upon the tile indicies.  If isvar is true and the
                0771 C     variable does not exist, then isvar is set to false and the
                0772 C     program continues normally.  This allows one to gracefully handle
                0773 C     the case of reading variables that might or might not exist.
b6432c788b Jean*0774 
1b5fb69d21 Ed H*0775 C     !USES:
e6bb5b2cc3 Ed H*0776       implicit none
8ae258cf2c Ed H*0777 #include "netcdf.inc"
07155994b8 Mart*0778 #include "MNC_COMMON.h"
8ae258cf2c Ed H*0779 #include "SIZE.h"
5bc9611487 Ed H*0780 #include "MNC_BUFF.h"
3e965d0c91 Ed H*0781 #include "EEPARAMS.h"
                0782 #include "PARAMS.h"
a30418b6b9 Ed H*0783 #include "MNC_PARAMS.h"
8ae258cf2c Ed H*0784 
1b5fb69d21 Ed H*0785 C     !INPUT PARAMETERS:
cb356b4c5f Ed H*0786       integer myThid, bi,bj
3ca071fc35 Ed H*0787       character*(*) stype, fbname, vtype
a906dd2a24 Ed H*0788       __V var(*)
c339ba9f47 Ed H*0789       LOGICAL isvar
e6bb5b2cc3 Ed H*0790 CEOP
8ae258cf2c Ed H*0791 
1b5fb69d21 Ed H*0792 C     !LOCAL VARIABLES:
cb356b4c5f Ed H*0793       integer i,k, nvf,nvl, n1,n2, igrid, ntot, indu
5bc9611487 Ed H*0794       integer bis,bie, bjs,bje, uniq_tnum,uniq_fnum, nfname, fid, idv
e40d346a32 Ed H*0795       integer ndim, err, lbi,lbj, bidim,bjdim, unlim_sz, kr
5bc9611487 Ed H*0796       integer ind_vt, npath, unlid, f_or_t, ixoff,iyoff
e40d346a32 Ed H*0797 C     integer f_sNx,f_sNy, alen, atype, ind_fv_ids, ierr, indf
a906dd2a24 Ed H*0798       integer p(9),s(9),e(9), vstart(9),vcount(9), udo(9)
                0799       integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
8ae258cf2c Ed H*0800       character*(MAX_LEN_MBUF) msgbuf
9705a0d5c6 Ed H*0801       character*(MNC_MAX_PATH) fname
                0802       character*(MNC_MAX_PATH) tmpnm
                0803       character*(MNC_MAX_PATH) path_fname
                0804       character*(MNC_MAX_PATH) bpath
0007eca320 Ed H*0805       integer indfg, fg1,fg2
7ad6cc105a Ed H*0806       REAL*8  resh_d( MNC_MAX_BUFF )
                0807       REAL*4  resh_r( MNC_MAX_BUFF )
                0808       INTEGER resh_i( MNC_MAX_BUFF )
b6432c788b Jean*0809 #ifdef MNC_READ_OLDNAMES
                0810       character*(MNC_MAX_PATH) fname_zs
                0811 #endif
e6bb5b2cc3 Ed H*0812 
1b5fb69d21 Ed H*0813 C     Functions
                0814       integer IFNBLNK, ILNBLNK
8ae258cf2c Ed H*0815 
                0816 C     Only do I/O if I am the master thread
                0817       _BEGIN_MASTER( myThid )
                0818 
9705a0d5c6 Ed H*0819       DO i = 1,MNC_MAX_PATH
                0820         bpath(i:i) = ' '
                0821       ENDDO
                0822 
0007eca320 Ed H*0823 C     Get the current index for the unlimited dimension from the file
                0824 C     group (or base) name
                0825       fg1 = IFNBLNK(fbname)
                0826       fg2 = ILNBLNK(fbname)
                0827       CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
                0828       IF (indfg .LT. 1) THEN
b6432c788b Jean*0829         write(msgbuf,'(3a)')
                0830      &       'MNC_CW_RX_W ERROR: file group name ''',
0007eca320 Ed H*0831      &       fbname(fg1:fg2), ''' is not defined'
                0832         CALL print_error(msgbuf, mythid)
3ca071fc35 Ed H*0833         STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
0007eca320 Ed H*0834       ENDIF
                0835       indu = mnc_cw_fgud(indfg)
                0836 
8ae258cf2c Ed H*0837 C     Check that the Variable Type exists
                0838       nvf = IFNBLNK(vtype)
                0839       nvl = ILNBLNK(vtype)
3f2ea2a4ed Ed H*0840       CALL MNC_GET_IND( MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt, myThid)
df6eaac306 Ed H*0841       IF (ind_vt .LT. 1) THEN
b6432c788b Jean*0842         write(msgbuf,'(3a)') 'MNC_CW_RX_R ERROR: vtype ''',
8ae258cf2c Ed H*0843      &       vtype(nvf:nvl), ''' is not defined'
                0844         CALL print_error(msgbuf, mythid)
3ca071fc35 Ed H*0845         STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
8ae258cf2c Ed H*0846       ENDIF
                0847       igrid = mnc_cw_vgind(ind_vt)
                0848 
                0849 C     Check for bi,bj indicies
a906dd2a24 Ed H*0850       bidim = mnc_cw_vbij(1,ind_vt)
                0851       bjdim = mnc_cw_vbij(2,ind_vt)
8ae258cf2c Ed H*0852 
                0853 C     Set the bi,bj indicies
                0854       bis = bi
                0855       bie = bi
                0856       IF (bi .LT. 1) THEN
                0857         bis = 1
                0858         bie = nSx
                0859       ENDIF
                0860       bjs = bj
                0861       bje = bj
                0862       IF (bj .LT. 1) THEN
                0863         bjs = 1
                0864         bje = nSy
                0865       ENDIF
                0866 
                0867       DO lbj = bjs,bje
                0868         DO lbi = bis,bie
                0869 
                0870 C         Create the file name
3f2ea2a4ed Ed H*0871           CALL MNC_CW_GET_TILE_NUM( lbi,lbj, uniq_tnum, myThid)
9705a0d5c6 Ed H*0872           fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
5bc9611487 Ed H*0873 
                0874 #ifdef MNC_READ_OLDNAMES
                0875 
8ae258cf2c Ed H*0876           n1 = IFNBLNK(fbname)
                0877           n2 = ILNBLNK(fbname)
                0878           ntot = n2 - n1 + 1
                0879           fname(1:ntot) = fbname(n1:n2)
                0880           ntot = ntot + 1
                0881           fname(ntot:ntot) = '.'
                0882           write(fname((ntot+1):(ntot+9)),'(i6.6,a3)') uniq_tnum, '.nc'
                0883           nfname = ntot+9
                0884 
3e965d0c91 Ed H*0885 C         Add the path to the file name
                0886           IF (mnc_use_indir) THEN
9705a0d5c6 Ed H*0887             path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
3e965d0c91 Ed H*0888             npath = ILNBLNK(mnc_indir_str)
                0889             path_fname(1:npath) = mnc_indir_str(1:npath)
                0890             path_fname((npath+1):(npath+nfname)) = fname(1:nfname)
9705a0d5c6 Ed H*0891             fname(1:MNC_MAX_PATH) = path_fname(1:MNC_MAX_PATH)
3e965d0c91 Ed H*0892             nfname = npath + nfname
                0893           ENDIF
                0894 
b6432c788b Jean*0895           WRITE(fname_zs,'(2a,i4.4,a1,i6.6,a3)')
                0896      &         mnc_indir_str(1:npath), fbname(n1:n2),
40843db068 Ed H*0897      &         0, '.', uniq_tnum, '.nc'
                0898 
                0899 C         The steps are:
                0900 C         (1) open the file in a READ-ONLY mode,
                0901 C         (2) get the var id for the current variable,
                0902 C         (3) read the data, and then
                0903 C         (4) close the file--theres no need to keep it open!
                0904 
b6432c788b Jean*0905           write(msgbuf,'(4a)') 'MNC_CW_RX_R: cannot open',
e40d346a32 Ed H*0906      &         ' file ''', fname(1:nfname), ''' in read-only mode'
                0907           err = NF_OPEN(fname, NF_NOWRITE, fid)
40843db068 Ed H*0908           IF ( err .NE. NF_NOERR ) THEN
                0909 C           If the initial open fails, try again using a name with a
                0910 C           zero sequence number inserted
                0911             err = NF_OPEN(fname_zs, NF_NOWRITE, fid)
                0912           ENDIF
e40d346a32 Ed H*0913           CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
                0914 
b6432c788b Jean*0915           write(msgbuf,'(5a)')
                0916      &         'MNC_CW_RX_R: cannot get id for variable ''',
e40d346a32 Ed H*0917      &         vtype(nvf:nvl), '''in file ''', fname(1:nfname), ''''
                0918           err = NF_INQ_VARID(fid, vtype, idv)
c339ba9f47 Ed H*0919           IF ( isvar .AND. ( err .NE. NF_NOERR ) ) THEN
                0920             isvar = .FALSE.
                0921             RETURN
                0922           ENDIF
                0923           isvar = .TRUE.
e40d346a32 Ed H*0924           CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
5bc9611487 Ed H*0925           f_or_t = 0
                0926 
                0927 #else
                0928 
                0929 C         The sequence for PER-FACE and PER-TILE is:
                0930 C         (1) check whether a PER-FACE file exists
                0931 C         .   (a) if only one face is used for the entire domain,
                0932 C         .       then omit the face index from the file name
                0933 C         .   (b) if the PER-FACE file exists and is somehow faulty,
                0934 C         .       then we die with an error message
                0935 C         (2) if no PER-FACE file exists, then use a PER-TILE file
                0936 
                0937 C         Create the PER-FACE file name
                0938           n1 = IFNBLNK(fbname)
                0939           n2 = ILNBLNK(fbname)
                0940 C         Add an iteraton count to the file name if its requested
                0941           IF (mnc_cw_cit(1,mnc_cw_fgci(indfg)) .LT. 0) THEN
                0942             WRITE(fname,'(a,a1)') fbname(n1:n2), '.'
                0943           ELSE
                0944             WRITE(fname,'(a,a1,i10.10,a1)') fbname(n1:n2), '.',
                0945      &            mnc_cw_cit(2,mnc_cw_fgci(indfg)), '.'
                0946           ENDIF
                0947           ntot = ILNBLNK(fname)
9705a0d5c6 Ed H*0948           path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
5bc9611487 Ed H*0949           npath = ILNBLNK(mnc_indir_str)
                0950 C         Add the face index
                0951           CALL MNC_CW_GET_FACE_NUM( lbi,lbj, uniq_fnum, myThid)
                0952           IF ( uniq_fnum .EQ. -1 ) THEN
                0953 C           There is only one face
b6432c788b Jean*0954             WRITE(path_fname,'(2a,a2)')
5bc9611487 Ed H*0955      &           mnc_indir_str(1:npath), fname(1:ntot), 'nc'
                0956           ELSE
                0957             CALL MNC_PSNCM(tmpnm, uniq_fnum, MNC_DEF_FMNC)
                0958             k = ILNBLNK(tmpnm)
b6432c788b Jean*0959             WRITE(path_fname,'(2a,a1,a,a3)')
5bc9611487 Ed H*0960      &           mnc_indir_str(1:npath), fname(1:ntot), 'f',
                0961      &           tmpnm(1:k), '.nc'
                0962           ENDIF
                0963 
                0964 C         Try to open the PER-FACE file
6d54906988 Ed H*0965 C         WRITE(*,*) 'trying: "', path_fname, '"'
5bc9611487 Ed H*0966           err = NF_OPEN(path_fname, NF_NOWRITE, fid)
                0967           IF ( err .EQ. NF_NOERR ) THEN
6d54906988 Ed H*0968             f_or_t = 1
5bc9611487 Ed H*0969           ELSE
                0970 
                0971 C           Create the PER-TILE file name
                0972             CALL MNC_PSNCM(tmpnm, uniq_tnum, MNC_DEF_TMNC)
                0973             k = ILNBLNK(tmpnm)
9705a0d5c6 Ed H*0974             path_fname(1:MNC_MAX_PATH) = bpath(1:MNC_MAX_PATH)
b6432c788b Jean*0975             WRITE(path_fname,'(2a,a1,a,a3)')
5bc9611487 Ed H*0976      &           mnc_indir_str(1:npath), fname(1:ntot), 't',
                0977      &           tmpnm(1:k), '.nc'
6d54906988 Ed H*0978 C           WRITE(*,*) 'trying: "', path_fname, '"'
5bc9611487 Ed H*0979             err = NF_OPEN(path_fname, NF_NOWRITE, fid)
                0980             IF ( err .EQ. NF_NOERR ) THEN
6d54906988 Ed H*0981               f_or_t = 0
5bc9611487 Ed H*0982             ELSE
                0983               k = ILNBLNK(path_fname)
b6432c788b Jean*0984               write(msgbuf,'(4a)')
5bc9611487 Ed H*0985      &             'MNC_CW_RX_R: cannot open either a per-face or a ',
                0986      &             'per-tile file: last try was ''', path_fname(1:k),
                0987      &             ''''
                0988               CALL print_error(msgbuf, mythid)
                0989               STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
                0990             ENDIF
                0991 
                0992           ENDIF
                0993 
                0994           ntot = ILNBLNK(path_fname)
b6432c788b Jean*0995           write(msgbuf,'(5a)')
5bc9611487 Ed H*0996      &         'MNC_CW_RX_R: cannot get netCDF id for variable ''',
                0997      &         vtype(nvf:nvl), ''' in file ''', path_fname(1:ntot),
                0998      &         ''''
                0999           err = NF_INQ_VARID(fid, vtype, idv)
c339ba9f47 Ed H*1000           IF ( isvar .AND. ( err .NE. NF_NOERR ) ) THEN
                1001             isvar = .FALSE.
                1002             RETURN
                1003           ENDIF
                1004           isvar = .TRUE.
5bc9611487 Ed H*1005           CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
                1006 
6d54906988 Ed H*1007           k = ILNBLNK(path_fname)
                1008           fname(1:k) = path_fname(1:k)
                1009           nfname = k
                1010 
5bc9611487 Ed H*1011 #endif
                1012 
                1013           IF ( f_or_t .EQ. 1 ) THEN
                1014 
b6432c788b Jean*1015 C           write(msgbuf,'(2a)')
6d54906988 Ed H*1016 C           &           'MNC_CW_RX_R: per-face reads are not yet ',
                1017 C           &           'implemented -- so pester Ed to finish them'
                1018 C           CALL print_error(msgbuf, mythid)
                1019 C           STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
b6432c788b Jean*1020 
5bc9611487 Ed H*1021 C           Get the X,Y PER-FACE offsets
                1022             CALL MNC_CW_GET_XYFO(lbi,lbj, ixoff,iyoff, myThid)
                1023 
                1024           ENDIF
a906dd2a24 Ed H*1025 
6d54906988 Ed H*1026 C         WRITE(*,*) 'f_or_t = ',f_or_t
                1027 
a906dd2a24 Ed H*1028 C         Check that the current sNy,sNy values and the in-file values
                1029 C         are compatible and WARN (only warn) if not
e40d346a32 Ed H*1030 C           f_sNx = -1
                1031 C           f_sNy = -1
                1032 C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)
                1033 C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
                1034 C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
b6432c788b Jean*1035 C             CALL MNC_HANDLE_ERR(err,
                1036 C      &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R',
e40d346a32 Ed H*1037 C      &           myThid)
                1038 C           ENDIF
                1039 C           err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
                1040 C           IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
                1041 C             err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
b6432c788b Jean*1042 C             CALL MNC_HANDLE_ERR(err,
e40d346a32 Ed H*1043 C      &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R',
                1044 C      &           myThid)
                1045 C           ENDIF
                1046 C           IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
                1047 C             write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',
b6432c788b Jean*1048 C      &           'attributes ''sNx'' and ''sNy'' within the file ''',
e40d346a32 Ed H*1049 C      &           fname(1:nfname), ''' do not exist or do not match ',
                1050 C      &           'the current sizes within the model'
                1051 C             CALL print_error(msgbuf, mythid)
                1052 C           ENDIF
8ae258cf2c Ed H*1053 
a906dd2a24 Ed H*1054 C         Check that the in-memory variable and the in-file variables
                1055 C         are of compatible sizes
efcf8593ff Ed H*1056 C           ires = 1
b6432c788b Jean*1057 C           CALL MNC_CHK_VTYP_R_NCVAR( ind_vt,
efcf8593ff Ed H*1058 C      &         indf, ind_fv_ids, indu, ires)
                1059 C           IF (ires .LT. 0) THEN
3ca071fc35 Ed H*1060 C             write(msgbuf,'(7a)') 'MNC_CW_RX_R WARNING: the sizes ',
b6432c788b Jean*1061 C      &           'of the in-program variable ''', vtype(nvf:nvl),
efcf8593ff Ed H*1062 C      &           ''' and the corresponding variable within file ''',
                1063 C      &           fname(1:nfname), ''' are not compatible -- please ',
                1064 C      &           'check the sizes'
                1065 C             CALL print_error(msgbuf, mythid)
3ca071fc35 Ed H*1066 C             STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
efcf8593ff Ed H*1067 C           ENDIF
8ae258cf2c Ed H*1068 
a906dd2a24 Ed H*1069 C         Check for bi,bj indicies
                1070           bidim = mnc_cw_vbij(1,ind_vt)
                1071           bjdim = mnc_cw_vbij(2,ind_vt)
                1072 
                1073 C         Set the dimensions for the in-memory array
                1074           ndim = mnc_cw_ndim(igrid)
                1075           k = mnc_cw_dims(1,igrid)
                1076           IF (k .GT. 0) THEN
                1077             p(1) = k
                1078           ELSE
                1079             p(1) = 1
                1080           ENDIF
                1081           DO i = 2,9
                1082             k = mnc_cw_dims(i,igrid)
                1083             IF (k .LT. 1) THEN
                1084               k = 1
                1085             ENDIF
                1086             IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
                1087               p(i) = nSx * p(i-1)
                1088             ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
                1089               p(i) = nSy * p(i-1)
                1090             ELSE
                1091               p(i) = k * p(i-1)
                1092             ENDIF
                1093           ENDDO
                1094 
                1095 C         Set starting and ending indicies for the in-memory array and
                1096 C         the unlimited dimension offset for the NetCDF array
                1097           DO i = 1,9
                1098             udo(i) = 0
                1099             s(i) = 1
                1100             e(i) = 1
                1101             IF (i .LE. ndim) THEN
                1102               s(i) = mnc_cw_is(i,igrid)
                1103               e(i) = mnc_cw_ie(i,igrid)
5bc9611487 Ed H*1104 
                1105               IF ( f_or_t .EQ. 1 ) THEN
                1106 C               Add the per-face X,Y offsets to the udo offset vector
                1107 C               since they accomplish the same thing
                1108                 IF ( mnc_cw_dn(i,igrid)(1:1) .EQ. 'X' ) THEN
                1109                   udo(i) = ixoff - 1
                1110                 ELSEIF ( mnc_cw_dn(i,igrid)(1:1) .EQ. 'Y' ) THEN
                1111                   udo(i) = iyoff - 1
                1112                 ENDIF
                1113               ENDIF
                1114 
a906dd2a24 Ed H*1115             ENDIF
                1116 C           Check for the unlimited dimension
b6432c788b Jean*1117             IF ((i .EQ. ndim)
a906dd2a24 Ed H*1118      &           .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
                1119               IF (indu .GT. 0) THEN
                1120 C               Use the indu value
                1121                 udo(i) = indu - 1
                1122               ELSE
e40d346a32 Ed H*1123 C               We need the current unlim dim size
                1124                 write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
b6432c788b Jean*1125      &               'unlim dim id within file ''',
e40d346a32 Ed H*1126      &               fname(1:nfname), ''''
                1127                 err = NF_INQ_UNLIMDIM(fid, unlid)
                1128                 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
                1129                 write(msgbuf,'(5a)') 'MNC_CW_RX_R: getting the ',
b6432c788b Jean*1130      &               'unlim dim size within file ''',
e40d346a32 Ed H*1131      &               fname(1:nfname), ''''
                1132                 err = NF_INQ_DIMLEN(fid, unlid, unlim_sz)
                1133                 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
                1134                 udo(i) = unlim_sz
a906dd2a24 Ed H*1135               ENDIF
                1136             ENDIF
                1137           ENDDO
                1138           IF (bidim .GT. 0) THEN
                1139             s(bidim) = lbi
                1140             e(bidim) = lbi
                1141           ENDIF
                1142           IF (bjdim .GT. 0) THEN
                1143             s(bjdim) = lbj
                1144             e(bjdim) = lbj
                1145           ENDIF
                1146 
efcf8593ff Ed H*1147 C     DO i = 9,1,-1
                1148 C     write(*,*) 'i,p(i),s(i),e(i) = ', i,': ',p(i),s(i),e(i)
                1149 C     ENDDO
b6432c788b Jean*1150 
                1151           write(msgbuf,'(5a)') 'reading variable type ''',
                1152      &         vtype(nvf:nvl), ''' within file ''',
a906dd2a24 Ed H*1153      &         fname(1:nfname), ''''
                1154 
                1155 C         Read the variable one vector at a time
                1156           DO j7 = s(7),e(7)
                1157             k7 = (j7 - 1)*p(6)
                1158             vstart(7) = udo(7) + j7 - s(7) + 1
                1159             vcount(7) = 1
                1160             DO j6 = s(6),e(6)
                1161               k6 = (j6 - 1)*p(5) + k7
                1162               vstart(6) = udo(6) + j6 - s(6) + 1
                1163               vcount(6) = 1
                1164               DO j5 = s(5),e(5)
                1165                 k5 = (j5 - 1)*p(4) + k6
                1166                 vstart(5) = udo(5) + j5 - s(5) + 1
                1167                 vcount(5) = 1
                1168                 DO j4 = s(4),e(4)
                1169                   k4 = (j4 - 1)*p(3) + k5
                1170                   vstart(4) = udo(4) + j4 - s(4) + 1
                1171                   vcount(4) = 1
                1172                   DO j3 = s(3),e(3)
                1173                     k3 = (j3 - 1)*p(2) + k4
                1174                     vstart(3) = udo(3) + j3 - s(3) + 1
                1175                     vcount(3) = 1
                1176                     DO j2 = s(2),e(2)
                1177                       k2 = (j2 - 1)*p(1) + k3
                1178                       vstart(2) = udo(2) + j2 - s(2) + 1
                1179                       vcount(2) = 1
                1180 
3ca071fc35 Ed H*1181       kr = 0
a906dd2a24 Ed H*1182       vstart(1) = udo(1) + 1
                1183       vcount(1) = e(1) - s(1) + 1
7ad6cc105a Ed H*1184 
                1185       IF (vcount(1) .GT. MNC_MAX_BUFF) THEN
                1186         write(msgbuf,'(2a,I7,a)') 'MNC_MAX_BUFF is too small',
                1187      &       '--please increase to at least ',
5bc9611487 Ed H*1188      &       vcount(1), ' in ''MNC_BUFF.h'''
7ad6cc105a Ed H*1189         CALL PRINT_ERROR(msgBuf , 1)
                1190         STOP 'ABNORMAL END: S/R MNC_CW_RX_R_OFFSET'
                1191       ENDIF
                1192 
3ca071fc35 Ed H*1193       IF (stype(1:1) .EQ. 'D') THEN
                1194         err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
                1195         CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
                1196         DO j1 = s(1),e(1)
                1197           k1 = k2 + j1
                1198           kr = kr + 1
409155d7b6 Ed H*1199           var(k1) = MNCI2( resh_d(kr) )
3ca071fc35 Ed H*1200         ENDDO
                1201       ENDIF
                1202       IF (stype(1:1) .EQ. 'R') THEN
                1203         err = NF_GET_VARA_REAL(fid, idv, vstart, vcount, resh_r)
                1204         CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
                1205         DO j1 = s(1),e(1)
                1206           k1 = k2 + j1
                1207           kr = kr + 1
409155d7b6 Ed H*1208           var(k1) = MNCI2( resh_r(kr) )
3ca071fc35 Ed H*1209         ENDDO
                1210       ENDIF
                1211       IF (stype(1:1) .EQ. 'I') THEN
                1212         err = NF_GET_VARA_INT(fid, idv, vstart, vcount, resh_i)
                1213         CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
                1214         DO j1 = s(1),e(1)
                1215           k1 = k2 + j1
                1216           kr = kr + 1
                1217           var(k1) = resh_i(kr)
                1218         ENDDO
                1219       ENDIF
a906dd2a24 Ed H*1220 
b6432c788b Jean*1221 
a906dd2a24 Ed H*1222                     ENDDO
                1223                   ENDDO
                1224                 ENDDO
                1225               ENDDO
                1226             ENDDO
                1227           ENDDO
8ae258cf2c Ed H*1228 
efcf8593ff Ed H*1229 C         Close the file
e40d346a32 Ed H*1230 C         CALL MNC_FILE_CLOSE(fname, myThid)
                1231           err = NF_CLOSE(fid)
b6432c788b Jean*1232           write(msgbuf,'(3a)') 'MNC_CW_RX_R:  cannot close file ''',
e40d346a32 Ed H*1233      &         fname(1:nfname), ''''
                1234           CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
                1235 
efcf8593ff Ed H*1236 
a906dd2a24 Ed H*1237 C         End the lbj,lbi loops
8ae258cf2c Ed H*1238         ENDDO
                1239       ENDDO
                1240 
                1241       _END_MASTER( myThid )
                1242 
                1243       RETURN
                1244       END
3623ff8097 Ed H*1245 
                1246 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                1247 
                1248 CEH3 ;;; Local Variables: ***
                1249 CEH3 ;;; mode:fortran ***
                1250 CEH3 ;;; End: ***