pkg/diagnostics/diagnostics_utils.F

C $Header: /u/gcmpack/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(
     I                    levreal, undef,
     O                    qtmp,
     I                    ipoint, mate, bi, bj, 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"

C     !INPUT PARAMETERS:
C     levreal .... Diagnostic LEVEL
C     undef  ..... UNDEFINED VALUE
C     ipoint ..... DIAGNOSTIC NUMBER FROM MENU
C     mate   ..... counter DIAGNOSTIC NUMBER if any ; 0 otherwise
C     bi     ..... X-direction tile number
C     bj     ..... Y-direction tile number
C     myThid ..... my thread Id number
      _RL levreal
      _RL undef
      INTEGER ipoint, mate
      INTEGER bi,bj, myThid

C     !OUTPUT PARAMETERS:
C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
      _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
CEOP

C     !LOCAL VARIABLES:
      _RL factor
      INTEGER i, j, ipnt,ipCt
      INTEGER lev, levCt, klev

      IF (ipoint.GE.1) THEN
       lev = NINT(levreal)
       klev = kdiag(ipoint)
       IF (lev.LE.klev) THEN

        IF ( mate.EQ.0 ) THEN
C-      No counter diagnostics => average = Sum / ndiag :

          ipnt = idiag(ipoint) + lev - 1
c         factor = 1.0
c         if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)
          factor = FLOAT(ndiag(ipoint))
          IF (ndiag(ipoint).NE.0) factor = 1. _d 0 / factor

          DO j = 1,sNy+1
            DO i = 1,sNx+1
              IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
                qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
              ELSE
                qtmp(i,j) = undef
              ENDIF
            ENDDO
          ENDDO

        ELSE
C-      With counter diagnostics => average = Sum / counter:

          ipnt = idiag(ipoint) + lev - 1
          levCt= MIN(lev,kdiag(mate))
          ipCt = idiag(mate) + levCt - 1
          DO j = 1,sNy+1
            DO i = 1,sNx+1
              IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
                qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)
     &                    / qdiag(i,j,ipCt,bi,bj)
              ELSE
                qtmp(i,j) = undef
              ENDIF
            ENDDO
          ENDDO

        ENDIF
       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
