pkg/diagnostics/diagstats_set_regions.F

9b091adb85 Jean*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: DIAGSTATS_SET_REGIONS
                0005 C     !INTERFACE:
                0006       SUBROUTINE DIAGSTATS_SET_REGIONS( myThid )
                0007
                0008 C     !DESCRIPTION: \bv
                0009 C     *==================================================================
                0010 C     | S/R DIAGSTATS_SET_REGIONS
                0011 C     | o set region-mask for regional statistics diagnostics
                0012 C     *==================================================================
                0013 C     \ev
                0014
                0015 C     !USES:
                0016       IMPLICIT NONE
                0017
                0018 C     == Global variables ===
                0019 #include "EEPARAMS.h"
                0020 #include "SIZE.h"
                0021 #include "PARAMS.h"
                0022 #include "DIAGNOSTICS_SIZE.h"
                0023 #include "DIAGSTATS_REGIONS.h"
                0024
                0025 C     !INPUT/OUTPUT PARAMETERS:
                0026 C     == Routine arguments ==
                0027 C     myThid - Thread number for this instance of the routine.
                0028       INTEGER myThid
                0029 CEOP
                0030
                0031 C     !LOCAL VARIABLES:
                0032 C     == Local variables ==
                0033       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0034       INTEGER iLen
                0035       INTEGER i, j
                0036       INTEGER bi, bj
                0037 #ifdef DIAGSTATS_REGION_MASK
                0038       CHARACTER*(MAX_LEN_MBUF) tmpBuf
                0039       INTEGER ioUnit
                0040       INTEGER k, nbReg
