C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.17 2005/01/28 01:06:12 jmc Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 0
C     !ROUTINE: GETDIAG

C     !INTERFACE:
      SUBROUTINE GETDIAG (levreal,ipoint,undef,qtmp,myThid)

C     !DESCRIPTION:
C     Retrieve averaged model diagnostic

C     !USES:
      implicit none
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"
CEOP

#ifdef ALLOW_FIZHI
#include "fizhi_SIZE.h"
#else
      integer Nrphys
      parameter (Nrphys=0)
#endif

C     INPUT:
C     levreal .... Diagnostic LEVEL
C     ipoint ..... DIAGNOSTIC NUMBER FROM MENU
C     undef  ..... UNDEFINED VALUE
C     bi     ..... X-direction process(or) number
C     bj     ..... Y-direction process(or) number
      _RL levreal
      integer myThid,ipoint
      _RL undef

C     OUTPUT:
C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
      _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)

      _RL factor
      integer i,j,ipnt,klev
      integer bi,bj
      integer lev

      if (ipoint.ge.1) then
       lev = NINT(levreal)

       klev = kdiag(ipoint)
       if (klev.ge.lev) then
        ipnt = idiag(ipoint) + lev - 1
        factor = 1.0
        if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)

        do bj=myByLo(myThid), myByHi(myThid)
          do bi=myBxLo(myThid), myBxHi(myThid)

            do j = 1,sNy
              do i = 1,sNx
                if ( qdiag(i,j,ipnt,bi,bj) .le. undef ) then
                  qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor
                else
                  qtmp(i,j,lev,bi,bj) = undef
                endif
              enddo
            enddo

          enddo
        enddo

       endif
      endif

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 0
C     !ROUTINE: GETDIAG2

C     !INTERFACE:
      SUBROUTINE GETDIAG2 (levreal,ipoint,undef,qtmp,myThid)

C     !DESCRIPTION:
C***********************************************************************
C  PURPOSE
C     Retrieve averaged model diagnostic
C  INPUT:
C  levreal .... Diagnostic LEVEL
C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU
C   undef ..... UNDEFINED VALUE
C
C  OUTPUT:
C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
C
C***********************************************************************

C     !USES:
      implicit none
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"
CEOP

#ifdef ALLOW_FIZHI
#include "fizhi_SIZE.h"
#else
       integer Nrphys
       parameter (Nrphys=0)
#endif

      _RL levreal
      integer myThid,ipoint
      _RL undef
      _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)

      integer i,j,ipnt,klev
      integer bi,bj
      integer lev

      if (ipoint.ge.1) then
       lev = NINT(levreal)

       klev = kdiag(ipoint)
       if (klev.ge.lev) then
        ipnt = idiag(ipoint) + lev - 1

        do bj=myByLo(myThid), myByHi(myThid)
          do bi=myBxLo(myThid), myBxHi(myThid)

            do j = 1,sNy
              do i = 1,sNx
                if ( qdiag(i,j,ipnt,bi,bj) .le. undef ) then
                  qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)
                else
                  qtmp(i,j,lev,bi,bj) = undef
                endif
              enddo
            enddo

          enddo
        enddo

       endif
      endif

      RETURN
      END

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

      subroutine clrindx (listnum, myThid)
C***********************************************************************
C
C  PURPOSE
C     DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST
C
C  ARGUMENT DESCRIPTION
C     listnum ....  diagnostics list number
C
C***********************************************************************

      implicit none
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"

      integer myThid, listnum

      integer m, n
      character*8 parms1
      character*3 mate_index
      integer mate

      do n=1,nfields(listnum)
       do m=1,ndiagt
        if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then
         call clrdiag (m, myThid)

c Check for Counter Diagnostic
c ----------------------------
         parms1 =  gdiag(m)(1:8)
         if ( parms1(5:5).eq.'C' ) then
          mate_index = parms1(6:8)
          read (mate_index,'(I3)') mate
          call clrdiag (mate, myThid)
         endif
        endif
       enddo
      enddo

      RETURN
      END


      subroutine clrdiag (index, myThid)
C***********************************************************************
C  PURPOSE
C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS
C***********************************************************************

      implicit none
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"

      integer myThid, index

      integer bi,bj
      integer i,j,k

C **********************************************************************
C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****
C **********************************************************************

      do bj=myByLo(myThid), myByHi(myThid)
       do bi=myBxLo(myThid), myBxHi(myThid)
        do k = 1,kdiag(index)
         do j = 1-OLy,sNy+OLy
          do i = 1-OLx,sNx+OLx
           qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
          enddo
         enddo
        enddo
       enddo
      enddo

      ndiag(index) = 0

      RETURN
      END

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

CBOP 0
C     !ROUTINE: DIAGNOSTICS_IS_ON

C     !INTERFACE:
      LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )

C     !DESCRIPTION:
C     *==========================================================*
C     | FUNCTION DIAGNOSTIC_IS_ON
C     | o Return TRUE if diagnostics "diagName" is Active
C     *==========================================================*

C     !USES:
      IMPLICIT NONE
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"

C     !INPUT PARAMETERS:
C     diagName   ::  diagnostic identificator name (8 characters long)
C     myThid     ::  my thread Id number
      CHARACTER*8  diagName
      INTEGER      myThid
CEOP

C     !LOCAL VARIABLES:
      INTEGER j,n,m

      DIAGNOSTICS_IS_ON = .FALSE.
      DO n=1,nlists
       DO m=1,nActive(n)
        IF ( diagName.EQ.flds(m,n) ) THEN
          j = jdiag(m,n)     
          IF ( idiag(j).NE.0 .AND. ndiag(j).GE.0 ) 
     &         DIAGNOSTICS_IS_ON = .TRUE.
        ENDIF
       ENDDO
      ENDDO

      RETURN
      END

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

CBOP 0
C     !ROUTINE: DIAGS_MK_UNITS

C     !INTERFACE:
      CHARACTER*16 FUNCTION DIAGS_MK_UNITS( 
     I                            diagUnitsInPieces, myThid )

C     !DESCRIPTION:
C     *==========================================================*
C     | FUNCTION DIAGS_MK_UNITS
C     | o Return the diagnostic units string (16c) removing 
C     |   blanks from the input string
C     *==========================================================*

C     !USES:
      IMPLICIT NONE
#include "EEPARAMS.h"

C     !INPUT PARAMETERS:
C     diagUnitsInPieces :: string for diagnostic units: in several 
C                          pieces, with blanks in between
C     myThid            ::  my thread Id number
      CHARACTER*(*) diagUnitsInPieces
      INTEGER      myThid
CEOP

C     !LOCAL VARIABLES:
      CHARACTER*(MAX_LEN_MBUF) msgBuf
      INTEGER i,j,n

      DIAGS_MK_UNITS = '          ' 
      n = LEN(diagUnitsInPieces)
      
      j = 0
      DO i=1,n
       IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
         j = j+1
         IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
       ENDIF
      ENDDO

      IF ( j.GT.16 ) THEN
         WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
     &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
        CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &       SQUEEZE_RIGHT , myThid)
         WRITE(msgBuf,'(3A)') '**WARNING** ',
     &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
        CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &       SQUEEZE_RIGHT , myThid)
      ENDIF

      RETURN
      END