pkg/diagnostics/diagnostics_fract_fill.F

17626c8a28 Jean*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: DIAGNOSTICS_FRACT_FILL
                0005 C     !INTERFACE:
                0006       SUBROUTINE DIAGNOSTICS_FRACT_FILL(
62f9c88755 Jean*0007      I               inpFld, fractFld, scaleFact, power, chardiag,
931cda44c0 Jean*0008      I               kLev, nLevs, bibjFlg, biArg, bjArg, myThid )
17626c8a28 Jean*0009
                0010 C     !DESCRIPTION:
                0011 C***********************************************************************
2d87091177 Jean*0012 C   Wrapper routine to increment the diagnostics arrays with a RL field
62f9c88755 Jean*0013 C           using a scaling factor & square option (power=2)
2d87091177 Jean*0014 C           and using a RL fraction-weight (assumed to be the
                0015 C           counter-mate of the current diagnostics)
17626c8a28 Jean*0016 C   Note: 1) fraction-weight has to correspond to the diagnostics
                0017 C            counter-mate (filled independently with a call to
                0018 C             DIAGNOSTICS_FILL)
                0019 C         2) assume for now that inpFld & fractFld are both _RL and
                0020 C            have the same horizontal shape (overlap,bi,bj ...)
                0021 C***********************************************************************
                0022 C     !USES:
                0023       IMPLICIT NONE
                0024
                0025 C     == Global variables ===
                0026 #include "EEPARAMS.h"
                0027 #include "SIZE.h"
                0028 #include "DIAGNOSTICS_SIZE.h"
                0029 #include "DIAGNOSTICS.h"
                0030
                0031 C     !INPUT PARAMETERS:
                0032 C***********************************************************************
                0033 C  Arguments Description
                0034 C  ----------------------
                0035 C     inpFld    :: Field to increment diagnostics array
                0036 C     fractFld  :: fraction used for weighted average diagnostics
                0037 C     scaleFact :: scaling factor
62f9c88755 Jean*0038 C     power     :: option to fill-in with the field square (power=2)
17626c8a28 Jean*0039 C     chardiag  :: Character expression for diag to fill
                0040 C     kLev      :: Integer flag for vertical levels:
                0041 C                  > 0 (any integer): WHICH single level to increment in qdiag.
                0042 C                  0,-1 to increment "nLevs" levels in qdiag,
                0043 C                  0 : fill-in in the same order as the input array
                0044 C                  -1: fill-in in reverse order.
                0045 C     nLevs     :: indicates Number of levels of the input field array
                0046 C                  (whether to fill-in all the levels (kLev<1) or just one (kLev>0))
                0047 C     bibjFlg   :: Integer flag to indicate instructions for bi bj loop
                0048 C                  0 indicates that the bi-bj loop must be done here
                0049 C                  1 indicates that the bi-bj loop is done OUTSIDE
                0050 C                  2 indicates that the bi-bj loop is done OUTSIDE
                0051 C                     AND that we have been sent a local array (with overlap regions)
                0052 C                  3 indicates that the bi-bj loop is done OUTSIDE
                0053 C                     AND that we have been sent a local array
                0054 C                     AND that the array has no overlap region (interior only)
                0055 C                  NOTE - bibjFlg can be NEGATIVE to indicate not to increment counter
                0056 C     biArg     :: X-direction tile number - used for bibjFlg=1-3
                0057 C     bjArg     :: Y-direction tile number - used for bibjFlg=1-3
                0058 C     myThid    ::  my thread Id number
                0059 C***********************************************************************
                0060 C                  NOTE: User beware! If a local (1 tile only) array
                0061 C                        is sent here, bibjFlg MUST NOT be set to 0
                0062 C                        or there will be out of bounds problems!
                0063 C***********************************************************************
                0064       _RL     inpFld(*)
                0065       _RL     fractFld(*)
                0066       _RL     scaleFact
62f9c88755 Jean*0067       INTEGER power
17626c8a28 Jean*0068       CHARACTER*8 chardiag
                0069       INTEGER kLev, nLevs, bibjFlg, biArg, bjArg
                0070       INTEGER myThid
                0071 CEOP
                0072
                0073 C     !LOCAL VARIABLES:
                0074 C     ndId      :: diagnostic Id number (in available diagnostics list)
102b7abbed Jean*0075 C     msgBuf    :: Informational/error message buffer
17626c8a28 Jean*0076       INTEGER m, n, j, k, l, bi, bj
                0077       INTEGER ndId, ipt, iSp
                0078       INTEGER region2fill(0:nRegions)
                0079       INTEGER mate, nLevFract
931cda44c0 Jean*0080       CHARACTER*10 gcode
17626c8a28 Jean*0081       CHARACTER*(MAX_LEN_MBUF) msgBuf
2d87091177 Jean*0082       INTEGER arrType
                0083       _RS     dummyRS(1)
                0084 C ===============
17626c8a28 Jean*0085
102b7abbed Jean*0086 C--   Check if this S/R is called from the right place ;
                0087 C     needs to be after DIAGNOSTICS_SWITCH_ONOFF and before DIAGNOSTICS_WRITE
                0088       IF ( diag_pkgStatus.NE.ready2fillDiags ) THEN
                0089         CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_FRACT_FILL',
                0090      &                   ' ', chardiag, ready2fillDiags, myThid )
                0091       ENDIF
                0092
2d87091177 Jean*0093       arrType = 0
17626c8a28 Jean*0094       IF ( bibjFlg.EQ.0 ) THEN
970e63b3d6 Jean*0095         bi = myBxLo(myThid)
                0096         bj = myByLo(myThid)
