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

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

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


Revision 1.57 - (show annotations) (download)
Mon Jun 27 22:27:23 2011 UTC (12 years, 10 months ago) by jmc
Branch: MAIN
Changes since 1.56: +4 -7 lines
use run-time parameter "useMissingValue" to fill land-point (i.e., where mask=0)
 with MissingValue (MNC output file only).
This replaces CPP-option DIAGNOSTICS_MISSING_VALUE.

1 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_out.F,v 1.56 2011/06/23 15:29:01 jmc Exp $
2 C $Name: $
3
4 #include "DIAG_OPTIONS.h"
5
6 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7 CBOP 0
8 C !ROUTINE: DIAGNOSTICS_OUT
9
10 C !INTERFACE:
11 SUBROUTINE DIAGNOSTICS_OUT(
12 I listId,
13 I myTime,
14 I myIter,
15 I myThid )
16
17 C !DESCRIPTION:
18 C Write output for diagnostics fields.
19
20 C !USES:
21 IMPLICIT NONE
22 #include "SIZE.h"
23 #include "EEPARAMS.h"
24 #include "PARAMS.h"
25 #include "GRID.h"
26 #include "DIAGNOSTICS_SIZE.h"
27 #include "DIAGNOSTICS.h"
28
29 INTEGER NrMax
30 PARAMETER( NrMax = numLevels )
31
32 C !INPUT PARAMETERS:
33 C listId :: Diagnostics list number being written
34 C myIter :: current iteration number
35 C myTime :: current time of simulation (s)
36 C myThid :: my Thread Id number
37 _RL myTime
38 INTEGER listId, myIter, myThid
39 CEOP
40
41 C !FUNCTIONS:
42 INTEGER ILNBLNK
43 EXTERNAL ILNBLNK
44 #ifdef ALLOW_FIZHI
45 _RL getcon
46 EXTERNAL getcon
47 #endif
48
49 C !LOCAL VARIABLES:
50 C i,j,k :: loop indices
51 C bi,bj :: tile indices
52 C lm :: loop index (averageCycle)
53 C md :: field number in the list "listId".
54 C ndId :: diagnostics Id number (in available diagnostics list)
55 C mate :: counter mate Id number (in available diagnostics list)
56 C ip :: diagnostics pointer to storage array
57 C im :: counter-mate pointer to storage array
58 C nLevOutp :: number of levels to write in output file
59 C
60 C-- COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)
61 C qtmp1 :: temporary array; used to store a copy of diag. output field.
62 C qtmp2 :: temporary array; used to store a copy of a 2nd diag. field.
63 C- Note: local common block no longer needed.
64 c COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1
65 _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
66 _RL qtmp2(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
67
68 INTEGER i, j, k, lm
69 INTEGER bi, bj
70 INTEGER md, ndId, nn, ip, im
71 INTEGER mate, mDbl, mVec
72 CHARACTER*10 gcode
73 _RL undefRL
74 INTEGER nLevOutp, kLev
75
76 INTEGER iLen
77 INTEGER ioUnit
78 CHARACTER*(MAX_LEN_FNAM) fn
79 CHARACTER*(MAX_LEN_MBUF) suff
80 CHARACTER*(MAX_LEN_MBUF) msgBuf
81 INTEGER prec, nRec, nTimRec
82 _RL timeRec(2)
83 _RL tmpLoc
84 #ifdef ALLOW_MDSIO
85 LOGICAL glf
86 #endif
87 #ifdef ALLOW_MNC
88 CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
89 #endif /* ALLOW_MNC */
90
91 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
92
93 C--- set file properties
94 ioUnit= standardMessageUnit
95 undefRL = UNSET_RL
96 #ifdef ALLOW_FIZHI
97 IF ( useFIZHI ) undefRL = getcon('UNDEF')
98 #endif
99 IF ( misvalFlt(listId).NE.UNSET_RL ) undefRL = misvalFlt(listId)
100
101 WRITE(suff,'(I10.10)') myIter
102 iLen = ILNBLNK(fnames(listId))
103 WRITE( fn, '(A,A,A)' ) fnames(listId)(1:iLen),'.',suff(1:10)
104 C- for now, if integrate vertically, output field has just 1 level:
105 nLevOutp = nlevels(listId)
106 IF ( fflags(listId)(2:2).EQ.'I' ) nLevOutp = 1
107
108 C-- Set time information:
109 IF ( freq(listId).LT.0. ) THEN
110 C- Snap-shot: store a unique time (which is consistent with State-Var timing)
111 nTimRec = 1
112 timeRec(1) = myTime
113 ELSE
114 C- Time-average: store the 2 edges of the time-averaging interval.
115 C this time is consitent with intermediate Var (i.e., non-state, e.g, flux,
116 C tendencies) timing. For State-Var, this is shifted by + halt time-step.
117 nTimRec = 2
118
119 C- end of time-averaging interval:
120 timeRec(2) = myTime
121
122 C- begining of time-averaging interval:
123 c timeRec(1) = myTime - freq(listId)
124 C a) find the time of the previous multiple of output freq:
125 timeRec(1) = myTime-deltaTClock*0.5 _d 0
126 timeRec(1) = (timeRec(1)-phase(listId))/freq(listId)
127 i = INT( timeRec(1) )
128 IF ( timeRec(1).LT.0. ) THEN
129 tmpLoc = FLOAT(i)
130 IF ( timeRec(1).NE.tmpLoc ) i = i - 1
131 ENDIF
132 timeRec(1) = phase(listId) + freq(listId)*FLOAT(i)
133 c if ( listId.eq.2 ) write(0,*) 'f',i,timeRec(1)/deltaTClock
134 timeRec(1) = MAX( timeRec(1), startTime )
135
136 C b) round off to nearest multiple of time-step:
137 timeRec(1) = (timeRec(1)-baseTime)/deltaTClock
138 i = NINT( timeRec(1) )
139 C if just half way, NINT will return the next time-step: correct this
140 tmpLoc = FLOAT(i) - 0.5 _d 0
141 IF ( timeRec(1).EQ.tmpLoc ) i = i - 1
142 timeRec(1) = baseTime + deltaTClock*FLOAT(i)
143 c if ( listId.eq.2 ) write(0,*) i,timeRec(1)/deltaTClock
144 ENDIF
145 C-- Convert time to iteration number (debug)
146 c DO i=1,nTimRec
147 c timeRec(i) = timeRec(i)/deltaTClock
148 c ENDDO
149
150 C-- Place the loop on lm (= averagePeriod) outside the loop on md (= field):
151 DO lm=1,averageCycle(listId)
152
153 #ifdef ALLOW_MNC
154 IF (useMNC .AND. diag_mnc) THEN
155 CALL DIAGNOSTICS_MNC_SET(
156 I nLevOutp, listId, lm,
157 O diag_mnc_bn,
158 I undefRL, myTime, myIter, myThid )
159 ENDIF
160 #endif /* ALLOW_MNC */
161
162 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
163
164 DO md = 1,nfields(listId)
165 ndId = jdiag(md,listId)
166 gcode = gdiag(ndId)(1:10)
167 mate = 0
168 mVec = 0
169 mDbl = 0
170 IF ( gcode(5:5).EQ.'C' ) THEN
171 C- Check for Mate of a Counter Diagnostic
172 mate = hdiag(ndId)
173 ELSEIF ( gcode(5:5).EQ.'P' ) THEN
174 C- Also load the mate (if stored) for Post-Processing
175 nn = ndId
176 DO WHILE ( gdiag(nn)(5:5).EQ.'P' )
177 nn = hdiag(nn)
178 ENDDO
179 IF ( mdiag(md,listId).NE.0 ) mDbl = hdiag(nn)
180 ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN
181 C- Check for Mate of a Vector Diagnostic
182 mVec = hdiag(ndId)
183 ENDIF
184 IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN
185 C-- Start processing 1 Fld :
186
187 ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
188 im = mdiag(md,listId)
189 IF (mate.GT.0) im = im + kdiag(mate)*(lm-1)
190 IF (mDbl.GT.0) im = im + kdiag(mDbl)*(lm-1)
191 IF (mVec.GT.0) im = im + kdiag(mVec)*(lm-1)
192
193 IF ( ndiag(ip,1,1).EQ.0 ) THEN
194 C- Empty diagnostics case :
195
196 _BEGIN_MASTER( myThid )
197 WRITE(msgBuf,'(A,I10)')
198 & '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
199 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
200 & SQUEEZE_RIGHT, myThid)
201 WRITE(msgBuf,'(A,I6,3A,I4,2A)')
202 & '- WARNING - diag.#',ndId, ' : ',flds(md,listId),
203 & ' (#',md,' ) in outp.Stream: ',fnames(listId)
204 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
205 & SQUEEZE_RIGHT, myThid)
206 IF ( averageCycle(listId).GT.1 ) THEN
207 WRITE(msgBuf,'(A,2(I3,A))')
208 & '- WARNING - has not been filled (ndiag(lm=',lm,')=',
209 & ndiag(ip,1,1), ' )'
210 ELSE
211 WRITE(msgBuf,'(A,2(I3,A))')
212 & '- WARNING - has not been filled (ndiag=',
213 & ndiag(ip,1,1), ' )'
214 ENDIF
215 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
216 & SQUEEZE_RIGHT, myThid)
217 WRITE(msgBuf,'(A)')
218 & 'WARNING DIAGNOSTICS_OUT => write ZEROS instead'
219 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
220 & SQUEEZE_RIGHT, myThid)
221 _END_MASTER( myThid )
222 DO bj = myByLo(myThid), myByHi(myThid)
223 DO bi = myBxLo(myThid), myBxHi(myThid)
224 DO k = 1,nLevOutp
225 DO j = 1-OLy,sNy+OLy
226 DO i = 1-OLx,sNx+OLx
227 qtmp1(i,j,k,bi,bj) = 0. _d 0
228 ENDDO
229 ENDDO
230 ENDDO
231 ENDDO
232 ENDDO
233
234 ELSE
235 C- diagnostics is not empty :
236
237 IF ( debugLevel.GE.debLevB .AND. myThid.EQ.1 ) THEN
238 IF ( gcode(5:5).EQ.'P' ) THEN
239 WRITE(ioUnit,'(A,I6,7A,I8,2A)')
240 & ' Post-Processing Diag # ', ndId, ' ', cdiag(ndId),
241 & ' Parms: ',gdiag(ndId)
242 IF ( mDbl.EQ.0 ) THEN
243 WRITE(ioUnit,'(2(3A,I6,A,I8))') ' from diag: ',
244 & cdiag(nn), ' (#', nn, ') Cnt=', ndiag(ip,1,1)
245 ELSE
246 WRITE(ioUnit,'(2(3A,I6,A,I8))') ' from diag: ',
247 & cdiag(nn), ' (#', nn, ') Cnt=', ndiag(ip,1,1),
248 & ' and diag: ',
249 & cdiag(mDbl),' (#',mDbl,') Cnt=',ndiag(im,1,1)
250 ENDIF
251 ELSE
252 WRITE(ioUnit,'(A,I6,3A,I8,2A)')
253 & ' Computing Diagnostic # ', ndId, ' ', cdiag(ndId),
254 & ' Counter:',ndiag(ip,1,1),' Parms: ',gdiag(ndId)
255 ENDIF
256 IF ( mate.GT.0 ) THEN
257 WRITE(ioUnit,'(3A,I6,2A)')
258 & ' use Counter Mate for ', cdiag(ndId),
259 & ' Diagnostic # ',mate, ' ', cdiag(mate)
260 ELSEIF ( mVec.GT.0 ) THEN
261 IF ( im.GT.0 .AND. ndiag(MAX(1,im),1,1).GT.0 ) THEN
262 WRITE(ioUnit,'(3A,I6,3A)')
263 & ' Vector Mate for ', cdiag(ndId),
264 & ' Diagnostic # ',mVec, ' ', cdiag(mVec),
265 & ' exists '
266 ELSE
267 WRITE(ioUnit,'(3A,I6,3A)')
268 & ' Vector Mate for ', cdiag(ndId),
269 & ' Diagnostic # ',mVec, ' ', cdiag(mVec),
270 & ' not enabled'
271 ENDIF
272 ENDIF
273 ENDIF
274
275 IF ( fflags(listId)(2:2).EQ.' ' ) THEN
276 C- get only selected levels:
277 DO bj = myByLo(myThid), myByHi(myThid)
278 DO bi = myBxLo(myThid), myBxHi(myThid)
279 DO k = 1,nlevels(listId)
280 kLev = NINT(levs(k,listId))
281 CALL DIAGNOSTICS_GET_DIAG(
282 I kLev, undefRL,
283 O qtmp1(1-OLx,1-OLy,k,bi,bj),
284 I ndId, mate, ip, im, bi, bj, myThid )
285 ENDDO
286 ENDDO
287 ENDDO
288 IF ( mDbl.GT.0 ) THEN
289 DO bj = myByLo(myThid), myByHi(myThid)
290 DO bi = myBxLo(myThid), myBxHi(myThid)
291 DO k = 1,nlevels(listId)
292 kLev = NINT(levs(k,listId))
293 CALL DIAGNOSTICS_GET_DIAG(
294 I kLev, undefRL,
295 O qtmp2(1-OLx,1-OLy,k,bi,bj),
296 I mDbl, 0, im, 0, bi, bj, myThid )
297 ENDDO
298 ENDDO
299 ENDDO
300 ENDIF
301 ELSE
302 C- get all the levels (for vertical post-processing)
303 DO bj = myByLo(myThid), myByHi(myThid)
304 DO bi = myBxLo(myThid), myBxHi(myThid)
305 CALL DIAGNOSTICS_GET_DIAG(
306 I 0, undefRL,
307 O qtmp1(1-OLx,1-OLy,1,bi,bj),
308 I ndId, mate, ip, im, bi, bj, myThid )
309 ENDDO
310 ENDDO
311 IF ( mDbl.GT.0 ) THEN
312 DO bj = myByLo(myThid), myByHi(myThid)
313 DO bi = myBxLo(myThid), myBxHi(myThid)
314 DO k = 1,nlevels(listId)
315 CALL DIAGNOSTICS_GET_DIAG(
316 I 0, undefRL,
317 O qtmp2(1-OLx,1-OLy,k,bi,bj),
318 I mDbl, 0, im, 0, bi, bj, myThid )
319 ENDDO
320 ENDDO
321 ENDDO
322 ENDIF
323 ENDIF
324
325 C-----------------------------------------------------------------------
326 C-- Apply specific post-processing (e.g., interpolate) before output
327 C-----------------------------------------------------------------------
328 IF ( fflags(listId)(2:2).EQ.'P' ) THEN
329 C- Do vertical interpolation:
330 IF ( fluidIsAir ) THEN
331 C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
332 CALL DIAGNOSTICS_INTERP_VERT(
333 I listId, md, ndId, ip, im, lm,
334 U qtmp1, qtmp2,
335 I undefRL, myTime, myIter, myThid )
336 ELSE
337 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
338 & 'INTERP_VERT not allowed in this config'
339 CALL PRINT_ERROR( msgBuf , myThid )
340 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
341 ENDIF
342 ENDIF
343 IF ( fflags(listId)(2:2).EQ.'I' ) THEN
344 C- Integrate vertically: for now, output field has just 1 level:
345 CALL DIAGNOSTICS_SUM_LEVELS(
346 I listId, md, ndId, ip, im, lm,
347 U qtmp1,
348 I undefRL, myTime, myIter, myThid )
349 ENDIF
350 IF ( gcode(5:5).EQ.'P' ) THEN
351 C- Do Post-Processing:
352 IF ( flds(md,listId).EQ.'PhiVEL '
353 c & .OR. flds(md,listId).EQ.'PsiVEL '
354 & ) THEN
355 CALL DIAGNOSTICS_CALC_PHIVEL(
356 I listId, md, ndId, ip, im, lm,
357 U qtmp1, qtmp2,
358 I myTime, myIter, myThid )
359 ELSE
360 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
361 & 'unknown Processing method for diag="',cdiag(ndId),'"'
362 CALL PRINT_ERROR( msgBuf , myThid )
363 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
364 ENDIF
365 ENDIF
366
367 C-- End of empty diag / not-empty diag block
368 ENDIF
369
370 C-- Ready to write field "md", element "lm" in averageCycle(listId)
371
372 C- write to binary file, using MDSIO pkg:
373 IF ( diag_mdsio ) THEN
374 c nRec = lm + (md-1)*averageCycle(listId)
375 nRec = md + (lm-1)*nfields(listId)
376 C default precision for output files
377 prec = writeBinaryPrec
378 C fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
379 IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
380 IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
381 C a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
382 CALL WRITE_REC_LEV_RL(
383 I fn, prec,
384 I NrMax, 1, nLevOutp,
385 I qtmp1, -nRec, myIter, myThid )
386 ENDIF
387
388 #ifdef ALLOW_MNC
389 IF (useMNC .AND. diag_mnc) THEN
390 CALL DIAGNOSTICS_MNC_OUT(
391 I NrMax, nLevOutp, listId, ndId, mate,
392 I diag_mnc_bn, qtmp1,
393 I undefRL, myTime, myIter, myThid )
394 ENDIF
395 #endif /* ALLOW_MNC */
396
397 C-- end of Processing Fld # md
398 ENDIF
399 ENDDO
400
401 C-- end loop on lm counter (= averagePeriod)
402 ENDDO
403
404 #ifdef ALLOW_MDSIO
405 IF (diag_mdsio) THEN
406 C- Note: temporary: since it is a pain to add more arguments to
407 C all MDSIO S/R, uses instead this specific S/R to write only
408 C meta files but with more informations in it.
409 glf = globalFiles
410 nRec = averageCycle(listId)*nfields(listId)
411 CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
412 & 0, 0, nLevOutp, ' ',
413 & nfields(listId), flds(1,listId), nTimRec, timeRec,
414 & nRec, myIter, myThid)
415 ENDIF
416 #endif /* ALLOW_MDSIO */
417
418 RETURN
419 END
420
421 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

  ViewVC Help
Powered by ViewVC 1.1.22