pkg/mnc/mnc_cwrapper.F

C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_cwrapper.F,v 1.28 2006/03/30 02:56:14 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     name, 
     I     ndim, 
     I     dlens, 
     I     dnames, 
     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     !INPUT PARAMETERS:
      integer myThid, ndim
      character*(*) name
      integer dlens(*), inds_beg(*), inds_end(*)
      character*(*) dnames(*)
CEOP

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(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(MNC_MAX_ID, mnc_cw_gname, 
     &     '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)
      mnc_cw_ndim(indg) = ndim

      DO i = 1,ndim
        mnc_cw_dn(i,indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
        nnf = IFNBLNK(dnames(i))
        nnl = ILNBLNK(dnames(i))
        mnc_cw_dn(i,indg)(1:(nnl-nnf+1)) = dnames(i)(nnf:nnl)
        mnc_cw_dims(i,indg) = dlens(i)
        mnc_cw_is(i,indg)   = inds_beg(i)
        mnc_cw_ie(i,indg)   = inds_end(i)
      ENDDO

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 0
C     !ROUTINE: MNC_CW_DEL_GNAME

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     !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)

      _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
          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:7), i=1,5)
          CALL PRINT_MESSAGE(
     &         s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
          
        ENDIF
      ENDDO
      
      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
          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)
            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:MNC_MAX_CHAR)
            CALL PRINT_MESSAGE(
     &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
          ENDDO
          DO i = 1,mnc_cw_vnat(2,j)
            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)
            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)
            CALL PRINT_MESSAGE(
     &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
        ENDDO
        
        ENDIF
      ENDDO
      IF (ntot .EQ. 0) THEN
        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

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"

C     !INPUT PARAMETERS:
      integer myThid, bi_dim, bj_dim
      character*(*) vname, gname
CEOP

C     !LOCAL VARIABLES:
      integer indv

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


      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     vname, 
     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     !INPUT PARAMETERS:
      integer myThid, bi_dim, bj_dim
      character*(*) vname, gname
CEOP

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(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(MNC_MAX_ID, mnc_cw_vname, 
     &     'mnc_cw_vname', indv, myThid)

C     Check that gname exists
      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'
        CALL print_error(msgbuf, mythid)
        stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'
      ENDIF

      mnc_cw_vname(indv)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
      mnc_cw_vname(indv)(1:(nvl-nvf+1)) = vname(nvf:nvl)
      mnc_cw_vgind(indv) = indg
      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

C     !INTERFACE:
      SUBROUTINE MNC_CW_DEL_VNAME( 
     I     vname, 
     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     !INPUT PARAMETERS:
      integer myThid
      character*(*) vname
CEOP

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 )

C     !DESCRIPTION:
C     Add a text attribute
      
C     !USES:
      implicit none

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 )

C     !DESCRIPTION:
C     Add integer attribute

C     !USES:
      implicit none

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 

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     vname, 
     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     !INPUT PARAMETERS:
      integer myThid
      integer atype
      character*(*) vname
      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

      nvf = IFNBLNK(vname)
      nvl = ILNBLNK(vname)

C     Check that vname is defined
      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'
        CALL print_error(msgbuf, mythid)
        stop 'ABNORMAL END: S/R MNC_CW_ADD_VATTR_ANY'
      ENDIF

      IF (atype .EQ. 1) THEN
C       Text Attribute
        n = mnc_cw_vnat(1,indv) + 1
        n1 = IFNBLNK(tname)
        n2 = ILNBLNK(tname)
        IF ((n2-n1+1) .GT. MNC_MAX_CHAR) THEN
          write(msgbuf,'(3a,i6,a)') 
     &         'MNC_CW_ADD_VATTR_ANY WARNING: attribute name ''',
     &         tname(n1:n2), ''' has more than ', MNC_MAX_CHAR,
     &         ' characters and has been truncated to fit'
          CALL PRINT_MESSAGE( msgbuf, errorMessageUnit,
     &                        SQUEEZE_RIGHT , myThid)
C         MNC_MAX_CHAR = n2 - n1 + 1
          n2 = MNC_MAX_CHAR + n1 - 1
        ENDIF
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 ((n2-n1+1) .GT. MNC_MAX_CHAR) THEN
          write(msgbuf,'(3a,i6,a)') 
     &         'MNC_CW_ADD_VATTR_ANY WARNING: attribute value ''',
     &         tval(n1:n2), ''' has more than ', MNC_MAX_CHAR,
     &         ' characters and has been truncated to fit'
          CALL PRINT_MESSAGE( msgbuf, errorMessageUnit,
     &                        SQUEEZE_RIGHT , myThid)
          n2 = MNC_MAX_CHAR + n1 - 1
        ENDIF

        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     bi, bj, 
     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     !INPUT PARAMETERS:
      integer myThid, bi,bj, uniq_tnum
CEOP

C     !LOCAL VARIABLES:
      integer iG,jG

      iG = 0
      jG = 0

#ifdef ALLOW_EXCH2

      uniq_tnum = W2_myTileList(bi)

#else

C     Global tile number for simple (non-cube) domains
      iG = bi+(myXGlobalLo-1)/sNx
      jG = bj+(myYGlobalLo-1)/sNy

      uniq_tnum = (jG - 1)*(nPx*nSx) + iG

#endif

CEH3      write(*,*) 'iG,jG,uniq_tnum :', iG,jG,uniq_tnum

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 1
C     !ROUTINE: MNC_CW_GET_FACE_NUM

C     !INTERFACE:
      SUBROUTINE MNC_CW_GET_FACE_NUM( 
     I     bi, bj, 
     O     uniq_fnum, 
     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     !INPUT PARAMETERS:
      integer myThid, bi,bj, uniq_fnum
CEOP

#ifdef ALLOW_EXCH2

      uniq_fnum = exch2_myFace( W2_myTileList(bi) )

#else

C     Global face number for simple (EXCH "1") domains
      uniq_fnum = -1

#endif

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 1
C     !ROUTINE: MNC_CW_GET_XYFO

C     !INTERFACE:
      SUBROUTINE MNC_CW_GET_XYFO( 
     I     bi, bj, 
     O     ixoff, iyoff, 
     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     !INPUT PARAMETERS:
      integer myThid, bi,bj, ixoff,iyoff
CEOP

C     !LOCAL VARIABLES:
      integer uniq_tnum

#ifdef ALLOW_EXCH2

      uniq_tnum = W2_myTileList(bi)
      ixoff = exch2_tbasex( uniq_tnum )
      iyoff = exch2_tbasey( uniq_tnum )

#else

C     Global tile number for simple (non-cube) domains
C     iG = bi+(myXGlobalLo-1)/sNx
C     jG = bj+(myYGlobalLo-1)/sNy
C     uniq_tnum = (jG - 1)*(nPx*nSx) + iG
      ixoff = myXGlobalLo + bi * sNx
      iyoff = myYGlobalLo + bj * sNy

#endif

      RETURN
      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     fname, 
     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     !INPUT PARAMETERS:
      integer myThid, indf, lbi, lbj, uniq_tnum
      character*(*) fname
CEOP

C     !LOCAL VARIABLES:
      integer ierr

C     Check if the file is already open
      CALL MNC_GET_IND(MNC_MAX_FID, 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(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     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-|--+----|
1	jmc	1.29	C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_cwrapper.F,v 1.28 2006/03/30 02:56:14 edhill Exp $
2	edhill	1.1	C $Name: $
3
4			#include "MNC_OPTIONS.h"
5
6			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
7	edhill	1.12	CBOP 0
8	edhill	1.11	C !ROUTINE: MNC_CW_ADD_GNAME
9	edhill	1.1
10	edhill	1.11	C !INTERFACE:
11	edhill	1.2	SUBROUTINE MNC_CW_ADD_GNAME(
12	edhill	1.1	I name,
13			I ndim,
14			I dlens,
15			I dnames,
16	edhill	1.9	I inds_beg, inds_end,
17			I myThid )
18	edhill	1.1
19	edhill	1.11	C !DESCRIPTION:
20			C Add a grid name to the MNC convenience wrapper layer.
21
22			C !USES:
23	edhill	1.1	implicit none
24			#include "mnc_common.h"
25			#include "EEPARAMS.h"
26
27	edhill	1.11	C !INPUT PARAMETERS:
28	edhill	1.1	integer myThid, ndim
29			character() name
30	edhill	1.20	integer dlens(), inds_beg(), inds_end(*)
31			character() dnames(*)
32	edhill	1.12	CEOP
33	edhill	1.1
34	edhill	1.11	C !LOCAL VARIABLES:
35			integer i, nnf,nnl, indg
36			character*(MAX_LEN_MBUF) msgbuf
37	edhill	1.12
38	edhill	1.2	C Functions
39			integer IFNBLNK, ILNBLNK
40
41	edhill	1.1	nnf = IFNBLNK(name)
42			nnl = ILNBLNK(name)
43
44			C Check that this name is not already defined
45	edhill	1.9	CALL MNC_GET_IND(MNC_MAX_ID, name, mnc_cw_gname, indg, myThid)
46	edhill	1.1	IF (indg .GT. 0) THEN
47	edhill	1.2	write(msgbuf,'(3a)') 'MNC_CW_ADD_GNAME ERROR: ''', name,
48	edhill	1.1	& ''' is already defined'
49			CALL print_error(msgbuf, mythid)
50	edhill	1.2	stop 'ABNORMAL END: S/R MNC_CW_ADD_GNAME'
51	edhill	1.1	ENDIF
52	edhill	1.9	CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_gname,
53	edhill	1.26	& 'mnc_cw_gname', indg, myThid)
54	edhill	1.1
55	edhill	1.2	mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
56			mnc_cw_gname(indg)(1:(nnl-nnf+1)) = name(nnf:nnl)
57	edhill	1.1	mnc_cw_ndim(indg) = ndim
58
59			DO i = 1,ndim
60			mnc_cw_dn(i,indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
61			nnf = IFNBLNK(dnames(i))
62			nnl = ILNBLNK(dnames(i))
63			mnc_cw_dn(i,indg)(1:(nnl-nnf+1)) = dnames(i)(nnf:nnl)
64			mnc_cw_dims(i,indg) = dlens(i)
65			mnc_cw_is(i,indg) = inds_beg(i)
66			mnc_cw_ie(i,indg) = inds_end(i)
67			ENDDO
68
69			RETURN
70			END
71
72	edhill	1.2	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
73	edhill	1.15	CBOP 0
74			C !ROUTINE: MNC_CW_DEL_GNAME
75
76			C !INTERFACE:
77			SUBROUTINE MNC_CW_DEL_GNAME(
78			I name,
79			I myThid )
80
81			C !DESCRIPTION:
82			C Delete a grid name from the MNC convenience wrapper layer.
83
84			C !USES:
85			implicit none
86			#include "mnc_common.h"
87			#include "EEPARAMS.h"
88
89			C !INPUT PARAMETERS:
90			integer myThid
91			character() name
92			CEOP
93
94			C !LOCAL VARIABLES:
95			integer nnf,nnl, indg
96
97			C Functions
98			integer IFNBLNK, ILNBLNK
99
100			nnf = IFNBLNK(name)
101			nnl = ILNBLNK(name)
102
103			C Check that this name is not already defined
104			CALL MNC_GET_IND(MNC_MAX_ID, name, mnc_cw_gname, indg, myThid)
105			IF (indg .LT. 1) THEN
106			RETURN
107			ENDIF
108
109			mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
110			mnc_cw_ndim(indg) = 0
111
112			RETURN
113			END
114
115			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
116	edhill	1.12	CBOP 1
117	edhill	1.11	C !ROUTINE: MNC_CW_DUMP
118	edhill	1.2
119	edhill	1.11	C !INTERFACE:
120	edhill	1.10	SUBROUTINE MNC_CW_DUMP( myThid )
121	edhill	1.2
122	edhill	1.11	C !DESCRIPTION:
123			C Write a condensed view of the current state of the MNC look-up
124			C tables for the convenience wrapper section.
125
126			C !USES:
127	edhill	1.2	implicit none
128			#include "mnc_common.h"
129	edhill	1.10	#include "SIZE.h"
130			#include "EEPARAMS.h"
131			#include "PARAMS.h"
132
133	edhill	1.11	C !INPUT PARAMETERS:
134	edhill	1.10	integer myThid
135	edhill	1.12	CEOP
136	edhill	1.2
137	edhill	1.11	C !LOCAL VARIABLES:
138	edhill	1.2	integer i,j, ntot
139	edhill	1.10	integer NBLNK
140			parameter ( NBLNK = 150 )
141			character s1(NBLNK), blnk(NBLNK)
142
143			_BEGIN_MASTER(myThid)
144
145			DO i = 1,NBLNK
146			blnk(i:i) = ' '
147			ENDDO
148
149			s1(1:NBLNK) = blnk(1:NBLNK)
150			write(s1,'(a5,a)') 'MNC: ',
151			& 'The currently defined Grid Types are:'
152			CALL PRINT_MESSAGE(
153			& s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
154	edhill	1.2	ntot = 0
155			DO j = 1,MNC_MAX_ID
156			IF (mnc_cw_gname(j)(1:MNC_MAX_CHAR)
157			& .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
158
159			ntot = ntot + 1
160	edhill	1.10	s1(1:NBLNK) = blnk(1:NBLNK)
161	edhill	1.14	write(s1,'(a5,2i5,a3,a20,i3,a3,5i4,a4,5i4,a4,5i4,6a8)')
162	edhill	1.10	& 'MNC: ',
163	edhill	1.2	& j, ntot, ' : ', mnc_cw_gname(j)(1:20), mnc_cw_ndim(j),
164			& ' : ', (mnc_cw_dims(i,j), i=1,5),
165			& ' \| ', (mnc_cw_is(i,j), i=1,5),
166			& ' \| ', (mnc_cw_ie(i,j), i=1,5),
167	edhill	1.14	& ' \| ', (mnc_cw_dn(i,j)(1:7), i=1,5)
168	edhill	1.10	CALL PRINT_MESSAGE(
169			& s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
170
171	edhill	1.2	ENDIF
172			ENDDO
173	edhill	1.10
174			s1(1:NBLNK) = blnk(1:NBLNK)
175			write(s1,'(a5,a)') 'MNC: ',
176			& 'The currently defined Variable Types are:'
177			CALL PRINT_MESSAGE(
178			& s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
179	edhill	1.3	ntot = 0
180			DO j = 1,MNC_MAX_ID
181			IF (mnc_cw_vname(j)(1:MNC_MAX_CHAR)
182			& .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
183	edhill	1.10
184	edhill	1.3	ntot = ntot + 1
185	edhill	1.10	s1(1:NBLNK) = blnk(1:NBLNK)
186			write(s1,'(a5,2i5,a3,a25,a3,i4)') 'MNC: ',
187			& j, ntot, ' \| ',
188			& mnc_cw_vname(j)(1:20), ' \| ', mnc_cw_vgind(j)
189			CALL PRINT_MESSAGE(
190			& s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
191
192	edhill	1.3	DO i = 1,mnc_cw_vnat(1,j)
193	edhill	1.10	s1(1:NBLNK) = blnk(1:NBLNK)
194			write(s1,'(a5,a14,i4,a3,a25,a3,a55)')
195			& 'MNC: ',' text_at:',i,
196	edhill	1.3	& ' : ', mnc_cw_vtnm(i,j)(1:25), ' : ',
197	edhill	1.26	& mnc_cw_vtat(i,j)(1:MNC_MAX_CHAR)
198	edhill	1.10	CALL PRINT_MESSAGE(
199			& s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
200	edhill	1.3	ENDDO
201			DO i = 1,mnc_cw_vnat(2,j)
202	edhill	1.10	s1(1:NBLNK) = blnk(1:NBLNK)
203			write(s1,'(a5,a14,i4,a3,a25,a3,i20)')
204			& 'MNC: ',' int__at:',i,
205	edhill	1.3	& ' : ', mnc_cw_vinm(i,j)(1:25), ' : ',
206			& mnc_cw_viat(i,j)
207	edhill	1.10	CALL PRINT_MESSAGE(
208			& s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
209	edhill	1.3	ENDDO
210			DO i = 1,mnc_cw_vnat(3,j)
211	edhill	1.10	s1(1:NBLNK) = blnk(1:NBLNK)
212			write(s1,'(a5,a14,i4,a3,a25,a3,f25.10)')
213			& 'MNC: ',' dbl__at:',i,
214	edhill	1.3	& ' : ', mnc_cw_vdnm(i,j)(1:25), ' : ',
215			& mnc_cw_vdat(i,j)
216	edhill	1.10	CALL PRINT_MESSAGE(
217			& s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
218			ENDDO
219
220	edhill	1.3	ENDIF
221			ENDDO
222			IF (ntot .EQ. 0) THEN
223	edhill	1.10	s1(1:NBLNK) = blnk(1:NBLNK)
224			write(s1,'(a)') 'MNC: None defined!'
225			CALL PRINT_MESSAGE(
226			& s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
227	edhill	1.3	ENDIF
228	edhill	1.10
229			_END_MASTER(myThid)
230	edhill	1.3
231	edhill	1.2	RETURN
232			END
233	edhill	1.1
234			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
235	edhill	1.12	CBOP 0
236	edhill	1.13	C !ROUTINE: MNC_CW_APPEND_VNAME
237
238			C !INTERFACE:
239			SUBROUTINE MNC_CW_APPEND_VNAME(
240			I vname,
241			I gname,
242			I bi_dim, bj_dim,
243			I myThid )
244
245			C !DESCRIPTION:
246			C If it is not yet defined within the MNC CW layer, append a
247			C variable type. Calls MNC\_CW\_ADD\_VNAME().
248
249			C !USES:
250			implicit none
251			#include "mnc_common.h"
252
253			C !INPUT PARAMETERS:
254			integer myThid, bi_dim, bj_dim
255			character() vname, gname
256			CEOP
257
258			C !LOCAL VARIABLES:
259			integer indv
260
261			C Check whether vname is defined
262			CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
263			IF (indv .LT. 1) THEN
264			CALL MNC_CW_ADD_VNAME(vname, gname, bi_dim, bj_dim, myThid)
265			ENDIF
266
267
268			RETURN
269			END
270
271			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
272			CBOP 0
273	edhill	1.11	C !ROUTINE: MNC_CW_ADD_VNAME
274	edhill	1.2
275	edhill	1.11	C !INTERFACE:
276	edhill	1.2	SUBROUTINE MNC_CW_ADD_VNAME(
277			I vname,
278	edhill	1.5	I gname,
279	edhill	1.9	I bi_dim, bj_dim,
280			I myThid )
281	edhill	1.2
282	edhill	1.13	C !DESCRIPTION:
283			C Add a variable type to the MNC CW layer. The variable type is an
284			C association between a variable type name and the following items:
285	edhill	1.12	C \begin{center}
286			C \begin{tabular}[h]{\|ll\|}\hline
287			C \textbf{Item} & \textbf{Purpose} \\\hline
288			C grid type & defines the in-memory arrangement \\
289			C \texttt{bi,bj} dimensions & tiling indices, if present \\\hline
290			C \end{tabular}
291			C \end{center}
292
293	edhill	1.11	C !USES:
294	edhill	1.2	implicit none
295			#include "mnc_common.h"
296			#include "EEPARAMS.h"
297
298	edhill	1.11	C !INPUT PARAMETERS:
299	edhill	1.5	integer myThid, bi_dim, bj_dim
300	edhill	1.2	character() vname, gname
301	edhill	1.12	CEOP
302	edhill	1.2
303	edhill	1.11	C !LOCAL VARIABLES:
304			integer i, nvf,nvl, ngf,ngl, indv,indg
305			character*(MAX_LEN_MBUF) msgbuf
306	edhill	1.12
307	edhill	1.2	C Functions
308			integer IFNBLNK, ILNBLNK
309
310			nvf = IFNBLNK(vname)
311			nvl = ILNBLNK(vname)
312			ngf = IFNBLNK(gname)
313			ngl = ILNBLNK(gname)
314
315			C Check that this vname is not already defined
316	edhill	1.9	CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
317	edhill	1.2	IF (indv .GT. 0) THEN
318			write(msgbuf,'(3a)') 'MNC_CW_ADD_VNAME ERROR: ''',
319			& vname(nvf:nvl), ''' is already defined'
320			CALL print_error(msgbuf, mythid)
321			stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'
322			ENDIF
323	edhill	1.9	CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_vname,
324	edhill	1.26	& 'mnc_cw_vname', indv, myThid)
325	edhill	1.2
326			C Check that gname exists
327	edhill	1.9	CALL MNC_GET_IND(MNC_MAX_ID, gname, mnc_cw_gname, indg, myThid)
328	edhill	1.2	IF (indg .LT. 1) THEN
329			write(msgbuf,'(3a)') 'MNC_CW_ADD_VNAME ERROR: ''',
330			& gname(ngf:ngl), ''' is not defined'
331			CALL print_error(msgbuf, mythid)
332			stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'
333			ENDIF
334
335			mnc_cw_vname(indv)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
336			mnc_cw_vname(indv)(1:(nvl-nvf+1)) = vname(nvf:nvl)
337			mnc_cw_vgind(indv) = indg
338			DO i = 1,3
339			mnc_cw_vnat(i,indv) = 0
340			ENDDO
341	edhill	1.5	mnc_cw_vbij(1,indv) = bi_dim
342			mnc_cw_vbij(2,indv) = bj_dim
343	edhill	1.6
344	edhill	1.18	#ifdef MNC_DEBUG_GTYPE
345	edhill	1.9	CALL MNC_CW_ADD_VATTR_TEXT(vname,1,'mitgcm_grid',gname, myThid)
346	edhill	1.18	#endif
347	edhill	1.2
348			RETURN
349			END
350
351			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
352	edhill	1.12	CBOP 0
353	edhill	1.15	C !ROUTINE: MNC_CW_DEL_VNAME
354
355			C !INTERFACE:
356			SUBROUTINE MNC_CW_DEL_VNAME(
357			I vname,
358			I myThid )
359
360			C !DESCRIPTION:
361			C Delete a variable type from the MNC CW layer.
362
363			C !USES:
364			implicit none
365			#include "mnc_common.h"
366			#include "EEPARAMS.h"
367
368			C !INPUT PARAMETERS:
369			integer myThid
370			character() vname
371			CEOP
372
373			C !LOCAL VARIABLES:
374			integer i, indv
375
376			C Check that this vname is not already defined
377			CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
378			IF (indv .LT. 1) THEN
379			RETURN
380			ENDIF
381
382			mnc_cw_vname(indv)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
383			mnc_cw_vgind(indv) = 0
384			DO i = 1,3
385			mnc_cw_vnat(i,indv) = 0
386			ENDDO
387
388			RETURN
389			END
390
391			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
392	edhill	1.20	CBOP
393	edhill	1.11	C !ROUTINE: MNC_CW_ADD_VATTR_TEXT
394			C !INTERFACE:
395	edhill	1.3	SUBROUTINE MNC_CW_ADD_VATTR_TEXT(
396	edhill	1.20	I vname, tname, tval,
397	edhill	1.9	I myThid )
398	edhill	1.3
399	edhill	1.11	C !DESCRIPTION:
400			C Add a text attribute
401
402			C !USES:
403	edhill	1.3	implicit none
404
405	edhill	1.11	C !INPUT PARAMETERS:
406	edhill	1.19	integer myThid
407			character() vname, tname, tval
408	edhill	1.20	integer ival
409			REAL*8 dval
410	edhill	1.11	CEOP
411	edhill	1.20	ival = 0
412			dval = 0.0D0
413			CALL MNC_CW_ADD_VATTR_ANY(vname, 1,
414			& tname, ' ', ' ', tval, ival, dval, myThid )
415	edhill	1.3	RETURN
416			END
417			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
418	edhill	1.11	CBOP
419			C !ROUTINE: MNC_CW_ADD_VATTR_INT
420			C !INTERFACE:
421	edhill	1.3	SUBROUTINE MNC_CW_ADD_VATTR_INT(
422	edhill	1.20	I vname, iname, ival,
423	edhill	1.9	I myThid )
424	edhill	1.3
425	edhill	1.11	C !DESCRIPTION:
426	edhill	1.20	C Add integer attribute
427	edhill	1.11
428			C !USES:
429	edhill	1.3	implicit none
430
431	edhill	1.11	C !INPUT PARAMETERS:
432	edhill	1.19	integer myThid
433			character() vname, iname
434			integer ival
435	edhill	1.20	REAL*8 dval
436	edhill	1.11	CEOP
437	edhill	1.20	dval = 0.0D0
438			CALL MNC_CW_ADD_VATTR_ANY(vname, 2,
439			& ' ', iname, ' ', ' ', ival, dval, myThid )
440	edhill	1.3	RETURN
441			END
442			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
443	edhill	1.20	CBOP
444	edhill	1.11	C !ROUTINE: MNC_CW_ADD_VATTR_DBL
445			C !INTERFACE:
446	edhill	1.3	SUBROUTINE MNC_CW_ADD_VATTR_DBL(
447	edhill	1.20	I vname, dname, dval,
448	edhill	1.9	I myThid )
449	edhill	1.3
450	edhill	1.11	C !DESCRIPTION:
451	edhill	1.20	C Add double-precision real attribute
452	edhill	1.11
453			C !USES:
454	edhill	1.3	implicit none
455
456	edhill	1.11	C !INPUT PARAMETERS:
457	edhill	1.19	integer myThid
458			character() vname, dname
459	edhill	1.20	integer ival
460	edhill	1.19	REAL*8 dval
461	edhill	1.11	CEOP
462	edhill	1.20	ival = 0
463			CALL MNC_CW_ADD_VATTR_ANY(vname, 3,
464			& ' ', ' ', dname, ' ', ival, dval, myThid )
465	edhill	1.3	RETURN
466			END
467			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
468	edhill	1.12	CBOP 1
469	edhill	1.11	C !ROUTINE: MNC_CW_ADD_VATTR_ANY
470	edhill	1.3
471	edhill	1.11	C !INTERFACE:
472	edhill	1.2	SUBROUTINE MNC_CW_ADD_VATTR_ANY(
473			I vname,
474	edhill	1.20	I atype,
475	edhill	1.19	I tname, iname, dname,
476			I tval, ival, dval,
477	edhill	1.9	I myThid )
478	edhill	1.2
479	edhill	1.11	C !DESCRIPTION:
480
481			C !USES:
482	edhill	1.2	implicit none
483			#include "mnc_common.h"
484			#include "EEPARAMS.h"
485
486	edhill	1.11	C !INPUT PARAMETERS:
487	edhill	1.19	integer myThid
488	edhill	1.20	integer atype
489	edhill	1.2	character() vname
490	edhill	1.19	character() tname, iname, dname
491			character() tval
492			integer ival
493			REAL*8 dval
494	edhill	1.12	CEOP
495	edhill	1.2
496	edhill	1.11	C !LOCAL VARIABLES:
497	edhill	1.19	integer n, nvf,nvl, n1,n2, indv
498	edhill	1.11	character*(MAX_LEN_MBUF) msgbuf
499	edhill	1.12
500	edhill	1.2	C Functions
501			integer IFNBLNK, ILNBLNK
502
503			nvf = IFNBLNK(vname)
504			nvl = ILNBLNK(vname)
505
506			C Check that vname is defined
507	edhill	1.9	CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
508	edhill	1.2	IF (indv .LT. 1) THEN
509			write(msgbuf,'(3a)') 'MNC_CW_ADD_VATTR_ANY ERROR: ''',
510			& vname(nvf:nvl), ''' is not defined'
511			CALL print_error(msgbuf, mythid)
512			stop 'ABNORMAL END: S/R MNC_CW_ADD_VATTR_ANY'
513			ENDIF
514
515	edhill	1.20	IF (atype .EQ. 1) THEN
516			C Text Attribute
517			n = mnc_cw_vnat(1,indv) + 1
518			n1 = IFNBLNK(tname)
519			n2 = ILNBLNK(tname)
520	edhill	1.28	IF ((n2-n1+1) .GT. MNC_MAX_CHAR) THEN
521			write(msgbuf,'(3a,i6,a)')
522			& 'MNC_CW_ADD_VATTR_ANY WARNING: attribute name ''',
523			& tname(n1:n2), ''' has more than ', MNC_MAX_CHAR,
524			& ' characters and has been truncated to fit'
525	jmc	1.29	CALL PRINT_MESSAGE( msgbuf, errorMessageUnit,
526			& SQUEEZE_RIGHT , myThid)
527	edhill	1.28	C MNC_MAX_CHAR = n2 - n1 + 1
528			n2 = MNC_MAX_CHAR + n1 - 1
529			ENDIF
530	edhill	1.20	C write(,) atype,tname(n1:n2)
531			mnc_cw_vtnm(n,indv)(1:MNC_MAX_CHAR) =
532	edhill	1.16	& mnc_blank_name(1:MNC_MAX_CHAR)
533	edhill	1.20	mnc_cw_vtnm(n,indv)(1:(n2-n1+1)) = tname(n1:n2)
534	edhill	1.28
535	edhill	1.20	n1 = IFNBLNK(tval)
536			n2 = ILNBLNK(tval)
537	edhill	1.28	IF ((n2-n1+1) .GT. MNC_MAX_CHAR) THEN
538			write(msgbuf,'(3a,i6,a)')
539			& 'MNC_CW_ADD_VATTR_ANY WARNING: attribute value ''',
540			& tval(n1:n2), ''' has more than ', MNC_MAX_CHAR,
541			& ' characters and has been truncated to fit'
542	jmc	1.29	CALL PRINT_MESSAGE( msgbuf, errorMessageUnit,
543			& SQUEEZE_RIGHT , myThid)
544	edhill	1.28	n2 = MNC_MAX_CHAR + n1 - 1
545			ENDIF
546
547	edhill	1.21	IF ((n1 .EQ. 0) .OR. (n2 .EQ. 0)) THEN
548			mnc_cw_vtat(n,indv)(1:MNC_MAX_CHAR) =
549			& mnc_blank_name(1:MNC_MAX_CHAR)
550			mnc_cw_vnat(1,indv) = n
551			ELSE
552			mnc_cw_vtat(n,indv)(1:MNC_MAX_CHAR) =
553			& mnc_blank_name(1:MNC_MAX_CHAR)
554			mnc_cw_vtat(n,indv)(1:(n2-n1+1)) = tval(n1:n2)
555			mnc_cw_vnat(1,indv) = n
556			ENDIF
557	edhill	1.20	ENDIF
558
559			IF (atype .EQ. 2) THEN
560			C Integer Attribute
561			n = mnc_cw_vnat(2,indv) + 1
562			n1 = IFNBLNK(iname)
563			n2 = ILNBLNK(iname)
564			C write(,) atype,iname(n1:n2)
565			mnc_cw_vinm(n,indv)(1:(n2-n1+1)) = iname(n1:n2)
566			mnc_cw_viat(n,indv) = ival
567			mnc_cw_vnat(2,indv) = n
568			ENDIF
569
570			IF (atype .EQ. 3) THEN
571			C Double Attribute
572			n = mnc_cw_vnat(3,indv) + 1
573			n1 = IFNBLNK(dname)
574			n2 = ILNBLNK(dname)
575			C write(,) atype,dname(n1:n2)
576			mnc_cw_vdnm(n,indv)(1:(n2-n1+1)) = dname(n1:n2)
577			mnc_cw_vdat(n,indv) = dval
578			mnc_cw_vnat(3,indv) = n
579			ENDIF
580	edhill	1.19
581	edhill	1.3	RETURN
582			END
583
584			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
585	edhill	1.12	CBOP 1
586	edhill	1.11	C !ROUTINE: MNC_CW_GET_TILE_NUM
587	edhill	1.3
588	edhill	1.11	C !INTERFACE:
589	edhill	1.3	SUBROUTINE MNC_CW_GET_TILE_NUM(
590			I bi, bj,
591	edhill	1.9	O uniq_tnum,
592			I myThid )
593	edhill	1.3
594	edhill	1.11	C !DESCRIPTION:
595
596			C !USES:
597	edhill	1.3	implicit none
598			#include "EEPARAMS.h"
599			#include "SIZE.h"
600	edhill	1.7	#ifdef ALLOW_EXCH2
601			#include "W2_EXCH2_TOPOLOGY.h"
602			#include "W2_EXCH2_PARAMS.h"
603			#endif
604	edhill	1.3
605	edhill	1.11	C !INPUT PARAMETERS:
606	edhill	1.3	integer myThid, bi,bj, uniq_tnum
607	edhill	1.12	CEOP
608	edhill	1.3
609	edhill	1.11	C !LOCAL VARIABLES:
610	edhill	1.3	integer iG,jG
611
612	edhill	1.4	iG = 0
613			jG = 0
614
615	edhill	1.3	#ifdef ALLOW_EXCH2
616
617			uniq_tnum = W2_myTileList(bi)
618
619			#else
620
621			C Global tile number for simple (non-cube) domains
622			iG = bi+(myXGlobalLo-1)/sNx
623			jG = bj+(myYGlobalLo-1)/sNy
624	edhill	1.4
625			uniq_tnum = (jG - 1)(nPxnSx) + iG
626	edhill	1.3
627			#endif
628
629	edhill	1.4	CEH3 write(,) 'iG,jG,uniq_tnum :', iG,jG,uniq_tnum
630
631	edhill	1.3	RETURN
632			END
633
634			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
635	edhill	1.12	CBOP 1
636	edhill	1.25	C !ROUTINE: MNC_CW_GET_FACE_NUM
637
638			C !INTERFACE:
639			SUBROUTINE MNC_CW_GET_FACE_NUM(
640			I bi, bj,
641			O uniq_fnum,
642			I myThid )
643
644			C !DESCRIPTION:
645
646			C !USES:
647			implicit none
648			#include "EEPARAMS.h"
649			#include "SIZE.h"
650			#ifdef ALLOW_EXCH2
651			#include "W2_EXCH2_TOPOLOGY.h"
652			#include "W2_EXCH2_PARAMS.h"
653			#endif
654
655			C !INPUT PARAMETERS:
656			integer myThid, bi,bj, uniq_fnum
657			CEOP
658
659			#ifdef ALLOW_EXCH2
660
661			uniq_fnum = exch2_myFace( W2_myTileList(bi) )
662
663			#else
664
665			C Global face number for simple (EXCH "1") domains
666			uniq_fnum = -1
667
668			#endif
669
670			RETURN
671			END
672
673			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
674			CBOP 1
675			C !ROUTINE: MNC_CW_GET_XYFO
676
677			C !INTERFACE:
678			SUBROUTINE MNC_CW_GET_XYFO(
679			I bi, bj,
680			O ixoff, iyoff,
681			I myThid )
682
683			C !DESCRIPTION:
684
685			C !USES:
686			implicit none
687			#include "EEPARAMS.h"
688			#include "SIZE.h"
689			#ifdef ALLOW_EXCH2
690			#include "W2_EXCH2_TOPOLOGY.h"
691			#include "W2_EXCH2_PARAMS.h"
692			#endif
693
694			C !INPUT PARAMETERS:
695			integer myThid, bi,bj, ixoff,iyoff
696			CEOP
697
698			C !LOCAL VARIABLES:
699			integer uniq_tnum
700
701			#ifdef ALLOW_EXCH2
702
703			uniq_tnum = W2_myTileList(bi)
704			ixoff = exch2_tbasex( uniq_tnum )
705			iyoff = exch2_tbasey( uniq_tnum )
706
707			#else
708
709			C Global tile number for simple (non-cube) domains
710			C iG = bi+(myXGlobalLo-1)/sNx
711			C jG = bj+(myYGlobalLo-1)/sNy
712			C uniq_tnum = (jG - 1)(nPxnSx) + iG
713			ixoff = myXGlobalLo + bi * sNx
714			iyoff = myYGlobalLo + bj * sNy
715
716			#endif
717
718			RETURN
719			END
720
721			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
722			CBOP 1
723	edhill	1.11	C !ROUTINE: MNC_CW_FILE_AORC
724
725			C !INTERFACE:
726	edhill	1.3	SUBROUTINE MNC_CW_FILE_AORC(
727	edhill	1.4	I fname,
728	edhill	1.9	O indf,
729	edhill	1.23	I lbi, lbj, uniq_tnum,
730	edhill	1.9	I myThid )
731	edhill	1.3
732	edhill	1.11	C !DESCRIPTION:
733	edhill	1.13	C Open a NetCDF file, appending to the file if it already exists
734			C and, if not, creating a new file.
735	edhill	1.11
736			C !USES:
737	edhill	1.3	implicit none
738			#include "netcdf.inc"
739			#include "mnc_common.h"
740			#include "EEPARAMS.h"
741
742	edhill	1.11	C !INPUT PARAMETERS:
743	edhill	1.23	integer myThid, indf, lbi, lbj, uniq_tnum
744	edhill	1.3	character() fname
745	edhill	1.12	CEOP
746	edhill	1.3
747	edhill	1.11	C !LOCAL VARIABLES:
748	edhill	1.14	integer ierr
749	edhill	1.3
750			C Check if the file is already open
751	edhill	1.27	CALL MNC_GET_IND(MNC_MAX_FID, fname, mnc_f_names, indf, myThid)
752	edhill	1.3	IF (indf .GT. 0) THEN
753			RETURN
754			ENDIF
755
756			C Try to open an existing file
757	edhill	1.9	CALL MNC_FILE_TRY_READ(fname, ierr, indf, myThid)
758	edhill	1.23	IF (ierr .NE. NF_NOERR) THEN
759			C Try to create a new one
760			CALL MNC_FILE_OPEN(fname, 0, indf, myThid)
761	edhill	1.3	ENDIF
762
763	edhill	1.23	C Add the global attributes
764			CALL MNC_CW_SET_GATTR(fname, lbi,lbj, uniq_tnum, myThid)
765	edhill	1.2
766	edhill	1.1	RETURN
767			END
768
769			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|