C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/mnc/mnc_cwrapper.F,v 1.27 2006/03/10 22:01:53 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) 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 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-|--+----|