pkg/mnc/mnc_var.F

4de8f8c098 Ed H*0001 #include "MNC_OPTIONS.h"
beebb2eade Jean*0002
                0003 C--  File mnc_var.F: Handle NetCDF variables (definition,description & writing)
                0004 C--   Contents
                0005 C--   o MNC_VAR_INIT_DBL
                0006 C--   o MNC_VAR_INIT_REAL
                0007 C--   o MNC_VAR_INIT_INT
                0008 C--   o MNC_VAR_INIT_ANY
                0009 C--   o MNC_VAR_ADD_ATTR_STR
                0010 C--   o MNC_VAR_ADD_ATTR_DBL
                0011 C--   o MNC_VAR_ADD_ATTR_REAL
                0012 C--   o MNC_VAR_ADD_ATTR_INT
                0013 C--   o MNC_VAR_ADD_ATTR_ANY
                0014 C--   o MNC_VAR_WRITE_DBL
                0015 C--   o MNC_VAR_WRITE_REAL
                0016 C--   o MNC_VAR_WRITE_INT
                0017 C--   o MNC_VAR_APPEND_DBL
                0018 C--   o MNC_VAR_APPEND_REAL
                0019 C--   o MNC_VAR_APPEND_INT
                0020 C--   o MNC_VAR_WRITE_ANY
                0021
e9b72f2bd9 Ed H*0022 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0023 CBOP 1
1b5fb69d21 Ed H*0024 C     !ROUTINE: MNC_VAR_INIT_DBL
4de8f8c098 Ed H*0025
1b5fb69d21 Ed H*0026 C     !INTERFACE:
beebb2eade Jean*0027       SUBROUTINE MNC_VAR_INIT_DBL(
                0028      I     fname,
                0029      I     gname,
                0030      I     vname,
21c48a3add Ed H*0031      I     irv,
3f2ea2a4ed Ed H*0032      I     myThid )
a7ffe10af7 Ed H*0033
1b5fb69d21 Ed H*0034 C     !DESCRIPTION:
beebb2eade Jean*0035 C     Create a double-precision real variable within a NetCDF file context.
                0036
1b5fb69d21 Ed H*0037 C     !USES:
beebb2eade Jean*0038       IMPLICIT NONE
a7ffe10af7 Ed H*0039 #include "netcdf.inc"
                0040
1b5fb69d21 Ed H*0041 C     !INPUT PARAMETERS:
beebb2eade Jean*0042       CHARACTER*(*) fname,gname,vname
                0043       INTEGER irv,myThid
1b5fb69d21 Ed H*0044 CEOP
a7ffe10af7 Ed H*0045
beebb2eade Jean*0046       CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_DOUBLE, irv,myThid )
                0047
a7ffe10af7 Ed H*0048       RETURN
                0049       END
                0050
e9b72f2bd9 Ed H*0051 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0052 CBOP 1
1b5fb69d21 Ed H*0053 C     !ROUTINE: MNC_VAR_INIT_REAL
a7ffe10af7 Ed H*0054
1b5fb69d21 Ed H*0055 C     !INTERFACE:
beebb2eade Jean*0056       SUBROUTINE MNC_VAR_INIT_REAL(
                0057      I     fname,
                0058      I     gname,
                0059      I     vname,
21c48a3add Ed H*0060      I     irv,
3f2ea2a4ed Ed H*0061      I     myThid )
a7ffe10af7 Ed H*0062
1b5fb69d21 Ed H*0063 C     !DESCRIPTION:
beebb2eade Jean*0064 C     Create a single-precision real variable within a NetCDF file context.
                0065
1b5fb69d21 Ed H*0066 C     !USES:
beebb2eade Jean*0067       IMPLICIT NONE
a7ffe10af7 Ed H*0068 #include "netcdf.inc"
                0069
1b5fb69d21 Ed H*0070 C     !INPUT PARAMETERS:
beebb2eade Jean*0071       CHARACTER*(*) fname,gname,vname
                0072       INTEGER irv,myThid
1b5fb69d21 Ed H*0073 CEOP
a7ffe10af7 Ed H*0074
beebb2eade Jean*0075       CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_FLOAT, irv,myThid )
                0076
a7ffe10af7 Ed H*0077       RETURN
                0078       END
                0079
e9b72f2bd9 Ed H*0080 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0081 CBOP 1
1b5fb69d21 Ed H*0082 C     !ROUTINE: MNC_VAR_INIT_INT
a7ffe10af7 Ed H*0083
1b5fb69d21 Ed H*0084 C     !INTERFACE:
beebb2eade Jean*0085       SUBROUTINE MNC_VAR_INIT_INT(
                0086      I     fname,
                0087      I     gname,
                0088      I     vname,
21c48a3add Ed H*0089      I     irv,
3f2ea2a4ed Ed H*0090      I     myThid )
a7ffe10af7 Ed H*0091
1b5fb69d21 Ed H*0092 C     !DESCRIPTION:
                0093 C     Create an integer variable within a NetCDF file context.