17626c8a28 Jean*0097       ELSE
                0098         bi = biArg
                0099         bj = bjArg
                0100       ENDIF
                0101 C--   2D/3D Diagnostics :
                0102 C Run through list of active diagnostics to make sure
                0103 C we are trying to fill a valid diagnostic
                0104       DO n=1,nlists
                0105        DO m=1,nActive(n)
                0106         IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
                0107          ipt = idiag(m,n)
                0108          IF ( ndiag(ipt,bi,bj).GE.0 ) THEN
b38beaf3c1 Jean*0109            ndId = ABS(jdiag(m,n))
666b944083 Jean*0110            ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
17626c8a28 Jean*0111 C-    check for a counter-mate:
                0112            mate = 0
931cda44c0 Jean*0113            gcode = gdiag(ndId)(1:10)
                0114            IF ( gcode(5:5).EQ.'C' ) mate = hdiag(ndId)
17626c8a28 Jean*0115            IF ( mate.LE.0 ) THEN
                0116              WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_FRACT_FILL: ',
                0117      &            'did not find a valid counter-mate'
                0118              CALL PRINT_ERROR( msgBuf , myThid )
931cda44c0 Jean*0119              WRITE(msgBuf,'(2A,I6,2A)') 'DIAGNOSTICS_FRACT_FILL: ',
17626c8a28 Jean*0120      &            'for diag(#',ndId,' ) :', chardiag
                0121              CALL PRINT_ERROR( msgBuf , myThid )
                0122              STOP 'ABNORMAL END: S/R DIAGNOSTICS_FRACT_FILL'
                0123            ENDIF
                0124 C-    set the nb of levels of fraction-weight field (not > kdiag(mate))
                0125            nLevFract = MIN(nLevs,kdiag(mate))
                0126 C-    diagnostic is valid & active, has a counter-mate, do the filling:
                0127            CALL DIAGNOSTICS_FILL_FIELD(
2d87091177 Jean*0128      I              inpFld, fractFld, dummyRS, dummyRS,
                0129      I              scaleFact, power, arrType, nLevFract,
62f9c88755 Jean*0130      I              ndId, ipt, kLev, nLevs,
                0131      I              bibjFlg, biArg, bjArg, myThid )
17626c8a28 Jean*0132          ENDIF
                0133         ENDIF
                0134        ENDDO
                0135       ENDDO
                0136
                0137 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0138 C--   Global/Regional Statistics :
                0139
                0140 C Run through list of active statistics-diagnostics to make sure
                0141 C we are trying to compute & fill a valid diagnostic
                0142
                0143       DO n=1,diagSt_nbLists
                0144        DO m=1,diagSt_nbActv(n)
                0145         IF ( chardiag.EQ.diagSt_Flds(m,n) .AND. iSdiag(m,n).GT.0 ) THEN
                0146          iSp = iSdiag(m,n)
                0147          IF ( qSdiag(0,0,iSp,bi,bj).GE.0. ) THEN
                0148            ndId = jSdiag(m,n)
                0149 C-    check for a counter-mate:
                0150            mate = 0
931cda44c0 Jean*0151            gcode = gdiag(ndId)(1:10)
                0152 c          IF ( gcode(5:5).EQ.'C' ) READ(gcode,'(5X,I3)') mate
                0153            IF ( gcode(5:5).EQ.'C' ) mate = hdiag(ndId)
17626c8a28 Jean*0154            IF ( mate.LE.0 ) THEN
                0155              WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_FRACT_FILL: ',
                0156      &            'did not find a valid counter-mate'
                0157              CALL PRINT_ERROR( msgBuf , myThid )
931cda44c0 Jean*0158              WRITE(msgBuf,'(2A,I6,2A)') 'DIAGNOSTICS_FRACT_FILL: ',
17626c8a28 Jean*0159      &            'for diag(#',ndId,' ) :', chardiag
                0160              CALL PRINT_ERROR( msgBuf , myThid )
                0161              STOP 'ABNORMAL END: S/R DIAGNOSTICS_FRACT_FILL'
                0162            ENDIF
                0163 C-    set the nb of levels of fraction-weight field (not > kdiag(mate))
                0164            nLevFract = MIN(nLevs,kdiag(mate))
                0165 C-    Find list of regions to fill:
                0166            DO j=0,nRegions
                0167             region2fill(j) = diagSt_region(j,n)
                0168            ENDDO
                0169 C-    if this diagnostics appears in several lists (with same freq)
                0170 C     then add regions from other lists
                0171            DO l=1,diagSt_nbLists
                0172             DO k=1,diagSt_nbActv(l)
                0173              IF ( iSdiag(k,l).EQ.-iSp ) THEN
                0174               DO j=0,nRegions
                0175                region2fill(j) = MAX(region2fill(j),diagSt_region(j,l))
                0176               ENDDO
                0177              ENDIF
                0178             ENDDO
                0179            ENDDO
                0180 C-    diagnostics is valid and Active, has a counter mate: Now do the filling
                0181            CALL DIAGSTATS_FILL(
2d87091177 Jean*0182      I              inpFld, fractFld,
                0183 #ifndef REAL4_IS_SLOW
                0184      I              dummyRS, dummyRS,
                0185 #endif
                0186      I              scaleFact, power, arrType, nLevFract,
62f9c88755 Jean*0187      I              ndId, iSp, region2fill, kLev, nLevs,
                0188      I              bibjFlg, biArg, bjArg, myThid )
17626c8a28 Jean*0189          ENDIF
                0190         ENDIF
                0191        ENDDO
                0192       ENDDO
                0193
                0194       RETURN
                0195       END