/[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.24 - (show annotations) (download)
Fri Nov 18 23:46:39 2005 UTC (18 years, 5 months ago) by molod
Branch: MAIN
Changes since 1.23: +6 -6 lines
Fix mnc diagnostics output level dimension for vertical interpolation case

1 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_out.F,v 1.23 2005/11/02 14:42:31 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 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,1,1,'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 Now define: Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
145 ctmp(1:5) = 'mul '
146 DO i = 1,3
147 dn(1)(1:NLEN) = dn_blnk(1:NLEN)
148 WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listId)
149 CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)
150 CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)
151
152 C The following three ztmp() loops should eventually be modified
153 C to reflect the fractional nature of levs(j,l) -- they should
154 C do something like:
155 C ztmp(j) = rC(INT(FLOOR(levs(j,l))))
156 C + ( rC(INT(FLOOR(levs(j,l))))
157 C + rC(INT(CEIL(levs(j,l)))) )
158 C / ( levs(j,l) - FLOOR(levs(j,l)) )
159 C for averaged levels.
160 IF (i .EQ. 1) THEN
161 DO j = 1,nlevels(listId)
162 ztmp(j) = rC(NINT(levs(j,listId)))
163 ENDDO
164 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
165 & 'Dimensional coordinate value at the mid point',
166 & myThid)
167 ELSEIF (i .EQ. 2) THEN
168 DO j = 1,nlevels(listId)
169 ztmp(j) = rF(NINT(levs(j,listId)) + 1)
170 ENDDO
171 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
172 & 'Dimensional coordinate value at the upper point',
173 & myThid)
174 ELSEIF (i .EQ. 3) THEN
175 DO j = 1,nlevels(listId)
176 ztmp(j) = rF(NINT(levs(j,listId)))
177 ENDDO
178 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
179 & 'Dimensional coordinate value at the lower point',
180 & myThid)
181 ENDIF
182 CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)
183 CALL MNC_CW_DEL_VNAME(dn(1), myThid)
184 CALL MNC_CW_DEL_GNAME(dn(1), myThid)
185 ENDDO
186 #endif /* DIAG_MNC_COORD_NEEDSWORK */
187
188 ENDIF
189 #endif /* ALLOW_MNC */
190
191 DO md = 1,nfields(listId)
192 ndId = jdiag(md,listId)
193 parms1 = gdiag(ndId)(1:8)
194 IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN
195 C-- Start processing 1 Fld :
196
197 ip = ABS(idiag(md,listId))
198 im = mdiag(md,listId)
199 IF ( ndiag(ip,1,1).EQ.0 ) THEN
200 C- Empty diagnostics case :
201
202 _BEGIN_MASTER( myThid )
203 WRITE(msgBuf,'(A,I10)')
204 & '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
205 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
206 & SQUEEZE_RIGHT, myThid)
207 WRITE(msgBuf,'(A,I4,3A,I3,2A)')
208 & '- WARNING - diag.#',ndId, ' : ',flds(md,listId),
209 & ' (#',md,' ) in outp.Stream: ',fnames(listId)
210 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
211 & SQUEEZE_RIGHT, myThid)
212 WRITE(msgBuf,'(A,I2,A)')
213 & '- WARNING - has not been filled (ndiag=',
214 & ndiag(ip,1,1), ' )'
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,nlevels(listId)
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 ( myThid.EQ.1 ) WRITE(ioUnit,'(A,I3,3A,I8,2A)')
238 & ' Computing Diagnostic # ', ndId, ' ', cdiag(ndId),
239 & ' Counter:',ndiag(ip,1,1),' Parms: ',gdiag(ndId)
240
241 IF ( parms1(5:5).EQ.'C' ) THEN
242 C Check for Mate of a Counter Diagnostic
243 C --------------------------------------
244 mate_index = parms1(6:8)
245 READ (mate_index,'(I3)') mate
246 IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,2A)')
247 & ' use Counter Mate for ', cdiag(ndId),
248 & ' Diagnostic # ',mate, ' ', cdiag(mate)
249
250 ELSE
251 mate = 0
252
253 C Check for Mate of a Vector Diagnostic
254 C -------------------------------------
255 IF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN
256 mate_index = parms1(6:8)
257 READ (mate_index,'(I3)') mVec
258 IF ( im.GT.0 .AND. ndiag(MAX(1,im),1,1).GT.0 ) THEN
259 IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')
260 & ' Vector Mate for ', cdiag(ndId),
261 & ' Diagnostic # ',mVec, ' ', cdiag(mVec),
262 & ' exists '
263 ELSE
264 IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')
265 & ' Vector Mate for ', cdiag(ndId),
266 & ' Diagnostic # ',mVec, ' ', cdiag(mVec),
267 & ' not enabled'
268 ENDIF
269 ENDIF
270 ENDIF
271
272 DO bj = myByLo(myThid), myByHi(myThid)
273 DO bi = myBxLo(myThid), myBxHi(myThid)
274 DO k = 1,nlevels(listId)
275 CALL GETDIAG(
276 I levs(k,listId),undef,
277 O qtmp1(1-OLx,1-OLy,k,bi,bj),
278 I ndId,mate,ip,im,bi,bj,myThid)
279 ENDDO
280 ENDDO
281 ENDDO
282
283 C- end of empty diag / not empty block
284 ENDIF
285
286 nlevsout = nlevels(listId)
287
288 C-----------------------------------------------------------------------
289 C Check to see if we need to interpolate before output
290 C-----------------------------------------------------------------------
291 IF ( fflags(listId)(2:2).EQ.'P' ) THEN
292 C- Do vertical interpolation:
293 CALL DIAGNOSTICS_INTERP_VERT(
294 I listId, md, ndId, ip, im,
295 U nlevsout,
296 U qtmp1,
297 I undef,
298 I myTime, myIter, myThid )
299 ENDIF
300
301 #ifdef ALLOW_MDSIO
302 C Prepare for mdsio optionality
303 IF (diag_mdsio) THEN
304 IF (fflags(listId)(1:1) .EQ. 'R') THEN
305 C Force it to be 32-bit precision
306 CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,
307 & 'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)
308 ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN
309 C Force it to be 64-bit precision
310 CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,
311 & 'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)
312 ELSE
313 C This is the old default behavior
314 CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,
315 & 'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)
316 ENDIF
317 ENDIF
318 #endif /* ALLOW_MDSIO */
319
320 #ifdef ALLOW_MNC
321 IF (useMNC .AND. diag_mnc) THEN
322
323 _BEGIN_MASTER( myThid )
324
325 DO ii = 1,CW_DIMS
326 d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
327 dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
328 ENDDO
329
330 C Note that the "d_cw_name" variable is a hack that hides a
331 C subtlety within MNC. Basically, each MNC-wrapped file is
332 C caching its own concept of what each "grid name" (that is, a
333 C dimension group name) means. So one cannot re-use the same
334 C "grid" name for different collections of dimensions within a
335 C given file. By appending the "ndId" values to each name, we
336 C guarantee uniqueness within each MNC-produced file.
337 WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',ndId
338
339 C XY dimensions
340 dim(1) = sNx + 2*OLx
341 dim(2) = sNy + 2*OLy
342 ib(1) = OLx + 1
343 ib(2) = OLy + 1
344 IF (gdiag(ndId)(2:2) .EQ. 'M') THEN
345 dn(1)(1:2) = 'X'
346 ie(1) = OLx + sNx
347 dn(2)(1:2) = 'Y'
348 ie(2) = OLy + sNy
349 ELSEIF (gdiag(ndId)(2:2) .EQ. 'U') THEN
350 dn(1)(1:3) = 'Xp1'
351 ie(1) = OLx + sNx + 1
352 dn(2)(1:2) = 'Y'
353 ie(2) = OLy + sNy
354 ELSEIF (gdiag(ndId)(2:2) .EQ. 'V') THEN
355 dn(1)(1:2) = 'X'
356 ie(1) = OLx + sNx
357 dn(2)(1:3) = 'Yp1'
358 ie(2) = OLy + sNy + 1
359 ELSEIF (gdiag(ndId)(2:2) .EQ. 'Z') THEN
360 dn(1)(1:3) = 'Xp1'
361 ie(1) = OLx + sNx + 1
362 dn(2)(1:3) = 'Yp1'
363 ie(2) = OLy + sNy + 1
364 ENDIF
365
366 C Z is special since it varies
367 WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout
368 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
369 & .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
370 WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevsout
371 ENDIF
372 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
373 & .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
374 WRITE(dn(3),'(a,i6.6)') 'Zld', nlevsout
375 ENDIF
376 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
377 & .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
378 WRITE(dn(3),'(a,i6.6)') 'Zud', nlevsout
379 ENDIF
380 dim(3) = Nr+Nrphys
381 ib(3) = 1
382 ie(3) = nlevsout
383
384 C Time dimension
385 dn(4)(1:1) = 'T'
386 dim(4) = -1
387 ib(4) = 1
388 ie(4) = 1
389
390 CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
391 & dim, dn, ib, ie, myThid)
392 CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,
393 & 4,5, myThid)
394 CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',
395 & tdiag(ndId),myThid)
396 CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
397 & udiag(ndId),myThid)
398
399 IF ( ( (writeBinaryPrec .EQ. precFloat32)
400 & .AND. (fflags(listId)(1:1) .NE. 'D')
401 & .AND. (fflags(listId)(1:1) .NE. 'R') )
402 & .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN
403 CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
404 & cdiag(ndId), qtmp1, myThid)
405 ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
406 & .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN
407 CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
408 & cdiag(ndId), qtmp1, myThid)
409 ENDIF
410
411 CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)
412 CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
413
414 _END_MASTER( myThid )
415
416 ENDIF
417 #endif /* ALLOW_MNC */
418
419 C-- end of Processing Fld # md
420 ENDIF
421 ENDDO
422
423 RETURN
424 END
425
426 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

  ViewVC Help
Powered by ViewVC 1.1.22