--- MITgcm/pkg/mnc/mnc_var.F 2004/01/08 07:24:47 1.5 +++ MITgcm/pkg/mnc/mnc_var.F 2004/09/23 16:17:57 1.17 @@ -1,121 +1,161 @@ -C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/mnc/mnc_var.F,v 1.5 2004/01/08 07:24:47 edhill Exp $ +C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/mnc/mnc_var.F,v 1.17 2004/09/23 16:17:57 jmc Exp $ C $Name: $ #include "MNC_OPTIONS.h" -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_INIT_DBL +C !INTERFACE: SUBROUTINE MNC_VAR_INIT_DBL( - I myThid, I fname, I gname, - I vname, - I units ) + I vname, + I myThid ) +C !DESCRIPTION: +C Create a double-precision real variable within a NetCDF file +C context. + +C !USES: implicit none #include "netcdf.inc" -C Arguments +C !INPUT PARAMETERS: integer myThid - character*(*) fname,gname,vname,units + character*(*) fname,gname,vname +CEOP - CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_DOUBLE) + CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_DOUBLE, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_INIT_REAL +C !INTERFACE: SUBROUTINE MNC_VAR_INIT_REAL( - I myThid, I fname, I gname, - I vname, - I units ) + I vname, + I myThid ) +C !DESCRIPTION: +C Create a single-precision real variable within a NetCDF file +C context. + +C !USES: implicit none #include "netcdf.inc" -C Arguments +C !INPUT PARAMETERS: integer myThid - character*(*) fname,gname,vname,units + character*(*) fname,gname,vname +CEOP - CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_FLOAT) + CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_FLOAT, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_INIT_INT +C !INTERFACE: SUBROUTINE MNC_VAR_INIT_INT( - I myThid, I fname, I gname, - I vname, - I units ) + I vname, + I myThid ) +C !DESCRIPTION: +C Create an integer variable within a NetCDF file context. + +C !USES: implicit none #include "netcdf.inc" -C Arguments +C !INPUT PARAMETERS: integer myThid - character*(*) fname,gname,vname,units + character*(*) fname,gname,vname +CEOP - CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_INT) + CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_INT, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_INIT_ANY +C !INTERFACE: SUBROUTINE MNC_VAR_INIT_ANY( - I myThid, I fname, I gname, I vname, - I units, - I vtype ) + I vtype, + I myThid ) +C !DESCRIPTION: +C General function for creating variables within a NetCDF file +C context. + +C !USES: implicit none #include "netcdf.inc" #include "mnc_common.h" #include "EEPARAMS.h" -C Arguments +C !INPUT PARAMETERS: integer myThid - character*(*) fname,gname,vname,units + character*(*) fname,gname,vname integer vtype +CEOP -C Functions - integer ILNBLNK - -C Local Variables +C !LOCAL VARIABLES: integer i,j,k, n, indf,indv, fid, nd, ngrid, is,ie, err - integer vid, nv, ind_g_finfo + integer vid, nv, ind_g_finfo, needed, nvar character*(MAX_LEN_MBUF) msgbuf - integer rids(10), ids(10) - integer lenf,leng,lenv,lenu + integer ids(20) + integer lenf,leng,lenv + +C Functions + integer ILNBLNK C Strip trailing spaces lenf = ILNBLNK(fname) leng = ILNBLNK(gname) lenv = ILNBLNK(vname) - lenu = ILNBLNK(units) C Check that the file is open - CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf) + CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid) IF (indf .LT. 1) THEN write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname, & ''' must be opened first' CALL print_error(msgbuf, mythid) - stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL' + stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY' ENDIF fid = mnc_f_info(indf,2) +C Check for sufficient storage space in mnc_fv_ids + needed = 1 + 3*(mnc_fv_ids(indf,1) + 1) + IF (needed .GE. MNC_MAX_INFO) THEN + write(msgbuf,'(2a,i7,a)') 'MNC ERROR: MNC_MAX_INFO exceeded', + & ': please increase it to ', 2*MNC_MAX_INFO, + & ' in the file ''pkg/mnc/mnc_common.h''' + CALL print_error(msgbuf, mythid) + stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY' + ENDIF + C Get the grid information ngrid = mnc_f_info(indf,3) IF (ngrid .LT. 1) THEN write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf), & ''' contains NO grids' CALL print_error(msgbuf, mythid) - stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL' + stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY' ENDIF DO i = 1,ngrid j = 4 + (i-1)*3 @@ -129,7 +169,7 @@ nd = 0 DO k = is,ie nd = nd + 1 - ids(nd) = mnc_fg_ids(indf,k) + ids(nd) = mnc_d_ids(mnc_fd_ind(indf,k)) ENDDO GOTO 10 ENDIF @@ -137,152 +177,232 @@ write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf), & ''' does not contain grid ''', gname(1:leng), '''' CALL print_error(msgbuf, mythid) - stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL' + stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY' 10 CONTINUE +C Check if the variable is already defined + nvar = mnc_fv_ids(indf,1) + DO i = 1,nvar + j = 2 + 3*(i-1) + IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vname) THEN + k = mnc_f_info(indf,mnc_fv_ids(indf,j+2)) + IF (mnc_g_names(k) .NE. gname) THEN + write(msgbuf,'(5a)') 'MNC ERROR: variable ''', + & vname(1:lenv), ''' is already defined in file ''', + & fname(1:lenf), ''' but using a different grid shape' + CALL print_error(msgbuf, mythid) + stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY' + ELSE +C Its OK, the variable and grid names are the same + RETURN + ENDIF + ENDIF + ENDDO + C Add the variable definition - CALL MNC_FILE_REDEF(myThid, fname) + CALL MNC_FILE_REDEF(fname, myThid) err = NF_DEF_VAR(fid, vname, vtype, nd, ids, vid) write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv), & ''' in file ''', fname(1:lenf), '''' - CALL MNC_HANDLE_ERR(myThid, err, msgbuf) + CALL MNC_HANDLE_ERR(err, msgbuf, myThid) C Success, so save the variable info - CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_v_names, indv) + CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID,mnc_v_names,indv, myThid) mnc_v_names(indv)(1:lenv) = vname(1:lenv) nv = mnc_fv_ids(indf,1) i = 2 + nv*3 - j = i + 1 - k = i + 2 - mnc_fv_ids(indf,i) = indv - mnc_fv_ids(indf,j) = vid - mnc_fv_ids(indf,k) = ind_g_finfo + mnc_fv_ids(indf,i) = indv + mnc_fv_ids(indf,i+1) = vid + mnc_fv_ids(indf,i+2) = ind_g_finfo mnc_fv_ids(indf,1) = nv + 1 -C Add the units - CALL MNC_VAR_ADD_ATTR_STR(myThid, fname, vname, 'units', units) - RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_ADD_ATTR_STR +C !INTERFACE: SUBROUTINE MNC_VAR_ADD_ATTR_STR( - I myThid, I fname, I vname, I atname, - I sval ) + I sval, + I myThid ) +C !DESCRIPTION: +C Subroutine for adding a character string attribute to a NetCDF +C file. + +C !USES: implicit none -C Arguments + +C !INPUT PARAMETERS: integer myThid character*(*) fname,vname,atname,sval +CEOP + real*8 dZero(1) + real*4 sZero(1) + integer iZero(1) + dZero(1) = 0.0D0 + sZero(1) = 0.0 + iZero(1) = 0 + + CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname, + & 1, sval, 0, dZero, sZero, iZero, myThid) + RETURN + END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_ADD_ATTR_DBL - CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname, - & 1, sval, 0, 0.0D0, 0.0, 0) - RETURN - END -C================================================================== - +C !INTERFACE: SUBROUTINE MNC_VAR_ADD_ATTR_DBL( - I myThid, I fname, I vname, I atname, I nv, - I dval ) + I dval, + I myThid ) +C !DESCRIPTION: +C Subroutine for adding a double-precision real attribute to a +C NetCDF file. + +C !USES: implicit none -C Arguments + +C !INPUT PARAMETERS: integer myThid,nv character*(*) fname,vname,atname - _RL dval(*) + REAL*8 dval(*) +CEOP + real*4 sZero(1) + integer iZero(1) + sZero(1) = 0.0 + iZero(1) = 0 - CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname, - & 2, ' ', nv, dval, 0.0, 0) + CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname, + & 2, ' ', nv, dval, sZero, iZero, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_ADD_ATTR_REAL +C !INTERFACE: SUBROUTINE MNC_VAR_ADD_ATTR_REAL( - I myThid, I fname, I vname, I atname, I nv, - I rval ) + I rval, + I myThid ) +C !DESCRIPTION: +C Subroutine for adding a single-precision real attribute to a +C NetCDF file. + +C !USES: implicit none -C Arguments + +C !INPUT PARAMETERS: integer myThid,nv character*(*) fname,vname,atname - _RS rval(*) + REAL*4 rval(*) +CEOP + real*8 dZero(1) + integer iZero(1) + dZero(1) = 0.0D0 + iZero(1) = 0 - CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname, - & 3, ' ', nv, 0.0D0, rval, 0) + CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname, + & 3, ' ', nv, dZero, rval, iZero, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_ADD_ATTR_INT +C !INTERFACE: SUBROUTINE MNC_VAR_ADD_ATTR_INT( - I myThid, I fname, I vname, I atname, I nv, - I ival ) + I ival, + I myThid ) +C !DESCRIPTION: +C Subroutine for adding an integer attribute to a +C NetCDF file. + +C !USES: implicit none -C Arguments + +C !INPUT PARAMETERS: integer myThid,nv character*(*) fname,vname,atname integer ival(*) +CEOP + real*8 dZero(1) + real*4 sZero(1) + dZero(1) = 0.0D0 + sZero(1) = 0.0 - CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname, - & 4, ' ', nv, 0.0D0, 0.0, ival) + CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname, + & 4, ' ', nv, dZero, sZero, ival, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_VAR_ADD_ATTR_ANY +C !INTERFACE: SUBROUTINE MNC_VAR_ADD_ATTR_ANY( - I myThid, I fname, I vname, I atname, - I atype, cs,len,dv,rv,iv ) + I atype, cs,len,dv,rv,iv, + I myThid ) +C !DESCRIPTION: +C General subroutine for adding attributes to a NetCDF file. + +C !USES: implicit none #include "netcdf.inc" #include "mnc_common.h" #include "EEPARAMS.h" -C Arguments +C !INPUT PARAMETERS: integer myThid,atype,len character*(*) fname,vname,atname character*(*) cs - _RL dv(*) - _RS rv(*) + REAL*8 dv(*) + REAL*4 rv(*) integer iv(*) +CEOP -C Functions - integer ILNBLNK - -C Local Variables - integer i,j,k, n, nv, indf,ind_fv_ids, fid,vid, err +C !LOCAL VARIABLES: + integer n, indf,ind_fv_ids, fid,vid, err character*(MAX_LEN_MBUF) msgbuf integer lenf,lenv,lenat,lens +C Functions + integer ILNBLNK + C Strip trailing spaces lenf = ILNBLNK(fname) lenv = ILNBLNK(vname) lenat = ILNBLNK(atname) lens = ILNBLNK(cs) - CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids) + CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid) IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf), & ''' is not open or does not contain variable ''', @@ -294,8 +414,7 @@ vid = mnc_fv_ids(indf,(ind_fv_ids+1)) C Set the attribute - CALL MNC_FILE_REDEF(myThid, fname) - print *, 'atype = ', atype + CALL MNC_FILE_REDEF(fname, myThid) IF (atype .EQ. 1) THEN err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs) ELSEIF (atype .EQ. 2) THEN @@ -313,54 +432,54 @@ ENDIF write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat), & ''' to file ''', fname(1:lenf), '''' - CALL MNC_HANDLE_ERR(myThid, err, msgbuf) + CALL MNC_HANDLE_ERR(err, msgbuf, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| SUBROUTINE MNC_VAR_WRITE_DBL( - I myThid, I fname, I vname, - I var ) + I var, + I myThid ) implicit none C Arguments integer myThid character*(*) fname,vname - _RL var(*) + REAL*8 var(*) - CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 1, var, 0.0, 0 ) + CALL MNC_VAR_WRITE_ANY(fname,vname,1,0,var,0.0,0, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| SUBROUTINE MNC_VAR_WRITE_REAL( - I myThid, I fname, I vname, - I var ) + I var, + I myThid ) implicit none C Arguments integer myThid character*(*) fname,vname - _RS var(*) + REAL*4 var(*) - CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 2, 0.0D0, var, 0 ) + CALL MNC_VAR_WRITE_ANY(fname,vname,2,0,0.0D0,var,0, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| SUBROUTINE MNC_VAR_WRITE_INT( - I myThid, I fname, I vname, - I var ) + I var, + I myThid ) implicit none C Arguments @@ -368,20 +487,78 @@ character*(*) fname,vname integer var(*) - CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 3, 0.0D0, 0.0, var ) + CALL MNC_VAR_WRITE_ANY(fname,vname,3,0,0.0D0,0.0,var, myThid) RETURN END -C================================================================== +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| + + SUBROUTINE MNC_VAR_APPEND_DBL( + I fname, + I vname, + I var, + I append, + I myThid ) + + implicit none +C Arguments + integer myThid, append + character*(*) fname,vname + REAL*8 var(*) + + CALL MNC_VAR_WRITE_ANY(fname,vname,1,append,var,0.0,0, myThid) + RETURN + END + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| + + SUBROUTINE MNC_VAR_APPEND_REAL( + I fname, + I vname, + I var, + I append, + I myThid ) + + implicit none +C Arguments + integer myThid, append + character*(*) fname,vname + REAL*4 var(*) + + CALL MNC_VAR_WRITE_ANY(fname,vname,2,append,0.0D0,var,0,myThid) + RETURN + END + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| + + SUBROUTINE MNC_VAR_APPEND_INT( + I fname, + I vname, + I var, + I append, + I myThid ) + + implicit none +C Arguments + integer myThid, append + character*(*) fname,vname + integer var(*) + + CALL MNC_VAR_WRITE_ANY(fname,vname,3,append,0.0D0,0.0,var,myThid) + RETURN + END + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| SUBROUTINE MNC_VAR_WRITE_ANY( - I myThid, I fname, I vname, I vtype, + I append, I dv, I rv, - I iv ) + I iv, + I myThid ) implicit none #include "netcdf.inc" @@ -391,9 +568,10 @@ C Arguments integer myThid, vtype character*(*) fname,vname - _RL dv(*) - _RS rv(*) + REAL*8 dv(*) + REAL*4 rv(*) integer iv(*) + integer append C Functions integer ILNBLNK @@ -403,13 +581,12 @@ character*(MAX_LEN_MBUF) msgbuf integer lenf,lenv, lend integer vstart(100), vcount(100) - integer rvstart(100), rvcount(100) C Strip trailing spaces lenf = ILNBLNK(fname) lenv = ILNBLNK(vname) - CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids) + CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid) IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf), & ''' is not open or does not contain variable ''', @@ -434,16 +611,19 @@ C Check for the unlimited dimension j = mnc_d_size( mnc_fd_ind(indf,de) ) IF (j .LT. 1) THEN - did = mnc_fg_ids(indf,de) + did = mnc_d_ids( mnc_fd_ind(indf,de) ) err = NF_INQ_DIMLEN(fid, did, lend) write(msgbuf,'(a)') 'reading current length of unlimited dim' - CALL MNC_HANDLE_ERR(myThid, err, msgbuf) - IF (lend .LT. 1) lend = lend + 1 + CALL MNC_HANDLE_ERR(err, msgbuf, myThid) + IF (append .GT. 0) THEN + lend = lend + append + ENDIF + IF (lend .LT. 1) lend = 1 vstart(k) = lend vcount(k) = 1 ENDIF - CALL MNC_FILE_ENDDEF(myThid, fname) + CALL MNC_FILE_ENDDEF(fname, myThid) IF (vtype .EQ. 1) THEN err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv) ELSEIF (vtype .EQ. 2) THEN @@ -459,8 +639,10 @@ ENDIF write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv), & ''' to file ''', fname(1:lenf), '''' - CALL MNC_HANDLE_ERR(myThid, err, msgbuf) + CALL MNC_HANDLE_ERR(err, msgbuf, myThid) RETURN END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +