pkg/diagnostics/diagstats_mnc_out.F

106a65ba8a Ed H*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP 0
                0005 C     !ROUTINE: DIAGSTATS_MNC_OUT
                0006
                0007 C     !INTERFACE:
                0008       SUBROUTINE DIAGSTATS_MNC_OUT(
                0009      I     statGlob, nLev, ndId,
f7d6890156 Ed H*0010      I     mId, listId, myTime, myIter, myThid )
106a65ba8a Ed H*0011
                0012 C     !DESCRIPTION:
                0013 C     Write Global statistics to a netCDF file
                0014
                0015 C     !USES:
                0016       IMPLICIT NONE
                0017 #include "SIZE.h"
                0018 #include "EEPARAMS.h"
                0019 #include "EESUPPORT.h"
                0020 #include "PARAMS.h"
                0021 #include "GRID.h"
                0022 #include "DIAGNOSTICS_SIZE.h"
                0023 #include "DIAGNOSTICS.h"
                0024
                0025 #ifdef ALLOW_FIZHI
                0026 #include "fizhi_SIZE.h"
                0027 #else
                0028       INTEGER Nrphys
                0029       PARAMETER (Nrphys=0)
                0030 #endif
                0031
                0032 C     !INPUT PARAMETERS:
                0033 C     statGlob :: AVERAGED DIAGNOSTIC QUANTITY
                0034 C     nLev     :: 2nd Dimension (max Nb of levels) of statGlob array
                0035 C     ndId     :: diagnostic Id number (in diagnostics long list)
                0036 C     mId      :: field rank in list "listId"
                0037 C     listId   :: current output Stream list
                0038 C     myIter   :: current Iteration Number
                0039 C     myTime   :: current time of simulation (s)
                0040 C     myThid   :: my thread Id number
                0041       INTEGER nLev
f7d6890156 Ed H*0042       _RL     statGlob(0:nStats,0:nLev,0:nRegions)
                0043       _RL     myTime
106a65ba8a Ed H*0044       INTEGER ndId, mId, listId
f7d6890156 Ed H*0045       INTEGER myIter, myThid
106a65ba8a Ed H*0046 CEOP
                0047
                0048 C     !LOCAL VARIABLES:
1b89c62173 Jean*0049 #ifdef ALLOW_MNC
106a65ba8a Ed H*0050       INTEGER im, ix, iv, ist
                0051       PARAMETER ( iv = nStats - 2 , im = nStats - 1 , ix = nStats )
                0052       INTEGER i, j, k
de57a2ec4b Mart*0053       CHARACTER*(MAX_LEN_FNAM) tnam
106a65ba8a Ed H*0054       CHARACTER*(3) stat_typ(5)
                0055       INTEGER ILNBLNK
                0056       EXTERNAL ILNBLNK
                0057       INTEGER ii, ilen
                0058       CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
                0059       INTEGER CW_DIMS, NLEN
                0060       PARAMETER ( CW_DIMS = 10 )
                0061       PARAMETER ( NLEN    = 80 )
                0062       INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
                0063       CHARACTER*(NLEN) dn(CW_DIMS)
                0064       CHARACTER*(NLEN) d_cw_gname
                0065       CHARACTER*(NLEN) d_cw_gname0
                0066       CHARACTER*(NLEN) dn_blnk
1b89c62173 Jean*0067 #ifdef DIAGST_MNC_NEEDSWORK
                0068       CHARACTER*(5) ctmp
106a65ba8a Ed H*0069       _RS ztmp(Nr+Nrphys)
1b89c62173 Jean*0070 #endif
106a65ba8a Ed H*0071       _RL stmp(Nr+Nrphys+1,nRegions+1)
                0072 #endif /*  ALLOW_MNC  */
                0073
                0074 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0075
                0076 #ifdef ALLOW_MNC
                0077
                0078       _BEGIN_MASTER( myThid)
                0079
                0080       stat_typ(1) = 'vol'
                0081       stat_typ(2) = 'ave'
                0082       stat_typ(3) = 'std'
                0083       stat_typ(4) = 'min'
                0084       stat_typ(5) = 'max'
                0085
                0086 #ifdef ALLOW_USE_MPI
                0087       IF ( diagSt_MNC .AND. mpiMyId.EQ.0 ) THEN
                0088 #else
                0089       IF ( diagSt_MNC ) THEN
                0090 #endif
                0091
                0092         DO i = 1,MAX_LEN_FNAM
                0093           diag_mnc_bn(i:i) = ' '
                0094         ENDDO
                0095         DO i = 1,NLEN
                0096           dn_blnk(i:i) = ' '
                0097         ENDDO
                0098         ilen = ILNBLNK(diagSt_Fname(listId))
                0099         WRITE(diag_mnc_bn, '(a)') diagSt_Fname(listId)(1:ilen)
                0100
                0101         IF (mId .EQ. 1) THEN
                0102 C         Update the record dimension by writing the iteration number
                0103           CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
