--- MITgcm/pkg/mnc/mnc_cwrapper.F 2004/02/04 05:45:09 1.4 +++ MITgcm/pkg/mnc/mnc_cwrapper.F 2004/12/17 21:28:26 1.24 @@ -1,48 +1,56 @@ -C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/mnc/mnc_cwrapper.F,v 1.4 2004/02/04 05:45:09 edhill Exp $ +C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/mnc/mnc_cwrapper.F,v 1.24 2004/12/17 21:28:26 edhill Exp $ C $Name: $ #include "MNC_OPTIONS.h" C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 0 +C !ROUTINE: MNC_CW_ADD_GNAME +C !INTERFACE: SUBROUTINE MNC_CW_ADD_GNAME( - I myThid, I name, I ndim, I dlens, I dnames, - I inds_beg, inds_end ) + I inds_beg, inds_end, + I myThid ) +C !DESCRIPTION: +C Add a grid name to the MNC convenience wrapper layer. + +C !USES: implicit none #include "mnc_common.h" #include "EEPARAMS.h" -C Arguments +C !INPUT PARAMETERS: integer myThid, ndim character*(*) name integer dlens(*), inds_beg(*), inds_end(*) character*(*) dnames(*) +CEOP -C Functions - integer IFNBLNK, ILNBLNK - -C Local Variables +C !LOCAL VARIABLES: integer i, nnf,nnl, indg character*(MAX_LEN_MBUF) msgbuf +C Functions + integer IFNBLNK, ILNBLNK + nnf = IFNBLNK(name) nnl = ILNBLNK(name) C Check that this name is not already defined - CALL MNC_GET_IND(myThid, MNC_MAX_ID, name, mnc_cw_gname, indg) + CALL MNC_GET_IND(MNC_MAX_ID, name, mnc_cw_gname, indg, myThid) IF (indg .GT. 0) THEN write(msgbuf,'(3a)') 'MNC_CW_ADD_GNAME ERROR: ''', name, & ''' is already defined' CALL print_error(msgbuf, mythid) stop 'ABNORMAL END: S/R MNC_CW_ADD_GNAME' ENDIF - CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_cw_gname, - & indg) + CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_gname, + & indg, myThid) mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR) mnc_cw_gname(indg)(1:(nnl-nnf+1)) = name(nnf:nnl) @@ -62,304 +70,261 @@ END C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 0 +C !ROUTINE: MNC_CW_DEL_GNAME - SUBROUTINE MNC_CW_DUMP() +C !INTERFACE: + SUBROUTINE MNC_CW_DEL_GNAME( + I name, + I myThid ) +C !DESCRIPTION: +C Delete a grid name from the MNC convenience wrapper layer. + +C !USES: implicit none #include "mnc_common.h" +#include "EEPARAMS.h" -C Local Variables +C !INPUT PARAMETERS: + integer myThid + character*(*) name +CEOP + +C !LOCAL VARIABLES: + integer nnf,nnl, indg + +C Functions + integer IFNBLNK, ILNBLNK + + nnf = IFNBLNK(name) + nnl = ILNBLNK(name) + +C Check that this name is not already defined + CALL MNC_GET_IND(MNC_MAX_ID, name, mnc_cw_gname, indg, myThid) + IF (indg .LT. 1) THEN + RETURN + ENDIF + + mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR) + mnc_cw_ndim(indg) = 0 + + RETURN + END + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_CW_DUMP + +C !INTERFACE: + SUBROUTINE MNC_CW_DUMP( myThid ) + +C !DESCRIPTION: +C Write a condensed view of the current state of the MNC look-up +C tables for the convenience wrapper section. + +C !USES: + implicit none +#include "mnc_common.h" +#include "SIZE.h" +#include "EEPARAMS.h" +#include "PARAMS.h" + +C !INPUT PARAMETERS: + integer myThid +CEOP + +C !LOCAL VARIABLES: integer i,j, ntot + integer NBLNK + parameter ( NBLNK = 150 ) + character s1*(NBLNK), blnk*(NBLNK) - write(*,'(a)') 'The currently defined Grid Types are:' + _BEGIN_MASTER(myThid) + + DO i = 1,NBLNK + blnk(i:i) = ' ' + ENDDO + + s1(1:NBLNK) = blnk(1:NBLNK) + write(s1,'(a5,a)') 'MNC: ', + & 'The currently defined Grid Types are:' + CALL PRINT_MESSAGE( + & s1, standardMessageUnit, SQUEEZE_RIGHT, mythid) ntot = 0 DO j = 1,MNC_MAX_ID IF (mnc_cw_gname(j)(1:MNC_MAX_CHAR) & .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN ntot = ntot + 1 - write(*,'(2i5,a3,a20,i3,a3,5i4,a4,5i4,a4,5i4,6a4)') + s1(1:NBLNK) = blnk(1:NBLNK) + write(s1,'(a5,2i5,a3,a20,i3,a3,5i4,a4,5i4,a4,5i4,6a8)') + & 'MNC: ', & j, ntot, ' : ', mnc_cw_gname(j)(1:20), mnc_cw_ndim(j), & ' : ', (mnc_cw_dims(i,j), i=1,5), & ' | ', (mnc_cw_is(i,j), i=1,5), & ' | ', (mnc_cw_ie(i,j), i=1,5), - & ' | ', (mnc_cw_dn(i,j)(1:4), i=1,5) - + & ' | ', (mnc_cw_dn(i,j)(1:7), i=1,5) + CALL PRINT_MESSAGE( + & s1, standardMessageUnit, SQUEEZE_RIGHT, mythid) + ENDIF ENDDO - - write(*,'(a)') 'The currently defined Variable Types are:' + + s1(1:NBLNK) = blnk(1:NBLNK) + write(s1,'(a5,a)') 'MNC: ', + & 'The currently defined Variable Types are:' + CALL PRINT_MESSAGE( + & s1, standardMessageUnit, SQUEEZE_RIGHT, mythid) ntot = 0 DO j = 1,MNC_MAX_ID IF (mnc_cw_vname(j)(1:MNC_MAX_CHAR) & .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN - + ntot = ntot + 1 - write(*,'(2i5,a3,a25,a3,i4)') j, ntot, ' : ', - & mnc_cw_vname(j)(1:20), ' : ', mnc_cw_vgind(j) - + s1(1:NBLNK) = blnk(1:NBLNK) + write(s1,'(a5,2i5,a3,a25,a3,i4)') 'MNC: ', + & j, ntot, ' | ', + & mnc_cw_vname(j)(1:20), ' | ', mnc_cw_vgind(j) + CALL PRINT_MESSAGE( + & s1, standardMessageUnit, SQUEEZE_RIGHT, mythid) + DO i = 1,mnc_cw_vnat(1,j) - write(*,'(a14,i4,a3,a25,a3,a25)') ' text_at:',i, + s1(1:NBLNK) = blnk(1:NBLNK) + write(s1,'(a5,a14,i4,a3,a25,a3,a55)') + & 'MNC: ',' text_at:',i, & ' : ', mnc_cw_vtnm(i,j)(1:25), ' : ', - & mnc_cw_vtat(i,j)(1:25) + & mnc_cw_vtat(i,j)(1:55) + CALL PRINT_MESSAGE( + & s1, standardMessageUnit, SQUEEZE_RIGHT, mythid) ENDDO DO i = 1,mnc_cw_vnat(2,j) - write(*,'(a14,i4,a3,a25,a3,i20)') ' int__at:',i, + s1(1:NBLNK) = blnk(1:NBLNK) + write(s1,'(a5,a14,i4,a3,a25,a3,i20)') + & 'MNC: ',' int__at:',i, & ' : ', mnc_cw_vinm(i,j)(1:25), ' : ', & mnc_cw_viat(i,j) + CALL PRINT_MESSAGE( + & s1, standardMessageUnit, SQUEEZE_RIGHT, mythid) ENDDO DO i = 1,mnc_cw_vnat(3,j) - write(*,'(a14,i4,a3,a25,a3,f25.10)') ' dbl__at:',i, + s1(1:NBLNK) = blnk(1:NBLNK) + write(s1,'(a5,a14,i4,a3,a25,a3,f25.10)') + & 'MNC: ',' dbl__at:',i, & ' : ', mnc_cw_vdnm(i,j)(1:25), ' : ', & mnc_cw_vdat(i,j) - ENDDO - + CALL PRINT_MESSAGE( + & s1, standardMessageUnit, SQUEEZE_RIGHT, mythid) + ENDDO + ENDIF ENDDO IF (ntot .EQ. 0) THEN - write(*,'(a)') ' None defined!' + s1(1:NBLNK) = blnk(1:NBLNK) + write(s1,'(a)') 'MNC: None defined!' + CALL PRINT_MESSAGE( + & s1, standardMessageUnit, SQUEEZE_RIGHT, mythid) ENDIF - + + _END_MASTER(myThid) RETURN END C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 0 +C !ROUTINE: MNC_CW_APPEND_VNAME - SUBROUTINE MNC_CW_INIT( - I myThid, - I sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr ) - +C !INTERFACE: + SUBROUTINE MNC_CW_APPEND_VNAME( + I vname, + I gname, + I bi_dim, bj_dim, + I myThid ) + +C !DESCRIPTION: +C If it is not yet defined within the MNC CW layer, append a +C variable type. Calls MNC\_CW\_ADD\_VNAME(). + +C !USES: implicit none #include "mnc_common.h" -#include "EEPARAMS.h" -C Arguments - integer myThid - integer sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr - -C Functions - integer IFNBLNK, ILNBLNK +C !INPUT PARAMETERS: + integer myThid, bi_dim, bj_dim + character*(*) vname, gname +CEOP -C Local Variables - integer CW_MAX_LOC - parameter ( CW_MAX_LOC = 5 ) - integer i, ihorz,ihsub,ivert,itime,ihalo, is,ih, n,ntot - integer ndim, ncomb - character*(MAX_LEN_MBUF) msgbuf - character*(MNC_MAX_CHAR) name - character*(MNC_MAX_CHAR) dn(CW_MAX_LOC) - character*(5) horz_dat(CW_MAX_LOC), hsub_dat(CW_MAX_LOC), - & vert_dat(CW_MAX_LOC), time_dat(CW_MAX_LOC), - & halo_dat(CW_MAX_LOC) - integer dim(CW_MAX_LOC), ib(CW_MAX_LOC), ie(CW_MAX_LOC) - -C ......12345....12345....12345....12345....12345... - data horz_dat / - & '- ', 'U ', 'V ', 'Cen ', 'Cor ' / - data hsub_dat / - & 'xy ', 'x ', 'y ', '- ', ' ' / - data halo_dat / - & 'Hn ', 'Hy ', '-- ', ' ', ' ' / - data vert_dat / - & '- ', 'C ', 'I ', ' ', ' ' / - data time_dat / - & '- ', 't ', ' ', ' ', ' ' / - - ncomb = 0 - DO ihorz = 1,5 - DO is = 1,3 - DO ih = 1,2 - -C Loop just ONCE if the Horiz component is "-" - ihsub = is - ihalo = ih - IF (ihorz .EQ. 1) THEN - IF ((is .EQ. 1) .AND. (ih .EQ. 1)) THEN - ihsub = 4 - ihalo = 3 - ELSE - GOTO 10 - ENDIF - ENDIF - - DO ivert = 1,3 - DO itime = 1,2 - -C horiz and hsub - name(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR) - n = ILNBLNK(horz_dat(ihorz)) - name(1:n) = horz_dat(ihorz)(1:n) - ntot = n + 1 - name(ntot:ntot) = '_' - n = ILNBLNK(hsub_dat(ihsub)) - name((ntot+1):(ntot+n)) = hsub_dat(ihsub)(1:n) - ntot = ntot + n - -C vert, time, and halo - write(name((ntot+1):(ntot+9)), '(a1,2a2,a1,a2,a1)') - & '_', halo_dat(ihalo)(1:2), '__', - & vert_dat(ivert)(1:1), '__', - & time_dat(itime)(1:1) - - ndim = 0 - DO i = 1,CW_MAX_LOC - dn(i)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR) - dim(i) = 0 - ib(i) = 0 - ie(i) = 0 - ENDDO - -C Horizontal dimensions - IF (halo_dat(ihalo)(1:5) .EQ. 'Hn ') THEN - - IF (hsub_dat(ihsub)(1:1) .EQ. 'x') THEN - ndim = ndim + 1 - IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cen') - & .OR. (horz_dat(ihorz)(1:1) .EQ. 'V') ) THEN - dn(ndim)(1:1) = 'X' - dim(ndim) = sNx + 2*OLx - ib(ndim) = OLx + 1 - ie(ndim) = OLx + sNx - ENDIF - IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cor') - & .OR. (horz_dat(ihorz)(1:1) .EQ. 'U') ) THEN - dn(ndim)(1:3) = 'Xp1' - dim(ndim) = sNx + 2*OLx - ib(ndim) = OLx + 1 - ie(ndim) = OLx + sNx + 1 - ENDIF - ENDIF - IF ((hsub_dat(ihsub)(1:1) .EQ. 'y') - & .OR. (hsub_dat(ihsub)(2:2) .EQ. 'y')) THEN - ndim = ndim + 1 - IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cen') - & .OR. (horz_dat(ihorz)(1:1) .EQ. 'U') ) THEN - dn(ndim)(1:1) = 'Y' - dim(ndim) = sNy + 2*OLy - ib(ndim) = OLy + 1 - ie(ndim) = OLy + sNy - ENDIF - IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cor') - & .OR. (horz_dat(ihorz)(1:1) .EQ. 'V') ) THEN - dn(ndim)(1:3) = 'Yp1' - dim(ndim) = sNy + 2*OLy - ib(ndim) = OLy + 1 - ie(ndim) = OLy + sNy + 1 - ENDIF - ENDIF - - ELSEIF (halo_dat(ihalo)(1:5) .EQ. 'Hy ') THEN - - IF (hsub_dat(ihsub)(1:1) .EQ. 'x') THEN - ndim = ndim + 1 - dn(ndim)(1:3) = 'Xwh' - dim(ndim) = sNx + 2*OLx - ib(ndim) = 1 - ie(ndim) = sNx + 2*OLx - ENDIF - IF ((hsub_dat(ihsub)(1:1) .EQ. 'y') - & .OR. (hsub_dat(ihsub)(2:2) .EQ. 'y')) THEN - ndim = ndim + 1 - dn(ndim)(1:3) = 'Ywh' - dim(ndim) = sNy + 2*OLy - ib(ndim) = 1 - ie(ndim) = sNy + 2*OLy - ENDIF - - ENDIF - -C Vertical dimension - IF (vert_dat(ivert)(1:1) .EQ. 'C') THEN - ndim = ndim + 1 - dn(ndim)(1:1) = 'Z' - dim(ndim) = Nr - ib(ndim) = 1 - ie(ndim) = Nr - ENDIF - IF (vert_dat(ivert)(1:1) .EQ. 'I') THEN - ndim = ndim + 1 - dn(ndim)(1:3) = 'Zp1' - dim(ndim) = Nr + 1 - ib(ndim) = 1 - ie(ndim) = Nr + 1 - ENDIF - -C Time dimension - IF (time_dat(itime)(1:1) .EQ. 't') THEN - ndim = ndim + 1 - dn(ndim)(1:1) = 'T' - dim(ndim) = -1 - ib(ndim) = 1 - ie(ndim) = 1 - ENDIF - - IF (ndim .GT. 0) THEN -#ifdef MNC_DEBUG - ncomb = ncomb + 1 - write(*,'(i4,a3,a15,i3,a3,5i4,a4,5i4,a4,5i4,6a4)') - & ncomb, ' : ', name(1:15), ndim, - & ' : ', (dim(i), i=1,5), - & ' | ', (ib(i), i=1,5), - & ' | ', (ie(i), i=1,5), - & ' | ', (dn(i)(1:4), i=1,5) -#endif +C !LOCAL VARIABLES: + integer indv - CALL MNC_CW_ADD_GNAME(myThid, name, ndim, - & dim, dn, ib, ie) - ENDIF +C Check whether vname is defined + CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid) + IF (indv .LT. 1) THEN + CALL MNC_CW_ADD_VNAME(vname, gname, bi_dim, bj_dim, myThid) + ENDIF - ENDDO - ENDDO - 10 CONTINUE - ENDDO - ENDDO - ENDDO - RETURN END C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 0 +C !ROUTINE: MNC_CW_ADD_VNAME +C !INTERFACE: SUBROUTINE MNC_CW_ADD_VNAME( - I myThid, I vname, - I gname ) - + I gname, + I bi_dim, bj_dim, + I myThid ) + +C !DESCRIPTION: +C Add a variable type to the MNC CW layer. The variable type is an +C association between a variable type name and the following items: +C \begin{center} +C \begin{tabular}[h]{|ll|}\hline +C \textbf{Item} & \textbf{Purpose} \\\hline +C grid type & defines the in-memory arrangement \\ +C \texttt{bi,bj} dimensions & tiling indices, if present \\\hline +C \end{tabular} +C \end{center} + +C !USES: implicit none #include "mnc_common.h" #include "EEPARAMS.h" -C Arguments - integer myThid +C !INPUT PARAMETERS: + integer myThid, bi_dim, bj_dim character*(*) vname, gname +CEOP -C Functions - integer IFNBLNK, ILNBLNK - -C Local Variables +C !LOCAL VARIABLES: integer i, nvf,nvl, ngf,ngl, indv,indg character*(MAX_LEN_MBUF) msgbuf +C Functions + integer IFNBLNK, ILNBLNK + nvf = IFNBLNK(vname) nvl = ILNBLNK(vname) ngf = IFNBLNK(gname) ngl = ILNBLNK(gname) C Check that this vname is not already defined - CALL MNC_GET_IND(myThid, MNC_MAX_ID, vname, mnc_cw_vname, indv) + CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid) IF (indv .GT. 0) THEN write(msgbuf,'(3a)') 'MNC_CW_ADD_VNAME ERROR: ''', & vname(nvf:nvl), ''' is already defined' CALL print_error(msgbuf, mythid) stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME' ENDIF - CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_cw_vname, - & indv) + CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_vname, + & indv, myThid) C Check that gname exists - CALL MNC_GET_IND(myThid, MNC_MAX_ID, gname, mnc_cw_gname, indg) + CALL MNC_GET_IND(MNC_MAX_ID, gname, mnc_cw_gname, indg, myThid) IF (indg .LT. 1) THEN write(msgbuf,'(3a)') 'MNC_CW_ADD_VNAME ERROR: ''', & gname(ngf:ngl), ''' is not defined' @@ -373,114 +338,173 @@ DO i = 1,3 mnc_cw_vnat(i,indv) = 0 ENDDO + mnc_cw_vbij(1,indv) = bi_dim + mnc_cw_vbij(2,indv) = bj_dim + +#ifdef MNC_DEBUG_GTYPE + CALL MNC_CW_ADD_VATTR_TEXT(vname,1,'mitgcm_grid',gname, myThid) +#endif RETURN END C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 0 +C !ROUTINE: MNC_CW_DEL_VNAME - SUBROUTINE MNC_CW_ADD_VATTR_TEXT( - I myThid, +C !INTERFACE: + SUBROUTINE MNC_CW_DEL_VNAME( I vname, - I ntat, - I tnames, - I tvals ) + I myThid ) +C !DESCRIPTION: +C Delete a variable type from the MNC CW layer. + +C !USES: implicit none +#include "mnc_common.h" +#include "EEPARAMS.h" -C Arguments - integer myThid, ntat - character*(*) vname, tnames(*), tvals(*) +C !INPUT PARAMETERS: + integer myThid + character*(*) vname +CEOP - CALL MNC_CW_ADD_VATTR_ANY(myThid, vname, - & ntat, 0, 0, - & tnames, ' ', ' ', - & tvals, 0, 0.0D0 ) +C !LOCAL VARIABLES: + integer i, indv + +C Check that this vname is not already defined + CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid) + IF (indv .LT. 1) THEN + RETURN + ENDIF + + mnc_cw_vname(indv)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR) + mnc_cw_vgind(indv) = 0 + DO i = 1,3 + mnc_cw_vnat(i,indv) = 0 + ENDDO RETURN END C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +C !ROUTINE: MNC_CW_ADD_VATTR_TEXT +C !INTERFACE: + SUBROUTINE MNC_CW_ADD_VATTR_TEXT( + I vname, tname, tval, + I myThid ) - SUBROUTINE MNC_CW_ADD_VATTR_INT( - I myThid, - I vname, - I niat, - I inames, - I ivals ) - +C !DESCRIPTION: +C Add a text attribute + +C !USES: implicit none -C Arguments - integer myThid, niat - character*(*) vname, inames(*) - integer ivals(*) - - CALL MNC_CW_ADD_VATTR_ANY(myThid, vname, - & 0, niat, 0, - & ' ', inames, ' ', - & ' ', ivals, 0.0D0 ) - +C !INPUT PARAMETERS: + integer myThid + character*(*) vname, tname, tval + integer ival + REAL*8 dval +CEOP + ival = 0 + dval = 0.0D0 + CALL MNC_CW_ADD_VATTR_ANY(vname, 1, + & tname, ' ', ' ', tval, ival, dval, myThid ) RETURN END - C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +C !ROUTINE: MNC_CW_ADD_VATTR_INT +C !INTERFACE: + SUBROUTINE MNC_CW_ADD_VATTR_INT( + I vname, iname, ival, + I myThid ) - SUBROUTINE MNC_CW_ADD_VATTR_DBL( - I myThid, - I vname, - I ndat, - I dnames, - I dvals ) +C !DESCRIPTION: +C Add integer attribute +C !USES: implicit none -C Arguments - integer myThid, ndat - character*(*) vname, dnames(*) - REAL*8 dvals(*) +C !INPUT PARAMETERS: + integer myThid + character*(*) vname, iname + integer ival + REAL*8 dval +CEOP + dval = 0.0D0 + CALL MNC_CW_ADD_VATTR_ANY(vname, 2, + & ' ', iname, ' ', ' ', ival, dval, myThid ) + RETURN + END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +C !ROUTINE: MNC_CW_ADD_VATTR_DBL +C !INTERFACE: + SUBROUTINE MNC_CW_ADD_VATTR_DBL( + I vname, dname, dval, + I myThid ) + +C !DESCRIPTION: +C Add double-precision real attribute - CALL MNC_CW_ADD_VATTR_ANY(myThid, vname, - & 0, 0, ndat, - & ' ', ' ', dnames, - & ' ', 0, dvals ) +C !USES: + implicit none +C !INPUT PARAMETERS: + integer myThid + character*(*) vname, dname + integer ival + REAL*8 dval +CEOP + ival = 0 + CALL MNC_CW_ADD_VATTR_ANY(vname, 3, + & ' ', ' ', dname, ' ', ival, dval, myThid ) RETURN END - C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_CW_ADD_VATTR_ANY +C !INTERFACE: SUBROUTINE MNC_CW_ADD_VATTR_ANY( - I myThid, I vname, - I ntat, niat, ndat, - I tnames, inames, dnames, - I tvals, ivals, dvals ) + I atype, + I tname, iname, dname, + I tval, ival, dval, + I myThid ) + +C !DESCRIPTION: +C !USES: implicit none #include "mnc_common.h" #include "EEPARAMS.h" -C Arguments - integer myThid, ntat, niat, ndat +C !INPUT PARAMETERS: + integer myThid + integer atype character*(*) vname - character*(*) tnames(*), inames(*), dnames(*) - character*(*) tvals(*) - integer ivals(*) - REAL*8 dvals(*) + character*(*) tname, iname, dname + character*(*) tval + integer ival + REAL*8 dval +CEOP + +C !LOCAL VARIABLES: + integer n, nvf,nvl, n1,n2, indv + character*(MAX_LEN_MBUF) msgbuf C Functions integer IFNBLNK, ILNBLNK -C Local Variables - integer i, n, nvf,nvl, n1,n2, indv - character*(MAX_LEN_MBUF) msgbuf - nvf = IFNBLNK(vname) nvl = ILNBLNK(vname) C Check that vname is defined - CALL MNC_GET_IND(myThid, MNC_MAX_ID, vname, mnc_cw_vname, indv) + CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid) IF (indv .LT. 1) THEN write(msgbuf,'(3a)') 'MNC_CW_ADD_VATTR_ANY ERROR: ''', & vname(nvf:nvl), ''' is not defined' @@ -488,56 +512,80 @@ stop 'ABNORMAL END: S/R MNC_CW_ADD_VATTR_ANY' ENDIF -C Text Attributes - n = mnc_cw_vnat(1,indv) - DO i = 1,ntat - n1 = IFNBLNK(tnames(i)) - n2 = ILNBLNK(tnames(i)) - mnc_cw_vtnm(n+i,indv)(1:(n2-n1+1)) = tnames(i)(n1:n2) - n1 = IFNBLNK(tvals(i)) - n2 = ILNBLNK(tvals(i)) - mnc_cw_vtat(n+i,indv)(1:(n2-n1+1)) = tvals(i)(n1:n2) - ENDDO - mnc_cw_vnat(1,indv) = n + ntat - -C Integer Attributes - n = mnc_cw_vnat(2,indv) - DO i = 1,niat - n1 = IFNBLNK(inames(i)) - n2 = ILNBLNK(inames(i)) - mnc_cw_vinm(n+i,indv)(1:(n2-n1+1)) = inames(i)(n1:n2) - mnc_cw_viat(n+i,indv) = ivals(i) - ENDDO - mnc_cw_vnat(2,indv) = n + niat - -C Double Attributes - n = mnc_cw_vnat(3,indv) - DO i = 1,ndat - n1 = IFNBLNK(dnames(i)) - n2 = ILNBLNK(dnames(i)) - mnc_cw_vdnm(n+i,indv)(1:(n2-n1+1)) = dnames(i)(n1:n2) - mnc_cw_vdat(n+i,indv) = dvals(i) - ENDDO - mnc_cw_vnat(3,indv) = n + ndat + IF (atype .EQ. 1) THEN +C Text Attribute + n = mnc_cw_vnat(1,indv) + 1 + n1 = IFNBLNK(tname) + n2 = ILNBLNK(tname) +C write(*,*) atype,tname(n1:n2) + mnc_cw_vtnm(n,indv)(1:MNC_MAX_CHAR) = + & mnc_blank_name(1:MNC_MAX_CHAR) + mnc_cw_vtnm(n,indv)(1:(n2-n1+1)) = tname(n1:n2) + n1 = IFNBLNK(tval) + n2 = ILNBLNK(tval) + IF ((n1 .EQ. 0) .OR. (n2 .EQ. 0)) THEN + mnc_cw_vtat(n,indv)(1:MNC_MAX_CHAR) = + & mnc_blank_name(1:MNC_MAX_CHAR) + mnc_cw_vnat(1,indv) = n + ELSE + mnc_cw_vtat(n,indv)(1:MNC_MAX_CHAR) = + & mnc_blank_name(1:MNC_MAX_CHAR) + mnc_cw_vtat(n,indv)(1:(n2-n1+1)) = tval(n1:n2) + mnc_cw_vnat(1,indv) = n + ENDIF + ENDIF + + IF (atype .EQ. 2) THEN +C Integer Attribute + n = mnc_cw_vnat(2,indv) + 1 + n1 = IFNBLNK(iname) + n2 = ILNBLNK(iname) +C write(*,*) atype,iname(n1:n2) + mnc_cw_vinm(n,indv)(1:(n2-n1+1)) = iname(n1:n2) + mnc_cw_viat(n,indv) = ival + mnc_cw_vnat(2,indv) = n + ENDIF + IF (atype .EQ. 3) THEN +C Double Attribute + n = mnc_cw_vnat(3,indv) + 1 + n1 = IFNBLNK(dname) + n2 = ILNBLNK(dname) +C write(*,*) atype,dname(n1:n2) + mnc_cw_vdnm(n,indv)(1:(n2-n1+1)) = dname(n1:n2) + mnc_cw_vdat(n,indv) = dval + mnc_cw_vnat(3,indv) = n + ENDIF + RETURN END C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP 1 +C !ROUTINE: MNC_CW_GET_TILE_NUM +C !INTERFACE: SUBROUTINE MNC_CW_GET_TILE_NUM( - I myThid, I bi, bj, - O uniq_tnum ) + O uniq_tnum, + I myThid ) + +C !DESCRIPTION: +C !USES: implicit none #include "EEPARAMS.h" #include "SIZE.h" +#ifdef ALLOW_EXCH2 +#include "W2_EXCH2_TOPOLOGY.h" +#include "W2_EXCH2_PARAMS.h" +#endif -C Arguments +C !INPUT PARAMETERS: integer myThid, bi,bj, uniq_tnum +CEOP -C Local Variables +C !LOCAL VARIABLES: integer iG,jG iG = 0 @@ -545,7 +593,6 @@ #ifdef ALLOW_EXCH2 -#include "W2_EXCH2_PARAMS.h" uniq_tnum = W2_myTileList(bi) #else @@ -564,42 +611,51 @@ END C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| - +CBOP 1 +C !ROUTINE: MNC_CW_FILE_AORC + +C !INTERFACE: SUBROUTINE MNC_CW_FILE_AORC( - I myThid, I fname, - O indf ) + O indf, + I lbi, lbj, uniq_tnum, + I myThid ) + +C !DESCRIPTION: +C Open a NetCDF file, appending to the file if it already exists +C and, if not, creating a new file. +C !USES: implicit none #include "netcdf.inc" #include "mnc_common.h" #include "EEPARAMS.h" -C Arguments - integer myThid, indf +C !INPUT PARAMETERS: + integer myThid, indf, lbi, lbj, uniq_tnum character*(*) fname +CEOP -C Local Variables - integer i, ierr - character*(MAX_LEN_MBUF) msgbuf +C !LOCAL VARIABLES: + integer ierr C Check if the file is already 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 .GT. 0) THEN RETURN ENDIF C Try to open an existing file - CALL MNC_FILE_TRY_READ(myThid, fname, ierr, indf) - IF (ierr .EQ. NF_NOERR) THEN - RETURN + CALL MNC_FILE_TRY_READ(fname, ierr, indf, myThid) + IF (ierr .NE. NF_NOERR) THEN +C Try to create a new one + CALL MNC_FILE_OPEN(fname, 0, indf, myThid) ENDIF -C Try to create a new one - CALL MNC_FILE_OPEN(myThid, fname, 0, indf) +C Add the global attributes + CALL MNC_CW_SET_GATTR(fname, lbi,lbj, uniq_tnum, myThid) RETURN END C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| -