41c4545f8f Jean*0041       _RS     tmpVar(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
970e63b3d6 Jean*0042       COMMON / SET_REGIONS_LOCAL / tmpVar
9b091adb85 Jean*0043 #else
                0044       LOGICAL flag
                0045 #endif
                0046       INTEGER  ILNBLNK
                0047       EXTERNAL ILNBLNK
                0048
                0049 #ifdef DIAGSTATS_REGION_MASK
                0050
                0051 C--   Initialize region-mask array to zero:
                0052       DO bj = myByLo(myThid), myByHi(myThid)
                0053        DO bi = myBxLo(myThid), myBxHi(myThid)
                0054         DO k=1,sizRegMsk
41c4545f8f Jean*0055          DO j=1-OLy,sNy+OLy
                0056           DO i=1-OLx,sNx+OLx
9b091adb85 Jean*0057            diagSt_regMask(i,j,k,bi,bj) = 0.
                0058           ENDDO
                0059          ENDDO
                0060         ENDDO
                0061        ENDDO
                0062       ENDDO
970e63b3d6 Jean*0063       ioUnit = -1
9b091adb85 Jean*0064
                0065       _BEGIN_MASTER( myThid )
970e63b3d6 Jean*0066       ioUnit = standardMessageUnit
9b091adb85 Jean*0067 C--   Check size & parameter first:
02e1437ea2 Jean*0068       IF ( (diagSt_regMaskFile.NE.' ' .AND. nSetRegMskFile.EQ.0)
                0069      & .OR.(diagSt_regMaskFile.EQ.' ' .AND. nSetRegMskFile.GT.0) ) THEN
9b091adb85 Jean*0070         WRITE(msgBuf,'(2A)') 'DIAGSTATS_SET_REGIONS:',
02e1437ea2 Jean*0071      &   ' regMaskFile and nSetRegMskFile Not consistent'
9b091adb85 Jean*0072         CALL PRINT_ERROR( msgBuf , myThid )
                0073         STOP 'ABNORMAL END: S/R DIAGSTATS_SET_REGIONS'
                0074       ENDIF
02e1437ea2 Jean*0075       IF ( nSetRegMskFile.GT.sizRegMsk ) THEN
9b091adb85 Jean*0076         WRITE(msgBuf,'(2A,I4,A,I4)') 'DIAGSTATS_SET_REGIONS:',
02e1437ea2 Jean*0077      &   ' regMaskFile set-index number=', nSetRegMskFile,
9b091adb85 Jean*0078      &   ' exceeds sizRegMsk=', sizRegMsk
                0079         CALL PRINT_ERROR( msgBuf , myThid )
                0080         STOP 'ABNORMAL END: S/R DIAGSTATS_SET_REGIONS'
                0081       ENDIF
                0082       _END_MASTER( myThid )
                0083
                0084 C--   Read region-mask from file
                0085       IF ( diagSt_regMaskFile .NE. ' ' ) THEN
970e63b3d6 Jean*0086        _BARRIER
9b091adb85 Jean*0087        iLen = ILNBLNK(diagSt_regMaskFile)
970e63b3d6 Jean*0088        IF (ioUnit.GE.0 ) WRITE(ioUnit,'(2A)')
9b091adb85 Jean*0089      &   ' DIAGSTATS_SET_REGIONS: start reading region-mask file: ',
                0090      &   diagSt_regMaskFile(1:iLen)
02e1437ea2 Jean*0091        DO k=1,nSetRegMskFile
9b091adb85 Jean*0092 C       _BEGIN_MASTER( myThid )
970e63b3d6 Jean*0093          IF (ioUnit.GE.0 )  WRITE(ioUnit,'(A,I3)')
02e1437ea2 Jean*0094      &   ' DIAGSTATS_SET_REGIONS:  reading set k=',k
9b091adb85 Jean*0095          CALL READ_REC_XY_RS( diagSt_regMaskFile, tmpVar, k,
                0096      &                        nIter0, myThid )
970e63b3d6 Jean*0097          IF (ioUnit.GE.0 ) WRITE(ioUnit,'(A,I3,A)')
02e1437ea2 Jean*0098      &   ' DIAGSTATS_SET_REGIONS:          set k=',k,' <= done'
9b091adb85 Jean*0099 C       _END_MASTER( myThid )
                0100         _EXCH_XY_RS( tmpVar, myThid )
                0101         DO bj = myByLo(myThid), myByHi(myThid)
                0102          DO bi = myBxLo(myThid), myBxHi(myThid)
41c4545f8f Jean*0103           DO j=1-OLy,sNy+OLy
                0104            DO i=1-OLx,sNx+OLx
9b091adb85 Jean*0105             diagSt_regMask(i,j,k,bi,bj) = tmpVar(i,j,bi,bj)
                0106            ENDDO
                0107           ENDDO
                0108          ENDDO
                0109         ENDDO
                0110 C-     end of k loop
                0111        ENDDO
                0112       ENDIF
                0113
                0114 C--   Other way to define regions (e.g., latitude bands):
02e1437ea2 Jean*0115 C      set corresponding set-index of the region-mask array,
                0116 C      starting from nSetRegMskFile+1 up to nSetRegMask
9b091adb85 Jean*0117 C note: for now, empty !
457000cc7d Jean*0118       _BEGIN_MASTER( myThid )
                0119       nSetRegMask = nSetRegMskFile
                0120       _END_MASTER( myThid )
9b091adb85 Jean*0121
                0122 C--   Region Identificator arrays
                0123 C       for now, directly filled when reading data.diagnostics
                0124
                0125       _BEGIN_MASTER( myThid )
                0126 C--   Check defined regions
                0127       nbReg = 0
                0128       DO j=1,nRegions
                0129 C-      check for valid region-mask index:
                0130         IF ( diagSt_kRegMsk(j).LT.0  .OR.
                0131      &       diagSt_kRegMsk(j).GT.sizRegMsk ) THEN
                0132           WRITE(msgBuf,'(2A,I3,A,I4)') 'DIAGSTATS_SET_REGIONS: ',
                0133      &     '(region',j,') invalid region-mask index :',diagSt_kRegMsk(j)
                0134           CALL PRINT_ERROR( msgBuf , myThid )
                0135           STOP 'ABNORMAL END: S/R DIAGSTATS_SET_REGIONS'
                0136 C-      check for unset region-mask:
02e1437ea2 Jean*0137         ELSEIF ( diagSt_kRegMsk(j).GT.nSetRegMask ) THEN
9b091adb85 Jean*0138           WRITE(msgBuf,'(2A,I3,A,I3,A)') 'DIAGSTATS_SET_REGIONS: ',
                0139      &     'region',j,' , kRegMsk=', diagSt_kRegMsk(j),
                0140      &     ' <- has not been set !'
                0141           CALL PRINT_ERROR( msgBuf , myThid )
                0142           STOP 'ABNORMAL END: S/R DIAGSTATS_SET_REGIONS'
                0143         ELSEIF ( diagSt_kRegMsk(j).NE.0 ) THEN
                0144           nbReg = nbReg + 1
                0145 C-      check for empty region: build temp mask 0 / 1 :
                0146 c         k = diagSt_kRegMsk(j)
                0147 c         IF ( diagSt_regMask(i,j,k,bi,bj).EQ.diagSt_vRegMsk(j) ) THEN
                0148 c           tmpVar(i,j,bi,bj) = 1.
                0149 c         ELSE
                0150 c           tmpVar(i,j,bi,bj) = 0.
                0151 c         ELSE
                0152 C-      print region mask:
41c4545f8f Jean*0153 c         IF ( diag_dBugLevel.GE.debLevA ) THEN
9b091adb85 Jean*0154 c           WRITE(msgBuf,'(A,I3,A)') 'DIAGSTAT Region',j,' mask:'
                0155 c           iLen = ILNBLNK(msgBuf)
                0156 c           CALL PLOT_FIELD_XYRS( tmpVar, msgBuf(1:iLen), -1, myThid )
                0157 c         ENDIF
                0158         ENDIF
                0159       ENDDO
                0160
                0161 C-    Global statistics (region # 0) <- done in diagnostics_readparams
                0162 c     diagSt_kRegMsk(0) = 1
                0163 c     diagSt_vRegMsk(0) = 0.
                0164
                0165       WRITE(msgBuf,'(A,I4,A)') 'DIAGSTATS_SET_REGIONS: define',
                0166      &                         nbReg,' regions:'
                0167       iLen = ILNBLNK(msgBuf)
                0168       DO j=1,nRegions
                0169         IF ( diagSt_kRegMsk(j).NE.0 ) THEN
                0170           iLen = MIN( iLen, MAX_LEN_MBUF -3 )
                0171           tmpBuf(1:iLen) = msgBuf(1:iLen)
                0172           WRITE(msgBuf,'(A,I3)') tmpBuf(1:iLen),j
                0173           iLen = iLen+3
                0174         ENDIF
                0175       ENDDO
                0176       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0177      &                      SQUEEZE_RIGHT , myThid)
                0178       WRITE(msgBuf,'(2A)')
                0179      &   '------------------------------------------------------------'
                0180       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0181      &                      SQUEEZE_RIGHT , myThid)
                0182
                0183       _END_MASTER( myThid )
                0184
                0185 #else /* DIAGSTATS_REGION_MASK */
                0186
                0187 C--   Initialize region-mask array to zero:
                0188       DO bj = myByLo(myThid), myByHi(myThid)
                0189        DO bi = myBxLo(myThid), myBxHi(myThid)
                0190 c        DO j=1-Oly,sNy+Oly
                0191 c         DO i=1-Olx,sNx+Olx