1	jmc	1.18	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.17 2005/01/28 01:06:12 jmc Exp $
2	edhill	1.8	C $Name: $
3
4	edhill	1.9	#include "DIAG_OPTIONS.h"
5
6	edhill	1.12	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
7			CBOP 0
8			C !ROUTINE: GETDIAG
9
10			C !INTERFACE:
11	jmc	1.18	SUBROUTINE GETDIAG(
12			I levreal, undef,
13			O qtmp,
14			I ipoint, mate, bi, bj, myThid )
15	edhill	1.12
16			C !DESCRIPTION:
17	edhill	1.13	C Retrieve averaged model diagnostic
18	jmc	1.15
19	edhill	1.12	C !USES:
20	jmc	1.18	IMPLICIT NONE
21	molod	1.3	#include "EEPARAMS.h"
22	molod	1.1	#include "SIZE.h"
23	jmc	1.15	#include "DIAGNOSTICS_SIZE.h"
24			#include "DIAGNOSTICS.h"
25	molod	1.3
26	jmc	1.18	C !INPUT PARAMETERS:
27	jmc	1.15	C levreal .... Diagnostic LEVEL
28	jmc	1.18	C undef ..... UNDEFINED VALUE
29	jmc	1.15	C ipoint ..... DIAGNOSTIC NUMBER FROM MENU
30	jmc	1.18	C mate ..... counter DIAGNOSTIC NUMBER if any ; 0 otherwise
31			C bi ..... X-direction tile number
32			C bj ..... Y-direction tile number
33			C myThid ..... my thread Id number
34	jmc	1.15	_RL levreal
35	molod	1.3	_RL undef
36	jmc	1.18	INTEGER ipoint, mate
37			INTEGER bi,bj, myThid
38	jmc	1.15
39	jmc	1.18	C !OUTPUT PARAMETERS:
40	edhill	1.12	C qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
41	jmc	1.18	_RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
42			CEOP
43	molod	1.11
44	jmc	1.18	C !LOCAL VARIABLES:
45	molod	1.3	_RL factor
46	jmc	1.18	INTEGER i, j, ipnt,ipCt
47			INTEGER lev, levCt, klev
48	molod	1.11
49	jmc	1.18	IF (ipoint.GE.1) THEN
50	jmc	1.15	lev = NINT(levreal)
51			klev = kdiag(ipoint)
52	jmc	1.18	IF (lev.LE.klev) THEN
53	jmc	1.15
54	jmc	1.18	IF ( mate.EQ.0 ) THEN
55			C- No counter diagnostics => average = Sum / ndiag :
56	jmc	1.15
57	jmc	1.18	ipnt = idiag(ipoint) + lev - 1
58			c factor = 1.0
59			c if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)
60			factor = FLOAT(ndiag(ipoint))
61			IF (ndiag(ipoint).NE.0) factor = 1. _d 0 / factor
62
63			DO j = 1,sNy+1
64			DO i = 1,sNx+1
65			IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
66			qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
67			ELSE
68			qtmp(i,j) = undef
69			ENDIF
70			ENDDO
71			ENDDO
72
73			ELSE
74			C- With counter diagnostics => average = Sum / counter:
75
76			ipnt = idiag(ipoint) + lev - 1
77			levCt= MIN(lev,kdiag(mate))
78			ipCt = idiag(mate) + levCt - 1
79			DO j = 1,sNy+1
80			DO i = 1,sNx+1
81			IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
82			qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)
83			& / qdiag(i,j,ipCt,bi,bj)
84			ELSE
85			qtmp(i,j) = undef
86			ENDIF
87			ENDDO
88			ENDDO
89	molod	1.1
90	jmc	1.18	ENDIF
91			ENDIF
92			ENDIF
93	molod	1.3
94	jmc	1.15	RETURN
95			END
96	edhill	1.12
97			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
98
99	jmc	1.15	subroutine clrindx (listnum, myThid)
100	molod	1.1	C***********************************************************************
101			C
102			C PURPOSE
103			C DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST
104			C
105			C ARGUMENT DESCRIPTION
106	molod	1.2	C listnum .... diagnostics list number
107	molod	1.1	C
108			C***********************************************************************
109
110			implicit none
111	molod	1.2	#include "EEPARAMS.h"
112	molod	1.1	#include "SIZE.h"
113	jmc	1.15	#include "DIAGNOSTICS_SIZE.h"
114			#include "DIAGNOSTICS.h"
115	molod	1.1
116	molod	1.2	integer myThid, listnum
117
118			integer m, n
119	molod	1.1	character*8 parms1
120			character*3 mate_index
121	molod	1.2	integer mate
122	molod	1.1
123	molod	1.11	do n=1,nfields(listnum)
124			do m=1,ndiagt
125			if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then
126	jmc	1.15	call clrdiag (m, myThid)
127	molod	1.11
128			c Check for Counter Diagnostic
129			c ----------------------------
130	jmc	1.15	parms1 = gdiag(m)(1:8)
131			if ( parms1(5:5).eq.'C' ) then
132			mate_index = parms1(6:8)
133			read (mate_index,'(I3)') mate
134			call clrdiag (mate, myThid)
135	molod	1.11	endif
136			endif
137			enddo
138	molod	1.2	enddo
139	jmc	1.15
140			RETURN
141			END
142	molod	1.1
143
144	jmc	1.15	subroutine clrdiag (index, myThid)
145			C***********************************************************************
146			C PURPOSE
147	molod	1.2	C ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS
148	jmc	1.15	C***********************************************************************
149
150	molod	1.1	implicit none
151	molod	1.2	#include "EEPARAMS.h"
152	molod	1.1	#include "SIZE.h"
153	jmc	1.15	#include "DIAGNOSTICS_SIZE.h"
154			#include "DIAGNOSTICS.h"
155	molod	1.1
156	molod	1.2	integer myThid, index
157
158			integer bi,bj
159	molod	1.1	integer i,j,k
160
161	jmc	1.15	C **********************************************************************
162			C ** SET DIAGNOSTIC AND COUNTER TO ZERO **
163			C **********************************************************************
164
165	molod	1.2	do bj=myByLo(myThid), myByHi(myThid)
166	jmc	1.15	do bi=myBxLo(myThid), myBxHi(myThid)
167			do k = 1,kdiag(index)
168			do j = 1-OLy,sNy+OLy
169			do i = 1-OLx,sNx+OLx
170			qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
171			enddo
172			enddo
173	molod	1.1	enddo
174	molod	1.11	enddo
175	molod	1.2	enddo
176	molod	1.11
177	molod	1.2	ndiag(index) = 0
178
179	jmc	1.15	RETURN
180			END
181	molod	1.2
182	jmc	1.15	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
183	molod	1.2
184	jmc	1.15	CBOP 0
185			C !ROUTINE: DIAGNOSTICS_IS_ON
186	molod	1.2
187	jmc	1.15	C !INTERFACE:
188			LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )
189	molod	1.2
190	jmc	1.15	C !DESCRIPTION:
191			C ==========================================================
192			C \| FUNCTION DIAGNOSTIC_IS_ON
193			C \| o Return TRUE if diagnostics "diagName" is Active
194			C ==========================================================
195	molod	1.2
196	jmc	1.15	C !USES:
197			IMPLICIT NONE
198			#include "EEPARAMS.h"
199			#include "SIZE.h"
200			#include "DIAGNOSTICS_SIZE.h"
201			#include "DIAGNOSTICS.h"
202	molod	1.2
203	jmc	1.15	C !INPUT PARAMETERS:
204			C diagName :: diagnostic identificator name (8 characters long)
205			C myThid :: my thread Id number
206			CHARACTER*8 diagName
207			INTEGER myThid
208			CEOP
209	molod	1.2
210	jmc	1.15	C !LOCAL VARIABLES:
211			INTEGER j,n,m
212	molod	1.2
213	jmc	1.15	DIAGNOSTICS_IS_ON = .FALSE.
214			DO n=1,nlists
215			DO m=1,nActive(n)
216			IF ( diagName.EQ.flds(m,n) ) THEN
217			j = jdiag(m,n)
218	jmc	1.16	IF ( idiag(j).NE.0 .AND. ndiag(j).GE.0 )
219			& DIAGNOSTICS_IS_ON = .TRUE.
220	jmc	1.15	ENDIF
221			ENDDO
222			ENDDO
223	molod	1.2
224			RETURN
225			END
226	jmc	1.17
227			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
228
229			CBOP 0
230			C !ROUTINE: DIAGS_MK_UNITS
231
232			C !INTERFACE:
233			CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
234			I diagUnitsInPieces, myThid )
235
236			C !DESCRIPTION:
237			C ==========================================================
238			C \| FUNCTION DIAGS_MK_UNITS
239			C \| o Return the diagnostic units string (16c) removing
240			C \| blanks from the input string
241			C ==========================================================
242
243			C !USES:
244			IMPLICIT NONE
245			#include "EEPARAMS.h"
246
247			C !INPUT PARAMETERS:
248			C diagUnitsInPieces :: string for diagnostic units: in several
249			C pieces, with blanks in between
250			C myThid :: my thread Id number
251			CHARACTER() diagUnitsInPieces
252			INTEGER myThid
253			CEOP
254
255			C !LOCAL VARIABLES:
256			CHARACTER*(MAX_LEN_MBUF) msgBuf
257			INTEGER i,j,n
258
259			DIAGS_MK_UNITS = ' '
260			n = LEN(diagUnitsInPieces)
261
262			j = 0
263			DO i=1,n
264			IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
265			j = j+1
266			IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
267			ENDIF
268			ENDDO
269
270			IF ( j.GT.16 ) THEN
271			WRITE(msgBuf,'(2A,I4,A)') 'WARNING ',
272			& 'DIAGS_MK_UNITS: too long (',j,' >16) input string'
273			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
274			& SQUEEZE_RIGHT , myThid)
275			WRITE(msgBuf,'(3A)') 'WARNING ',
276			& 'DIAGS_MK_UNITS: input=', diagUnitsInPieces
277			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
278			& SQUEEZE_RIGHT , myThid)
279			ENDIF
280
281			RETURN
282			END