C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagstats_set_pointers.F,v 1.7 2008/10/30 18:52:54 dfer Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

CBOP
C     !ROUTINE: DIAGSTATS_SET_POINTERS
C     !INTERFACE:
      SUBROUTINE DIAGSTATS_SET_POINTERS( myThid )

C     !DESCRIPTION: \bv
C     *==================================================================
C     | S/R DIAGSTATS_SET_POINTERS
C     | o set pointers for active statistics diagnostics
C     *==================================================================
C     \ev

C     !USES:
      IMPLICIT NONE

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

C     !INPUT/OUTPUT PARAMETERS:
C     == Routine arguments ==
C     myThid - Thread number for this instance of the routine.
      INTEGER myThid
CEOP

C     !LOCAL VARIABLES:
C     == Local variables ==
      INTEGER ndiagcount, ndCount
      INTEGER md,ld,nd
      INTEGER mm, mate, nActiveMax
      INTEGER j, k, l
      LOGICAL found, addMate2List, inList, regListPb
      CHARACTER*(MAX_LEN_MBUF) msgBuf


      _BEGIN_MASTER( myThid)

C--   Initialize pointer arrays to zero:
      DO ld=1,numlists
       DO md=1,numperlist
        iSdiag(md,ld) = 0
        jSdiag(md,ld) = 0
        mSdiag(md,ld) = 0
       ENDDO
      ENDDO

C--   Calculate pointers for diagnostics set to non-zero frequency

      ndiagcount = 0
      nActiveMax = 0
      DO ld=1,diagSt_nbLists
       diagSt_nbActv(ld) = diagSt_nbFlds(ld)
       DO md=1,diagSt_nbFlds(ld)

         found = .FALSE.
C        Search all possible model diagnostics
         DO nd=1,ndiagt
          IF ( diagSt_Flds(md,ld).EQ.cdiag(nd) ) THEN
            CALL DIAGSTATS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
            found = .TRUE.
            jSdiag(md,ld) = nd
          ENDIF
         ENDDO
         IF ( .NOT.found ) THEN
           CALL DIAGNOSTICS_LIST_CHECK(
     O                      ndCount,
     I                      ld,md, diagSt_nbLists,
     I                      diagSt_nbFlds,diagSt_Flds,myThid)
           IF ( ndCount.EQ.0 ) THEN
             WRITE(msgBuf,'(3A)') 'DIAGSTATS_SET_POINTERS: ',
     &                     diagSt_Flds(md,ld),' is not a Diagnostic'
             CALL PRINT_ERROR( msgBuf , myThid )
           ENDIF
           STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
         ENDIF
         IF ( found .AND. mate.LE.-1 ) THEN
C-       add this fields to the active list in case regions are differents:
           addMate2List = .FALSE.
           DO l=1,ld-1
            inList = .FALSE.
            DO k=1,diagSt_nbActv(l)
              IF ( diagSt_Flds(k,l).EQ.cdiag(-mate) ) inList=.TRUE.
            ENDDO
            IF ( inList ) THEN
             DO j=0,nRegions
              addMate2List = addMate2List
     &                 .OR. (diagSt_region(j,l).LT.diagSt_region(j,ld))
             ENDDO
            ENDIF
           ENDDO
           IF ( .NOT.addMate2List ) mate = 0
         ENDIF
         IF ( found .AND. mate.NE.0 ) THEN
            mm = diagSt_nbActv(ld) + 1
            IF ( mm.LE.numperlist ) THEN
             iSdiag(mm,ld) = SIGN(mSdiag(md,ld),mate)
             mate = ABS(mate)
             jSdiag(mm,ld) = mate
             diagSt_Flds(mm,ld) = cdiag(mate)
            ENDIF
            diagSt_nbActv(ld) = mm
         ENDIF

       ENDDO
       nActiveMax = MAX(diagSt_nbActv(ld),nActiveMax)
      ENDDO

      IF (  ndiagcount.LE.diagSt_size .AND.
     &      nActiveMax.LE.numperlist ) THEN
        WRITE(msgBuf,'(A,I8,A)')
     &    '  space allocated for all stats-diags:',
     &    ndiagcount, ' levels'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)
      ELSE
       IF ( ndiagcount.GT.diagSt_size ) THEN
         WRITE(msgBuf,'(2A)')
     &    'DIAGSTATS_SET_POINTERS: Not enough space',
     &    ' for all active stats-diags (from data.diagnostics)'
         CALL PRINT_ERROR( msgBuf , myThid )
         WRITE(msgBuf,'(A,I8,A,I8)')
     &    'DIAGSTATS_SET_POINTERS: diagSt_size=', diagSt_size,
     &    ' but needs at least', ndiagcount
         CALL PRINT_ERROR( msgBuf , myThid )
       ENDIF
       IF ( nActiveMax.GT.numperlist ) THEN
         WRITE(msgBuf,'(2A)')
     &    'DIAGSTATS_SET_POINTERS: Not enough space',
     &    ' for all active stats-diags (from data.diagnostics)'
         CALL PRINT_ERROR( msgBuf , myThid )
         WRITE(msgBuf,'(A,I6,A,I6)')
     &    'DIAGSTATS_SET_POINTERS: numperlist=', numperlist,
     &    ' but needs at least', nActiveMax
         CALL PRINT_ERROR( msgBuf , myThid )
       ENDIF
       STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
      ENDIF

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C--   Set list of regions to write
C-    check that all selected regions are actually defined
      regListPb = .FALSE.
      DO l=1,diagSt_nbLists
       DO j=1,nRegions
        IF ( diagSt_region(j,l).NE.0 ) THEN
          IF ( diagSt_kRegMsk(j).LT.1 .OR.
     &         diagSt_kRegMsk(j).GT.nSetRegMask ) THEN
            WRITE(msgBuf,'(A,3(A,I5))') 'DIAGSTATS_SET_POINTERS:',
     &       ' region', j, ' undefined (k=', diagSt_kRegMsk(j),
     &       ') in list l=', l
            CALL PRINT_ERROR( msgBuf , myThid )
            regListPb = .TRUE.
          ENDIF
        ENDIF
       ENDDO
      ENDDO
      IF ( regListPb ) THEN
        WRITE(msgBuf,'(2A)') 'DIAGSTATS_SET_POINTERS:',
     &                       ' Cannot select undefined regions'
        CALL PRINT_ERROR( msgBuf , myThid )
        STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
      ENDIF

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

        WRITE(msgBuf,'(A)') 'DIAGSTATS_SET_POINTERS: done'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)
        WRITE(msgBuf,'(2A)')
     &   '------------------------------------------------------------'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)

      _END_MASTER( myThid )

      RETURN
      END