Back to home page

MITgcm
 
 

    

File indexing completed on 2018-03-02 18:42:00 UTC

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
e9b72f2bd9 Ed H*0001 #include "MNC_OPTIONS.h"
c424ee7cc7 Jean*0002 
b6432c788b Jean*0003 C--  File mnc_cwrapper.F:
                0004 C--   Contents
                0005 C--   o MNC_CW_ADD_GNAME
                0006 C--   o MNC_CW_DEL_GNAME
                0007 C--   o MNC_CW_DUMP
                0008 C--   o MNC_CW_APPEND_VNAME
                0009 C--   o MNC_CW_ADD_VNAME
                0010 C--   o MNC_CW_DEL_VNAME
                0011 C--   o MNC_CW_ADD_VATTR_TEXT
                0012 C--   o MNC_CW_ADD_VATTR_INT
                0013 C--   o MNC_CW_ADD_VATTR_DBL
                0014 C--   o MNC_CW_ADD_VATTR_ANY
                0015 C--   o MNC_CW_GET_TILE_NUM
                0016 C--   o MNC_CW_GET_FACE_NUM
                0017 C--   o MNC_CW_GET_XYFO
                0018 C--   o MNC_CW_FILE_AORC
                0019 
e9b72f2bd9 Ed H*0020 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0021 CBOP 0
1b5fb69d21 Ed H*0022 C     !ROUTINE: MNC_CW_ADD_GNAME
e9b72f2bd9 Ed H*0023 
1b5fb69d21 Ed H*0024 C     !INTERFACE:
c424ee7cc7 Jean*0025       SUBROUTINE MNC_CW_ADD_GNAME(
                0026      I     name,
                0027      I     ndim,
                0028      I     dlens,
                0029      I     dnames,
                0030      I     inds_beg, inds_end,
3f2ea2a4ed Ed H*0031      I     myThid )
e9b72f2bd9 Ed H*0032 
1b5fb69d21 Ed H*0033 C     !DESCRIPTION:
                0034 C     Add a grid name to the MNC convenience wrapper layer.
c424ee7cc7 Jean*0035 
1b5fb69d21 Ed H*0036 C     !USES:
e9b72f2bd9 Ed H*0037       implicit none
07155994b8 Mart*0038 #include "MNC_COMMON.h"
e9b72f2bd9 Ed H*0039 #include "EEPARAMS.h"
                0040 
1b5fb69d21 Ed H*0041 C     !INPUT PARAMETERS:
e9b72f2bd9 Ed H*0042       integer myThid, ndim
                0043       character*(*) name
580dd6560d Ed H*0044       integer dlens(*), inds_beg(*), inds_end(*)
                0045       character*(*) dnames(*)
e6bb5b2cc3 Ed H*0046 CEOP
e9b72f2bd9 Ed H*0047 
1b5fb69d21 Ed H*0048 C     !LOCAL VARIABLES:
e9b72f2bd9 Ed H*0049       integer i, nnf,nnl, indg
                0050       character*(MAX_LEN_MBUF) msgbuf
e6bb5b2cc3 Ed H*0051 
1b5fb69d21 Ed H*0052 C     Functions
                0053       integer IFNBLNK, ILNBLNK
e9b72f2bd9 Ed H*0054 
                0055       nnf = IFNBLNK(name)
                0056       nnl = ILNBLNK(name)
                0057 
                0058 C     Check that this name is not already defined
