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

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

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

Revision 1.15 - (show annotations) (download)
Tue Jun 21 18:00:15 2011 UTC (12 years, 11 months ago) by jmc
Branch: MAIN
Changes since 1.14: +7 -16 lines 
Implement setting of "Post-Processed" diagnostics (corresponding to gdiag(5)='P')
 which are not filled-up but computed from other diags ; In this case,
 the mate diag indicate the primary (filled-up) diag to used for post processing.
1 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.14 2011/06/15 13:22:43 jmc Exp $
2 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 C myThid :: my Thread Id. number
30 INTEGER myThid
31 CEOP
32
33 C !LOCAL VARIABLES:
34 C == Local variables ==
35 INTEGER ndiagcount, ndCount
36 INTEGER md,ld,nd
37 INTEGER mate, nActiveMax
38 INTEGER i, j, k, k1, k2, kLev
39 LOGICAL found
40 CHARACTER*(MAX_LEN_MBUF) msgBuf
41 CHARACTER*12 suffix
42
43 _BEGIN_MASTER( myThid)
44
45 C-- Initialize pointer arrays to zero:
46 DO ld=1,numLists
47 DO md=1,numperList
48 idiag(md,ld) = 0
49 jdiag(md,ld) = 0
50 mdiag(md,ld) = 0
51 ENDDO
52 ENDDO
53
54 C-- Calculate pointers for diagnostics in active output-stream
55 C (i.e., with defined filename)
56
57 ndiagcount = 0
58 nActiveMax = 0
59 DO ld=1,nlists
60 nActive(ld) = nfields(ld)
61 DO md=1,nfields(ld)
62
63 found = .FALSE.
64 C Search all possible model diagnostics
65 DO nd=1,ndiagt
66 IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
67 CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
68 found = .TRUE.
69 jdiag(md,ld) = nd
70 ENDIF
71 ENDDO
72 IF ( .NOT.found ) THEN
73 CALL DIAGNOSTICS_LIST_CHECK(
74 O ndCount,
75 I ld, md, nlists, nfields, flds, myThid )
76 IF ( ndCount.EQ.0 ) THEN
77 WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
78 & flds(md,ld),' is not a Diagnostic'
79 CALL PRINT_ERROR( msgBuf , myThid )
80 ENDIF
81 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
82 ENDIF
83
84 ENDDO
85 nActiveMax = MAX(nActive(ld),nActiveMax)
86 ENDDO
87
88 IF ( ndiagcount.LE.numDiags .AND.
89 & nActiveMax.LE.numperList ) THEN
90 WRITE(msgBuf,'(A,I8,A)')
91 & ' space allocated for all diagnostics:',
92 & ndiagcount, ' levels'
93 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
94 & SQUEEZE_RIGHT , myThid)
95 ELSE
96 IF ( ndiagcount.GT.numDiags ) THEN
97 WRITE(msgBuf,'(2A)')
98 & 'DIAGNOSTICS_SET_POINTERS: Not enough space',
99 & ' for all active diagnostics (from data.diagnostics)'
100 CALL PRINT_ERROR( msgBuf , myThid )
101 WRITE(msgBuf,'(A,I8,A,I8)')
102 & 'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
103 & ' but needs at least', ndiagcount
104 CALL PRINT_ERROR( msgBuf , myThid )
105 ENDIF
106 IF ( nActiveMax.GT.numperList ) THEN
107 WRITE(msgBuf,'(2A)')
108 & 'DIAGNOSTICS_SET_POINTERS: Not enough space',
109 & ' for all active diagnostics (from data.diagnostics)'
110 CALL PRINT_ERROR( msgBuf , myThid )
111 WRITE(msgBuf,'(A,I6,A,I6)')
112 & 'DIAGNOSTICS_SET_POINTERS: numperList=', numperList,
113 & ' but needs at least', nActiveMax
114 CALL PRINT_ERROR( msgBuf , myThid )
115 ENDIF
116 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
117 ENDIF
118
119 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
120 C-- Set pointer for mate (e.g.vector component mate) if not already done
121 C and if it exists. Note: for now, only used to print message.
122 DO ld=1,nlists
123 DO md=1,nActive(ld)
124 IF (mdiag(md,ld).EQ.0 ) THEN
125
126 nd = jdiag(md,ld)
127 mate = hdiag(nd)
128 IF ( mate.GT.0 ) THEN
129 DO j=1,nlists
130 DO i=1,nActive(j)
131 IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
132 IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
133 & .AND. averageFreq(j) .EQ.averageFreq(ld)
134 & .AND. averagePhase(j).EQ.averagePhase(ld)
135 & .AND. averageCycle(j).EQ.averageCycle(ld) )
136 & mdiag(md,ld) = ABS(idiag(i,j))
137 ENDIF
138 ENDDO
139 ENDDO
140 ENDIF
141 IF ( mdiag(md,ld).NE.0 ) THEN
142 WRITE(msgBuf,'(A,I6,5A,I6)') ' set mate pointer for diag #',
143 & nd, ' ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
144 & ' , mate:', hdiag(nd)
145 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
146 & SQUEEZE_RIGHT , myThid)
147 ENDIF
148
149 ENDIF
150 ENDDO
151 ENDDO
152
153 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
154 C-- Set list of levels to write (if not specified in data.diagnostics)
155
156 DO ld=1,nlists
157 IF ( nlevels(ld).EQ.-1 ) THEN
158 C- set Nb of levels to the minimum size of all diag of this list:
159 kLev = numLevels*10
160 DO md=1,nfields(ld)
161 nd = jdiag(md,ld)
162 kLev = MIN(kdiag(nd),kLev)
163 ENDDO
164 IF ( kLev.LE.0 ) THEN
165 WRITE(msgBuf,'(2A,I4,2A)')
166 & 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
167 & ' setting levs of list l=',ld,', fnames=', fnames(ld)
168 CALL PRINT_ERROR( msgBuf , myThid )
169 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
170 ELSEIF ( kLev.GT.numLevels ) THEN
171 WRITE(msgBuf,'(A,2(I6,A))')
172 & 'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
173 & ' >', numLevels, ' =numLevels'
174 CALL PRINT_ERROR( msgBuf , myThid )
175 WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
176 & ' setting levs of list l=',ld,', fnames=', fnames(ld)
177 CALL PRINT_ERROR( msgBuf , myThid )
178 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
179 ENDIF
180 nlevels(ld) = kLev
181 DO k=1,kLev
182 levs(k,ld) = k
183 ENDDO
184 WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
185 & 'Set levels for Outp.Stream: ',fnames(ld)
186 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
187 & SQUEEZE_RIGHT, myThid)
188 suffix = ' Levels: '
189 IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
190 DO k1=1,nlevels(ld),20
191 k2 = MIN(nlevels(ld),k1+19)
192 WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
193 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
194 & SQUEEZE_RIGHT, myThid)
195 ENDDO
196 ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
197 C- if no Vert.Interpolation, check for levels out of range ( > kdiag):
198 kLev = 0
199 DO k=1,nlevels(ld)
200 kLev = MAX(NINT(levs(k,ld)),kLev)
201 ENDDO
202 DO md=1,nfields(ld)
203 nd = jdiag(md,ld)
204 IF ( kLev.GT.kdiag(nd) ) THEN
205 C- Note: diagnostics_out take care (in some way) of this case
206 C so that it does not cause "index out-off bounds" error.
207 C However, the output file looks strange.
208 C- For now, choose to stop, but could change it to just a warning
209 WRITE(msgBuf,'(A,I4,A,I6,2A)')
210 & 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
211 & ' in list l=', ld, ', filename: ', fnames(ld)
212 CALL PRINT_ERROR( msgBuf , myThid )
213 WRITE(msgBuf,'(2A,I4,A,I6,2A)')
214 & 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
215 & '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
216 CALL PRINT_ERROR( msgBuf , myThid )
217 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
218 & ' parsing code >>',gdiag(nd),'<<'
219 CALL PRINT_ERROR( msgBuf , myThid )
220 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
221 ENDIF
222 ENDDO
223 ENDIF
224 ENDDO
225
226 WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
227 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
228 & SQUEEZE_RIGHT , myThid)
229 WRITE(msgBuf,'(2A)')
230 & '------------------------------------------------------------'
231 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
232 & SQUEEZE_RIGHT , myThid)
233
234 _END_MASTER( myThid )
235
236 RETURN
237 END
  ViewVC Help
Powered by ViewVC 1.1.22