41c4545f8f Jean*0192          DO j=1-OLy,1-OLy
                0193           DO i=1-OLx,1-OLx
9b091adb85 Jean*0194            diagSt_regMask(i,j,1,bi,bj) = 0.
                0195           ENDDO
                0196          ENDDO
                0197        ENDDO
                0198       ENDDO
                0199
                0200       _BEGIN_MASTER( myThid )
                0201 C--   Check parameter consitency:
                0202       flag = .FALSE.
                0203       DO j=1,nRegions
                0204         flag = flag .OR. diagSt_kRegMsk(j).NE.0
                0205      &              .OR. diagSt_vRegMsk(j).NE.0.
                0206       ENDDO
                0207       iLen = ILNBLNK(diagSt_regMaskFile)
02e1437ea2 Jean*0208       IF ( flag .OR. iLen.GE.1 .OR. nSetRegMskFile.NE.0 ) THEN
9b091adb85 Jean*0209         WRITE(msgBuf,'(2A)') 'DIAGSTATS_SET_REGIONS:',
                0210      &   ' #define DIAGSTATS_REGION_MASK missing in DIAG_OPTIONS.h'
                0211         CALL PRINT_ERROR( msgBuf , myThid )
                0212         STOP 'ABNORMAL END: S/R DIAGSTATS_SET_REGIONS'
                0213       ENDIF
                0214
                0215       WRITE(msgBuf,'(A)') 'DIAGSTATS_SET_REGIONS: define no region'
                0216       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0217      &                      SQUEEZE_RIGHT , myThid)
                0218       WRITE(msgBuf,'(2A)')
                0219      &   '------------------------------------------------------------'
                0220       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0221      &                      SQUEEZE_RIGHT , myThid)
                0222
                0223       _END_MASTER( myThid )
                0224
                0225 #endif /* DIAGSTATS_REGION_MASK */
                0226
                0227       RETURN
                0228       END