pkg/diagnostics/diagnostics_fill.F

337bea277a Jean*0001 #include "DIAG_OPTIONS.h"
                0002
228efec02b Jean*0003 CBOP
                0004 C     !ROUTINE: DIAGNOSTICS_FILL
                0005 C     !INTERFACE:
8c4f953ef4 Jean*0006       SUBROUTINE DIAGNOSTICS_FILL(
62f9c88755 Jean*0007      I               inpFld, chardiag,
                0008      I               kLev, nLevs, bibjFlg, biArg, bjArg, myThid )
228efec02b Jean*0009
                0010 C     !DESCRIPTION:
337bea277a Jean*0011 C***********************************************************************
2d87091177 Jean*0012 C   Wrapper routine to increment the diagnostics arrays with a RL field
228efec02b Jean*0013 C***********************************************************************
                0014 C     !USES:
                0015       IMPLICIT NONE
                0016
                0017 C     == Global variables ===
                0018 #include "EEPARAMS.h"
                0019 #include "SIZE.h"
                0020 #include "DIAGNOSTICS_SIZE.h"
                0021 #include "DIAGNOSTICS.h"
                0022
                0023 C     !INPUT PARAMETERS:
                0024 C***********************************************************************
337bea277a Jean*0025 C  Arguments Description
                0026 C  ----------------------
8c4f953ef4 Jean*0027 C     inpFld    :: Field to increment diagnostics array
                0028 C     chardiag  :: Character expression for diag to fill
                0029 C     kLev      :: Integer flag for vertical levels:
ec6884a5db Jean*0030 C                  > 0 (any integer): WHICH single level to increment in qdiag.
                0031 C                  0,-1 to increment "nLevs" levels in qdiag,
3ae5f90260 Jean*0032 C                  0 : fill-in in the same order as the input array
ec6884a5db Jean*0033 C                  -1: fill-in in reverse order.
8c4f953ef4 Jean*0034 C     nLevs     :: indicates Number of levels of the input field array
ec6884a5db Jean*0035 C                  (whether to fill-in all the levels (kLev<1) or just one (kLev>0))
8c4f953ef4 Jean*0036 C     bibjFlg   :: Integer flag to indicate instructions for bi bj loop
337bea277a Jean*0037 C                  0 indicates that the bi-bj loop must be done here
                0038 C                  1 indicates that the bi-bj loop is done OUTSIDE
                0039 C                  2 indicates that the bi-bj loop is done OUTSIDE
                0040 C                     AND that we have been sent a local array (with overlap regions)
35876c174e Dimi*0041 C                     (local array here means that it has no bi-bj dimensions)
337bea277a Jean*0042 C                  3 indicates that the bi-bj loop is done OUTSIDE
                0043 C                     AND that we have been sent a local array
                0044 C                     AND that the array has no overlap region (interior only)
3ae5f90260 Jean*0045 C                  NOTE - bibjFlg can be NEGATIVE to indicate not to increment counter
8c4f953ef4 Jean*0046 C     biArg     :: X-direction tile number - used for bibjFlg=1-3
                0047 C     bjArg     :: Y-direction tile number - used for bibjFlg=1-3
                0048 C     myThid    ::  my thread Id number
337bea277a Jean*0049 C***********************************************************************
                0050 C                  NOTE: User beware! If a local (1 tile only) array
3ae5f90260 Jean*0051 C                        is sent here, bibjFlg MUST NOT be set to 0
337bea277a Jean*0052 C                        or there will be out of bounds problems!
                0053 C***********************************************************************
8c4f953ef4 Jean*0054       _RL     inpFld(*)
228efec02b Jean*0055       CHARACTER*8 chardiag
3ae5f90260 Jean*0056       INTEGER kLev, nLevs, bibjFlg, biArg, bjArg
228efec02b Jean*0057       INTEGER myThid
                0058 CEOP
                0059
                0060 C     !LOCAL VARIABLES:
3ae5f90260 Jean*0061 C     ndId      :: diagnostic Id number (in available diagnostics list)
                0062       INTEGER m, n, j, k, l, bi, bj
                0063       INTEGER ndId, ipt, iSp
3e5de6a370 Jean*0064       INTEGER region2fill(0:nRegions)
e24eb5a158 Jean*0065       INTEGER arrType, wFac
8c4f953ef4 Jean*0066       _RL     scaleFact
2d87091177 Jean*0067       _RL     dummyRL(1)
                0068       _RS     dummyRS(1)
                0069 C ===============
