pkg/diagnostics/diagstats_setdiag.F

3e5de6a370 Jean*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: DIAGSTATS_SETDIAG
                0005 C     !INTERFACE:
3ae5f90260 Jean*0006       SUBROUTINE DIAGSTATS_SETDIAG(
3e5de6a370 Jean*0007      O                      mate,
3ae5f90260 Jean*0008      U                      ndiagmx,
                0009      I                      mId, listId, ndId, myThid )
3e5de6a370 Jean*0010
                0011 C     !DESCRIPTION: \bv
                0012 C     *==================================================================
                0013 C     | S/R DIAGSTATS_SETDIAG
3ae5f90260 Jean*0014 C     | o activate statistics diagnostic "ndId":
3e5de6a370 Jean*0015 C     |   set pointer locations for this diagnostic ;
                0016 C     |   look for a counter mate and set it
                0017 C     *==================================================================
                0018 C     \ev
                0019
                0020 C     !USES:
                0021       IMPLICIT NONE
                0022
                0023 C     == Global variables ===
                0024 #include "EEPARAMS.h"
                0025 #include "SIZE.h"
                0026 #include "DIAGNOSTICS_SIZE.h"
                0027 #include "DIAGNOSTICS.h"
                0028
                0029 C     !INPUT/OUTPUT PARAMETERS:
                0030 C     == Routine arguments ==
3ae5f90260 Jean*0031 C     mate    :: counter-mate number in available diagnostics list
                0032 C     ndiagmx :: current space allocated in storage array
                0033 C     mId    :: current field index in list "listId"
                0034 C     listId :: current list number that contains field "mId"
                0035 C     ndId   :: diagnostic number in available diagnostics list
                0036 C     myThid :: Thread number for this instance of the routine.
3e5de6a370 Jean*0037       INTEGER mate
                0038       INTEGER ndiagmx
3ae5f90260 Jean*0039       INTEGER mId, listId, ndId
3e5de6a370 Jean*0040       INTEGER myThid
                0041 CEOP
                0042
                0043 C     !LOCAL VARIABLES:
                0044 C     == Local variables ==
                0045       INTEGER stdUnit, errUnit
3ae5f90260 Jean*0046       INTEGER k, l
                0047       LOGICAL flag
3e5de6a370 Jean*0048
931cda44c0 Jean*0049       CHARACTER*10 gcode
3e5de6a370 Jean*0050       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0051
                0052
                0053 C **********************************************************************
931cda44c0 Jean*0054 C ****                SET POINTERS FOR DIAGNOSTIC ndId              ****
3e5de6a370 Jean*0055 C **********************************************************************
                0056
931cda44c0 Jean*0057       gcode   = gdiag(ndId)(1:8)
3e5de6a370 Jean*0058       stdUnit = standardMessageUnit
                0059       errUnit = errorMessageUnit
                0060
3ae5f90260 Jean*0061 C--   Seach for the same diag (with same freq) to see if already set
                0062       flag = .TRUE.
                0063       DO l=1,listId
                0064        IF (flag .AND. diagSt_freq(l) .EQ. diagSt_freq(listId)
                0065      &          .AND. diagSt_phase(l).EQ.diagSt_phase(listId) ) THEN
                0066         DO k=1,MIN(diagSt_nbActv(l),numperlist)
                0067          IF (flag .AND. jSdiag(k,l).GT.0) THEN
                0068           IF (cdiag(ndId).EQ.cdiag(jSdiag(k,l)) ) THEN
                0069 C-    diagnostics already set ; use the same slot:
                0070            flag = .FALSE.
                0071            iSdiag(mId,listId) = -ABS(iSdiag(k,l))
                0072            mSdiag(mId,listId) = mSdiag(k,l)
                0073           ENDIF
                0074          ENDIF
                0075         ENDDO
                0076        ENDIF
                0077       ENDDO
                0078
                0079 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0080
                0081       IF ( flag ) THEN
                0082         IF (ndiagmx+kdiag(ndId).GT.diagSt_size) THEN