beebb2eade Jean*0094
1b5fb69d21 Ed H*0095 C     !USES:
beebb2eade Jean*0096       IMPLICIT NONE
a7ffe10af7 Ed H*0097 #include "netcdf.inc"
                0098
1b5fb69d21 Ed H*0099 C     !INPUT PARAMETERS:
beebb2eade Jean*0100       CHARACTER*(*) fname,gname,vname
                0101       INTEGER irv,myThid
1b5fb69d21 Ed H*0102 CEOP
a7ffe10af7 Ed H*0103
beebb2eade Jean*0104       CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_INT, irv,myThid )
                0105
a7ffe10af7 Ed H*0106       RETURN
                0107       END
                0108
e9b72f2bd9 Ed H*0109 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0110 CBOP 1
1b5fb69d21 Ed H*0111 C     !ROUTINE: MNC_VAR_INIT_ANY
a7ffe10af7 Ed H*0112
1b5fb69d21 Ed H*0113 C     !INTERFACE:
beebb2eade Jean*0114       SUBROUTINE MNC_VAR_INIT_ANY(
                0115      I     fname,
                0116      I     gname,
                0117      I     vname,
                0118      I     vtype,
21c48a3add Ed H*0119      I     irv,
3f2ea2a4ed Ed H*0120      I     myThid )
4de8f8c098 Ed H*0121
1b5fb69d21 Ed H*0122 C     !DESCRIPTION:
beebb2eade Jean*0123 C     General function for creating variables within a NetCDF file context.
                0124
1b5fb69d21 Ed H*0125 C     !USES:
beebb2eade Jean*0126       IMPLICIT NONE
07155994b8 Mart*0127 #include "MNC_COMMON.h"
4de8f8c098 Ed H*0128 #include "EEPARAMS.h"
853ee6565e Jean*0129 #include "netcdf.inc"
4de8f8c098 Ed H*0130
1b5fb69d21 Ed H*0131 C     !INPUT PARAMETERS:
beebb2eade Jean*0132       CHARACTER*(*) fname,gname,vname
                0133       INTEGER vtype
                0134       INTEGER irv,myThid
e6bb5b2cc3 Ed H*0135 CEOP
4de8f8c098 Ed H*0136
1b5fb69d21 Ed H*0137 C     Functions
beebb2eade Jean*0138       INTEGER  ILNBLNK
                0139       EXTERNAL ILNBLNK
                0140
                0141 C     !LOCAL VARIABLES:
                0142       INTEGER i,j,k, n, nf, indf,indv, fid, nd, ngrid, is,ie, err
                0143       INTEGER vid, nv, ind_g_finfo, needed, nvar
                0144       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0145       INTEGER ids(20)
                0146       INTEGER lenf,leng,lenv
4de8f8c098 Ed H*0147
907e360dab Ed H*0148 C     Strip trailing spaces
                0149       lenf = ILNBLNK(fname)
                0150       leng = ILNBLNK(gname)
                0151       lenv = ILNBLNK(vname)
                0152
                0153 C     Check that the file is open
ef92f00980 Ed H*0154       CALL MNC_GET_IND(MNC_MAX_FID, fname, mnc_f_names, indf, myThid)
907e360dab Ed H*0155       IF (indf .LT. 1) THEN
16a9213e57 Ed H*0156         nf = ILNBLNK( fname )
beebb2eade Jean*0157         WRITE(msgBuf,'(3A)') 'MNC ERROR: file ''', fname(1:nf),
907e360dab Ed H*0158      &       ''' must be opened first'
beebb2eade Jean*0159         CALL print_error(msgBuf, myThid)
                0160         STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
907e360dab Ed H*0161       ENDIF
                0162       fid = mnc_f_info(indf,2)
                0163
dad4143247 Ed H*0164 C     Check for sufficient storage space in mnc_fv_ids
                0165       needed = 1 + 3*(mnc_fv_ids(indf,1) + 1)
                0166       IF (needed .GE. MNC_MAX_INFO) THEN
beebb2eade Jean*0167         WRITE(msgBuf,'(2A,I7,A)') 'MNC ERROR: MNC_MAX_INFO exceeded',
                0168      &       ': please increase it to ', 2*MNC_MAX_INFO,
99056ab1c6 Oliv*0169      &       ' in the file ''pkg/mnc/MNC_SIZE.h'''
beebb2eade Jean*0170         CALL print_error(msgBuf, myThid)
                0171         STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
