/[MITgcm]/MITgcm/pkg/diagnostics/diagnostics_utils.F
ViewVC logotype

Annotation of /MITgcm/pkg/diagnostics/diagnostics_utils.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.24 - (hide annotations) (download)
Sun Dec 24 20:18:05 2006 UTC (17 years, 4 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint58u_post, checkpoint58w_post, checkpoint58x_post, checkpoint58t_post, checkpoint59e, checkpoint59d, checkpoint59g, checkpoint59f, checkpoint59a, checkpoint59c, checkpoint59b, checkpoint59m, checkpoint59l, checkpoint59i, checkpoint59h, checkpoint59k, checkpoint59j, checkpoint59, checkpoint58y_post, checkpoint58v_post
Changes since 1.23: +75 -23 lines
change S/R DIAGNOSTICS_GET_POINTERS: add 1 argument that allow to catch
 the "right" diagnostic (since 1 diagnostic can be stored multiple times,
 for different output frequency,phase, ...)

1 jmc 1.24 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.23 2006/06/25 23:03:55 jmc 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 jmc 1.18 SUBROUTINE GETDIAG(
12     I levreal, undef,
13     O qtmp,
14 jmc 1.21 I ndId, mate, ip, im, bi, bj, myThid )
15 edhill 1.12
16     C !DESCRIPTION:
17 edhill 1.13 C Retrieve averaged model diagnostic
18 jmc 1.15
19 edhill 1.12 C !USES:
20 jmc 1.18 IMPLICIT NONE
21 molod 1.3 #include "EEPARAMS.h"
22 molod 1.1 #include "SIZE.h"
23 jmc 1.15 #include "DIAGNOSTICS_SIZE.h"
24     #include "DIAGNOSTICS.h"
25 molod 1.3
26 jmc 1.18 C !INPUT PARAMETERS:
27 jmc 1.21 C levreal :: Diagnostic LEVEL
28     C undef :: UNDEFINED VALUE
29     C ndId :: DIAGNOSTIC NUMBER FROM MENU
30     C mate :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise
31     C ip :: pointer to storage array location for diag.
32     C im :: pointer to storage array location for mate
33     C bi :: X-direction tile number
34     C bj :: Y-direction tile number
35     C myThid :: my thread Id number
36 jmc 1.15 _RL levreal
37 molod 1.3 _RL undef
38 jmc 1.21 INTEGER ndId, mate, ip, im
39 jmc 1.18 INTEGER bi,bj, myThid
40 jmc 1.15
41 jmc 1.18 C !OUTPUT PARAMETERS:
42 edhill 1.12 C qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
43 jmc 1.18 _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
44     CEOP
45 molod 1.11
46 jmc 1.18 C !LOCAL VARIABLES:
47 molod 1.3 _RL factor
48 jmc 1.18 INTEGER i, j, ipnt,ipCt
49     INTEGER lev, levCt, klev
50 molod 1.11
51 jmc 1.21 IF (ndId.GE.1) THEN
52 jmc 1.15 lev = NINT(levreal)
53 jmc 1.21 klev = kdiag(ndId)
54 jmc 1.18 IF (lev.LE.klev) THEN
55 jmc 1.15
56 jmc 1.18 IF ( mate.EQ.0 ) THEN
57     C- No counter diagnostics => average = Sum / ndiag :
58 jmc 1.15
59 jmc 1.21 ipnt = ip + lev - 1
60     factor = FLOAT(ndiag(ip,bi,bj))
61     IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
62 jmc 1.18
63     DO j = 1,sNy+1
64     DO i = 1,sNx+1
65     IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
66     qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
67     ELSE
68     qtmp(i,j) = undef
69     ENDIF
70     ENDDO
71     ENDDO
72    
73     ELSE
74     C- With counter diagnostics => average = Sum / counter:
75    
76 jmc 1.21 ipnt = ip + lev - 1
77 jmc 1.18 levCt= MIN(lev,kdiag(mate))
78 jmc 1.21 ipCt = im + levCt - 1
79 jmc 1.18 DO j = 1,sNy+1
80     DO i = 1,sNx+1
81     IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
82     qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)
83     & / qdiag(i,j,ipCt,bi,bj)
84     ELSE
85     qtmp(i,j) = undef
86     ENDIF
87     ENDDO
88     ENDDO
89 molod 1.1
90 jmc 1.18 ENDIF
91     ENDIF
92     ENDIF
93 molod 1.3
94 jmc 1.15 RETURN
95     END
96 edhill 1.12
97     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
98    
99 jmc 1.15 CBOP 0
100 jmc 1.19 C !ROUTINE: DIAGNOSTICS_COUNT
101     C !INTERFACE:
102 jmc 1.21 SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
103     I biArg, bjArg, myThid)
104 jmc 1.19
105     C !DESCRIPTION:
106     C***********************************************************************
107     C routine to increment the diagnostic counter only
108     C***********************************************************************
109     C !USES:
110     IMPLICIT NONE
111    
112     C == Global variables ===
113     #include "EEPARAMS.h"
114     #include "SIZE.h"
115     #include "DIAGNOSTICS_SIZE.h"
116     #include "DIAGNOSTICS.h"
117    
118     C !INPUT PARAMETERS:
119     C***********************************************************************
120     C Arguments Description
121     C ----------------------
122     C chardiag :: Character expression for diag to increment the counter
123     C biArg :: X-direction tile number, or 0 if called outside bi,bj loops
124     C bjArg :: Y-direction tile number, or 0 if called outside bi,bj loops
125     C myThid :: my thread Id number
126     C***********************************************************************
127     CHARACTER*8 chardiag
128     INTEGER biArg, bjArg
129     INTEGER myThid
130     CEOP
131    
132     C !LOCAL VARIABLES:
133     C ===============
134 jmc 1.21 INTEGER m, n
135     INTEGER bi, bj
136     INTEGER ipt
137 jmc 1.19 c CHARACTER*(MAX_LEN_MBUF) msgBuf
138    
139 jmc 1.21 C-- Run through list of active diagnostics to find which counter
140     C to increment (needs to be a valid & active diagnostic-counter)
141 jmc 1.19 DO n=1,nlists
142     DO m=1,nActive(n)
143 jmc 1.21 IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
144     ipt = idiag(m,n)
145     IF (ndiag(ipt,1,1).GE.0) THEN
146     C- Increment the counter for the diagnostic
147     IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
148     DO bj=myByLo(myThid), myByHi(myThid)
149     DO bi=myBxLo(myThid), myBxHi(myThid)
150     ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
151     ENDDO
152     ENDDO
153     ELSE
154     bi = MIN(biArg,nSx)
155     bj = MIN(bjArg,nSy)
156     ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
157     ENDIF
158     C- Increment is done
159     ENDIF
160 jmc 1.19 ENDIF
161     ENDDO
162     ENDDO
163    
164 jmc 1.21 RETURN
165 jmc 1.19 END
166    
167     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
168    
169     CBOP 0
170 jmc 1.17 C !ROUTINE: DIAGS_MK_UNITS
171    
172     C !INTERFACE:
173 jmc 1.21 CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
174 jmc 1.17 I diagUnitsInPieces, myThid )
175    
176     C !DESCRIPTION:
177     C *==========================================================*
178     C | FUNCTION DIAGS_MK_UNITS
179 jmc 1.21 C | o Return the diagnostic units string (16c) removing
180 jmc 1.17 C | blanks from the input string
181     C *==========================================================*
182    
183     C !USES:
184     IMPLICIT NONE
185     #include "EEPARAMS.h"
186    
187     C !INPUT PARAMETERS:
188 jmc 1.21 C diagUnitsInPieces :: string for diagnostic units: in several
189 jmc 1.17 C pieces, with blanks in between
190     C myThid :: my thread Id number
191     CHARACTER*(*) diagUnitsInPieces
192     INTEGER myThid
193     CEOP
194    
195     C !LOCAL VARIABLES:
196     CHARACTER*(MAX_LEN_MBUF) msgBuf
197     INTEGER i,j,n
198    
199 jmc 1.21 DIAGS_MK_UNITS = ' '
200 jmc 1.17 n = LEN(diagUnitsInPieces)
201 jmc 1.21
202 jmc 1.17 j = 0
203     DO i=1,n
204     IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
205     j = j+1
206     IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
207     ENDIF
208     ENDDO
209    
210     IF ( j.GT.16 ) THEN
211     WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
212     & 'DIAGS_MK_UNITS: too long (',j,' >16) input string'
213     CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
214     & SQUEEZE_RIGHT , myThid)
215     WRITE(msgBuf,'(3A)') '**WARNING** ',
216     & 'DIAGS_MK_UNITS: input=', diagUnitsInPieces
217     CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
218     & SQUEEZE_RIGHT , myThid)
219     ENDIF
220    
221     RETURN
222     END
223 jmc 1.23
224     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
225    
226     CBOP 0
227     C !ROUTINE: DIAGS_MK_TITLE
228    
229     C !INTERFACE:
230     CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
231     I diagTitleInPieces, myThid )
232    
233     C !DESCRIPTION:
234     C *==========================================================*
235     C | FUNCTION DIAGS_MK_TITLE
236     C | o Return the diagnostic title string (80c) removing
237     C | consecutive blanks from the input string
238     C *==========================================================*
239    
240     C !USES:
241     IMPLICIT NONE
242     #include "EEPARAMS.h"
243    
244     C !INPUT PARAMETERS:
245     C diagTitleInPieces :: string for diagnostic units: in several
246     C pieces, with blanks in between
247     C myThid :: my Thread Id number
248     CHARACTER*(*) diagTitleInPieces
249     INTEGER myThid
250     CEOP
251    
252     C !LOCAL VARIABLES:
253     CHARACTER*(MAX_LEN_MBUF) msgBuf
254     LOGICAL flag
255     INTEGER i,j,n
256    
257 molod 1.22 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
258 jmc 1.23
259     DIAGS_MK_TITLE = ' '
260     & //' '
261     n = LEN(diagTitleInPieces)
262    
263     j = 0
264     flag = .FALSE.
265     DO i=1,n
266     IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
267     IF ( flag ) THEN
268     j = j+1
269     IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
270     ENDIF
271     j = j+1
272     IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
273     flag = .FALSE.
274     ELSE
275     flag = j.GE.1
276     ENDIF
277     ENDDO
278    
279     IF ( j.GT.80 ) THEN
280     WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
281     & 'DIAGS_MK_TITLE: too long (',j,' >80) input string'
282     CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
283     & SQUEEZE_RIGHT , myThid)
284     WRITE(msgBuf,'(3A)') '**WARNING** ',
285     & 'DIAGS_MK_TITLE: input=', diagTitleInPieces
286     CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
287     & SQUEEZE_RIGHT , myThid)
288     ENDIF
289    
290     RETURN
291     END
292    
293     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
294    
295 molod 1.22 CBOP 0
296 jmc 1.24 C !ROUTINE: DIAGNOSTICS_GET_POINTERS
297 molod 1.22 C !INTERFACE:
298 jmc 1.24 SUBROUTINE DIAGNOSTICS_GET_POINTERS(
299     I diagName, listId,
300     O ndId, ip,
301     I myThid )
302 molod 1.22
303     C !DESCRIPTION:
304 jmc 1.24 C *================================================================*
305     C | o Returns the diagnostic Id number and diagnostic
306     C | pointer to storage array for a specified diagnostic.
307     C *================================================================*
308     C | Note: A diagnostics field can be stored multiple times
309     C | (for different output frequency,phase, ...).
310     C | operates in 2 ways:
311     C | o listId =0 => find 1 diagnostics Id & pointer which name matches.
312     C | o listId >0 => find the unique diagnostic Id & pointer with
313     C | the right name and same output time as "listId" output-list
314     C | o return ip=0 if did not find the right diagnostic;
315     C | (ndId <>0 if diagnostic exist but output time does not match)
316     C *================================================================*
317 molod 1.22
318     C !USES:
319     IMPLICIT NONE
320     #include "EEPARAMS.h"
321     #include "SIZE.h"
322     #include "DIAGNOSTICS_SIZE.h"
323     #include "DIAGNOSTICS.h"
324    
325     C !INPUT PARAMETERS:
326 jmc 1.24 C diagName :: diagnostic identificator name (8 characters long)
327     C listId :: list number that specify the output frequency
328     C myThid :: my Thread Id number
329 molod 1.22 C !OUTPUT PARAMETERS:
330 jmc 1.24 C ndId :: diagnostics Id number (in available diagnostics list)
331     C ip :: diagnostics pointer to storage array
332    
333 molod 1.22
334     CHARACTER*8 diagName
335 jmc 1.24 INTEGER listId
336     INTEGER ndId, ip
337     INTEGER myThid
338 molod 1.22 CEOP
339    
340     C !LOCAL VARIABLES:
341     INTEGER n,m
342    
343 jmc 1.24 ip = 0
344     ndId = 0
345    
346     IF ( listId.LE.0 ) THEN
347     C-- select the 1rst one which name matches:
348 molod 1.22
349     C- search for this diag. in the active 2D/3D diagnostics list
350 jmc 1.24 DO n=1,nlists
351     DO m=1,nActive(n)
352     IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
353     & .AND. idiag(m,n).NE.0 ) THEN
354     ip = ABS(idiag(m,n))
355     ndId = jdiag(m,n)
356     ENDIF
357     ENDDO
358     ENDDO
359    
360     ELSEIF ( listId.LE.nlists ) THEN
361     C-- select the unique diagnostic with output-time identical to listId
362    
363     C- search for this diag. in the active 2D/3D diagnostics list
364     DO n=1,nlists
365     IF ( ip.EQ.0
366     & .AND. freq(n) .EQ. freq(listId)
367     & .AND. phase(n).EQ.phase(listId)
368     & .AND. averageFreq(n) .EQ.averageFreq(listId)
369     & .AND. averagePhase(n).EQ.averagePhase(listId)
370     & .AND. averageCycle(n).EQ.averageCycle(listId)
371     & ) THEN
372     DO m=1,nActive(n)
373     IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
374     & .AND. idiag(m,n).NE.0 ) THEN
375     ip = ABS(idiag(m,n))
376     ndId = jdiag(m,n)
377     ENDIF
378     ENDDO
379     ELSEIF ( ip.EQ.0 ) THEN
380     DO m=1,nActive(n)
381     IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
382     & .AND. idiag(m,n).NE.0 ) THEN
383     ndId = jdiag(m,n)
384     ENDIF
385     ENDDO
386     ENDIF
387     ENDDO
388    
389     ELSE
390     STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
391     ENDIF
392 molod 1.22
393     RETURN
394     END

  ViewVC Help
Powered by ViewVC 1.1.22