3f2ea2a4ed Ed H*0059       CALL MNC_GET_IND(MNC_MAX_ID, name, mnc_cw_gname, indg, myThid)
e9b72f2bd9 Ed H*0060       IF (indg .GT. 0) THEN
c424ee7cc7 Jean*0061         write(msgbuf,'(3a)') 'MNC_CW_ADD_GNAME ERROR: ''', name,
e9b72f2bd9 Ed H*0062      &       ''' is already defined'
                0063         CALL print_error(msgbuf, mythid)
15688ab4b4 Ed H*0064         stop 'ABNORMAL END: S/R MNC_CW_ADD_GNAME'
e9b72f2bd9 Ed H*0065       ENDIF
c424ee7cc7 Jean*0066       CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_gname,
9705a0d5c6 Ed H*0067      &     'mnc_cw_gname', indg, myThid)
e9b72f2bd9 Ed H*0068 
15688ab4b4 Ed H*0069       mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
                0070       mnc_cw_gname(indg)(1:(nnl-nnf+1)) = name(nnf:nnl)
e9b72f2bd9 Ed H*0071       mnc_cw_ndim(indg) = ndim
                0072 
                0073       DO i = 1,ndim
                0074         mnc_cw_dn(i,indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
                0075         nnf = IFNBLNK(dnames(i))
                0076         nnl = ILNBLNK(dnames(i))
                0077         mnc_cw_dn(i,indg)(1:(nnl-nnf+1)) = dnames(i)(nnf:nnl)
                0078         mnc_cw_dims(i,indg) = dlens(i)
                0079         mnc_cw_is(i,indg)   = inds_beg(i)
                0080         mnc_cw_ie(i,indg)   = inds_end(i)
                0081       ENDDO
                0082 
                0083       RETURN
                0084       END
                0085 
15688ab4b4 Ed H*0086 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
ce33c3eabe Ed H*0087 CBOP 0
                0088 C     !ROUTINE: MNC_CW_DEL_GNAME
                0089 
                0090 C     !INTERFACE:
c424ee7cc7 Jean*0091       SUBROUTINE MNC_CW_DEL_GNAME(
                0092      I     name,
ce33c3eabe Ed H*0093      I     myThid )
                0094 
                0095 C     !DESCRIPTION:
                0096 C     Delete a grid name from the MNC convenience wrapper layer.
c424ee7cc7 Jean*0097 
ce33c3eabe Ed H*0098 C     !USES:
                0099       implicit none
07155994b8 Mart*0100 #include "MNC_COMMON.h"
ce33c3eabe Ed H*0101 #include "EEPARAMS.h"
                0102 
                0103 C     !INPUT PARAMETERS:
                0104       integer myThid
                0105       character*(*) name
                0106 CEOP
                0107 
                0108 C     !LOCAL VARIABLES:
                0109       integer nnf,nnl, indg
                0110 
                0111 C     Functions
                0112       integer IFNBLNK, ILNBLNK
                0113 
                0114       nnf = IFNBLNK(name)
                0115       nnl = ILNBLNK(name)
                0116 
                0117 C     Check that this name is not already defined
                0118       CALL MNC_GET_IND(MNC_MAX_ID, name, mnc_cw_gname, indg, myThid)
                0119       IF (indg .LT. 1) THEN
                0120         RETURN
                0121       ENDIF
                0122 
                0123       mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
                0124       mnc_cw_ndim(indg) = 0
                0125 
                0126       RETURN
                0127       END
                0128 
                0129 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0130 CBOP 1
1b5fb69d21 Ed H*0131 C     !ROUTINE: MNC_CW_DUMP
15688ab4b4 Ed H*0132 
1b5fb69d21 Ed H*0133 C     !INTERFACE:
1d48290185 Ed H*0134       SUBROUTINE MNC_CW_DUMP( myThid )
15688ab4b4 Ed H*0135 
1b5fb69d21 Ed H*0136 C     !DESCRIPTION:
                0137 C     Write a condensed view of the current state of the MNC look-up
                0138 C     tables for the convenience wrapper section.
c424ee7cc7 Jean*0139 
1b5fb69d21 Ed H*0140 C     !USES:
15688ab4b4 Ed H*0141       implicit none
07155994b8 Mart*0142 #include "MNC_COMMON.h"
1d48290185 Ed H*0143 #include "SIZE.h"
                0144 #include "EEPARAMS.h"
                0145 #include "PARAMS.h"
                0146 
1b5fb69d21 Ed H*0147 C     !INPUT PARAMETERS:
1d48290185 Ed H*0148       integer myThid
e6bb5b2cc3 Ed H*0149 CEOP
15688ab4b4 Ed H*0150 
1b5fb69d21 Ed H*0151 C     !LOCAL VARIABLES:
15688ab4b4 Ed H*0152       integer i,j, ntot
1d48290185 Ed H*0153       integer NBLNK
                0154       parameter ( NBLNK = 150 )
                0155       character s1*(NBLNK), blnk*(NBLNK)
15688ab4b4 Ed H*0156 
1d48290185 Ed H*0157       _BEGIN_MASTER(myThid)
c424ee7cc7 Jean*0158 
1d48290185 Ed H*0159       DO i = 1,NBLNK
                0160         blnk(i:i) = ' '
                0161       ENDDO
c424ee7cc7 Jean*0162 
1d48290185 Ed H*0163       s1(1:NBLNK) = blnk(1:NBLNK)
                0164       write(s1,'(a5,a)') 'MNC: ',
                0165      &     'The currently defined Grid Types are:'
                0166       CALL PRINT_MESSAGE(
                0167      &     s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
15688ab4b4 Ed H*0168       ntot = 0
                0169       DO j = 1,MNC_MAX_ID
c424ee7cc7 Jean*0170         IF (mnc_cw_gname(j)(1:MNC_MAX_CHAR)
15688ab4b4 Ed H*0171      &       .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
c424ee7cc7 Jean*0172 
15688ab4b4 Ed H*0173           ntot = ntot + 1
1d48290185 Ed H*0174           s1(1:NBLNK) = blnk(1:NBLNK)
c90c060abd Ed H*0175           write(s1,'(a5,2i5,a3,a20,i3,a3,5i4,a4,5i4,a4,5i4,6a8)')
1d48290185 Ed H*0176      &         'MNC: ',
c424ee7cc7 Jean*0177      &         j, ntot, ' : ', mnc_cw_gname(j)(1:20), mnc_cw_ndim(j),
                0178      &         ' : ', (mnc_cw_dims(i,j), i=1,5),
15688ab4b4 Ed H*0179      &         '  | ', (mnc_cw_is(i,j), i=1,5),
                0180      &         '  | ', (mnc_cw_ie(i,j), i=1,5),
c90c060abd Ed H*0181      &         '  | ', (mnc_cw_dn(i,j)(1:7), i=1,5)
1d48290185 Ed H*0182           CALL PRINT_MESSAGE(
                0183      &         s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
c424ee7cc7 Jean*0184 
15688ab4b4 Ed H*0185         ENDIF
                0186       ENDDO
c424ee7cc7 Jean*0187 
1d48290185 Ed H*0188       s1(1:NBLNK) = blnk(1:NBLNK)
                0189       write(s1,'(a5,a)') 'MNC: ',
                0190      &     'The currently defined Variable Types are:'
                0191       CALL PRINT_MESSAGE(
                0192      &     s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
3623ff8097 Ed H*0193       ntot = 0
                0194       DO j = 1,MNC_MAX_ID
c424ee7cc7 Jean*0195         IF (mnc_cw_vname(j)(1:MNC_MAX_CHAR)
3623ff8097 Ed H*0196      &       .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
c424ee7cc7 Jean*0197 
3623ff8097 Ed H*0198           ntot = ntot + 1
1d48290185 Ed H*0199           s1(1:NBLNK) = blnk(1:NBLNK)
                0200           write(s1,'(a5,2i5,a3,a25,a3,i4)') 'MNC: ',
c424ee7cc7 Jean*0201      &         j, ntot, ' | ',
1d48290185 Ed H*0202      &         mnc_cw_vname(j)(1:20), ' | ', mnc_cw_vgind(j)
                0203           CALL PRINT_MESSAGE(
                0204      &         s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
c424ee7cc7 Jean*0205 
3623ff8097 Ed H*0206           DO i = 1,mnc_cw_vnat(1,j)
1d48290185 Ed H*0207             s1(1:NBLNK) = blnk(1:NBLNK)
c424ee7cc7 Jean*0208             write(s1,'(a5,a14,i4,a3,a25,a3,a55)')
                0209      &           'MNC: ','      text_at:',i,
3623ff8097 Ed H*0210      &           ' : ', mnc_cw_vtnm(i,j)(1:25), ' : ',
9705a0d5c6 Ed H*0211      &           mnc_cw_vtat(i,j)(1:MNC_MAX_CHAR)
1d48290185 Ed H*0212             CALL PRINT_MESSAGE(
                0213      &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
3623ff8097 Ed H*0214           ENDDO
                0215           DO i = 1,mnc_cw_vnat(2,j)
1d48290185 Ed H*0216             s1(1:NBLNK) = blnk(1:NBLNK)
c424ee7cc7 Jean*0217             write(s1,'(a5,a14,i4,a3,a25,a3,i20)')
                0218      &           'MNC: ','      int__at:',i,
3623ff8097 Ed H*0219      &           ' : ', mnc_cw_vinm(i,j)(1:25), ' : ',
                0220      &           mnc_cw_viat(i,j)
1d48290185 Ed H*0221             CALL PRINT_MESSAGE(
                0222      &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
3623ff8097 Ed H*0223           ENDDO
                0224           DO i = 1,mnc_cw_vnat(3,j)
1d48290185 Ed H*0225             s1(1:NBLNK) = blnk(1:NBLNK)
c424ee7cc7 Jean*0226             write(s1,'(a5,a14,i4,a3,a25,a3,f25.10)')
                0227      &           'MNC: ','      dbl__at:',i,
3623ff8097 Ed H*0228      &           ' : ', mnc_cw_vdnm(i,j)(1:25), ' : ',
                0229      &           mnc_cw_vdat(i,j)
1d48290185 Ed H*0230             CALL PRINT_MESSAGE(
                0231      &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
                0232         ENDDO
c424ee7cc7 Jean*0233 
3623ff8097 Ed H*0234         ENDIF
                0235       ENDDO
                0236       IF (ntot .EQ. 0) THEN
1d48290185 Ed H*0237         s1(1:NBLNK) = blnk(1:NBLNK)
                0238         write(s1,'(a)') 'MNC:    None defined!'
                0239         CALL PRINT_MESSAGE(
                0240      &       s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
3623ff8097 Ed H*0241       ENDIF
c424ee7cc7 Jean*0242 
1d48290185 Ed H*0243       _END_MASTER(myThid)
3623ff8097 Ed H*0244 
15688ab4b4 Ed H*0245       RETURN
                0246       END
e9b72f2bd9 Ed H*0247 
                0248 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0249 CBOP 0
357126def9 Ed H*0250 C     !ROUTINE: MNC_CW_APPEND_VNAME
                0251 
                0252 C     !INTERFACE:
c424ee7cc7 Jean*0253       SUBROUTINE MNC_CW_APPEND_VNAME(
                0254      I     vname,
                0255      I     gname,
                0256      I     bi_dim, bj_dim,
357126def9 Ed H*0257      I     myThid )
                0258 
                0259 C     !DESCRIPTION:
                0260 C     If it is not yet defined within the MNC CW layer, append a
                0261 C     variable type.  Calls MNC\_CW\_ADD\_VNAME().
c424ee7cc7 Jean*0262 
357126def9 Ed H*0263 C     !USES:
                0264       implicit none
07155994b8 Mart*0265 #include "MNC_COMMON.h"
357126def9 Ed H*0266 
                0267 C     !INPUT PARAMETERS:
                0268       integer myThid, bi_dim, bj_dim
                0269       character*(*) vname, gname
                0270 CEOP
                0271 
                0272 C     !LOCAL VARIABLES:
                0273       integer indv
                0274 
                0275 C     Check whether vname is defined
                0276       CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
                0277       IF (indv .LT. 1) THEN
                0278         CALL MNC_CW_ADD_VNAME(vname, gname, bi_dim, bj_dim, myThid)
                0279       ENDIF
                0280 
                0281 
                0282       RETURN
                0283       END
                0284 
                0285 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0286 CBOP 0
1b5fb69d21 Ed H*0287 C     !ROUTINE: MNC_CW_ADD_VNAME
e9b72f2bd9 Ed H*0288 
1b5fb69d21 Ed H*0289 C     !INTERFACE:
c424ee7cc7 Jean*0290       SUBROUTINE MNC_CW_ADD_VNAME(
                0291      I     vname,
                0292      I     gname,
                0293      I     bi_dim, bj_dim,
3f2ea2a4ed Ed H*0294      I     myThid )
15688ab4b4 Ed H*0295 
c424ee7cc7 Jean*0296 C     !DESCRIPTION:
357126def9 Ed H*0297 C     Add a variable type to the MNC CW layer.  The variable type is an
                0298 C     association between a variable type name and the following items:
e6bb5b2cc3 Ed H*0299 C     \begin{center}
                0300 C       \begin{tabular}[h]{|ll|}\hline
                0301 C         \textbf{Item}  & \textbf{Purpose}  \\\hline
                0302 C         grid type  &  defines the in-memory arrangement  \\
                0303 C         \texttt{bi,bj} dimensions  &  tiling indices, if present  \\\hline
                0304 C       \end{tabular}
                0305 C     \end{center}
c424ee7cc7 Jean*0306 
1b5fb69d21 Ed H*0307 C     !USES:
15688ab4b4 Ed H*0308       implicit none
07155994b8 Mart*0309 #include "MNC_COMMON.h"
15688ab4b4 Ed H*0310 #include "EEPARAMS.h"
                0311 
1b5fb69d21 Ed H*0312 C     !INPUT PARAMETERS:
ef84d10314 Ed H*0313       integer myThid, bi_dim, bj_dim
15688ab4b4 Ed H*0314       character*(*) vname, gname
e6bb5b2cc3 Ed H*0315 CEOP
15688ab4b4 Ed H*0316 
1b5fb69d21 Ed H*0317 C     !LOCAL VARIABLES:
15688ab4b4 Ed H*0318       integer i, nvf,nvl, ngf,ngl, indv,indg
                0319       character*(MAX_LEN_MBUF) msgbuf
e6bb5b2cc3 Ed H*0320 
1b5fb69d21 Ed H*0321 C     Functions
                0322       integer IFNBLNK, ILNBLNK
15688ab4b4 Ed H*0323 
                0324       nvf = IFNBLNK(vname)
                0325       nvl = ILNBLNK(vname)
                0326       ngf = IFNBLNK(gname)
                0327       ngl = ILNBLNK(gname)
                0328 
                0329 C     Check that this vname is not already defined
3f2ea2a4ed Ed H*0330       CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
15688ab4b4 Ed H*0331       IF (indv .GT. 0) THEN
c424ee7cc7 Jean*0332         write(msgbuf,'(3a)') 'MNC_CW_ADD_VNAME ERROR: ''',
15688ab4b4 Ed H*0333      &       vname(nvf:nvl), ''' is already defined'
                0334         CALL print_error(msgbuf, mythid)
                0335         stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'
                0336       ENDIF
c424ee7cc7 Jean*0337       CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_vname,
9705a0d5c6 Ed H*0338      &     'mnc_cw_vname', indv, myThid)
15688ab4b4 Ed H*0339 
                0340 C     Check that gname exists
3f2ea2a4ed Ed H*0341       CALL MNC_GET_IND(MNC_MAX_ID, gname, mnc_cw_gname, indg, myThid)
15688ab4b4 Ed H*0342       IF (indg .LT. 1) THEN
c424ee7cc7 Jean*0343         write(msgbuf,'(3a)') 'MNC_CW_ADD_VNAME ERROR: ''',
15688ab4b4 Ed H*0344      &       gname(ngf:ngl), ''' is not defined'
                0345         CALL print_error(msgbuf, mythid)
                0346         stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'
                0347       ENDIF
                0348 
                0349       mnc_cw_vname(indv)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
                0350       mnc_cw_vname(indv)(1:(nvl-nvf+1)) = vname(nvf:nvl)
                0351       mnc_cw_vgind(indv) = indg
                0352       DO i = 1,3
                0353         mnc_cw_vnat(i,indv) = 0
                0354       ENDDO
ef84d10314 Ed H*0355       mnc_cw_vbij(1,indv) = bi_dim
                0356       mnc_cw_vbij(2,indv) = bj_dim
15688ab4b4 Ed H*0357 
1d87512e64 Ed H*0358 #ifdef MNC_DEBUG_GTYPE
3f2ea2a4ed Ed H*0359       CALL MNC_CW_ADD_VATTR_TEXT(vname,1,'mitgcm_grid',gname, myThid)
1d87512e64 Ed H*0360 #endif
119438a015 Ed H*0361 
15688ab4b4 Ed H*0362       RETURN
                0363       END
                0364 
                0365 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0366 CBOP 0
ce33c3eabe Ed H*0367 C     !ROUTINE: MNC_CW_DEL_VNAME
                0368 
                0369 C     !INTERFACE:
c424ee7cc7 Jean*0370       SUBROUTINE MNC_CW_DEL_VNAME(
                0371      I     vname,
ce33c3eabe Ed H*0372      I     myThid )
                0373 
c424ee7cc7 Jean*0374 C     !DESCRIPTION:
ce33c3eabe Ed H*0375 C     Delete a variable type from the MNC CW layer.
c424ee7cc7 Jean*0376 
ce33c3eabe Ed H*0377 C     !USES:
                0378       implicit none
07155994b8 Mart*0379 #include "MNC_COMMON.h"
ce33c3eabe Ed H*0380 #include "EEPARAMS.h"
                0381 
                0382 C     !INPUT PARAMETERS:
                0383       integer myThid
                0384       character*(*) vname
                0385 CEOP
                0386 
                0387 C     !LOCAL VARIABLES:
                0388       integer i, indv
                0389 
                0390 C     Check that this vname is not already defined
                0391       CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
                0392       IF (indv .LT. 1) THEN
                0393         RETURN
                0394       ENDIF
                0395 
                0396       mnc_cw_vname(indv)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
                0397       mnc_cw_vgind(indv) = 0
                0398       DO i = 1,3
                0399         mnc_cw_vnat(i,indv) = 0
                0400       ENDDO
                0401 
                0402       RETURN
                0403       END
                0404 
                0405 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
580dd6560d Ed H*0406 CBOP
1b5fb69d21 Ed H*0407 C     !ROUTINE: MNC_CW_ADD_VATTR_TEXT
                0408 C     !INTERFACE:
c424ee7cc7 Jean*0409       SUBROUTINE MNC_CW_ADD_VATTR_TEXT(
                0410      I     vname, tname, tval,
3f2ea2a4ed Ed H*0411      I     myThid )
3623ff8097 Ed H*0412 
1b5fb69d21 Ed H*0413 C     !DESCRIPTION:
                0414 C     Add a text attribute
c424ee7cc7 Jean*0415 
1b5fb69d21 Ed H*0416 C     !USES:
3623ff8097 Ed H*0417       implicit none
                0418 
1b5fb69d21 Ed H*0419 C     !INPUT PARAMETERS:
2509c39694 Ed H*0420       integer myThid
                0421       character*(*) vname, tname, tval
580dd6560d Ed H*0422       integer ival
                0423       REAL*8 dval
1b5fb69d21 Ed H*0424 CEOP
580dd6560d Ed H*0425       ival = 0
                0426       dval = 0.0D0
                0427       CALL MNC_CW_ADD_VATTR_ANY(vname, 1,
                0428      &     tname, ' ', ' ', tval, ival, dval, myThid )
3623ff8097 Ed H*0429       RETURN
                0430       END
                0431 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
1b5fb69d21 Ed H*0432 CBOP
                0433 C     !ROUTINE: MNC_CW_ADD_VATTR_INT
                0434 C     !INTERFACE:
c424ee7cc7 Jean*0435       SUBROUTINE MNC_CW_ADD_VATTR_INT(
                0436      I     vname, iname, ival,
3f2ea2a4ed Ed H*0437      I     myThid )
3623ff8097 Ed H*0438 
1b5fb69d21 Ed H*0439 C     !DESCRIPTION:
580dd6560d Ed H*0440 C     Add integer attribute
1b5fb69d21 Ed H*0441 
                0442 C     !USES:
3623ff8097 Ed H*0443       implicit none
                0444 
1b5fb69d21 Ed H*0445 C     !INPUT PARAMETERS:
2509c39694 Ed H*0446       integer myThid
                0447       character*(*) vname, iname
                0448       integer ival
580dd6560d Ed H*0449       REAL*8 dval
1b5fb69d21 Ed H*0450 CEOP
580dd6560d Ed H*0451       dval = 0.0D0
                0452       CALL MNC_CW_ADD_VATTR_ANY(vname, 2,
                0453      &     ' ', iname, ' ', ' ', ival, dval, myThid )
3623ff8097 Ed H*0454       RETURN
                0455       END
                0456 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
580dd6560d Ed H*0457 CBOP
1b5fb69d21 Ed H*0458 C !ROUTINE: MNC_CW_ADD_VATTR_DBL
                0459 C !INTERFACE:
c424ee7cc7 Jean*0460       SUBROUTINE MNC_CW_ADD_VATTR_DBL(
                0461      I     vname, dname, dval,
3f2ea2a4ed Ed H*0462      I     myThid )
3623ff8097 Ed H*0463 
1b5fb69d21 Ed H*0464 C     !DESCRIPTION:
c424ee7cc7 Jean*0465 C     Add double-precision real attribute
1b5fb69d21 Ed H*0466 
                0467 C     !USES:
3623ff8097 Ed H*0468       implicit none
                0469 
1b5fb69d21 Ed H*0470 C     !INPUT PARAMETERS:
2509c39694 Ed H*0471       integer myThid
                0472       character*(*) vname, dname
580dd6560d Ed H*0473       integer ival
2509c39694 Ed H*0474       REAL*8 dval
1b5fb69d21 Ed H*0475 CEOP
580dd6560d Ed H*0476       ival = 0
                0477       CALL MNC_CW_ADD_VATTR_ANY(vname, 3,
                0478      &     ' ', ' ', dname, ' ', ival, dval, myThid )
3623ff8097 Ed H*0479       RETURN
                0480       END
                0481 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0482 CBOP 1
1b5fb69d21 Ed H*0483 C     !ROUTINE: MNC_CW_ADD_VATTR_ANY
3623ff8097 Ed H*0484 
1b5fb69d21 Ed H*0485 C     !INTERFACE:
c424ee7cc7 Jean*0486       SUBROUTINE MNC_CW_ADD_VATTR_ANY(
                0487      I     vname,
580dd6560d Ed H*0488      I     atype,
2509c39694 Ed H*0489      I     tname, iname, dname,
c424ee7cc7 Jean*0490      I     tval,  ival,  dval,
3f2ea2a4ed Ed H*0491      I     myThid )
15688ab4b4 Ed H*0492 
1b5fb69d21 Ed H*0493 C     !DESCRIPTION:
                0494 
                0495 C     !USES:
15688ab4b4 Ed H*0496       implicit none
07155994b8 Mart*0497 #include "MNC_COMMON.h"
15688ab4b4 Ed H*0498 #include "EEPARAMS.h"
                0499 
1b5fb69d21 Ed H*0500 C     !INPUT PARAMETERS:
2509c39694 Ed H*0501       integer myThid
580dd6560d Ed H*0502       integer atype
15688ab4b4 Ed H*0503       character*(*) vname
2509c39694 Ed H*0504       character*(*) tname, iname, dname
                0505       character*(*) tval
                0506       integer ival
                0507       REAL*8 dval
e6bb5b2cc3 Ed H*0508 CEOP
15688ab4b4 Ed H*0509 
1b5fb69d21 Ed H*0510 C     !LOCAL VARIABLES:
a52c49e4a8 Ed H*0511       integer n, nvf,nvl, n1,n2, indv, ic
15688ab4b4 Ed H*0512       character*(MAX_LEN_MBUF) msgbuf
e6bb5b2cc3 Ed H*0513 
1b5fb69d21 Ed H*0514 C     Functions
                0515       integer IFNBLNK, ILNBLNK
15688ab4b4 Ed H*0516 
                0517       nvf = IFNBLNK(vname)
                0518       nvl = ILNBLNK(vname)
                0519 
                0520 C     Check that vname is defined
3f2ea2a4ed Ed H*0521       CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
15688ab4b4 Ed H*0522       IF (indv .LT. 1) THEN
c424ee7cc7 Jean*0523         write(msgbuf,'(3a)') 'MNC_CW_ADD_VATTR_ANY ERROR: ''',
15688ab4b4 Ed H*0524      &       vname(nvf:nvl), ''' is not defined'
                0525         CALL print_error(msgbuf, mythid)
                0526         stop 'ABNORMAL END: S/R MNC_CW_ADD_VATTR_ANY'
                0527       ENDIF
                0528 
580dd6560d Ed H*0529       IF (atype .EQ. 1) THEN
                0530 C       Text Attribute
                0531         n = mnc_cw_vnat(1,indv) + 1
                0532         n1 = IFNBLNK(tname)
                0533         n2 = ILNBLNK(tname)
79116c6cc5 Ed H*0534         IF ((n2-n1+1) .GT. MNC_MAX_CHAR) THEN
c424ee7cc7 Jean*0535           write(msgbuf,'(3a,i6,2a)')
79116c6cc5 Ed H*0536      &         'MNC_CW_ADD_VATTR_ANY WARNING: attribute name ''',
                0537      &         tname(n1:n2), ''' has more than ', MNC_MAX_CHAR,
a52c49e4a8 Ed H*0538      &         ' characters and has been truncated to fit--please',
                0539      &         'use a smaller name or increase MNC_MAX_CHAR'
1111090fe8 Jean*0540           CALL PRINT_MESSAGE( msgbuf, errorMessageUnit,
                0541      &                        SQUEEZE_RIGHT , myThid)
79116c6cc5 Ed H*0542 C         MNC_MAX_CHAR = n2 - n1 + 1
                0543           n2 = MNC_MAX_CHAR + n1 - 1
                0544         ENDIF
580dd6560d Ed H*0545 C       write(*,*) atype,tname(n1:n2)
                0546         mnc_cw_vtnm(n,indv)(1:MNC_MAX_CHAR) =
39c888b928 Ed H*0547      &       mnc_blank_name(1:MNC_MAX_CHAR)
580dd6560d Ed H*0548         mnc_cw_vtnm(n,indv)(1:(n2-n1+1)) = tname(n1:n2)
79116c6cc5 Ed H*0549 
580dd6560d Ed H*0550         n1 = IFNBLNK(tval)
                0551         n2 = ILNBLNK(tval)
a52c49e4a8 Ed H*0552         IF ((n2-n1+1) .GT. MNC_MAX_CATT) THEN
c424ee7cc7 Jean*0553           write(msgbuf,'(3a,i6,2a)')
79116c6cc5 Ed H*0554      &         'MNC_CW_ADD_VATTR_ANY WARNING: attribute value ''',
a52c49e4a8 Ed H*0555      &         tval(n1:n2), ''' has more than ', MNC_MAX_CATT,
                0556      &         ' characters and has been truncated to fit--please',
                0557      &         'use a smaller name or increase MNC_MAX_CATT'
1111090fe8 Jean*0558           CALL PRINT_MESSAGE( msgbuf, errorMessageUnit,
                0559      &                        SQUEEZE_RIGHT , myThid)
a52c49e4a8 Ed H*0560           n2 = MNC_MAX_CATT + n1 - 1
79116c6cc5 Ed H*0561         ENDIF
c424ee7cc7 Jean*0562 
a52c49e4a8 Ed H*0563         mnc_cw_vnat(1,indv) = n
                0564         DO ic = 1,MNC_MAX_CATT
                0565           mnc_cw_vtat(n,indv)(ic:ic) = ' '
                0566         ENDDO
                0567         IF ((n1 .NE. 0) .AND. (n2 .NE. 0)) THEN
d65cc4075b Ed H*0568           mnc_cw_vtat(n,indv)(1:(n2-n1+1)) = tval(n1:n2)
                0569         ENDIF
580dd6560d Ed H*0570       ENDIF
c424ee7cc7 Jean*0571 
580dd6560d Ed H*0572       IF (atype .EQ. 2) THEN
                0573 C       Integer Attribute
                0574         n = mnc_cw_vnat(2,indv) + 1
                0575         n1 = IFNBLNK(iname)
                0576         n2 = ILNBLNK(iname)
                0577 C       write(*,*) atype,iname(n1:n2)
                0578         mnc_cw_vinm(n,indv)(1:(n2-n1+1)) = iname(n1:n2)
                0579         mnc_cw_viat(n,indv) = ival
                0580         mnc_cw_vnat(2,indv) = n
                0581       ENDIF
                0582 
                0583       IF (atype .EQ. 3) THEN
                0584 C       Double Attribute
                0585         n = mnc_cw_vnat(3,indv) + 1
                0586         n1 = IFNBLNK(dname)
                0587         n2 = ILNBLNK(dname)
                0588 C       write(*,*) atype,dname(n1:n2)
                0589         mnc_cw_vdnm(n,indv)(1:(n2-n1+1)) = dname(n1:n2)
                0590         mnc_cw_vdat(n,indv) = dval
                0591         mnc_cw_vnat(3,indv) = n
                0592       ENDIF
c424ee7cc7 Jean*0593 
15688ab4b4 Ed H*0594       RETURN
                0595       END
                0596 
                0597 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0598 CBOP 1
1b5fb69d21 Ed H*0599 C     !ROUTINE: MNC_CW_GET_TILE_NUM
15688ab4b4 Ed H*0600 
1b5fb69d21 Ed H*0601 C     !INTERFACE:
c424ee7cc7 Jean*0602       SUBROUTINE MNC_CW_GET_TILE_NUM(
                0603      I     bi, bj,
                0604      O     uniq_tnum,
3f2ea2a4ed Ed H*0605      I     myThid )
3623ff8097 Ed H*0606 
1b5fb69d21 Ed H*0607 C     !DESCRIPTION:
                0608 
                0609 C     !USES:
3623ff8097 Ed H*0610       implicit none
                0611 #include "EEPARAMS.h"
                0612 #include "SIZE.h"
da4209d891 Ed H*0613 #ifdef ALLOW_EXCH2
f9f661930b Jean*0614 #include "W2_EXCH2_SIZE.h"
da4209d891 Ed H*0615 #include "W2_EXCH2_TOPOLOGY.h"
                0616 #endif
3623ff8097 Ed H*0617 
1b5fb69d21 Ed H*0618 C     !INPUT PARAMETERS:
3623ff8097 Ed H*0619       integer myThid, bi,bj, uniq_tnum
e6bb5b2cc3 Ed H*0620 CEOP
3623ff8097 Ed H*0621 
1b5fb69d21 Ed H*0622 C     !LOCAL VARIABLES:
3623ff8097 Ed H*0623       integer iG,jG
                0624 
b11e5981be Ed H*0625       iG = 0
                0626       jG = 0
                0627 
3623ff8097 Ed H*0628 #ifdef ALLOW_EXCH2
                0629 
c424ee7cc7 Jean*0630       uniq_tnum = W2_myTileList(bi,bj)
3623ff8097 Ed H*0631 
                0632 #else
                0633 
                0634 C     Global tile number for simple (non-cube) domains
                0635       iG = bi+(myXGlobalLo-1)/sNx
                0636       jG = bj+(myYGlobalLo-1)/sNy
b11e5981be Ed H*0637 
                0638       uniq_tnum = (jG - 1)*(nPx*nSx) + iG
3623ff8097 Ed H*0639 
                0640 #endif
                0641 
b11e5981be Ed H*0642 CEH3      write(*,*) 'iG,jG,uniq_tnum :', iG,jG,uniq_tnum
                0643 
3623ff8097 Ed H*0644       RETURN
                0645       END
                0646 
                0647 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0648 CBOP 1
5bc9611487 Ed H*0649 C     !ROUTINE: MNC_CW_GET_FACE_NUM
                0650 
                0651 C     !INTERFACE:
c424ee7cc7 Jean*0652       SUBROUTINE MNC_CW_GET_FACE_NUM(
                0653      I     bi, bj,
                0654      O     uniq_fnum,
5bc9611487 Ed H*0655      I     myThid )
                0656 
                0657 C     !DESCRIPTION:
                0658 
                0659 C     !USES:
                0660       implicit none
                0661 #include "EEPARAMS.h"
                0662 #include "SIZE.h"
                0663 #ifdef ALLOW_EXCH2
f9f661930b Jean*0664 #include "W2_EXCH2_SIZE.h"
5bc9611487 Ed H*0665 #include "W2_EXCH2_TOPOLOGY.h"
                0666 #endif
                0667 
                0668 C     !INPUT PARAMETERS:
                0669       integer myThid, bi,bj, uniq_fnum
                0670 CEOP
                0671 
                0672 #ifdef ALLOW_EXCH2
                0673 
c424ee7cc7 Jean*0674       uniq_fnum = exch2_myFace( W2_myTileList(bi,bj) )
5bc9611487 Ed H*0675 
                0676 #else
                0677 
                0678 C     Global face number for simple (EXCH "1") domains
                0679       uniq_fnum = -1
                0680 
                0681 #endif
                0682 
                0683       RETURN
                0684       END
                0685 
                0686 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0687 CBOP 1
                0688 C     !ROUTINE: MNC_CW_GET_XYFO
                0689 
                0690 C     !INTERFACE:
c424ee7cc7 Jean*0691       SUBROUTINE MNC_CW_GET_XYFO(
                0692      I     bi, bj,
                0693      O     ixoff, iyoff,
5bc9611487 Ed H*0694      I     myThid )
                0695 
                0696 C     !DESCRIPTION:
                0697 
                0698 C     !USES:
                0699       implicit none
                0700 #include "EEPARAMS.h"
                0701 #include "SIZE.h"
                0702 #ifdef ALLOW_EXCH2
f9f661930b Jean*0703 #include "W2_EXCH2_SIZE.h"
5bc9611487 Ed H*0704 #include "W2_EXCH2_TOPOLOGY.h"
                0705 #endif
                0706 
                0707 C     !INPUT PARAMETERS:
                0708       integer myThid, bi,bj, ixoff,iyoff
                0709 CEOP
                0710 
                0711 C     !LOCAL VARIABLES:
b6432c788b Jean*0712 #ifdef ALLOW_EXCH2
5bc9611487 Ed H*0713       integer uniq_tnum
b6432c788b Jean*0714 #endif
5bc9611487 Ed H*0715 
                0716 #ifdef ALLOW_EXCH2
                0717 
c424ee7cc7 Jean*0718       uniq_tnum = W2_myTileList(bi,bj)
5bc9611487 Ed H*0719       ixoff = exch2_tbasex( uniq_tnum )
                0720       iyoff = exch2_tbasey( uniq_tnum )
                0721 
                0722 #else
                0723 
                0724 C     Global tile number for simple (non-cube) domains
                0725 C     iG = bi+(myXGlobalLo-1)/sNx
                0726 C     jG = bj+(myYGlobalLo-1)/sNy
                0727 C     uniq_tnum = (jG - 1)*(nPx*nSx) + iG
                0728       ixoff = myXGlobalLo + bi * sNx
                0729       iyoff = myYGlobalLo + bj * sNy
                0730 
                0731 #endif
                0732 
                0733       RETURN
                0734       END
                0735 
                0736 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0737 CBOP 1
1b5fb69d21 Ed H*0738 C     !ROUTINE: MNC_CW_FILE_AORC
c424ee7cc7 Jean*0739 
1b5fb69d21 Ed H*0740 C     !INTERFACE:
c424ee7cc7 Jean*0741       SUBROUTINE MNC_CW_FILE_AORC(
                0742      I     fname,
                0743      O     indf,
                0744      I     lbi, lbj, uniq_tnum,
3f2ea2a4ed Ed H*0745      I     myThid )
3623ff8097 Ed H*0746 
1b5fb69d21 Ed H*0747 C     !DESCRIPTION:
357126def9 Ed H*0748 C     Open a NetCDF file, appending to the file if it already exists
                0749 C     and, if not, creating a new file.
1b5fb69d21 Ed H*0750 
                0751 C     !USES:
3623ff8097 Ed H*0752       implicit none
07155994b8 Mart*0753 #include "MNC_COMMON.h"
3623ff8097 Ed H*0754 #include "EEPARAMS.h"
853ee6565e Jean*0755 #include "netcdf.inc"
3623ff8097 Ed H*0756 
1b5fb69d21 Ed H*0757 C     !INPUT PARAMETERS:
c5f7d8f43a Ed H*0758       integer myThid, indf, lbi, lbj, uniq_tnum
3623ff8097 Ed H*0759       character*(*) fname
e6bb5b2cc3 Ed H*0760 CEOP
3623ff8097 Ed H*0761 
1b5fb69d21 Ed H*0762 C     !LOCAL VARIABLES:
c90c060abd Ed H*0763       integer ierr
3623ff8097 Ed H*0764 
                0765 C     Check if the file is already open
ef92f00980 Ed H*0766       CALL MNC_GET_IND(MNC_MAX_FID, fname, mnc_f_names, indf, myThid)
3623ff8097 Ed H*0767       IF (indf .GT. 0) THEN
                0768         RETURN
                0769       ENDIF
                0770 
                0771 C     Try to open an existing file
3f2ea2a4ed Ed H*0772       CALL MNC_FILE_TRY_READ(fname, ierr, indf, myThid)
c5f7d8f43a Ed H*0773       IF (ierr .NE. NF_NOERR) THEN
                0774 C       Try to create a new one
                0775         CALL MNC_FILE_OPEN(fname, 0, indf, myThid)
3623ff8097 Ed H*0776       ENDIF
                0777 
c5f7d8f43a Ed H*0778 C     Add the global attributes
                0779       CALL MNC_CW_SET_GATTR(fname, lbi,lbj, uniq_tnum, myThid)
3623ff8097 Ed H*0780 
                0781       RETURN
                0782       END
                0783 
                0784 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!