2368d7b5e2 Ed H*0104           CALL MNC_CW_RL_W_S('D',diag_mnc_bn,1,1,'T',myTime,myThid)
106a65ba8a Ed H*0105           CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
2368d7b5e2 Ed H*0106           CALL MNC_CW_I_W_S('I',diag_mnc_bn,1,1,'iter',myIter,myThid)
106a65ba8a Ed H*0107         ENDIF
                0108
                0109 #ifdef DIAGST_MNC_NEEDSWORK
                0110 C       This is turned off for the time being but it should eventually
                0111 C       be re-worked and turned on so that coordinate dimensions are
                0112 C       supplied along with the data.  Unfortunately, the current
                0113 C       diagnostics system has **NO** way of telling us whether a
                0114 C       quantity is defined on a typical vertical grid (eg. the dynamics
                0115 C       grid), a gridalt--style grid, or a single-level field that has
                0116 C       no specified vertical location.
                0117
                0118         dn(1)(1:NLEN) = dn_blnk(1:NLEN)
                0119         WRITE(dn(1),'(a,i6.6)') 'Zmd', kdiag(ndId)
                0120         dim(1) = kdiag(ndId)
                0121         ib(1)  = 1
                0122         ie(1)  = kdiag(ndId)
                0123
                0124         CALL MNC_CW_ADD_GNAME('diag_levels', 1,
                0125      &       dim, dn, ib, ie, myThid)
                0126         CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
                0127      &       0,0, myThid)
                0128         CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
                0129      &       'Idicies of vertical levels within the source arrays',
                0130      &       myThid)
                0131
2368d7b5e2 Ed H*0132         CALL MNC_CW_RL_W('D',diag_mnc_bn,1,1,
106a65ba8a Ed H*0133      &       'diag_levels', levs(1,listId), myThid)
                0134
                0135         CALL MNC_CW_DEL_VNAME('diag_levels', myThid)
                0136         CALL MNC_CW_DEL_GNAME('diag_levels', myThid)
                0137
                0138 C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
                0139         ctmp(1:5) = 'mul  '
                0140         DO i = 1,3
                0141           dn(1)(1:NLEN) = dn_blnk(1:NLEN)
                0142           WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listId)
                0143           CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)
                0144           CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)
                0145
                0146 C         The following three ztmp() loops should eventually be modified
                0147 C         to reflect the fractional nature of levs(j,l) -- they should
                0148 C         do something like:
                0149 C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))
                0150 C                      + ( rC(INT(FLOOR(levs(j,l))))
                0151 C                          + rC(INT(CEIL(levs(j,l)))) )
                0152 C                        / ( levs(j,l) - FLOOR(levs(j,l)) )
                0153 C         for averaged levels.
                0154           IF (i .EQ. 1) THEN
                0155             DO j = 1,nlevels(listId)
                0156               ztmp(j) = rC(NINT(levs(j,listId)))
                0157             ENDDO
                0158             CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
                0159      &           'Dimensional coordinate value at the mid point',
                0160      &           myThid)
                0161           ELSEIF (i .EQ. 2) THEN
                0162             DO j = 1,nlevels(listId)
                0163               ztmp(j) = rF(NINT(levs(j,listId)) + 1)
                0164             ENDDO
                0165             CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
                0166      &           'Dimensional coordinate value at the upper point',
                0167      &           myThid)
                0168           ELSEIF (i .EQ. 3) THEN
                0169             DO j = 1,nlevels(listId)
                0170               ztmp(j) = rF(NINT(levs(j,listId)))
                0171             ENDDO
                0172             CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
                0173      &           'Dimensional coordinate value at the lower point',
                0174      &           myThid)
                0175           ENDIF