dad4143247 Ed H*0172       ENDIF
                0173
907e360dab Ed H*0174 C     Get the grid information
                0175       ngrid = mnc_f_info(indf,3)
                0176       IF (ngrid .LT. 1) THEN
beebb2eade Jean*0177         WRITE(msgBuf,'(3A)') 'MNC ERROR: file ''', fname(1:lenf),
907e360dab Ed H*0178      &       ''' contains NO grids'
beebb2eade Jean*0179         CALL print_error(msgBuf, myThid)
                0180         STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
907e360dab Ed H*0181       ENDIF
                0182       DO i = 1,ngrid
                0183         j = 4 + (i-1)*3
                0184         k = mnc_f_info(indf,j)
                0185         n = ILNBLNK(mnc_g_names(k))
beebb2eade Jean*0186         IF ((leng .EQ. n)
907e360dab Ed H*0187      &       .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
376f4203f6 Ed H*0188           ind_g_finfo = j
907e360dab Ed H*0189           is = mnc_f_info(indf,(j+1))
                0190           ie = mnc_f_info(indf,(j+2))
                0191           nd = 0
                0192           DO k = is,ie
                0193             nd = nd + 1
75987013ac Ed H*0194             ids(nd) = mnc_d_ids(mnc_fd_ind(indf,k))
907e360dab Ed H*0195           ENDDO
                0196           GOTO 10
                0197         ENDIF
                0198       ENDDO
beebb2eade Jean*0199       WRITE(msgBuf,'(5A)') 'MNC ERROR: file ''', fname(1:lenf),
907e360dab Ed H*0200      &     ''' does not contain grid ''', gname(1:leng), ''''
beebb2eade Jean*0201       CALL print_error(msgBuf, myThid)
                0202       STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
907e360dab Ed H*0203  10   CONTINUE
                0204
b11e5981be Ed H*0205 C     Check if the variable is already defined
                0206       nvar = mnc_fv_ids(indf,1)
                0207       DO i = 1,nvar
                0208         j = 2 + 3*(i-1)
                0209         IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vname) THEN
                0210           k = mnc_f_info(indf,mnc_fv_ids(indf,j+2))
                0211           IF (mnc_g_names(k) .NE. gname) THEN
beebb2eade Jean*0212             WRITE(msgBuf,'(5A)') 'MNC ERROR: variable ''',
                0213      &           vname(1:lenv), ''' is already defined in file ''',