931cda44c0 Jean*0083          WRITE(msgBuf,'(A,I6,1X,A)')
3ae5f90260 Jean*0084      &    'SETDIAG: Not enough space for Stats-Diag #',ndId,cdiag(ndId)
3e5de6a370 Jean*0085          CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
                0086         ELSE
931cda44c0 Jean*0087          WRITE(msgBuf,'(A,I3,A,I6,1X,A)') 'SETDIAG: Allocate',
3ae5f90260 Jean*0088      &    kdiag(ndId), ' Levels for Stats-Diag #', ndId, cdiag(ndId)
3e5de6a370 Jean*0089          CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
                0090         ENDIF
3ae5f90260 Jean*0091         iSdiag(mId,listId) = ndiagmx + 1
                0092         ndiagmx = ndiagmx + kdiag(ndId)
3e5de6a370 Jean*0093       ELSE
931cda44c0 Jean*0094         WRITE(msgBuf,'(A,I6,1X,2A)')
324746cc27 Jean*0095      &    '- NOTE - SETDIAG: Stats-Diag #', ndId, cdiag(ndId),
3e5de6a370 Jean*0096      &    ' has already been set'
324746cc27 Jean*0097         CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
3e5de6a370 Jean*0098       ENDIF
                0099
324746cc27 Jean*0100 C---  Check for Counter Diagnostic
                0101
3e5de6a370 Jean*0102       mate = 0
931cda44c0 Jean*0103       IF ( gcode(5:5).EQ.'C') THEN
                0104         mate = hdiag(ndId)
3e5de6a370 Jean*0105
3ae5f90260 Jean*0106 C--     Seach for the same diag (with same freq) to see if already set
                0107         flag = .TRUE.
                0108         DO l=1,listId
                0109          IF (flag .AND. diagSt_freq(l) .EQ. diagSt_freq(listId)
                0110      &            .AND. diagSt_phase(l).EQ.diagSt_phase(listId) ) THEN
                0111           DO k=1,MIN(diagSt_nbActv(l),numperlist)
                0112            IF (flag .AND. jSdiag(k,l).GT.0) THEN
                0113             IF (cdiag(mate).EQ.cdiag(jSdiag(k,l)) ) THEN
                0114 C-    diagnostics already set ; use the same slot:
                0115              flag = .FALSE.
                0116              mSdiag(mId,listId) = ABS(iSdiag(k,l))
                0117             ENDIF
                0118            ENDIF
                0119           ENDDO
                0120          ENDIF
                0121         ENDDO
                0122
                0123         IF ( flag ) THEN
3e5de6a370 Jean*0124           IF (ndiagmx+kdiag(mate).GT.diagSt_size) THEN
931cda44c0 Jean*0125            WRITE(msgBuf,'(A,I6,1X,A)')
3ae5f90260 Jean*0126      &      'SETDIAG: Not enough space for Counter Diagnostic #',
                0127      &      mate, cdiag(mate)
3e5de6a370 Jean*0128            CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
                0129           ELSE
931cda44c0 Jean*0130            WRITE(msgBuf,'(A,I3,A,I6,1X,A)') 'SETDIAG: Allocate',
3e5de6a370 Jean*0131      &     kdiag(mate), ' Levels for Count.Diag #', mate, cdiag(mate)
                0132            CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
                0133           ENDIF
3ae5f90260 Jean*0134           mSdiag(mId,listId) = ndiagmx + 1
                0135           ndiagmx = ndiagmx + kdiag(mate)
3e5de6a370 Jean*0136         ELSE
931cda44c0 Jean*0137           WRITE(msgBuf,'(A,I6,1X,2A)')
3e5de6a370 Jean*0138      &    '- NOTE - SETDIAG: Counter Diagnostic #', mate, cdiag(mate),
                0139      &    ' has already been set'
                0140           CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
                0141           mate = -mate
                0142         ENDIF
                0143       ENDIF
                0144
                0145 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0146       RETURN
                0147       END