pkg/diagnostics/diagnostics_utils.F

      subroutine getdiag (lev,ipoint,bi,bj,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 "CPP_OPTIONS.h"
#include "SIZE.h"
#include "fizhi_SIZE.h"
#include "diagnostics_SIZE.h"
#include "diagnostics.h"

      integer bi,bj
      integer lev,ipoint
      integer i,j,ipnt,klev
      _RL undef, factor
      _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)

      do j = 1,sNy
      do i = 1,sNx
       qtmp(i,j,bi,bj) = undef
      enddo
      enddo

      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 j = 1,sNy
      do i = 1,sNx
      if( qdiag(i,j,ipnt,bi,bj).ne.undef ) 
     .     qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor
      enddo
      enddo
      ENDIF

 999  RETURN
      END

      subroutine getdiag2 (lev,ipoint,bi,bj,undef,qtmp)
C***********************************************************************        
C                                                                               
C  PURPOSE                                                                      
C     Retrieve model diagnostic (No Averaging)
C  INPUT:                                                                       
C     lev ..... Model LEVEL                                                     
C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                     
C   undef ..... UNDEFINED VALUE                                                 
C      im ..... X-DIMENSION
C      jm ..... Y-DIMENSION
C      nd ..... Number of 2-D Diagnostics
C                                                                               
C  OUTPUT:                                                                      
C    qtmp ..... DIAGNOSTIC QUANTITY                                             
C                                                                               
C***********************************************************************        
      implicit none

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

      integer bi,bj

      integer lev,ipoint
      integer i,j,ipnt,klev
      _RL undef
      _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)

      do j = 1,sNy
      do i = 1,sNx
       qtmp(i,j,bi,bj) = undef
      enddo
      enddo

      IF (IPOINT.LT.1) GO TO 999

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