pkg/diagnostics/diagnostics_utils.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.12 2004/07/08 00:30:45 edhill Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 0
C     !ROUTINE: GETDIAG

C     !INTERFACE:
      SUBROUTINE GETDIAG (myThid,lev,ipoint,undef,qtmp)

C     !DESCRIPTION:
C     Retrieve averaged model diagnostic
      
C     !USES:
      implicit none
#include "EEPARAMS.h"
#include "CPP_OPTIONS.h"
#include "SIZE.h"
CEOP

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

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

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
      integer myThid,lev,ipoint
      _RL undef
      
C     OUTPUT:
C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
      _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) .le. 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

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 0
C     !ROUTINE: GETDIAG2

C     !INTERFACE:
      SUBROUTINE GETDIAG2 (myThid,lev,ipoint,undef,qtmp)

C     !DESCRIPTION:
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***********************************************************************        
      
C     !USES:
      implicit none
#include "EEPARAMS.h"
#include "CPP_OPTIONS.h"
#include "SIZE.h"
CEOP

#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) .le. 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

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

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