b11e5981be Ed H*0214      &           fname(1:lenf), ''' but using a different grid shape'
beebb2eade Jean*0215             CALL print_error(msgBuf, myThid)
                0216             STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
b11e5981be Ed H*0217           ELSE
                0218 C           Its OK, the variable and grid names are the same
21c48a3add Ed H*0219             irv = 0
b11e5981be Ed H*0220             RETURN
                0221           ENDIF
                0222         ENDIF
                0223       ENDDO
                0224
21c48a3add Ed H*0225       irv = 1
                0226
907e360dab Ed H*0227 C     Add the variable definition
3f2ea2a4ed Ed H*0228       CALL MNC_FILE_REDEF(fname, myThid)
a7ffe10af7 Ed H*0229       err = NF_DEF_VAR(fid, vname, vtype, nd, ids, vid)
0ae5aeaaaa Ed H*0230       IF ( err .NE. NF_NOERR ) THEN
beebb2eade Jean*0231         WRITE(msgBuf,'(2A)') 'ERROR:  MNC will not ',
0ae5aeaaaa Ed H*0232      &       'overwrite variables in existing NetCDF'
                0233         CALL PRINT_ERROR( msgBuf, myThid )
beebb2eade Jean*0234         WRITE(msgBuf,'(2A)') '        files.  Please',
0ae5aeaaaa Ed H*0235      &       ' make sure that you are not trying to'
                0236         CALL PRINT_ERROR( msgBuf, myThid )
beebb2eade Jean*0237         WRITE(msgBuf,'(2A)') '        overwrite output',
0ae5aeaaaa Ed H*0238      &       'files from a previous model run!'
                0239         CALL PRINT_ERROR( msgBuf, myThid )
beebb2eade Jean*0240         WRITE(msgBuf,'(5A)') 'defining variable ''', vname(1:lenv),
907e360dab Ed H*0241      &     ''' in file ''', fname(1:lenf), ''''
beebb2eade Jean*0242         CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
0ae5aeaaaa Ed H*0243       ENDIF
907e360dab Ed H*0244
                0245 C     Success, so save the variable info
9705a0d5c6 Ed H*0246       CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID,mnc_v_names,'mnc_v_names',
                0247      &     indv, myThid)
907e360dab Ed H*0248       mnc_v_names(indv)(1:lenv) = vname(1:lenv)
                0249       nv = mnc_fv_ids(indf,1)
a7ffe10af7 Ed H*0250       i = 2 + nv*3
75987013ac Ed H*0251       mnc_fv_ids(indf,i)   = indv
                0252       mnc_fv_ids(indf,i+1) = vid
                0253       mnc_fv_ids(indf,i+2) = ind_g_finfo
907e360dab Ed H*0254       mnc_fv_ids(indf,1) = nv + 1
                0255
                0256       RETURN
                0257       END
                0258
e9b72f2bd9 Ed H*0259 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0260 CBOP 1
1b5fb69d21 Ed H*0261 C     !ROUTINE: MNC_VAR_ADD_ATTR_STR
907e360dab Ed H*0262
1b5fb69d21 Ed H*0263 C     !INTERFACE:
beebb2eade Jean*0264       SUBROUTINE MNC_VAR_ADD_ATTR_STR(
                0265      I     fname,
                0266      I     vname,
                0267      I     atname,
                0268      I     sval,
3f2ea2a4ed Ed H*0269      I     myThid )
907e360dab Ed H*0270
1b5fb69d21 Ed H*0271 C     !DESCRIPTION:
beebb2eade Jean*0272 C     Subroutine for adding a character string attribute to a NetCDF file.
                0273
1b5fb69d21 Ed H*0274 C     !USES:
beebb2eade Jean*0275       IMPLICIT NONE
1b5fb69d21 Ed H*0276
                0277 C     !INPUT PARAMETERS:
beebb2eade Jean*0278       CHARACTER*(*) fname,vname,atname,sval
                0279       INTEGER myThid
1b5fb69d21 Ed H*0280 CEOP
169a7aa8bd Jean*0281       real*8 dZero(1)
                0282       real*4 sZero(1)
beebb2eade Jean*0283       INTEGER iZero(1)
169a7aa8bd Jean*0284       dZero(1) = 0.0D0
                0285       sZero(1) = 0.0
                0286       iZero(1) = 0
a7ffe10af7 Ed H*0287
beebb2eade Jean*0288       CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
                0289      &     1, sval, 0, dZero, sZero, iZero, myThid )
                0290
a7ffe10af7 Ed H*0291       RETURN
                0292       END
e9b72f2bd9 Ed H*0293 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0294 CBOP 1
1b5fb69d21 Ed H*0295 C     !ROUTINE: MNC_VAR_ADD_ATTR_DBL
a7ffe10af7 Ed H*0296
1b5fb69d21 Ed H*0297 C     !INTERFACE:
beebb2eade Jean*0298       SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
                0299      I     fname,
                0300      I     vname,
                0301      I     atname,
                0302      I     nv,
                0303      I     dval,
3f2ea2a4ed Ed H*0304      I     myThid )
a7ffe10af7 Ed H*0305
1b5fb69d21 Ed H*0306 C     !DESCRIPTION:
beebb2eade Jean*0307 C     Subroutine for adding a double-precision real attribute to a NetCDF file.
                0308
1b5fb69d21 Ed H*0309 C     !USES:
beebb2eade Jean*0310       IMPLICIT NONE
1b5fb69d21 Ed H*0311
                0312 C     !INPUT PARAMETERS:
beebb2eade Jean*0313       CHARACTER*(*) fname,vname,atname
                0314       INTEGER nv
                0315       Real*8 dval(*)
                0316       INTEGER myThid
1b5fb69d21 Ed H*0317 CEOP
169a7aa8bd Jean*0318       real*4 sZero(1)
beebb2eade Jean*0319       INTEGER iZero(1)
169a7aa8bd Jean*0320       sZero(1) = 0.0
                0321       iZero(1) = 0
a7ffe10af7 Ed H*0322
beebb2eade Jean*0323       CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
                0324      &     2, ' ', nv, dval, sZero, iZero, myThid )
                0325
a7ffe10af7 Ed H*0326       RETURN
                0327       END
                0328
e9b72f2bd9 Ed H*0329 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0330 CBOP 1
5eef09f930 Ed H*0331 C     !ROUTINE: MNC_VAR_ADD_ATTR_REAL
a7ffe10af7 Ed H*0332
1b5fb69d21 Ed H*0333 C     !INTERFACE:
beebb2eade Jean*0334       SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
                0335      I     fname,
                0336      I     vname,
                0337      I     atname,
                0338      I     nv,
                0339      I     rval,
3f2ea2a4ed Ed H*0340      I     myThid )
a7ffe10af7 Ed H*0341
1b5fb69d21 Ed H*0342 C     !DESCRIPTION:
beebb2eade Jean*0343 C     Subroutine for adding a single-precision real attribute to a NetCDF file.
                0344
1b5fb69d21 Ed H*0345 C     !USES:
beebb2eade Jean*0346       IMPLICIT NONE
1b5fb69d21 Ed H*0347
                0348 C     !INPUT PARAMETERS:
beebb2eade Jean*0349       CHARACTER*(*) fname,vname,atname
                0350       INTEGER nv
                0351       Real*4 rval(*)
                0352       INTEGER myThid
1b5fb69d21 Ed H*0353 CEOP
169a7aa8bd Jean*0354       real*8 dZero(1)
beebb2eade Jean*0355       INTEGER iZero(1)
169a7aa8bd Jean*0356       dZero(1) = 0.0D0
                0357       iZero(1) = 0
a7ffe10af7 Ed H*0358
beebb2eade Jean*0359       CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
                0360      &     3, ' ', nv, dZero, rval, iZero, myThid )
a7ffe10af7 Ed H*0361       RETURN
                0362       END
                0363
e9b72f2bd9 Ed H*0364 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0365 CBOP 1
1b5fb69d21 Ed H*0366 C     !ROUTINE: MNC_VAR_ADD_ATTR_INT
a7ffe10af7 Ed H*0367
1b5fb69d21 Ed H*0368 C     !INTERFACE:
beebb2eade Jean*0369       SUBROUTINE MNC_VAR_ADD_ATTR_INT(
                0370      I     fname,
                0371      I     vname,
                0372      I     atname,
                0373      I     nv,
                0374      I     ival,
3f2ea2a4ed Ed H*0375      I     myThid )
a7ffe10af7 Ed H*0376
1b5fb69d21 Ed H*0377 C     !DESCRIPTION:
beebb2eade Jean*0378 C     Subroutine for adding an integer attribute to a NetCDF file.
                0379
1b5fb69d21 Ed H*0380 C     !USES:
beebb2eade Jean*0381       IMPLICIT NONE
1b5fb69d21 Ed H*0382
                0383 C     !INPUT PARAMETERS:
beebb2eade Jean*0384       CHARACTER*(*) fname,vname,atname
                0385       INTEGER nv
                0386       INTEGER ival(*)
                0387       INTEGER myThid
1b5fb69d21 Ed H*0388 CEOP
169a7aa8bd Jean*0389       real*8 dZero(1)
                0390       real*4 sZero(1)
                0391       dZero(1) = 0.0D0
                0392       sZero(1) = 0.0
a7ffe10af7 Ed H*0393
beebb2eade Jean*0394       CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
                0395      &     4, ' ', nv, dZero, sZero, ival, myThid )
                0396
a7ffe10af7 Ed H*0397       RETURN
                0398       END
                0399
e9b72f2bd9 Ed H*0400 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0401 CBOP 1
1b5fb69d21 Ed H*0402 C     !ROUTINE: MNC_VAR_ADD_ATTR_ANY
a7ffe10af7 Ed H*0403
1b5fb69d21 Ed H*0404 C     !INTERFACE:
beebb2eade Jean*0405       SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
                0406      I     fname,
                0407      I     vname,
                0408      I     atname,
                0409      I     atype, cs,len,dv,rv,iv,
3f2ea2a4ed Ed H*0410      I     myThid )
a7ffe10af7 Ed H*0411
1b5fb69d21 Ed H*0412 C     !DESCRIPTION:
beebb2eade Jean*0413 C     General SUBROUTINE for adding attributes to a NetCDF file.
                0414
1b5fb69d21 Ed H*0415 C     !USES:
beebb2eade Jean*0416       IMPLICIT NONE
07155994b8 Mart*0417 #include "MNC_COMMON.h"
907e360dab Ed H*0418 #include "EEPARAMS.h"
853ee6565e Jean*0419 #include "netcdf.inc"
907e360dab Ed H*0420
1b5fb69d21 Ed H*0421 C     !INPUT PARAMETERS:
beebb2eade Jean*0422       CHARACTER*(*) fname,vname,atname
                0423       INTEGER atype
                0424       CHARACTER*(*) cs
                0425       INTEGER len
                0426       Real*8 dv(*)
                0427       Real*4 rv(*)
                0428       INTEGER iv(*)
                0429       INTEGER myThid
e6bb5b2cc3 Ed H*0430 CEOP
907e360dab Ed H*0431
1b5fb69d21 Ed H*0432 C     Functions
beebb2eade Jean*0433       INTEGER  ILNBLNK
                0434       EXTERNAL ILNBLNK
                0435
                0436 C     !LOCAL VARIABLES:
                0437       INTEGER n, indf,ind_fv_ids, fid,vid, err
                0438       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0439       INTEGER lenf,lenv,lenat,lens
907e360dab Ed H*0440
                0441 C     Strip trailing spaces
                0442       lenf = ILNBLNK(fname)
                0443       lenv = ILNBLNK(vname)
                0444       lenat = ILNBLNK(atname)
a7ffe10af7 Ed H*0445       lens = ILNBLNK(cs)
907e360dab Ed H*0446
3f2ea2a4ed Ed H*0447       CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
376f4203f6 Ed H*0448       IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
beebb2eade Jean*0449         WRITE(msgBuf,'(5A)') 'MNC ERROR: file ''', fname(1:lenf),
                0450      &       ''' is not open or does not contain variable ''',
