pkg/diagnostics/diagnostics_utils.F

      subroutine getdiag (myThid,lev,ipoint,undef,qtmp)
C***********************************************************************        
C  PURPOSE                                                                      
C     Retrieve averaged model diagnostic
C  INPUT:                                                                       
C     lev ..... 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
C                                                                               
C  OUTPUT:                                                                      
C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
C                                                                               
C***********************************************************************        
      implicit none

#include "EEPARAMS.h"
#include "CPP_OPTIONS.h"
#include "SIZE.h"

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

#include "diagnostics_SIZE.h"
#include "diagnostics.h"

      integer myThid,lev,ipoint
      _RL undef
      _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)

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

      if (ipoint.lt.1) go to 999

      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).ne.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

 999  return
      end

      subroutine getdiag2 (myThid,lev,ipoint,undef,qtmp)
C***********************************************************************        
C  PURPOSE                                                                      
C     Retrieve averaged model diagnostic
C  INPUT:                                                                       
C     lev ..... Diagnostic LEVEL
C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                     
C   undef ..... UNDEFINED VALUE                                                 
C                                                                               
C  OUTPUT:                                                                      
C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
C                                                                               
C***********************************************************************        
      implicit none

#include "EEPARAMS.h"
#include "CPP_OPTIONS.h"
#include "SIZE.h"

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

#include "diagnostics_SIZE.h"
#include "diagnostics.h"

      integer myThid,lev,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

      if (ipoint.lt.1) go to 999

      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).ne.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

 999  return
      end
      subroutine clrindx (myThid,listnum)
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 "CPP_OPTIONS.h"
#include "SIZE.h"
#include "fizhi_SIZE.h"
#include "diagnostics_SIZE.h"
#include "diagnostics.h"

      integer myThid, listnum

      integer m, n
      character*8 parms1
      character*1 parse1(8)
      character*3 mate_index
      integer mate

      equivalence (     parms1 , parse1(1) )
      equivalence ( mate_index , parse1(6) )

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

c Check for Counter Diagnostic
c ----------------------------
         parms1 =  gdiag(m)
         if( parse1(5).eq.'C' ) then
          read (mate_index,100) mate
          call clrdiag (myThid,mate)
         endif
        endif
       enddo
      enddo
                   
  100 format(i3)
      RETURN       
      END          


      subroutine clrdiag (myThid,index)
C***********************************************************************        
C  PURPOSE                                                                      
C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS
C***********************************************************************        
                                                                                
      implicit none
#include "EEPARAMS.h"
#include "CPP_OPTIONS.h"
#include "SIZE.h"
#include "fizhi_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,sNy
        do i = 1,sNx
         qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
        enddo
        enddo
       enddo
      enddo
      enddo

      ndiag(index) = 0

      return
      end

      subroutine setdiag (myThid,num,ndiagmx)
C***********************************************************************
C
C  PURPOSE
C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM
C
C***********************************************************************

      implicit none
#include "CPP_OPTIONS.h"
#include "SIZE.h"
#include "fizhi_SIZE.h"
#include "diagnostics_SIZE.h"
#include "diagnostics.h"

      integer num,myThid,ndiagmx
      integer ipointer

      DATA IPOINTER / 1 /

      character*8 parms1
      character*1 parse1(8)
      character*3 mate_index
      integer     mate

      equivalence (     parms1 , parse1(1) )
      equivalence ( mate_index , parse1(6) )

C **********************************************************************
C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****
C **********************************************************************

      parms1 = gdiag(num)

      IF( IDIAG(NUM).EQ.0 ) THEN
        if(ndiagmx+kdiag(num).gt.numdiags) then
          write(6,4000)num,cdiag(num)
        else
          IDIAG(NUM) = IPOINTER
          IPOINTER   = IPOINTER + KDIAG(NUM)
          ndiagmx    = ndiagmx  + KDIAG(NUM)
          if(myThid.eq.0) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx
        endif
      ELSE
          if(myThid.eq.0) WRITE(6,3000) NUM, CDIAG(NUM)
      ENDIF

c Check for Counter Diagnostic
c ----------------------------
      if( parse1(5).eq.'C') then
      read (mate_index,100) mate

      IF( IDIAG(mate).EQ.0 ) THEN
       if(ndiagmx+kdiag(num).gt.numdiags) then
        write(6,5000)num,cdiag(num)
       else
        IDIAG(mate) = IPOINTER
        IPOINTER    = IPOINTER + KDIAG(mate)
        ndiagmx     = ndiagmx  + KDIAG(mate)
        if(myThid.eq.0)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx
       endif
      ELSE
          if(myThid.eq.0) WRITE(6,3000) mate, CDIAG(mate)
      ENDIF
      endif

      RETURN

  100 format(i3)
 2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,
     .          ' (',A8,'),  Total Number of Diagnostics: ',I5)
 3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')
 4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,
     .                      ' (',A8,')')
 5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',
     .    I3,' (',A8,')',' WARNING - Diag will not accumulate properly')
      END
