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

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

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

Revision 1.16 - (hide annotations) (download)
Fri Jul 1 18:52:18 2011 UTC (12 years, 10 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint64y, checkpoint64x, checkpoint64z, checkpoint64q, checkpoint64p, checkpoint64s, checkpoint64r, checkpoint64u, checkpoint64t, checkpoint64w, checkpoint64v, checkpoint64i, checkpoint64h, checkpoint64k, checkpoint64j, checkpoint64m, checkpoint64l, checkpoint64o, checkpoint64n, checkpoint64a, checkpoint64c, checkpoint64b, checkpoint64e, checkpoint64d, checkpoint64g, checkpoint64f, checkpoint63p, checkpoint63q, checkpoint63r, checkpoint63s, checkpoint63l, checkpoint63m, checkpoint63n, checkpoint63o, checkpoint63h, checkpoint63i, checkpoint63j, checkpoint63k, checkpoint63d, checkpoint63e, checkpoint63f, checkpoint63g, checkpoint63a, checkpoint63b, checkpoint63c, checkpoint64, checkpoint65, checkpoint63, checkpoint66g, checkpoint66f, checkpoint66e, checkpoint66d, checkpoint66c, checkpoint66b, checkpoint66a, checkpoint66i, checkpoint66h, checkpoint65z, checkpoint65x, checkpoint65y, checkpoint65r, checkpoint65s, checkpoint65p, checkpoint65q, checkpoint65v, checkpoint65w, checkpoint65t, checkpoint65u, checkpoint65j, checkpoint65k, checkpoint65h, checkpoint65i, checkpoint65n, checkpoint65o, checkpoint65l, checkpoint65m, checkpoint65b, checkpoint65c, checkpoint65a, checkpoint65f, checkpoint65g, checkpoint65d, checkpoint65e
Changes since 1.15: +76 -3 lines 
In case an output file contains 2 post-processed diags which are computed
together (mate of 2nd PP-diag one is 1rst PP-diag), move these 2 diags
next to each other (to only computate them once): 1rst one then 2nd one.
1 jmc 1.16 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.15 2011/06/21 18:00:15 jmc Exp $
2 jmc 1.1 C $Name: $
3    
4     #include "DIAG_OPTIONS.h"
5    
6     CBOP
7     C !ROUTINE: DIAGNOSTICS_SET_POINTERS
8     C !INTERFACE:
9     SUBROUTINE DIAGNOSTICS_SET_POINTERS( myThid )
10    
11     C !DESCRIPTION: \bv
12     C *==================================================================
13     C | S/R DIAGNOSTICS_SET_POINTERS
14     C | o set pointers for active diagnostics
15     C *==================================================================
16     C \ev
17    
18     C !USES:
19     IMPLICIT NONE
20    
21     C == Global variables ===
22     #include "EEPARAMS.h"
23     #include "SIZE.h"
24     #include "DIAGNOSTICS_SIZE.h"
25     #include "DIAGNOSTICS.h"
26    
27     C !INPUT/OUTPUT PARAMETERS:
28     C == Routine arguments ==
29 jmc 1.13 C myThid :: my Thread Id. number
30 jmc 1.1 INTEGER myThid
31     CEOP
32    
33     C !LOCAL VARIABLES:
34     C == Local variables ==
35 jmc 1.7 INTEGER ndiagcount, ndCount
36 jmc 1.5 INTEGER md,ld,nd
37 jmc 1.1 INTEGER mate, nActiveMax
38 jmc 1.15 INTEGER i, j, k, k1, k2, kLev
39 jmc 1.1 LOGICAL found
40     CHARACTER*(MAX_LEN_MBUF) msgBuf
41 jmc 1.13 CHARACTER*12 suffix
42 jmc 1.1
43     _BEGIN_MASTER( myThid)
44    
45 jmc 1.16 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
46    
47     C-- In case an output file contains 2 post-processed diags which are computed
48     C together (mate of 2nd PP-diag one is 1rst PP-diag), move these 2 diags
49     C next to each other (to only computate them once): 1rst one then 2nd one.
50     DO ld=1,nlists
51     found = .FALSE.
52     DO md=1,nfields(ld)
53     C Search all possible model diagnostics
54     nd = 0
55     DO i=1,ndiagt
56     IF ( nd.EQ.0 .AND. flds(md,ld).EQ.cdiag(i) ) nd = i
57     ENDDO
58     j = 0
59     IF ( nd.GE.1 ) THEN
60     IF ( gdiag(nd)(5:5).EQ.'P' ) THEN
61     mate = hdiag(nd)
62     IF ( gdiag(mate)(5:5).EQ.'P' ) THEN
63     C Mate of Post-Processed diag "nd" is also Post-Processed
64     DO i=1,nfields(ld)
65     IF ( j.EQ.0 .AND. flds(i,ld).EQ.cdiag(mate) ) j = i
66     ENDDO
67     ENDIF
68     ENDIF
69     ENDIF
70     C And is found in the same output stream "ld" (at rank "j")
71     IF ( j.GE.1 .AND. j.NE.md-1 ) THEN
72     IF ( .NOT.found ) THEN
73     WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
74     & 'Re-Order Diags in Outp.Stream: ',fnames(ld)
75     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
76     & SQUEEZE_RIGHT, myThid )
77     ENDIF
78     found = .TRUE.
79     IF ( j.LT.md-1 ) THEN
80     WRITE(msgBuf,'(2A,2(A,I4),2A)')
81     & ' move ',flds(j,ld),' from ',j,' down to',md-1,
82     & ' just before ',flds(md,ld)
83     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
84     & SQUEEZE_RIGHT, myThid )
85     DO i=j,md-2
86     flds(i,ld) = flds(i+1,ld)
87     ENDDO
88     flds(md-1,ld) = cdiag(mate)
89     ELSEIF ( j.GT.md ) THEN
90     WRITE(msgBuf,'(2A,2(A,I4),2A)')
91     & ' move ',flds(j,ld),' from ',j,' up to ',md,
92     & ' just before ',flds(md,ld)
93     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
94     & SQUEEZE_RIGHT, myThid )
95     DO i=j,md+1,-1
96     flds(i,ld) = flds(i-1,ld)
97     ENDDO
98     flds(md,ld) = cdiag(mate)
99     ENDIF
100     ENDIF
101     ENDDO
102     IF ( found ) THEN
103     WRITE(msgBuf,'(2A,I4,A)') 'DIAGNOSTICS_SET_POINTERS: ',
104     & 'Updated list in Outp.Stream #', ld, ' :'
105     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
106     & SQUEEZE_RIGHT, myThid )
107     DO md = 1,nfields(ld),10
108     j = MIN(nfields(ld),md+9)
109     WRITE(msgBuf,'(21A)') ' Fields: ',(' ',flds(i,ld),i=md,j)
110     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
111     & SQUEEZE_RIGHT, myThid )
112     ENDDO
113     ENDIF
114     ENDDO
115    
116     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
117    
118 jmc 1.4 C-- Initialize pointer arrays to zero:
119 jmc 1.15 DO ld=1,numLists
120     DO md=1,numperList
121 jmc 1.5 idiag(md,ld) = 0
122     jdiag(md,ld) = 0
123     mdiag(md,ld) = 0
124     ENDDO
125 jmc 1.4 ENDDO
126    
127 jmc 1.6 C-- Calculate pointers for diagnostics in active output-stream
128     C (i.e., with defined filename)
129 jmc 1.4
130 jmc 1.1 ndiagcount = 0
131     nActiveMax = 0
132 jmc 1.5 DO ld=1,nlists
133     nActive(ld) = nfields(ld)
134     DO md=1,nfields(ld)
135 jmc 1.1
136     found = .FALSE.
137     C Search all possible model diagnostics
138 jmc 1.5 DO nd=1,ndiagt
139     IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
140     CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
141 jmc 1.1 found = .TRUE.
142 jmc 1.5 jdiag(md,ld) = nd
143 jmc 1.1 ENDIF
144     ENDDO
145     IF ( .NOT.found ) THEN
146 jmc 1.7 CALL DIAGNOSTICS_LIST_CHECK(
147     O ndCount,
148 dfer 1.11 I ld, md, nlists, nfields, flds, myThid )
149 jmc 1.7 IF ( ndCount.EQ.0 ) THEN
150     WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
151 jmc 1.5 & flds(md,ld),' is not a Diagnostic'
152 jmc 1.7 CALL PRINT_ERROR( msgBuf , myThid )
153     ENDIF
154 jmc 1.1 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
155     ENDIF
156    
157     ENDDO
158 jmc 1.5 nActiveMax = MAX(nActive(ld),nActiveMax)
159 jmc 1.1 ENDDO
160    
161 jmc 1.10 IF ( ndiagcount.LE.numDiags .AND.
162 jmc 1.15 & nActiveMax.LE.numperList ) THEN
163 jmc 1.10 WRITE(msgBuf,'(A,I8,A)')
164 jmc 1.5 & ' space allocated for all diagnostics:',
165 jmc 1.1 & ndiagcount, ' levels'
166     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
167 jmc 1.16 & SQUEEZE_RIGHT, myThid )
168 jmc 1.1 ELSE
169 jmc 1.10 IF ( ndiagcount.GT.numDiags ) THEN
170 jmc 1.1 WRITE(msgBuf,'(2A)')
171     & 'DIAGNOSTICS_SET_POINTERS: Not enough space',
172     & ' for all active diagnostics (from data.diagnostics)'
173     CALL PRINT_ERROR( msgBuf , myThid )
174 jmc 1.10 WRITE(msgBuf,'(A,I8,A,I8)')
175     & 'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
176 jmc 1.1 & ' but needs at least', ndiagcount
177     CALL PRINT_ERROR( msgBuf , myThid )
178     ENDIF
179 jmc 1.15 IF ( nActiveMax.GT.numperList ) THEN
180 jmc 1.1 WRITE(msgBuf,'(2A)')
181     & 'DIAGNOSTICS_SET_POINTERS: Not enough space',
182     & ' for all active diagnostics (from data.diagnostics)'
183     CALL PRINT_ERROR( msgBuf , myThid )
184     WRITE(msgBuf,'(A,I6,A,I6)')
185 jmc 1.15 & 'DIAGNOSTICS_SET_POINTERS: numperList=', numperList,
186 jmc 1.1 & ' but needs at least', nActiveMax
187     CALL PRINT_ERROR( msgBuf , myThid )
188     ENDIF
189     STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
190     ENDIF
191    
192 jmc 1.3 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
193 jmc 1.5 C-- Set pointer for mate (e.g.vector component mate) if not already done
194     C and if it exists. Note: for now, only used to print message.
195     DO ld=1,nlists
196     DO md=1,nActive(ld)
197     IF (mdiag(md,ld).EQ.0 ) THEN
198    
199     nd = jdiag(md,ld)
200 jmc 1.10 mate = hdiag(nd)
201     IF ( mate.GT.0 ) THEN
202 jmc 1.5 DO j=1,nlists
203     DO i=1,nActive(j)
204     IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
205 jmc 1.14 IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
206     & .AND. averageFreq(j) .EQ.averageFreq(ld)
207     & .AND. averagePhase(j).EQ.averagePhase(ld)
208     & .AND. averageCycle(j).EQ.averageCycle(ld) )
209     & mdiag(md,ld) = ABS(idiag(i,j))
210 jmc 1.5 ENDIF
211     ENDDO
212     ENDDO
213     ENDIF
214     IF ( mdiag(md,ld).NE.0 ) THEN
215 jmc 1.10 WRITE(msgBuf,'(A,I6,5A,I6)') ' set mate pointer for diag #',
216     & nd, ' ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
217     & ' , mate:', hdiag(nd)
218 jmc 1.5 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
219 jmc 1.16 & SQUEEZE_RIGHT, myThid )
220 jmc 1.5 ENDIF
221    
222     ENDIF
223     ENDDO
224     ENDDO
225    
226     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
227 jmc 1.3 C-- Set list of levels to write (if not specified in data.diagnostics)
228    
229 jmc 1.5 DO ld=1,nlists
230     IF ( nlevels(ld).EQ.-1 ) THEN
231 jmc 1.3 C- set Nb of levels to the minimum size of all diag of this list:
232 jmc 1.12 kLev = numLevels*10
233 jmc 1.5 DO md=1,nfields(ld)
234     nd = jdiag(md,ld)
235     kLev = MIN(kdiag(nd),kLev)
236 jmc 1.3 ENDDO
237     IF ( kLev.LE.0 ) THEN
238 jmc 1.12 WRITE(msgBuf,'(2A,I4,2A)')
239     & 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
240     & ' setting levs of list l=',ld,', fnames=', fnames(ld)
241     CALL PRINT_ERROR( msgBuf , myThid )
242     STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
243     ELSEIF ( kLev.GT.numLevels ) THEN
244     WRITE(msgBuf,'(A,2(I6,A))')
245     & 'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
246     & ' >', numLevels, ' =numLevels'
247     CALL PRINT_ERROR( msgBuf , myThid )
248     WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
249     & ' setting levs of list l=',ld,', fnames=', fnames(ld)
250 jmc 1.3 CALL PRINT_ERROR( msgBuf , myThid )
251     STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
252     ENDIF
253 jmc 1.5 nlevels(ld) = kLev
254 jmc 1.3 DO k=1,kLev
255 jmc 1.5 levs(k,ld) = k
256 jmc 1.3 ENDDO
257     WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
258 jmc 1.5 & 'Set levels for Outp.Stream: ',fnames(ld)
259 jmc 1.3 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
260     & SQUEEZE_RIGHT, myThid)
261 jmc 1.13 suffix = ' Levels: '
262     IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
263 jmc 1.5 DO k1=1,nlevels(ld),20
264     k2 = MIN(nlevels(ld),k1+19)
265 jmc 1.13 WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
266 jmc 1.3 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
267     & SQUEEZE_RIGHT, myThid)
268     ENDDO
269 jmc 1.8 ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
270     C- if no Vert.Interpolation, check for levels out of range ( > kdiag):
271 jmc 1.3 kLev = 0
272 jmc 1.5 DO k=1,nlevels(ld)
273     kLev = MAX(NINT(levs(k,ld)),kLev)
274 jmc 1.3 ENDDO
275 jmc 1.5 DO md=1,nfields(ld)
276     nd = jdiag(md,ld)
277     IF ( kLev.GT.kdiag(nd) ) THEN
278     C- Note: diagnostics_out take care (in some way) of this case
279 jmc 1.3 C so that it does not cause "index out-off bounds" error.
280     C However, the output file looks strange.
281     C- For now, choose to stop, but could change it to just a warning
282 jmc 1.10 WRITE(msgBuf,'(A,I4,A,I6,2A)')
283 jmc 1.3 & 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
284 jmc 1.5 & ' in list l=', ld, ', filename: ', fnames(ld)
285 jmc 1.3 CALL PRINT_ERROR( msgBuf , myThid )
286 jmc 1.10 WRITE(msgBuf,'(2A,I4,A,I6,2A)')
287 jmc 1.3 & 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
288 jmc 1.5 & '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
289 jmc 1.3 CALL PRINT_ERROR( msgBuf , myThid )
290     WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
291 jmc 1.5 & ' parsing code >>',gdiag(nd),'<<'
292 jmc 1.3 CALL PRINT_ERROR( msgBuf , myThid )
293     STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
294     ENDIF
295     ENDDO
296     ENDIF
297     ENDDO
298    
299     WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
300     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
301     & SQUEEZE_RIGHT , myThid)
302     WRITE(msgBuf,'(2A)')
303     & '------------------------------------------------------------'
304     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
305     & SQUEEZE_RIGHT , myThid)
306    
307 jmc 1.1 _END_MASTER( myThid )
308    
309     RETURN
310     END
  ViewVC Help
Powered by ViewVC 1.1.22