2368d7b5e2 Ed H*0176           CALL MNC_CW_RS_W('D',diag_mnc_bn,1,1, dn(1), ztmp, myThid)
106a65ba8a Ed H*0177           CALL MNC_CW_DEL_VNAME(dn(1), myThid)
                0178           CALL MNC_CW_DEL_GNAME(dn(1), myThid)
                0179         ENDDO
                0180 #endif  /* DIAGST_MNC_NEEDSWORK */
                0181
                0182         DO ii = 1,CW_DIMS
                0183           d_cw_gname(1:NLEN) = dn_blnk(1:NLEN)
                0184           dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
                0185         ENDDO
e129400813 Jean*0186
106a65ba8a Ed H*0187 C       Z is special since it varies
942bf02c7a Ed H*0188         WRITE(dn(1),'(a,i6.6)') 'Zd', kdiag(ndId)
106a65ba8a Ed H*0189         IF ( (gdiag(ndId)(10:10) .EQ. 'R')
                0190      &       .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
942bf02c7a Ed H*0191           WRITE(dn(1),'(a,i6.6)') 'Zmd', kdiag(ndId)
106a65ba8a Ed H*0192         ENDIF
                0193         IF ( (gdiag(ndId)(10:10) .EQ. 'R')
                0194      &       .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
942bf02c7a Ed H*0195           WRITE(dn(1),'(a,i6.6)') 'Zld', kdiag(ndId)
106a65ba8a Ed H*0196         ENDIF
                0197         IF ( (gdiag(ndId)(10:10) .EQ. 'R')
                0198      &       .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
942bf02c7a Ed H*0199           WRITE(dn(1),'(a,i6.6)') 'Zud', kdiag(ndId)
106a65ba8a Ed H*0200         ENDIF
                0201         dim(1) = Nr+Nrphys+1
                0202         ib(1)  = 1
                0203         ie(1)  = kdiag(ndId)
e129400813 Jean*0204
106a65ba8a Ed H*0205 C       "region" dimension
                0206         dim(2)     = nRegions + 1
                0207         ib(2)      = 1
                0208         dn(2)(1:6) = 'region'
                0209         ie(2)      = nRegions + 1
e129400813 Jean*0210
106a65ba8a Ed H*0211 C       Time dimension
                0212         dn(3)(1:1) = 'T'
                0213         dim(3)     = -1
                0214         ib(3)      = 1
                0215         ie(3)      = 1
e129400813 Jean*0216
106a65ba8a Ed H*0217 C       Note that the "d_cw_gname" variable is a hack that hides a
                0218 C       subtlety within MNC.  Basically, each MNC-wrapped file is
                0219 C       caching its own concept of what each "grid name" (that is, a
                0220 C       dimension group name) means.  So one cannot re-use the same
                0221 C       "grid" name for different collections of dimensions within a
                0222 C       given file.  By appending the "ndId" values to each name, we
                0223 C       guarantee uniqueness within each MNC-produced file.
                0224
                0225         WRITE(d_cw_gname,'(a7,i6.6)') 'dst_cw_', ndId
                0226         CALL MNC_CW_ADD_GNAME(d_cw_gname, 3,
                0227      &       dim, dn, ib, ie, myThid)
                0228
                0229         WRITE(dn(1),'(a3)') 'Zd0'
                0230         ie(1)  = 1
                0231         WRITE(d_cw_gname0,'(a9,i6.6)') 'dst_cw_0_', ndId
                0232         CALL MNC_CW_ADD_GNAME(d_cw_gname0, 3,
                0233      &       dim, dn, ib, ie, myThid)
e129400813 Jean*0234
106a65ba8a Ed H*0235         DO ist = 0,nStats
e129400813 Jean*0236
106a65ba8a Ed H*0237           DO i = 1,MAX_LEN_FNAM
                0238             tnam(i:i) = ' '
                0239           ENDDO
                0240
e1f31af394 Jean*0241 c         IF ( kdiag(ndId) .GT. 1 ) THEN
e129400813 Jean*0242
106a65ba8a Ed H*0243             ilen = ILNBLNK(cdiag(ndId))
e129400813 Jean*0244             WRITE(tnam,'(a,a1,a3)')
e1f31af394 Jean*0245      &           cdiag(ndId)(1:ilen),'_',stat_typ(ist+1)
e129400813 Jean*0246
106a65ba8a Ed H*0247             CALL MNC_CW_ADD_VNAME(tnam, d_cw_gname0,
                0248      &           0,0, myThid)
                0249             CALL MNC_CW_ADD_VATTR_TEXT(tnam,'description',
                0250      &           tdiag(ndId),myThid)
                0251             CALL MNC_CW_ADD_VATTR_TEXT(tnam,'units',
                0252      &           udiag(ndId),myThid)
e129400813 Jean*0253
106a65ba8a Ed H*0254 C           Copy the data into a temporary with the necessary shape
                0255             DO j = 0,nRegions
                0256               stmp(1,j+1) = statGlob(ist,0,j)
                0257             ENDDO
e129400813 Jean*0258
a400a7f6e8 Jean*0259 C-jmc: fflags is not for Statistics-Diagnostics, can be unset, and since
                0260 C-     size of the output file will not be an issue here: Always write real*8
                0261 c           IF ((fflags(listId)(1:1) .EQ. ' ')
                0262 c    &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN
e129400813 Jean*0263 c
a400a7f6e8 Jean*0264 c             CALL MNC_CW_RL_W('R',diag_mnc_bn,1,1,
                0265 c    &             tnam, stmp, myThid)
e129400813 Jean*0266 c
a400a7f6e8 Jean*0267 c           ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN
e129400813 Jean*0268
2368d7b5e2 Ed H*0269               CALL MNC_CW_RL_W('D',diag_mnc_bn,1,1,
106a65ba8a Ed H*0270      &             tnam, stmp, myThid)
e129400813 Jean*0271
a400a7f6e8 Jean*0272 c           else
                0273 c             write(0,*) myIter, ndId, listId
                0274 c             write(0,'(3A)') '>',cdiag(ndId),'<'
                0275 c             write(0,'(3A)') '>',fflags(listId),'<'
                0276 c             STOP ' in DIAGSTATS_MNC_OUT'
                0277 c           ENDIF
e129400813 Jean*0278
106a65ba8a Ed H*0279             CALL MNC_CW_DEL_VNAME(tnam, myThid)
e129400813 Jean*0280
e1f31af394 Jean*0281 c         ENDIF
e129400813 Jean*0282
e1f31af394 Jean*0283           IF ( kdiag(ndId) .GT. 1 ) THEN
                0284
                0285             ilen = ILNBLNK(cdiag(ndId))
e129400813 Jean*0286             WRITE(tnam,'(a,a4,a3)')
e1f31af394 Jean*0287      &           cdiag(ndId)(1:ilen),'_lv_',stat_typ(ist+1)
e129400813 Jean*0288
e1f31af394 Jean*0289             CALL MNC_CW_ADD_VNAME(tnam, d_cw_gname,
                0290      &           0,0, myThid)
                0291             CALL MNC_CW_ADD_VATTR_TEXT(tnam,'description',
                0292      &           tdiag(ndId),myThid)
                0293             CALL MNC_CW_ADD_VATTR_TEXT(tnam,'units',
                0294      &         udiag(ndId),myThid)
e129400813 Jean*0295
e1f31af394 Jean*0296 C           Copy the data into a temporary with the necessary shape
                0297             DO j = 0,nRegions
                0298               DO k = 1,kdiag(ndId)
                0299                 stmp(k,j+1) = statGlob(ist,k,j)
                0300               ENDDO
                0301             ENDDO
e129400813 Jean*0302
a400a7f6e8 Jean*0303 C-jmc: Always write real*8 (size of the output file will not be an issue here)
2368d7b5e2 Ed H*0304               CALL MNC_CW_RL_W('D',diag_mnc_bn,1,1,
e1f31af394 Jean*0305      &             tnam, stmp, myThid)
e129400813 Jean*0306
e1f31af394 Jean*0307             CALL MNC_CW_DEL_VNAME(tnam, myThid)
e129400813 Jean*0308
e1f31af394 Jean*0309           ENDIF
                0310
106a65ba8a Ed H*0311         ENDDO
e129400813 Jean*0312
106a65ba8a Ed H*0313         CALL MNC_CW_DEL_GNAME(d_cw_gname, myThid)
                0314         CALL MNC_CW_DEL_GNAME(d_cw_gname0, myThid)
                0315
                0316       ENDIF
e129400813 Jean*0317
106a65ba8a Ed H*0318       _END_MASTER( myThid )
                0319
                0320 #endif /*  ALLOW_MNC  */
                0321
                0322       RETURN
                0323       END
                0324 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|