pkg/diagnostics/diagnostics_utils.F

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