337bea277a Jean*0070
102b7abbed Jean*0071 C--   Check if this S/R is called from the right place ;
                0072 C     needs to be after DIAGNOSTICS_SWITCH_ONOFF and before DIAGNOSTICS_WRITE
                0073       IF ( diag_pkgStatus.NE.ready2fillDiags ) THEN
                0074         CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_FILL',
                0075      &                   ' ', chardiag, ready2fillDiags, myThid )
                0076       ENDIF
                0077
2d87091177 Jean*0078       arrType = 0
8c4f953ef4 Jean*0079       scaleFact = 1. _d 0
3ae5f90260 Jean*0080       IF ( bibjFlg.EQ.0 ) THEN
970e63b3d6 Jean*0081         bi = myBxLo(myThid)
                0082         bj = myByLo(myThid)
3ae5f90260 Jean*0083       ELSE
                0084         bi = biArg
                0085         bj = bjArg
                0086       ENDIF
90d17db25d Jean*0087 C--   2D/3D Diagnostics :
337bea277a Jean*0088 C Run through list of active diagnostics to make sure
                0089 C we are trying to fill a valid diagnostic
                0090       DO n=1,nlists
                0091        DO m=1,nActive(n)
3ae5f90260 Jean*0092         IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
                0093          ipt = idiag(m,n)
                0094          IF ( ndiag(ipt,bi,bj).GE.0 ) THEN
e24eb5a158 Jean*0095            ndId = ABS(jdiag(m,n))
                0096            wFac = MIN( jdiag(m,n), 0 )
666b944083 Jean*0097            ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
8c4f953ef4 Jean*0098 C-    diagnostic is valid & active, do the filling:
                0099            CALL DIAGNOSTICS_FILL_FIELD(
2d87091177 Jean*0100      I              inpFld, dummyRL, dummyRS, dummyRS,
e24eb5a158 Jean*0101      I              scaleFact, 1, arrType, wFac,
62f9c88755 Jean*0102      I              ndId, ipt, kLev, nLevs,
                0103      I              bibjFlg, biArg, bjArg, myThid )
3ae5f90260 Jean*0104          ENDIF
337bea277a Jean*0105         ENDIF
                0106        ENDDO
                0107       ENDDO
                0108
                0109 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
3e5de6a370 Jean*0110 C--   Global/Regional Statistics :
                0111
                0112 C Run through list of active statistics-diagnostics to make sure
                0113 C we are trying to compute & fill a valid diagnostic
                0114
                0115       DO n=1,diagSt_nbLists
                0116        DO m=1,diagSt_nbActv(n)
3ae5f90260 Jean*0117         IF ( chardiag.EQ.diagSt_Flds(m,n) .AND. iSdiag(m,n).GT.0 ) THEN
                0118          iSp = iSdiag(m,n)
                0119          IF ( qSdiag(0,0,iSp,bi,bj).GE.0. ) THEN
8c4f953ef4 Jean*0120            ndId = jSdiag(m,n)
                0121 C-    Find list of regions to fill:
3e5de6a370 Jean*0122            DO j=0,nRegions
                0123             region2fill(j) = diagSt_region(j,n)
                0124            ENDDO
8c4f953ef4 Jean*0125 C-    if this diagnostics appears in several lists (with same freq)
                0126 C     then add regions from other lists
3ae5f90260 Jean*0127            DO l=1,diagSt_nbLists
                0128             DO k=1,diagSt_nbActv(l)
                0129              IF ( iSdiag(k,l).EQ.-iSp ) THEN
                0130               DO j=0,nRegions
                0131                region2fill(j) = MAX(region2fill(j),diagSt_region(j,l))
                0132               ENDDO
                0133              ENDIF
                0134             ENDDO
3e5de6a370 Jean*0135            ENDDO
8c4f953ef4 Jean*0136 C-    diagnostics is valid and Active: Now do the filling
                0137            CALL DIAGSTATS_FILL(
2d87091177 Jean*0138      I              inpFld, dummyRL,
                0139 #ifndef REAL4_IS_SLOW
                0140      I              dummyRS, dummyRS,
                0141 #endif
                0142      I              scaleFact, 1, arrType, 0,
62f9c88755 Jean*0143      I              ndId, iSp, region2fill, kLev, nLevs,
                0144      I              bibjFlg, biArg, bjArg, myThid )
3e5de6a370 Jean*0145          ENDIF
                0146         ENDIF
                0147        ENDDO
                0148       ENDDO
                0149
3ae5f90260 Jean*0150       RETURN
228efec02b Jean*0151       END