pkg/diagnostics/diagnostics_utils.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.10 2004/07/07 03:47:05 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).ge.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).ge.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.11	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.10 2004/07/07 03:47:05 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	molod	1.11	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	molod	1.11
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	molod	1.11
40	molod	1.3	_RL factor
41			integer i,j,ipnt,klev
42	molod	1.2	integer bi,bj
43	molod	1.11
44	molod	1.3	if (ipoint.lt.1) go to 999
45	molod	1.11
46	molod	1.3	klev = kdiag(ipoint)
47			if(klev.ge.lev) then
48	molod	1.11	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).ge.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	molod	1.11
111	molod	1.3	klev = kdiag(ipoint)
112	molod	1.11	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			if( qdiag(i,j,ipnt,bi,bj).ge.undef ) then
121			qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)
122			else
123			qtmp(i,j,lev,bi,bj) = undef
124			endif
125			enddo
126			enddo
127
128			enddo
129			enddo
130
131	molod	1.3	endif
132
133			999 return
134			end
135	molod	1.2	subroutine clrindx (myThid,listnum)
136	molod	1.1	C***********************************************************************
137			C
138			C PURPOSE
139			C DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST
140			C
141			C ARGUMENT DESCRIPTION
142	molod	1.2	C listnum .... diagnostics list number
143	molod	1.1	C
144			C***********************************************************************
145
146			implicit none
147	molod	1.2	#include "EEPARAMS.h"
148			#include "CPP_OPTIONS.h"
149	molod	1.1	#include "SIZE.h"
150			#include "diagnostics_SIZE.h"
151			#include "diagnostics.h"
152
153	molod	1.2	integer myThid, listnum
154
155			integer m, n
156	molod	1.1	character*8 parms1
157			character*1 parse1(8)
158			character*3 mate_index
159	molod	1.2	integer mate
160	molod	1.1
161			equivalence ( parms1 , parse1(1) )
162			equivalence ( mate_index , parse1(6) )
163
164	molod	1.11	do n=1,nfields(listnum)
165			do m=1,ndiagt
166			if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then
167			call clrdiag (myThid,m)
168
169			c Check for Counter Diagnostic
170			c ----------------------------
171			parms1 = gdiag(m)
172			if( parse1(5).eq.'C' ) then
173			read (mate_index,100) mate
174			call clrdiag (myThid,mate)
175			endif
176			endif
177			enddo
178	molod	1.2	enddo
179	molod	1.1
180			100 format(i3)
181			RETURN
182			END
183
184
185	molod	1.2	subroutine clrdiag (myThid,index)
186	molod	1.1	C***********************************************************************
187			C PURPOSE
188	molod	1.2	C ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS
189	molod	1.1	C***********************************************************************
190
191			implicit none
192	molod	1.2	#include "EEPARAMS.h"
193			#include "CPP_OPTIONS.h"
194	molod	1.1	#include "SIZE.h"
195			#include "diagnostics_SIZE.h"
196			#include "diagnostics.h"
197
198	molod	1.2	integer myThid, index
199
200			integer bi,bj
201	molod	1.1	integer i,j,k
202
203			C **********************************************************************
204			C ** SET DIAGNOSTIC AND COUNTER TO ZERO **
205			C **********************************************************************
206
207	molod	1.2	do bj=myByLo(myThid), myByHi(myThid)
208	molod	1.11	do bi=myBxLo(myThid), myBxHi(myThid)
209			do k = 1,kdiag(index)
210			do j = 1,sNy
211			do i = 1,sNx
212			qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
213			enddo
214	molod	1.1	enddo
215	molod	1.11	enddo
216	molod	1.2	enddo
217	molod	1.11	enddo
218
219	molod	1.2	ndiag(index) = 0
220
221			return
222			end
223
224			subroutine setdiag (myThid,num,ndiagmx)
225			C***********************************************************************
226			C
227			C PURPOSE
228			C SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM
229			C
230			C***********************************************************************
231
232			implicit none
233			#include "CPP_OPTIONS.h"
234			#include "SIZE.h"
235			#include "diagnostics_SIZE.h"
236			#include "diagnostics.h"
237
238			integer num,myThid,ndiagmx
239			integer ipointer
240
241			DATA IPOINTER / 1 /
242
243			character*8 parms1
244			character*1 parse1(8)
245			character*3 mate_index
246			integer mate
247
248			equivalence ( parms1 , parse1(1) )
249			equivalence ( mate_index , parse1(6) )
250
251			C **********************************************************************
252			C ** SET POINTERS FOR DIAGNOSTIC NUM **
253			C **********************************************************************
254
255			parms1 = gdiag(num)
256
257			IF( IDIAG(NUM).EQ.0 ) THEN
258			if(ndiagmx+kdiag(num).gt.numdiags) then
259			write(6,4000)num,cdiag(num)
260			else
261			IDIAG(NUM) = IPOINTER
262			IPOINTER = IPOINTER + KDIAG(NUM)
263			ndiagmx = ndiagmx + KDIAG(NUM)
264	molod	1.11	if(myThid.eq.1) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx
265	molod	1.2	endif
266			ELSE
267	molod	1.11	if(myThid.eq.1) WRITE(6,3000) NUM, CDIAG(NUM)
268	molod	1.2	ENDIF
269
270	molod	1.11	c Check for Counter Diagnostic
271			c ----------------------------
272			if( parse1(5).eq.'C') then
273			read (mate_index,100) mate
274
275			IF( IDIAG(mate).EQ.0 ) THEN
276			if(ndiagmx+kdiag(num).gt.numdiags) then
277			write(6,5000)num,cdiag(num)
278			else
279			IDIAG(mate) = IPOINTER
280			IPOINTER = IPOINTER + KDIAG(mate)
281			ndiagmx = ndiagmx + KDIAG(mate)
282			if(myThid.eq.1)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx
283			endif
284			ELSE
285	molod	1.4	if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)
286	molod	1.11	ENDIF
287	molod	1.2	endif
288
289			RETURN
290	molod	1.1
291	molod	1.2	100 format(i3)
292			2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,
293			. ' (',A8,'), Total Number of Diagnostics: ',I5)
294			3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')
295			4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,
296			. ' (',A8,')')
297			5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',
298			. I3,' (',A8,')',' WARNING - Diag will not accumulate properly')
299			END