/[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.26 - (show annotations) (download)
Thu Jan 26 04:15:05 2006 UTC (18 years, 3 months ago) by edhill
Branch: MAIN
Changes since 1.25: +2 -2 lines
bug: only the first tile contained 'iter' data but ALL tiles should
 - bug (indirectly) reported by D. Ferreira because not having the iter
   data causes serious problems in both rdnctiles() and rdmnc()

1 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_out.F,v 1.25 2005/11/25 06:12:31 edhill 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 myIter,
14 I myTime,
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 #ifdef ALLOW_FIZHI
30 #include "fizhi_SIZE.h"
31 #else
32 INTEGER Nrphys
33 PARAMETER (Nrphys=0)
34 #endif
35
36
37 C !INPUT PARAMETERS:
38 C listId :: Diagnostics list number being written
39 C myIter :: current iteration number
40 C myTime :: current time of simulation (s)
41 C myThid :: my Thread Id number
42 _RL myTime
43 INTEGER listId, myIter, myThid
44 CEOP
45
46 C !LOCAL VARIABLES:
47 C i,j,k :: loop indices
48 C md :: field number in the list "listId".
49 C ndId :: diagnostics Id number (in available diagnostics list)
50 C mate :: counter mate Id number (in available diagnostics list)
51 C ip :: diagnostics pointer to storage array
52 C im :: counter-mate pointer to storage array
53 INTEGER i, j, k
54 INTEGER bi, bj
55 INTEGER md, ndId, ip, im
56 INTEGER mate, mVec
57 CHARACTER*8 parms1
58 CHARACTER*3 mate_index
59 _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)
60 _RL undef, getcon
61 EXTERNAL getcon
62 INTEGER ILNBLNK
63 EXTERNAL ILNBLNK
64 INTEGER ilen
65 INTEGER nlevsout
66
67 INTEGER ioUnit
68 CHARACTER*(MAX_LEN_FNAM) fn
69 CHARACTER*(MAX_LEN_MBUF) suff
70 CHARACTER*(MAX_LEN_MBUF) msgBuf
71 LOGICAL glf
72 #ifdef ALLOW_MNC
73 INTEGER ii
74 CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
75 INTEGER CW_DIMS, NLEN
76 PARAMETER ( CW_DIMS = 10 )
77 PARAMETER ( NLEN = 80 )
78 INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
79 CHARACTER*(NLEN) dn(CW_DIMS)
80 CHARACTER*(NLEN) d_cw_name
81 CHARACTER*(NLEN) dn_blnk
82 #ifdef DIAG_MNC_COORD_NEEDSWORK
83 CHARACTER*(5) ctmp
84 _RS ztmp(Nr+Nrphys)
85 #endif
86 #endif /* ALLOW_MNC */
87
88 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
89
90 ioUnit= standardMessageUnit
91 undef = getcon('UNDEF')
92 glf = globalFiles
93 WRITE(suff,'(I10.10)') myIter
94 ilen = ILNBLNK(fnames(listId))
95 WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)
96
97 #ifdef ALLOW_MNC
98 IF (useMNC .AND. diag_mnc) THEN
99 DO i = 1,MAX_LEN_FNAM
100 diag_mnc_bn(i:i) = ' '
101 ENDDO
102 DO i = 1,NLEN
103 dn_blnk(i:i) = ' '
104 ENDDO
105 WRITE( diag_mnc_bn, '(A)' ) fnames(listId)(1:ilen)
106
107 C Update the record dimension by writing the iteration number
108 CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
109 CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)
110 CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
111 CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)
112
113 C NOTE: at some point it would be a good idea to add a time_bounds
114 C variable that has dimension (2,T) and clearly denotes the
115 C beginning and ending times for each diagnostics period
116
117 dn(1)(1:NLEN) = dn_blnk(1:NLEN)
118 WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listId)
119 dim(1) = nlevels(listId)
120 ib(1) = 1
121 ie(1) = nlevels(listId)
122
123 CALL MNC_CW_ADD_GNAME('diag_levels', 1,
124 & dim, dn, ib, ie, myThid)
125 CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
126 & 0,0, myThid)
127 CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
128 & 'Idicies of vertical levels within the source arrays',
129 & myThid)
130
131 CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
132 & 'diag_levels', levs(1,listId), myThid)
133
134 CALL MNC_CW_DEL_VNAME('diag_levels', myThid)
135 CALL MNC_CW_DEL_GNAME('diag_levels', myThid)
136
137 #ifdef DIAG_MNC_COORD_NEEDSWORK
138 C This part has been placed in an #ifdef because, as its currently
139 C written, it will only work with variables defined on a dynamics
140 C grid. As we start using diagnostics for physics grids, ice
141 C levels, land levels, etc. the different vertical coordinate
142 C dimensions will have to be taken into account.
143
144 C 20051021 JMC & EH3 : We need to extend this so that a few
145 C variables each defined on different grids do not have the same
146 C vertical dimension names so we should be using a pattern such
147 C as: Z[uml]td000000 where the 't' is the type as specified by
148 C gdiag(10)
149
150 C Now define: Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
151 ctmp(1:5) = 'mul '
152 DO i = 1,3
153 dn(1)(1:NLEN) = dn_blnk(1:NLEN)
154 WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listId)
155 CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)
156 CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)
157
158 C The following three ztmp() loops should eventually be modified
159 C to reflect the fractional nature of levs(j,l) -- they should
160 C do something like:
161 C ztmp(j) = rC(INT(FLOOR(levs(j,l))))
162 C + ( rC(INT(FLOOR(levs(j,l))))
163 C + rC(INT(CEIL(levs(j,l)))) )
164 C / ( levs(j,l) - FLOOR(levs(j,l)) )
165 C for averaged levels.
166 IF (i .EQ. 1) THEN
167 DO j = 1,nlevels(listId)
168 ztmp(j) = rC(NINT(levs(j,listId)))
169 ENDDO
170 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
171 & 'Dimensional coordinate value at the mid point',
172 & myThid)
173 ELSEIF (i .EQ. 2) THEN
174 DO j = 1,nlevels(listId)
175 ztmp(j) = rF(NINT(levs(j,listId)) + 1)
176 ENDDO
177 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
178 & 'Dimensional coordinate value at the upper point',
179 & myThid)
180 ELSEIF (i .EQ. 3) THEN
181 DO j = 1,nlevels(listId)
182 ztmp(j) = rF(NINT(levs(j,listId)))
183 ENDDO
184 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
185 & 'Dimensional coordinate value at the lower point',
186 & myThid)
187 ENDIF
188 CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)
189 CALL MNC_CW_DEL_VNAME(dn(1), myThid)
190 CALL MNC_CW_DEL_GNAME(dn(1), myThid)
191 ENDDO
192 #endif /* DIAG_MNC_COORD_NEEDSWORK */
193
194 ENDIF
195 #endif /* ALLOW_MNC */
196
197 DO md = 1,nfields(listId)
198 ndId = jdiag(md,listId)
199 parms1 = gdiag(ndId)(1:8)
200 IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN
201 C-- Start processing 1 Fld :
202
203 ip = ABS(idiag(md,listId))
204 im = mdiag(md,listId)
205 IF ( ndiag(ip,1,1).EQ.0 ) THEN
206 C- Empty diagnostics case :
207
208 _BEGIN_MASTER( myThid )
209 WRITE(msgBuf,'(A,I10)')
210 & '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
211 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
212 & SQUEEZE_RIGHT, myThid)
213 WRITE(msgBuf,'(A,I4,3A,I3,2A)')
214 & '- WARNING - diag.#',ndId, ' : ',flds(md,listId),
215 & ' (#',md,' ) in outp.Stream: ',fnames(listId)
216 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
217 & SQUEEZE_RIGHT, myThid)
218 WRITE(msgBuf,'(A,I2,A)')
219 & '- WARNING - has not been filled (ndiag=',
220 & ndiag(ip,1,1), ' )'
221 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
222 & SQUEEZE_RIGHT, myThid)
223 WRITE(msgBuf,'(A)')
224 & 'WARNING DIAGNOSTICS_OUT => write ZEROS instead'
225 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
226 & SQUEEZE_RIGHT, myThid)
227 _END_MASTER( myThid )
228 DO bj = myByLo(myThid), myByHi(myThid)
229 DO bi = myBxLo(myThid), myBxHi(myThid)
230 DO k = 1,nlevels(listId)
231 DO j = 1-OLy,sNy+OLy
232 DO i = 1-OLx,sNx+OLx
233 qtmp1(i,j,k,bi,bj) = 0. _d 0
234 ENDDO
235 ENDDO
236 ENDDO
237 ENDDO
238 ENDDO
239
240 ELSE
241 C- diagnostics is not empty :
242
243 IF ( myThid.EQ.1 ) WRITE(ioUnit,'(A,I3,3A,I8,2A)')
244 & ' Computing Diagnostic # ', ndId, ' ', cdiag(ndId),
245 & ' Counter:',ndiag(ip,1,1),' Parms: ',gdiag(ndId)
246
247 IF ( parms1(5:5).EQ.'C' ) THEN
248 C Check for Mate of a Counter Diagnostic
249 C --------------------------------------
250 mate_index = parms1(6:8)
251 READ (mate_index,'(I3)') mate
252 IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,2A)')
253 & ' use Counter Mate for ', cdiag(ndId),
254 & ' Diagnostic # ',mate, ' ', cdiag(mate)
255
256 ELSE
257 mate = 0
258
259 C Check for Mate of a Vector Diagnostic
260 C -------------------------------------
261 IF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN
262 mate_index = parms1(6:8)
263 READ (mate_index,'(I3)') mVec
264 IF ( im.GT.0 .AND. ndiag(MAX(1,im),1,1).GT.0 ) THEN
265 IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')
266 & ' Vector Mate for ', cdiag(ndId),
267 & ' Diagnostic # ',mVec, ' ', cdiag(mVec),
268 & ' exists '
269 ELSE
270 IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')
271 & ' Vector Mate for ', cdiag(ndId),
272 & ' Diagnostic # ',mVec, ' ', cdiag(mVec),
273 & ' not enabled'
274 ENDIF
275 ENDIF
276 ENDIF
277
278 DO bj = myByLo(myThid), myByHi(myThid)
279 DO bi = myBxLo(myThid), myBxHi(myThid)
280 DO k = 1,nlevels(listId)
281 CALL GETDIAG(
282 I levs(k,listId),undef,
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
289 C- end of empty diag / not empty block
290 ENDIF
291
292 nlevsout = nlevels(listId)
293
294 C-----------------------------------------------------------------------
295 C Check to see if we need to interpolate before output
296 C-----------------------------------------------------------------------
297 IF ( fflags(listId)(2:2).EQ.'P' ) THEN
298 C- Do vertical interpolation:
299 CALL DIAGNOSTICS_INTERP_VERT(
300 I listId, md, ndId, ip, im,
301 U nlevsout,
302 U qtmp1,
303 I undef,
304 I myTime, myIter, myThid )
305 ENDIF
306
307 #ifdef ALLOW_MDSIO
308 C Prepare for mdsio optionality
309 IF (diag_mdsio) THEN
310 IF (fflags(listId)(1:1) .EQ. 'R') THEN
311 C Force it to be 32-bit precision
312 CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,
313 & 'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)
314 ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN
315 C Force it to be 64-bit precision
316 CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,
317 & 'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)
318 ELSE
319 C This is the old default behavior
320 CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,
321 & 'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)
322 ENDIF
323 ENDIF
324 #endif /* ALLOW_MDSIO */
325
326 #ifdef ALLOW_MNC
327 IF (useMNC .AND. diag_mnc) THEN
328
329 _BEGIN_MASTER( myThid )
330
331 DO ii = 1,CW_DIMS
332 d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
333 dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
334 ENDDO
335
336 C Note that the "d_cw_name" variable is a hack that hides a
337 C subtlety within MNC. Basically, each MNC-wrapped file is
338 C caching its own concept of what each "grid name" (that is, a
339 C dimension group name) means. So one cannot re-use the same
340 C "grid" name for different collections of dimensions within a
341 C given file. By appending the "ndId" values to each name, we
342 C guarantee uniqueness within each MNC-produced file.
343 WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',ndId
344
345 C XY dimensions
346 dim(1) = sNx + 2*OLx
347 dim(2) = sNy + 2*OLy
348 ib(1) = OLx + 1
349 ib(2) = OLy + 1
350 IF (gdiag(ndId)(2:2) .EQ. 'M') THEN
351 dn(1)(1:2) = 'X'
352 ie(1) = OLx + sNx
353 dn(2)(1:2) = 'Y'
354 ie(2) = OLy + sNy
355 ELSEIF (gdiag(ndId)(2:2) .EQ. 'U') THEN
356 dn(1)(1:3) = 'Xp1'
357 ie(1) = OLx + sNx + 1
358 dn(2)(1:2) = 'Y'
359 ie(2) = OLy + sNy
360 ELSEIF (gdiag(ndId)(2:2) .EQ. 'V') THEN
361 dn(1)(1:2) = 'X'
362 ie(1) = OLx + sNx
363 dn(2)(1:3) = 'Yp1'
364 ie(2) = OLy + sNy + 1
365 ELSEIF (gdiag(ndId)(2:2) .EQ. 'Z') THEN
366 dn(1)(1:3) = 'Xp1'
367 ie(1) = OLx + sNx + 1
368 dn(2)(1:3) = 'Yp1'
369 ie(2) = OLy + sNy + 1
370 ENDIF
371
372 C Z is special since it varies
373 WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout
374 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
375 & .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
376 WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevsout
377 ENDIF
378 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
379 & .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
380 WRITE(dn(3),'(a,i6.6)') 'Zld', nlevsout
381 ENDIF
382 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
383 & .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
384 WRITE(dn(3),'(a,i6.6)') 'Zud', nlevsout
385 ENDIF
386 dim(3) = Nr+Nrphys
387 ib(3) = 1
388 ie(3) = nlevsout
389
390 C Time dimension
391 dn(4)(1:1) = 'T'
392 dim(4) = -1
393 ib(4) = 1
394 ie(4) = 1
395
396 CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
397 & dim, dn, ib, ie, myThid)
398 CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,
399 & 4,5, myThid)
400 CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',
401 & tdiag(ndId),myThid)
402 CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
403 & udiag(ndId),myThid)
404
405 IF ( ( (writeBinaryPrec .EQ. precFloat32)
406 & .AND. (fflags(listId)(1:1) .NE. 'D')
407 & .AND. (fflags(listId)(1:1) .NE. 'R') )
408 & .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN
409 CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
410 & cdiag(ndId), qtmp1, myThid)
411 ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
412 & .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN
413 CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
414 & cdiag(ndId), qtmp1, myThid)
415 ENDIF
416
417 CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)
418 CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
419
420 _END_MASTER( myThid )
421
422 ENDIF
423 #endif /* ALLOW_MNC */
424
425 C-- end of Processing Fld # md
426 ENDIF
427 ENDDO
428
429 RETURN
430 END
431
432 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

  ViewVC Help
Powered by ViewVC 1.1.22