C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.10 2017/07/23 00:32:33 jmc Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

CBOP
C     !ROUTINE: DIAGNOSTICS_SETDIAG
C     !INTERFACE:
      SUBROUTINE DIAGNOSTICS_SETDIAG(
     O                      mate,
     U                      ndiagmx,
     I                      mId, listId, ndId, myThid )

C     !DESCRIPTION: \bv
C     *==================================================================
C     | S/R DIAGNOSTICS_SETDIAG
C     | o activate diagnostic "ndId":
C     |   set pointer locations for this diagnostic ;
C     |   look for a counter mate and set it
C     *==================================================================
C     \ev

C     !USES:
      IMPLICIT NONE

C     == Global variables ===
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"

C     !INPUT/OUTPUT PARAMETERS:
C     == Routine arguments ==
C     mate    :: counter-mate number in available diagnostics list
C     ndiagmx :: current space allocated in storage array
C     mId     :: current field index in list "listId"
C     listId  :: current list number that contains field "mId"
C     ndId    :: diagnostic number in available diagnostics list
C     myThid  :: Thread number for this instance of the routine.
      INTEGER mate
      INTEGER ndiagmx
      INTEGER mId, listId, ndId
      INTEGER myThid
CEOP

C     !LOCAL VARIABLES:
C     == Local variables ==
      INTEGER stdUnit, errUnit
      INTEGER nn, k, l, no_hFac
      LOGICAL diagIsPP, flagD, flagP, flagM, use_hFac

      CHARACTER*10 gcode
      CHARACTER*12 tmpMsg
      CHARACTER*(MAX_LEN_MBUF) msgBuf

C **********************************************************************
C ****                SET POINTERS FOR DIAGNOSTIC ndId              ****
C **********************************************************************

      stdUnit = standardMessageUnit
      errUnit = errorMessageUnit

C-    Case of Post-Procesed diag, not filled up but computed from other diags:
      diagIsPP = gdiag(ndId)(5:5).EQ.'P'

C-    Register negative "jdiag" when cumulating thickness (hFac) weighted field
      no_hFac = 1
      IF ( fflags(listId)(3:3).EQ.'h' ) THEN
        gcode = gdiag(ndId)(1:10)
        use_hFac = ( gcode(2:2).EQ.'U' .OR. gcode(2:2).EQ.'V'
     &                                 .OR. gcode(2:2).EQ.'M' )
        use_hFac = use_hFac .AND. gcode(9:10).EQ.'MR'
     &                      .AND. gcode(3:3).EQ.'R'
     &                      .AND. gcode(5:5).EQ.' '
        IF ( use_hFac ) no_hFac = -1
      ENDIF