376f4203f6 Ed H*0451      &       vname(1:lenv), ''''
beebb2eade Jean*0452         CALL print_error(msgBuf, myThid)
                0453         STOP 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
4de8f8c098 Ed H*0454       ENDIF
907e360dab Ed H*0455       fid = mnc_f_info(indf,2)
376f4203f6 Ed H*0456       vid = mnc_fv_ids(indf,(ind_fv_ids+1))
907e360dab Ed H*0457
                0458 C     Set the attribute
3f2ea2a4ed Ed H*0459       CALL MNC_FILE_REDEF(fname, myThid)
a7ffe10af7 Ed H*0460       IF (atype .EQ. 1) THEN
                0461         err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
                0462       ELSEIF (atype .EQ. 2) THEN
                0463         err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
                0464       ELSEIF (atype .EQ. 3) THEN
                0465         err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
                0466       ELSEIF (atype .EQ. 4) THEN
                0467         err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
                0468       ELSE
beebb2eade Jean*0469         WRITE(msgBuf,'(A,I10,A)') 'MNC ERROR: atype = ''', atype,
a7ffe10af7 Ed H*0470      &       ''' is invalid--must be: [1-4]'
beebb2eade Jean*0471         n = ILNBLNK(msgBuf)
                0472         CALL print_error(msgBuf(1:n), myThid)
                0473         STOP 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
a7ffe10af7 Ed H*0474       ENDIF
beebb2eade Jean*0475       WRITE(msgBuf,'(5A)') 'adding attribute ''', atname(1:lenat),
907e360dab Ed H*0476      &     ''' to file ''', fname(1:lenf), ''''
beebb2eade Jean*0477       CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
4de8f8c098 Ed H*0478
a27dc5c859 Ed H*0479       RETURN
4de8f8c098 Ed H*0480       END
                0481
e9b72f2bd9 Ed H*0482 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
376f4203f6 Ed H*0483
beebb2eade Jean*0484       SUBROUTINE MNC_VAR_WRITE_DBL(
                0485      I     fname,
                0486      I     vname,
                0487      I     var,
3f2ea2a4ed Ed H*0488      I     myThid )
376f4203f6 Ed H*0489
beebb2eade Jean*0490       IMPLICIT NONE
a7ffe10af7 Ed H*0491 C     Arguments
beebb2eade Jean*0492       CHARACTER*(*) fname, vname
                0493       Real*8 var(*)
                0494       INTEGER myThid
                0495
                0496 C     Local Variables
                0497       Real*4  dummyR4(1)
                0498       INTEGER dummyI (1)
                0499
                0500       DATA dummyR4 / 0. /
                0501       DATA dummyI  / 0 /
                0502
                0503       CALL MNC_VAR_WRITE_ANY( fname, vname, 1, 0,
                0504      &                        var, dummyR4, dummyI, myThid )
a7ffe10af7 Ed H*0505
                0506       RETURN
                0507       END
                0508
e9b72f2bd9 Ed H*0509 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
a7ffe10af7 Ed H*0510
beebb2eade Jean*0511       SUBROUTINE MNC_VAR_WRITE_REAL(
                0512      I     fname,
                0513      I     vname,
                0514      I     var,
3f2ea2a4ed Ed H*0515      I     myThid )
a7ffe10af7 Ed H*0516
beebb2eade Jean*0517       IMPLICIT NONE
a7ffe10af7 Ed H*0518 C     Arguments
beebb2eade Jean*0519       CHARACTER*(*) fname, vname
                0520       Real*4 var(*)
                0521       INTEGER myThid
                0522
                0523 C     Local Variables
                0524       Real*8  dummyR8(1)
                0525       INTEGER dummyI (1)
                0526
                0527       DATA dummyR8 / 0. _d 0 /
                0528       DATA dummyI  / 0 /
                0529
                0530       CALL MNC_VAR_WRITE_ANY( fname, vname, 2, 0,
                0531      &                        dummyR8, var, dummyI, myThid )
a7ffe10af7 Ed H*0532
                0533       RETURN
                0534       END
                0535
e9b72f2bd9 Ed H*0536 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
a7ffe10af7 Ed H*0537
beebb2eade Jean*0538       SUBROUTINE MNC_VAR_WRITE_INT(
                0539      I     fname,
                0540      I     vname,
                0541      I     var,
3f2ea2a4ed Ed H*0542      I     myThid )
a7ffe10af7 Ed H*0543
beebb2eade Jean*0544       IMPLICIT NONE
a7ffe10af7 Ed H*0545 C     Arguments
beebb2eade Jean*0546       CHARACTER*(*) fname, vname
                0547       INTEGER var(*)
                0548       INTEGER myThid
                0549
                0550 C     Local Variables
                0551       Real*8  dummyR8(1)
                0552       Real*4  dummyR4(1)
                0553
                0554       DATA dummyR8 / 0. _d 0 /
                0555       DATA dummyR4 / 0. /
                0556
                0557       CALL MNC_VAR_WRITE_ANY( fname, vname, 3, 0,
                0558      &                        dummyR8, dummyR4, var, myThid )
a7ffe10af7 Ed H*0559
251b9a88c9 Ed H*0560       RETURN
                0561       END
                0562
e9b72f2bd9 Ed H*0563 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
251b9a88c9 Ed H*0564
beebb2eade Jean*0565       SUBROUTINE MNC_VAR_APPEND_DBL(
                0566      I     fname,
                0567      I     vname,
                0568      I     var,
                0569      I     append,
3f2ea2a4ed Ed H*0570      I     myThid )
251b9a88c9 Ed H*0571
beebb2eade Jean*0572       IMPLICIT NONE
251b9a88c9 Ed H*0573 C     Arguments
beebb2eade Jean*0574       CHARACTER*(*) fname, vname
                0575       Real*8 var(*)
                0576       INTEGER append, myThid
                0577
                0578 C     Local Variables
                0579       Real*4  dummyR4(1)
                0580       INTEGER dummyI (1)
                0581
                0582       DATA dummyR4 / 0. /
                0583       DATA dummyI  / 0 /
                0584
                0585       CALL MNC_VAR_WRITE_ANY( fname, vname, 1, append,
                0586      &                        var, dummyR4, dummyI, myThid )
251b9a88c9 Ed H*0587
                0588       RETURN
                0589       END
                0590
e9b72f2bd9 Ed H*0591 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
251b9a88c9 Ed H*0592
beebb2eade Jean*0593       SUBROUTINE MNC_VAR_APPEND_REAL(
                0594      I     fname,
                0595      I     vname,
                0596      I     var,
                0597      I     append,
3f2ea2a4ed Ed H*0598      I     myThid )
251b9a88c9 Ed H*0599
beebb2eade Jean*0600       IMPLICIT NONE
251b9a88c9 Ed H*0601 C     Arguments
beebb2eade Jean*0602       CHARACTER*(*) fname, vname
                0603       Real*4 var(*)
                0604       INTEGER append, myThid
                0605
                0606 C     Local Variables
                0607       Real*8  dummyR8(1)
                0608       INTEGER dummyI (1)
                0609
                0610       DATA dummyR8 / 0. _d 0 /
                0611       DATA dummyI  / 0 /
                0612
                0613       CALL MNC_VAR_WRITE_ANY( fname, vname, 2, append,
                0614      &                        dummyR8, var, dummyI, myThid )
251b9a88c9 Ed H*0615
                0616       RETURN
                0617       END
                0618
e9b72f2bd9 Ed H*0619 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
251b9a88c9 Ed H*0620
beebb2eade Jean*0621       SUBROUTINE MNC_VAR_APPEND_INT(
                0622      I     fname,
                0623      I     vname,
                0624      I     var,
                0625      I     append,
3f2ea2a4ed Ed H*0626      I     myThid )
251b9a88c9 Ed H*0627
beebb2eade Jean*0628       IMPLICIT NONE
251b9a88c9 Ed H*0629 C     Arguments
beebb2eade Jean*0630       CHARACTER*(*) fname, vname
                0631       INTEGER var(*)
                0632       INTEGER append, myThid
                0633
                0634 C     Local Variables
                0635       Real*8  dummyR8(1)
                0636       Real*4  dummyR4(1)
                0637
                0638       DATA dummyR8 / 0. _d 0 /
                0639       DATA dummyR4 / 0. /
                0640
                0641       CALL MNC_VAR_WRITE_ANY( fname, vname, 3, append,
                0642      &                        dummyR8, dummyR4, var, myThid )
251b9a88c9 Ed H*0643
a7ffe10af7 Ed H*0644       RETURN
                0645       END
                0646
e9b72f2bd9 Ed H*0647 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
a7ffe10af7 Ed H*0648
beebb2eade Jean*0649       SUBROUTINE MNC_VAR_WRITE_ANY(
                0650      I     fname,
                0651      I     vname,
a7ffe10af7 Ed H*0652      I     vtype,
251b9a88c9 Ed H*0653      I     append,
a7ffe10af7 Ed H*0654      I     dv,
                0655      I     rv,
beebb2eade Jean*0656      I     iv,
3f2ea2a4ed Ed H*0657      I     myThid )
a7ffe10af7 Ed H*0658
beebb2eade Jean*0659       IMPLICIT NONE
07155994b8 Mart*0660 #include "MNC_COMMON.h"
376f4203f6 Ed H*0661 #include "EEPARAMS.h"
853ee6565e Jean*0662 #include "netcdf.inc"
376f4203f6 Ed H*0663
                0664 C     Arguments
beebb2eade Jean*0665       CHARACTER*(*) fname, vname
                0666       INTEGER vtype
                0667       INTEGER append
                0668       Real*8 dv(*)
                0669       Real*4 rv(*)
                0670       INTEGER iv(*)
                0671       INTEGER myThid
376f4203f6 Ed H*0672
                0673 C     Functions
beebb2eade Jean*0674       INTEGER ILNBLNK
376f4203f6 Ed H*0675
                0676 C     Local Variables
beebb2eade Jean*0677       INTEGER i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
                0678       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0679       INTEGER lenf,lenv, lend
                0680       INTEGER vstart(100), vcount(100)
376f4203f6 Ed H*0681
                0682 C     Strip trailing spaces
                0683       lenf = ILNBLNK(fname)
                0684       lenv = ILNBLNK(vname)
                0685
3f2ea2a4ed Ed H*0686       CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
376f4203f6 Ed H*0687       IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
beebb2eade Jean*0688         WRITE(msgBuf,'(5A)') 'MNC ERROR: file ''', fname(1:lenf),
                0689      &       ''' is not open or does not contain variable ''',
