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: ***
