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 "PACKAGES_CONFIG.h"
#include "EEPARAMS.h"
#include "CPP_OPTIONS.h"
#include "SIZE.h"

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