C---  Seach for the same diag (with same freq) to see if already set
C     do it recursively on Post-Processed diag dependance (=mate)
C     until we find either one already set or a non Post-Processed diag
      flagD = .TRUE.
      flagP = .TRUE.
      nn = ndId
      DO WHILE ( flagP )
        DO l=1,listId
         IF (flagD .AND. freq(l) .EQ. freq(listId)
     &             .AND. phase(l).EQ.phase(listId)
     &             .AND. averageFreq(l) .EQ.averageFreq(listId)
     &             .AND. averagePhase(l).EQ.averagePhase(listId)
     &             .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
          DO k=1,MIN(nActive(l),numperList)
           IF ( flagD .AND. no_hFac*jdiag(k,l).GT.0 ) THEN
            IF ( cdiag(nn).EQ.cdiag(ABS(jdiag(k,l))) ) THEN
C-    diagnostics already set ; use the same slot:
             flagD = .FALSE.
             idiag(mId,listId) = -ABS(idiag(k,l))
             mdiag(mId,listId) = mdiag(k,l)
            ENDIF
           ENDIF
          ENDDO
         ENDIF
        ENDDO
        flagP = flagD .AND. gdiag(nn)(5:5).EQ.'P'
        IF ( flagP ) nn = hdiag(nn)
      ENDDO
      jdiag(mId,listId) = no_hFac*ndId

C---  Set pointer if not already set, otherwise just print a message

      IF ( diagIsPP ) THEN
        WRITE(msgBuf,'(2(A,I6,1X,A))')
     &    'SETDIAG: Diag #', ndId, cdiag(ndId),
     &    ' processed from Diag #',nn,cdiag(nn)
        CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
      ENDIF
      gcode   = gdiag(nn)(1:10)
      IF ( flagD ) THEN
        IF ( diagIsPP ) THEN
C-      Add this diag with negative idiag pointer (since those 2 diags
C        share the same pointer and "nn" will get the positive pointer).
          idiag(mId,listId) = -(ndiagmx+1)
C-      Also add "nn" to the Active list
          k = nActive(listId) + 1
          IF ( k.LE.numperList ) THEN
            jdiag(k,listId) = nn
            idiag(k,listId) = ndiagmx + 1
            flds (k,listId) = cdiag(nn)
          ENDIF
          nActive(listId) = k
        ELSE
          idiag(mId,listId) = ndiagmx + 1
        ENDIF
        ndiagmx = ndiagmx + kdiag(nn)*averageCycle(listId)
        IF ( ndiagmx.GT.numDiags ) THEN
         WRITE(msgBuf,'(A,I6,1X,A)')
     &    'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn)
         CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
        ELSE
         WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
     &                   kdiag(nn), ' x', averageCycle(listId),
     &                ' Levels for Diagnostic #', nn, cdiag(nn)
         CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
        ENDIF
      ELSE
        tmpMsg = ' Diagnostic '
        WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
     &           ' #', nn, cdiag(nn), ' is already set'
        CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
      ENDIF

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

C---  Check for Counter Diagnostic
      mate = 0

C-    if Post-Processed diag, activate 2nd components of vector field
      tmpMsg = ' Vector-mate'
      IF ( diagIsPP .AND. gcode(5:5).NE.'P' .AND.
     &    (gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V') ) mate = hdiag(nn)
C-    activate mate if this is a Counter Diagnostic
      IF ( gcode(5:5).EQ.'C') THEN
        mate = hdiag(nn)
        tmpMsg = 'Counter-mate'
      ENDIF

      IF ( mate.GT.0 ) THEN
C--     Seach for the same diag (with same freq) to see if already set
        flagM = .TRUE.
        DO l=1,listId
         IF (flagM .AND. freq(l) .EQ.freq(listId)
     &             .AND. phase(l).EQ.phase(listId)
     &             .AND. averageFreq(l) .EQ.averageFreq(listId)
     &             .AND. averagePhase(l).EQ.averagePhase(listId)
     &             .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
          DO k=1,MIN(nActive(l),numperList)
           IF (flagM .AND. jdiag(k,l).GT.0) THEN
            IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
C-    diagnostics already set ; use the same slot:
             flagM = .FALSE.
             mdiag(mId,listId) = ABS(idiag(k,l))
            ENDIF
           ENDIF
          ENDDO
         ENDIF
        ENDDO

C---  Set pointer if not already set, otherwise just print a message
        IF ( flagM ) THEN
          mdiag(mId,listId) = ndiagmx + 1
          k = nActive(listId) + 1
          IF ( k.LE.numperList ) THEN
C-      Also add mate to the Active list
            jdiag(k,listId) = mate
            idiag(k,listId) = ndiagmx + 1
            flds (k,listId) = cdiag(mate)
          ENDIF
          nActive(listId) = k
          ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
          IF ( ndiagmx.GT.numDiags ) THEN
           WRITE(msgBuf,'(3A,I6,1X,A)')
     &      'SETDIAG: Not enough space for ',tmpMsg,' #',
     &      mate, cdiag(mate)
           CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
          ELSE
           WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
     &                     kdiag(mate), ' x', averageCycle(listId),
     &                  ' Levels for Mate Diag. #', mate, cdiag(mate)
           CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
          ENDIF
        ELSE
          WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
     &    ' #', mate, cdiag(mate), ' is already set'
          CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
        ENDIF
      ENDIF

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
      RETURN
      END