1	molod	1.3	subroutine getdiag (myThid,lev,ipoint,undef,qtmp)
2	molod	1.1	C***********************************************************************
3			C PURPOSE
4			C Retrieve averaged model diagnostic
5			C INPUT:
6	molod	1.2	C lev ..... Diagnostic LEVEL
7	molod	1.1	C ipoint ..... DIAGNOSTIC NUMBER FROM MENU
8			C undef ..... UNDEFINED VALUE
9	molod	1.2	C bi ..... X-direction process(or) number
10			C bj ..... Y-direction process(or) number
11	molod	1.1	C
12			C OUTPUT:
13	molod	1.2	C qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
14	molod	1.1	C
15			C***********************************************************************
16			implicit none
17
18	molod	1.3	#include "EEPARAMS.h"
19	molod	1.2	#include "CPP_OPTIONS.h"
20	molod	1.1	#include "SIZE.h"
21	molod	1.3
22			#ifdef ALLOW_FIZHI
23	molod	1.1	#include "fizhi_SIZE.h"
24	molod	1.3	#else
25			integer Nrphys
26			parameter (Nrphys=1)
27			#endif
28
29	molod	1.1	#include "diagnostics_SIZE.h"
30			#include "diagnostics.h"
31
32	molod	1.3	integer myThid,lev,ipoint
33			_RL undef
34			_RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)
35
36			_RL factor
37			integer i,j,ipnt,klev
38	molod	1.2	integer bi,bj
39	molod	1.3
40			if (ipoint.lt.1) go to 999
41
42			klev = kdiag(ipoint)
43			if(klev.ge.lev) then
44			ipnt = idiag(ipoint) + lev - 1
45			factor = 1.0
46			if(ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)
47
48			do bj=myByLo(myThid), myByHi(myThid)
49			do bi=myBxLo(myThid), myBxHi(myThid)
50	molod	1.1
51	molod	1.2	do j = 1,sNy
52			do i = 1,sNx
53	molod	1.3	if( qdiag(i,j,ipnt,bi,bj).ne.undef ) then
54			qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor
55			else
56			qtmp(i,j,lev,bi,bj) = undef
57			endif
58	molod	1.1	enddo
59			enddo
60
61			enddo
62			enddo
63
64	molod	1.3	endif
65	molod	1.1
66	molod	1.3	999 return
67			end
68
69			subroutine getdiag2 (myThid,lev,ipoint,undef,qtmp)
70	molod	1.1	C***********************************************************************
71			C PURPOSE
72	molod	1.3	C Retrieve averaged model diagnostic
73	molod	1.1	C INPUT:
74	molod	1.3	C lev ..... Diagnostic LEVEL
75	molod	1.1	C ipoint ..... DIAGNOSTIC NUMBER FROM MENU
76			C undef ..... UNDEFINED VALUE
77			C
78			C OUTPUT:
79	molod	1.3	C qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
80	molod	1.1	C
81			C***********************************************************************
82			implicit none
83
84	molod	1.3	#include "EEPARAMS.h"
85	molod	1.2	#include "CPP_OPTIONS.h"
86	molod	1.1	#include "SIZE.h"
87	molod	1.3
88			#ifdef ALLOW_FIZHI
89	molod	1.1	#include "fizhi_SIZE.h"
90	molod	1.3	#else
91			integer Nrphys
92			parameter (Nrphys=1)
93			#endif
94
95	molod	1.1	#include "diagnostics_SIZE.h"
96			#include "diagnostics.h"
97
98	molod	1.3	integer myThid,lev,ipoint
99			_RL undef
100			_RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)
101
102			integer i,j,ipnt,klev
103	molod	1.2	integer bi,bj
104	molod	1.1
105	molod	1.3	if (ipoint.lt.1) go to 999
106
107			klev = kdiag(ipoint)
108			if(klev.ge.lev) then
109			ipnt = idiag(ipoint) + lev - 1
110
111			do bj=myByLo(myThid), myByHi(myThid)
112			do bi=myBxLo(myThid), myBxHi(myThid)
113	molod	1.1
114	molod	1.2	do j = 1,sNy
115			do i = 1,sNx
116	molod	1.3	if( qdiag(i,j,ipnt,bi,bj).ne.undef ) then
117			qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)
118			else
119			qtmp(i,j,lev,bi,bj) = undef
120			endif
121	molod	1.1	enddo
122			enddo
123
124			enddo
125			enddo
126
127	molod	1.3	endif
128
129			999 return
130			end
131	molod	1.2	subroutine clrindx (myThid,listnum)
132	molod	1.1	C***********************************************************************
133			C
134			C PURPOSE
135			C DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST
136			C
137			C ARGUMENT DESCRIPTION
138	molod	1.2	C listnum .... diagnostics list number
139	molod	1.1	C
140			C***********************************************************************
141
142			implicit none
143	molod	1.2	#include "EEPARAMS.h"
144			#include "CPP_OPTIONS.h"
145	molod	1.1	#include "SIZE.h"
146			#include "fizhi_SIZE.h"
147			#include "diagnostics_SIZE.h"
148			#include "diagnostics.h"
149
150	molod	1.2	integer myThid, listnum
151
152			integer m, n
153	molod	1.1	character*8 parms1
154			character*1 parse1(8)
155			character*3 mate_index
156	molod	1.2	integer mate
157	molod	1.1
158			equivalence ( parms1 , parse1(1) )
159			equivalence ( mate_index , parse1(6) )
160
161	molod	1.2	do n=1,nfields(listnum)
162			do m=1,ndiagt
163			if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then
164			call clrdiag (myThid,m)
165	molod	1.1
166			c Check for Counter Diagnostic
167			c ----------------------------
168	molod	1.2	parms1 = gdiag(m)
169			if( parse1(5).eq.'C' ) then
170			read (mate_index,100) mate
171			call clrdiag (myThid,mate)
172			endif
173			endif
174			enddo
175			enddo
176	molod	1.1
177			100 format(i3)
178			RETURN
179			END
180
181
182	molod	1.2	subroutine clrdiag (myThid,index)
183	molod	1.1	C***********************************************************************
184			C PURPOSE
185	molod	1.2	C ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS
186	molod	1.1	C***********************************************************************
187
188			implicit none
189	molod	1.2	#include "EEPARAMS.h"
190			#include "CPP_OPTIONS.h"
191	molod	1.1	#include "SIZE.h"
192			#include "fizhi_SIZE.h"
193			#include "diagnostics_SIZE.h"
194			#include "diagnostics.h"
195
196	molod	1.2	integer myThid, index
197
198			integer bi,bj
199	molod	1.1	integer i,j,k
200
201			C **********************************************************************
202			C ** SET DIAGNOSTIC AND COUNTER TO ZERO **
203			C **********************************************************************
204
205	molod	1.2	do bj=myByLo(myThid), myByHi(myThid)
206			do bi=myBxLo(myThid), myBxHi(myThid)
207			do k = 1,kdiag(index)
208			do j = 1,sNy
209			do i = 1,sNx
210			qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
211	molod	1.1	enddo
212			enddo
213	molod	1.2	enddo
214			enddo
215			enddo
216
217			ndiag(index) = 0
218
219			return
220			end
221
222			subroutine setdiag (myThid,num,ndiagmx)
223			C***********************************************************************
224			C
225			C PURPOSE
226			C SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM
227			C
228			C***********************************************************************
229
230			implicit none
231			#include "CPP_OPTIONS.h"
232			#include "SIZE.h"
233			#include "fizhi_SIZE.h"
234			#include "diagnostics_SIZE.h"
235			#include "diagnostics.h"
236
237			integer num,myThid,ndiagmx
238			integer ipointer
239
240			DATA IPOINTER / 1 /
241
242			character*8 parms1
243			character*1 parse1(8)
244			character*3 mate_index
245			integer mate
246
247			equivalence ( parms1 , parse1(1) )
248			equivalence ( mate_index , parse1(6) )
249
250			C **********************************************************************
251			C ** SET POINTERS FOR DIAGNOSTIC NUM **
252			C **********************************************************************
253
254			parms1 = gdiag(num)
255
256			IF( IDIAG(NUM).EQ.0 ) THEN
257			if(ndiagmx+kdiag(num).gt.numdiags) then
258			write(6,4000)num,cdiag(num)
259			else
260			IDIAG(NUM) = IPOINTER
261			IPOINTER = IPOINTER + KDIAG(NUM)
262			ndiagmx = ndiagmx + KDIAG(NUM)
263			if(myThid.eq.0) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx
264			endif
265			ELSE
266			if(myThid.eq.0) WRITE(6,3000) NUM, CDIAG(NUM)
267			ENDIF
268
269			c Check for Counter Diagnostic
270			c ----------------------------
271			if( parse1(5).eq.'C') then
272			read (mate_index,100) mate
273
274			IF( IDIAG(mate).EQ.0 ) THEN
275			if(ndiagmx+kdiag(num).gt.numdiags) then
276			write(6,5000)num,cdiag(num)
277			else
278			IDIAG(mate) = IPOINTER
279			IPOINTER = IPOINTER + KDIAG(mate)
280			ndiagmx = ndiagmx + KDIAG(mate)
281			if(myThid.eq.0)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx
282			endif
283			ELSE
284			if(myThid.eq.0) WRITE(6,3000) mate, CDIAG(mate)
285			ENDIF
286			endif
287
288			RETURN
289	molod	1.1
290	molod	1.2	100 format(i3)
291			2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,
292			. ' (',A8,'), Total Number of Diagnostics: ',I5)
293			3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')
294			4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,
295			. ' (',A8,')')
296			5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',
297			. I3,' (',A8,')',' WARNING - Diag will not accumulate properly')
298			END