pkg/diagnostics/diagnostics_utils.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.9 2004/07/06 03:55:53 edhill Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

      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=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
                qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)
              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
            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. _d 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
      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	edhill	1.10	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.9 2004/07/06 03:55:53 edhill Exp $
2	edhill	1.8	C $Name: $
3
4	edhill	1.9	#include "DIAG_OPTIONS.h"
5
6	molod	1.3	subroutine getdiag (myThid,lev,ipoint,undef,qtmp)
7	molod	1.1	C***********************************************************************
8			C PURPOSE
9			C Retrieve averaged model diagnostic
10			C INPUT:
11	molod	1.2	C lev ..... Diagnostic LEVEL
12	molod	1.1	C ipoint ..... DIAGNOSTIC NUMBER FROM MENU
13			C undef ..... UNDEFINED VALUE
14	molod	1.2	C bi ..... X-direction process(or) number
15			C bj ..... Y-direction process(or) number
16	molod	1.1	C
17			C OUTPUT:
18	molod	1.2	C qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
19	molod	1.1	C
20			C***********************************************************************
21			implicit none
22	molod	1.3	#include "EEPARAMS.h"
23	molod	1.2	#include "CPP_OPTIONS.h"
24	molod	1.1	#include "SIZE.h"
25	molod	1.3
26			#ifdef ALLOW_FIZHI
27	molod	1.1	#include "fizhi_SIZE.h"
28	molod	1.3	#else
29	edhill	1.10	integer Nrphys
30			parameter (Nrphys=0)
31	molod	1.3	#endif
32
33	molod	1.1	#include "diagnostics_SIZE.h"
34			#include "diagnostics.h"
35	edhill	1.10
36	molod	1.3	integer myThid,lev,ipoint
37			_RL undef
38			_RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)
39	edhill	1.10
40	molod	1.3	_RL factor
41			integer i,j,ipnt,klev
42	molod	1.2	integer bi,bj
43	edhill	1.10
44	molod	1.3	if (ipoint.lt.1) go to 999
45	edhill	1.10
46	molod	1.3	klev = kdiag(ipoint)
47			if(klev.ge.lev) then
48	edhill	1.10	ipnt = idiag(ipoint) + lev - 1
49			factor = 1.0
50			if(ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)
51
52			do bj=myByLo(myThid), myByHi(myThid)
53			do bi=myBxLo(myThid), myBxHi(myThid)
54
55			do j = 1,sNy
56			do i = 1,sNx
57			if( qdiag(i,j,ipnt,bi,bj).ne.undef ) then
58			qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor
59			else
60			qtmp(i,j,lev,bi,bj) = undef
61			endif
62			enddo
63			enddo
64
65			enddo
66			enddo
67	molod	1.1
68	molod	1.3	endif
69	molod	1.1
70	molod	1.3	999 return
71			end
72
73			subroutine getdiag2 (myThid,lev,ipoint,undef,qtmp)
74	molod	1.1	C***********************************************************************
75			C PURPOSE
76	molod	1.3	C Retrieve averaged model diagnostic
77	molod	1.1	C INPUT:
78	molod	1.3	C lev ..... Diagnostic LEVEL
79	molod	1.1	C ipoint ..... DIAGNOSTIC NUMBER FROM MENU
80			C undef ..... UNDEFINED VALUE
81			C
82			C OUTPUT:
83	molod	1.3	C qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
84	molod	1.1	C
85			C***********************************************************************
86			implicit none
87
88	molod	1.3	#include "EEPARAMS.h"
89	molod	1.2	#include "CPP_OPTIONS.h"
90	molod	1.1	#include "SIZE.h"
91	molod	1.3
92			#ifdef ALLOW_FIZHI
93	molod	1.1	#include "fizhi_SIZE.h"
94	molod	1.3	#else
95			integer Nrphys
96	molod	1.6	parameter (Nrphys=0)
97	molod	1.3	#endif
98
99	molod	1.1	#include "diagnostics_SIZE.h"
100			#include "diagnostics.h"
101
102	molod	1.3	integer myThid,lev,ipoint
103			_RL undef
104			_RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)
105
106			integer i,j,ipnt,klev
107	molod	1.2	integer bi,bj
108	molod	1.1
109	molod	1.3	if (ipoint.lt.1) go to 999
110	edhill	1.10
111	molod	1.3	klev = kdiag(ipoint)
112	edhill	1.10	if (klev .ge. lev) then
113			ipnt = idiag(ipoint) + lev - 1
114
115			do bj=myByLo(myThid), myByHi(myThid)
116			do bi=myBxLo(myThid), myBxHi(myThid)
117
118			do j = 1,sNy
119			do i = 1,sNx
120			qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)
121			enddo
122			enddo
123
124			enddo
125			enddo
126
127	molod	1.3	endif
128
129			999 return
130			end
131	edhill	1.10
132
133	molod	1.2	subroutine clrindx (myThid,listnum)
134	molod	1.1	C***********************************************************************
135			C
136			C PURPOSE
137			C DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST
138			C
139			C ARGUMENT DESCRIPTION
140	molod	1.2	C listnum .... diagnostics list number
141	molod	1.1	C
142			C***********************************************************************
143
144			implicit none
145	molod	1.2	#include "EEPARAMS.h"
146			#include "CPP_OPTIONS.h"
147	molod	1.1	#include "SIZE.h"
148			#include "diagnostics_SIZE.h"
149			#include "diagnostics.h"
150
151	molod	1.2	integer myThid, listnum
152
153			integer m, n
154	molod	1.1	character*8 parms1
155			character*1 parse1(8)
156			character*3 mate_index
157	molod	1.2	integer mate
158	molod	1.1
159			equivalence ( parms1 , parse1(1) )
160			equivalence ( mate_index , parse1(6) )
161
162	edhill	1.10	do n = 1,nfields(listnum)
163			do m = 1,ndiagt
164			if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then
165			call clrdiag (myThid,m)
166
167			C Check for Counter Diagnostic
168			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	molod	1.2	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	edhill	1.10	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. _d 0
210			enddo
211			enddo
212			enddo
213	molod	1.1	enddo
214	molod	1.2	enddo
215	edhill	1.10
216	molod	1.2	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	edhill	1.10	if (myThid.eq.1)
262			& WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx
263	molod	1.2	endif
264			ELSE
265	edhill	1.10	if (myThid.eq.1)
266			& WRITE(6,3000) NUM, CDIAG(NUM)
267	molod	1.2	ENDIF
268
269	edhill	1.10	C Check for Counter Diagnostic
270			if ( parse1(5).eq.'C') then
271			read (mate_index,100) mate
272
273			IF( IDIAG(mate).EQ.0 ) THEN
274			if(ndiagmx+kdiag(num).gt.numdiags) then
275			write(6,5000)num,cdiag(num)
276			else
277			IDIAG(mate) = IPOINTER
278			IPOINTER = IPOINTER + KDIAG(mate)
279			ndiagmx = ndiagmx + KDIAG(mate)
280			if (myThid.eq.1)
281			& WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx
282			endif
283			ELSE
284	molod	1.4	if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)
285	edhill	1.10	ENDIF
286	molod	1.2	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