--- MITgcm/pkg/mnc/mnc_cwrapper.F 2004/01/27 05:47:32 1.1 +++ MITgcm/pkg/mnc/mnc_cwrapper.F 2004/03/29 03:33:51 1.11 @@ -1,78 +1,58 @@ -C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/mnc/mnc_cwrapper.F,v 1.1 2004/01/27 05:47:32 edhill Exp $ +C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/mnc/mnc_cwrapper.F,v 1.11 2004/03/29 03:33:51 edhill Exp $ C $Name: $ #include "MNC_OPTIONS.h" C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +C !ROUTINE: MNC_CW_ADD_GNAME -C SUBROUTINE MNC_CW_W_RL( -C I myThid, myIter, -C I filebn, -C I bi,bj, -C I Gtype, -C I Rtype, -C I vname, -C I var ) - -C implicit none -C #include "netcdf.inc" -C #include "mnc_common.h" -C #include "EEPARAMS.h" - -C C Arguments -C integer myThid, myIter, bi,bj -C character*(*) filebn, Gtype -C character*(2) Rtype -C _RL var*(*) - - - -C RETURN -C END - -C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| - - SUBROUTINE MNC_CW_ADD_NAME( - I myThid, +C !INTERFACE: + SUBROUTINE MNC_CW_ADD_GNAME( 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 Functions - integer IFNBLNK, ILNBLNK - -C Arguments +C !INPUT PARAMETERS: integer myThid, ndim character*(*) name integer dlens(*), inds_beg(*), inds_end(*) character*(*) dnames(*) -C Local Variables +C !LOCAL VARIABLES: integer i, nnf,nnl, indg character*(MAX_LEN_MBUF) msgbuf +CEOP +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_names, 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_NAME ERROR: ''', name, + 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_NAME' + stop 'ABNORMAL END: S/R MNC_CW_ADD_GNAME' ENDIF - CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_cw_names, - & indg) + CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_gname, + & indg, myThid) - mnc_cw_names(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR) - mnc_cw_names(indg)(1:(nnl-nnf+1)) = name(nnf:nnl) + 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 @@ -88,29 +68,151 @@ RETURN END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +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 + +C !LOCAL VARIABLES: + integer i,j, ntot + integer NBLNK + parameter ( NBLNK = 150 ) + character s1*(NBLNK), blnk*(NBLNK) +CEOP + + _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,6a4)') + & '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) + 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:55) + 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 +C !ROUTINE: MNC_CW_INIT +C !INTERFACE: SUBROUTINE MNC_CW_INIT( - I myThid, - I sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr ) + I sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr, + I myThid ) +C !DESCRIPTION: +C Create the pre-defined grid types and variable types + +C !USES: implicit none #include "mnc_common.h" #include "EEPARAMS.h" -C Arguments +C !INPUT PARAMETERS: integer myThid integer sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr -C Functions - integer IFNBLNK, ILNBLNK - -C Local Variables +C !LOCAL VARIABLES: integer CW_MAX_LOC parameter ( CW_MAX_LOC = 5 ) - integer i, ihorz,ihsub,ivert,itime,ihalo, is, n,ntot - integer ndim + 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) @@ -118,37 +220,42 @@ & 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) +CEOP +C Functions + integer IFNBLNK, ILNBLNK 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 ', ' ', ' ', ' ' / - data halo_dat / - & 'Hn ', 'Hy ', ' ', ' ', ' ' / - + ncomb = 0 DO ihorz = 1,5 DO is = 1,3 - -C Loop just ONCE if the Horiz component is "-" - ihsub = is - IF (ihorz .EQ. 1) THEN - IF (is .EQ. 1) THEN - ihsub = 4 - ELSE - GOTO 10 + 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 - ENDIF - - DO ivert = 1,3 - DO itime = 1,2 - DO ihalo = 1,2 - + + 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)) @@ -160,15 +267,17 @@ ntot = ntot + n C vert, time, and halo - write(name((ntot+1):(ntot+7)), '(5a1,a2)') '_', - & vert_dat(ivert)(1:1), '_', - & time_dat(itime)(1:1), '_', - & halo_dat(ihalo)(1:2) + 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 @@ -225,7 +334,7 @@ dn(ndim)(1:3) = 'Ywh' dim(ndim) = sNy + 2*OLy ib(ndim) = 1 - ie(ndim) = sNx + 2*OLx + ie(ndim) = sNy + 2*OLy ENDIF ENDIF @@ -255,23 +364,369 @@ ie(ndim) = 1 ENDIF - write(*,*) name(1:15), ndim, ' : ', (dim(i), i=1,5) - IF (ndim .GT. 0) THEN - CALL MNC_CW_ADD_NAME(myThid, name, ndim, - & dim, dn, ib, ie) +#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 + + CALL MNC_CW_ADD_GNAME(name, ndim, + & dim, dn, ib, ie, myThid) ENDIF ENDDO ENDDO - ENDDO - 10 CONTINUE + 10 CONTINUE + ENDDO ENDDO ENDDO RETURN END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +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. + +C !USES: + implicit none +#include "mnc_common.h" +#include "EEPARAMS.h" + +C !INPUT PARAMETERS: + integer myThid, bi_dim, bj_dim + character*(*) vname, gname + +C !LOCAL VARIABLES: + integer i, nvf,nvl, ngf,ngl, indv,indg + character*(MAX_LEN_MBUF) msgbuf +CEOP +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, + & 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 + + CALL MNC_CW_ADD_VATTR_TEXT(vname,1,'mitgcm_grid',gname, myThid) + + 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, + I ntat, + I tnames, + I tvals, + I myThid ) + +C !DESCRIPTION: +C Add a text attribute + +C !USES: + implicit none + +C !INPUT PARAMETERS: + integer myThid, ntat + character*(*) vname, tnames(*), tvals(*) +CEOP + + CALL MNC_CW_ADD_VATTR_ANY(vname, + & ntat, 0, 0, + & tnames, ' ', ' ', + & tvals, 0, 0.0D0, 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, + I niat, + I inames, + I ivals, + I myThid ) + +C !DESCRIPTION: + +C !USES: + implicit none + +C !INPUT PARAMETERS: + integer myThid, niat + character*(*) vname, inames(*) + integer ivals(*) +CEOP + + CALL MNC_CW_ADD_VATTR_ANY(vname, + & 0, niat, 0, + & ' ', inames, ' ', + & ' ', ivals, 0.0D0, 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, + I ndat, + I dnames, + I dvals, + I myThid ) + +C !DESCRIPTION: + +C !USES: + implicit none + +C !INPUT PARAMETERS: + integer myThid, ndat + character*(*) vname, dnames(*) + REAL*8 dvals(*) +CEOP + + CALL MNC_CW_ADD_VATTR_ANY(vname, + & 0, 0, ndat, + & ' ', ' ', dnames, + & ' ', 0, dvals, myThid ) + + RETURN + END + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +C !ROUTINE: MNC_CW_ADD_VATTR_ANY + +C !INTERFACE: + SUBROUTINE MNC_CW_ADD_VATTR_ANY( + I vname, + I ntat, niat, ndat, + I tnames, inames, dnames, + I tvals, ivals, dvals, + I myThid ) + +C !DESCRIPTION: + +C !USES: + implicit none +#include "mnc_common.h" +#include "EEPARAMS.h" + +C !INPUT PARAMETERS: + integer myThid, ntat, niat, ndat + character*(*) vname + character*(*) tnames(*), inames(*), dnames(*) + character*(*) tvals(*) + integer ivals(*) + REAL*8 dvals(*) + +C !LOCAL VARIABLES: + integer i, n, nvf,nvl, n1,n2, indv + character*(MAX_LEN_MBUF) msgbuf +CEOP +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 + +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 + + RETURN + END + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +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 + +C !LOCAL VARIABLES: + integer iG,jG +CEOP + + 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 +C !ROUTINE: MNC_CW_FILE_AORC + +C !INTERFACE: + SUBROUTINE MNC_CW_FILE_AORC( + I fname, + O indf, + I myThid ) + +C !DESCRIPTION: + +C !USES: + implicit none +#include "netcdf.inc" +#include "mnc_common.h" +#include "EEPARAMS.h" + +C !INPUT PARAMETERS: + integer myThid, indf + character*(*) fname + +C !LOCAL VARIABLES: + integer i, ierr + character*(MAX_LEN_MBUF) msgbuf +CEOP + +C Check if the file is already open + 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(fname, ierr, indf, myThid) + IF (ierr .EQ. NF_NOERR) THEN + RETURN + ENDIF + +C Try to create a new one + CALL MNC_FILE_OPEN(fname, 0, indf, myThid) + + RETURN + END + C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|