376f4203f6 Ed H*0690      &       vname(1:lenv), ''''
beebb2eade Jean*0691         CALL print_error(msgBuf, myThid)
                0692         STOP 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
376f4203f6 Ed H*0693       ENDIF
                0694       fid = mnc_f_info(indf,2)
                0695       vid = mnc_fv_ids(indf,(ind_fv_ids+1))
                0696
                0697 C     Get the lengths from the dim IDs
                0698       ig = mnc_fv_ids(indf,(ind_fv_ids+2))
                0699       ds = mnc_f_info(indf,ig+1)
                0700       de = mnc_f_info(indf,ig+2)
                0701       k = 0
                0702       DO i = ds,de
                0703         k = k + 1
                0704         vstart(k) = 1
                0705         vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
                0706       ENDDO
                0707
                0708 C     Check for the unlimited dimension
                0709       j = mnc_d_size( mnc_fd_ind(indf,de) )
                0710       IF (j .LT. 1) THEN
75987013ac Ed H*0711         did = mnc_d_ids( mnc_fd_ind(indf,de) )
376f4203f6 Ed H*0712         err = NF_INQ_DIMLEN(fid, did, lend)
beebb2eade Jean*0713         WRITE(msgBuf,'(A)') 'reading current length of unlimited dim'
                0714         CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
251b9a88c9 Ed H*0715         IF (append .GT. 0) THEN
                0716           lend = lend + append
                0717         ENDIF
                0718         IF (lend .LT. 1) lend = 1
376f4203f6 Ed H*0719         vstart(k) = lend
                0720         vcount(k) = 1
                0721       ENDIF
                0722
3f2ea2a4ed Ed H*0723       CALL MNC_FILE_ENDDEF(fname, myThid)
a7ffe10af7 Ed H*0724       IF (vtype .EQ. 1) THEN
                0725         err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
                0726       ELSEIF (vtype .EQ. 2) THEN
                0727         err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
                0728       ELSEIF (vtype .EQ. 3) THEN
                0729         err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
                0730       ELSE
beebb2eade Jean*0731         WRITE(msgBuf,'(A,I10,A)') 'MNC ERROR: vtype = ''', vtype,
a7ffe10af7 Ed H*0732      &       ''' is invalid--must be: [1|2|3]'
beebb2eade Jean*0733         n = ILNBLNK(msgBuf)
                0734         CALL print_error(msgBuf(1:n), myThid)
                0735         STOP 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
                0736       ENDIF
                0737       WRITE(msgBuf,'(5A)') 'writing variable ''', vname(1:lenv),
376f4203f6 Ed H*0738      &     ''' to file ''', fname(1:lenf), ''''
beebb2eade Jean*0739       CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
376f4203f6 Ed H*0740
                0741       RETURN
                0742       END
                0743
e9b72f2bd9 Ed H*0744 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0745