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

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

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


Revision 1.1 - (show annotations) (download)
Sat Jun 11 23:29:44 2011 UTC (12 years, 11 months ago) by jmc
Branch: MAIN
move MNC code out of diagnostics_out.F into 2 S/R (in diagnostics_mnc_out.F)

1 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_out.F,v 1.49 2011/06/06 15:42:58 jmc Exp $
2 C $Name: $
3
4 #include "DIAG_OPTIONS.h"
5 #undef DIAG_MNC_COORD_NEEDSWORK
6
7 C-- File diagnostics_mnc_out.F: Routines to write MNC diagnostics output
8 C-- Contents:
9 C-- o DIAGNOSTICS_MNC_SET
10 C-- o DIAGNOSTICS_MNC_OUT
11
12 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
13 CBOP 0
14 C !ROUTINE: DIAGNOSTICS_MNC_SET
15
16 C !INTERFACE:
17 SUBROUTINE DIAGNOSTICS_MNC_SET(
18 I nLevOutp, listId, lm,
19 O diag_mnc_bn,
20 O useMissingValue, misValLoc,
21 I myTime, myIter, myThid )
22
23 C !DESCRIPTION:
24 C Set MNC file for writing diagnostics fields.
25
26 C !USES:
27 IMPLICIT NONE
28 #include "SIZE.h"
29 #include "EEPARAMS.h"
30 #include "PARAMS.h"
31 #include "GRID.h"
32 #include "DIAGNOSTICS_SIZE.h"
33 #include "DIAGNOSTICS.h"
34
35
36 C !INPUT PARAMETERS:
37 C nLevOutp :: number of levels to write in output file
38 C listId :: Diagnostics list number being written
39 C lm :: loop index (averageCycle)
40 C myIter :: current iteration number
41 C myTime :: current time of simulation (s)
42 C myThid :: my Thread Id number
43 INTEGER nLevOutp
44 INTEGER listId, lm
45 CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
46 LOGICAL useMissingValue
47 REAL*8 misValLoc
48 _RL myTime
49 INTEGER myIter, myThid
50 CEOP
51
52 #ifdef ALLOW_MNC
53 C !FUNCTIONS:
54 INTEGER ILNBLNK
55 EXTERNAL ILNBLNK
56
57 C !LOCAL VARIABLES:
58 INTEGER NrMax
59 PARAMETER( NrMax = numLevels )
60
61 _RL undef
62 _RL tmpLev
63 INTEGER iLen
64
65 c CHARACTER*(MAX_LEN_MBUF) msgBuf
66 INTEGER ii, klev
67 INTEGER CW_DIMS, NLEN
68 PARAMETER ( CW_DIMS = 10 )
69 PARAMETER ( NLEN = 80 )
70 INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
71 CHARACTER*(NLEN) dn(CW_DIMS)
72 c CHARACTER*(NLEN) d_cw_name
73 c CHARACTER*(NLEN) dn_blnk
74 #ifdef DIAG_MNC_COORD_NEEDSWORK
75 INTEGER i, j
76 CHARACTER*(5) ctmp
77 _RS ztmp(NrMax)
78 #endif
79 INTEGER misvalIntLoc
80 REAL*8 misval_r8(2)
81 REAL*4 misval_r4(2)
82 INTEGER misval_int(2)
83
84 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
85 c IF (useMNC .AND. diag_mnc) THEN
86
87 C Handle missing value attribute (land points)
88 useMissingValue = .FALSE.
89 #ifdef DIAGNOSTICS_MISSING_VALUE
90 useMissingValue = .TRUE.
91 #endif /* DIAGNOSTICS_MISSING_VALUE */
92 IF ( misvalFlt(listId) .NE. UNSET_RL ) THEN
93 misValLoc = misvalFlt(listId)
94 ELSE
95 misValLoc = undef
96 ENDIF
97 C Defaults to UNSET_I
98 misvalIntLoc = misvalInt(listId)
99 DO ii=1,2
100 misval_r4(ii) = misValLoc
101 misval_r8(ii) = misValLoc
102 misval_int(ii) = UNSET_I
103 ENDDO
104 c DO i = 1,MAX_LEN_FNAM
105 c diag_mnc_bn(i:i) = ' '
106 c ENDDO
107 c DO i = 1,NLEN
108 c dn_blnk(i:i) = ' '
109 c ENDDO
110 iLen = ILNBLNK(fnames(listId))
111 WRITE( diag_mnc_bn, '(A)' ) fnames(listId)(1:iLen)
112
113 C Update the record dimension by writing the iteration number
114 klev = myIter + lm - averageCycle(listId)
115 tmpLev = myTime + deltaTClock*( lm - averageCycle(listId) )
116 CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
117 CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',tmpLev,myThid)
118 CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
119 CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',klev,myThid)
120
121 C NOTE: at some point it would be a good idea to add a time_bounds
122 C variable that has dimension (2,T) and clearly denotes the
123 C beginning and ending times for each diagnostics period
124
125 c dn(1)(1:NLEN) = dn_blnk(1:NLEN)
126 WRITE(dn(1),'(a,i6.6)') 'Zmd', nLevOutp
127 dim(1) = nLevOutp
128 ib(1) = 1
129 ie(1) = nLevOutp
130
131 CALL MNC_CW_ADD_GNAME('diag_levels', 1,
132 & dim, dn, ib, ie, myThid)
133 CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
134 & 0,0, myThid)
135 CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
136 & 'Idicies of vertical levels within the source arrays',
137 & myThid)
138 C suppress the missing value attribute (iflag = 0)
139 IF (useMissingValue)
140 & CALL MNC_CW_VATTR_MISSING('diag_levels', 0,
141 I misval_r8, misval_r4, misval_int, myThid )
142
143 CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
144 & 'diag_levels', levs(1,listId), myThid)
145
146 CALL MNC_CW_DEL_VNAME('diag_levels', myThid)
147 CALL MNC_CW_DEL_GNAME('diag_levels', myThid)
148
149 #ifdef DIAG_MNC_COORD_NEEDSWORK
150 C This part has been placed in an #ifdef because, as its currently
151 C written, it will only work with variables defined on a dynamics
152 C grid. As we start using diagnostics for physics grids, ice
153 C levels, land levels, etc. the different vertical coordinate
154 C dimensions will have to be taken into account.
155
156 C 20051021 JMC & EH3 : We need to extend this so that a few
157 C variables each defined on different grids do not have the same
158 C vertical dimension names so we should be using a pattern such
159 C as: Z[uml]td000000 where the 't' is the type as specified by
160 C gdiag(10)
161
162 C Now define: Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
163 ctmp(1:5) = 'mul '
164 DO i = 1,3
165 c dn(1)(1:NLEN) = dn_blnk(1:NLEN)
166 WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listId)
167 CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)
168 CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)
169
170 C The following three ztmp() loops should eventually be modified
171 C to reflect the fractional nature of levs(j,l) -- they should
172 C do something like:
173 C ztmp(j) = rC(INT(FLOOR(levs(j,l))))
174 C + ( rC(INT(FLOOR(levs(j,l))))
175 C + rC(INT(CEIL(levs(j,l)))) )
176 C / ( levs(j,l) - FLOOR(levs(j,l)) )
177 C for averaged levels.
178 IF (i .EQ. 1) THEN
179 DO j = 1,nlevels(listId)
180 ztmp(j) = rC(NINT(levs(j,listId)))
181 ENDDO
182 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
183 & 'Dimensional coordinate value at the mid point',
184 & myThid)
185 ELSEIF (i .EQ. 2) THEN
186 DO j = 1,nlevels(listId)
187 ztmp(j) = rF(NINT(levs(j,listId)) + 1)
188 ENDDO
189 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
190 & 'Dimensional coordinate value at the upper point',
191 & myThid)
192 ELSEIF (i .EQ. 3) THEN
193 DO j = 1,nlevels(listId)
194 ztmp(j) = rF(NINT(levs(j,listId)))
195 ENDDO
196 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
197 & 'Dimensional coordinate value at the lower point',
198 & myThid)
199 ENDIF
200 C suppress the missing value attribute (iflag = 0)
201 IF (useMissingValue)
202 & CALL MNC_CW_VATTR_MISSING(dn(1), 0,
203 I misval_r8, misval_r4, misval_int, myThid )
204 CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)
205 CALL MNC_CW_DEL_VNAME(dn(1), myThid)
206 CALL MNC_CW_DEL_GNAME(dn(1), myThid)
207 ENDDO
208 #endif /* DIAG_MNC_COORD_NEEDSWORK */
209
210 c ENDIF
211 #endif /* ALLOW_MNC */
212
213 RETURN
214 END
215
216 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
217 CBOP 0
218 C !ROUTINE: DIAGNOSTICS_MNC_OUT
219
220 C !INTERFACE:
221 SUBROUTINE DIAGNOSTICS_MNC_OUT(
222 I NrMax, nLevOutp, listId, ndId,
223 I diag_mnc_bn,
224 I useMissingValue, misValLoc,
225 I qtmp,
226 I myTime, myIter, myThid )
227
228 C !DESCRIPTION:
229 C write diagnostics fields to MNC file.
230
231 C !USES:
232 IMPLICIT NONE
233 #include "SIZE.h"
234 #include "EEPARAMS.h"
235 #include "PARAMS.h"
236 #include "GRID.h"
237 #include "DIAGNOSTICS_SIZE.h"
238 #include "DIAGNOSTICS.h"
239
240 C !INPUT PARAMETERS:
241 C nLevOutp :: number of levels to write in output file
242 C listId :: Diagnostics list number being written
243 C ndId :: diagnostics Id number (in available diagnostics list)
244 C myTime :: current time of simulation (s)
245 C myIter :: current iteration number
246 C myThid :: my Thread Id number
247 INTEGER NrMax
248 INTEGER nLevOutp
249 INTEGER listId
250 INTEGER ndId
251 CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
252 LOGICAL useMissingValue
253 REAL*8 misValLoc
254 _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
255 _RL myTime
256 INTEGER myIter, myThid
257 CEOP
258
259 C !FUNCTIONS:
260 c INTEGER ILNBLNK
261 c EXTERNAL ILNBLNK
262
263 C !LOCAL VARIABLES:
264 C i,j,k :: loop indices
265 C bi,bj :: tile indices
266 INTEGER i, j, k
267 INTEGER bi, bj
268
269 c CHARACTER*(MAX_LEN_MBUF) msgBuf
270 #ifdef ALLOW_MNC
271 c INTEGER ll, llMx, jj, jjMx
272 INTEGER ii, klev
273 INTEGER CW_DIMS, NLEN
274 PARAMETER ( CW_DIMS = 10 )
275 PARAMETER ( NLEN = 80 )
276 INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
277 CHARACTER*(NLEN) dn(CW_DIMS)
278 CHARACTER*(NLEN) d_cw_name
279 c CHARACTER*(NLEN) dn_blnk
280 LOGICAL useMisValForThisDiag
281 REAL*8 misval_r8(2)
282 REAL*4 misval_r4(2)
283 INTEGER misval_int(2)
284
285 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
286 c IF (useMNC .AND. diag_mnc) THEN
287
288 _BEGIN_MASTER( myThid )
289
290 DO ii = 1,CW_DIMS
291 c d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
292 c dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
293 dn(ii) = ' '
294 ENDDO
295 DO ii=1,2
296 misval_r4(ii) = misValLoc
297 misval_r8(ii) = misValLoc
298 misval_int(ii) = UNSET_I
299 ENDDO
300
301 C Note that the "d_cw_name" variable is a hack that hides a
302 C subtlety within MNC. Basically, each MNC-wrapped file is
303 C caching its own concept of what each "grid name" (that is, a
304 C dimension group name) means. So one cannot re-use the same
305 C "grid" name for different collections of dimensions within a
306 C given file. By appending the "ndId" values to each name, we
307 C guarantee uniqueness within each MNC-produced file.
308 WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',ndId
309
310 C XY dimensions
311 dim(1) = sNx + 2*OLx
312 dim(2) = sNy + 2*OLy
313 ib(1) = OLx + 1
314 ib(2) = OLy + 1
315 IF (gdiag(ndId)(2:2) .EQ. 'M') THEN
316 dn(1)(1:2) = 'X'
317 ie(1) = OLx + sNx
318 dn(2)(1:2) = 'Y'
319 ie(2) = OLy + sNy
320 ELSEIF (gdiag(ndId)(2:2) .EQ. 'U') THEN
321 dn(1)(1:3) = 'Xp1'
322 ie(1) = OLx + sNx + 1
323 dn(2)(1:2) = 'Y'
324 ie(2) = OLy + sNy
325 ELSEIF (gdiag(ndId)(2:2) .EQ. 'V') THEN
326 dn(1)(1:2) = 'X'
327 ie(1) = OLx + sNx
328 dn(2)(1:3) = 'Yp1'
329 ie(2) = OLy + sNy + 1
330 ELSEIF (gdiag(ndId)(2:2) .EQ. 'Z') THEN
331 dn(1)(1:3) = 'Xp1'
332 ie(1) = OLx + sNx + 1
333 dn(2)(1:3) = 'Yp1'
334 ie(2) = OLy + sNy + 1
335 ENDIF
336
337 C Z is special since it varies
338 WRITE(dn(3),'(a,i6.6)') 'Zd', nLevOutp
339 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
340 & .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
341 WRITE(dn(3),'(a,i6.6)') 'Zmd', nLevOutp
342 ENDIF
343 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
344 & .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
345 WRITE(dn(3),'(a,i6.6)') 'Zld', nLevOutp
346 ENDIF
347 IF ( (gdiag(ndId)(10:10) .EQ. 'R')
348 & .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
349 WRITE(dn(3),'(a,i6.6)') 'Zud', nLevOutp
350 ENDIF
351 dim(3) = NrMax
352 ib(3) = 1
353 ie(3) = nLevOutp
354
355 C Time dimension
356 dn(4)(1:1) = 'T'
357 dim(4) = -1
358 ib(4) = 1
359 ie(4) = 1
360
361 CALL MNC_CW_ADD_GNAME( d_cw_name, 4,
362 & dim, dn, ib, ie, myThid )
363 CALL MNC_CW_ADD_VNAME( cdiag(ndId), d_cw_name,
364 & 4, 5, myThid )
365 CALL MNC_CW_ADD_VATTR_TEXT( cdiag(ndId),'description',
366 & tdiag(ndId), myThid )
367 CALL MNC_CW_ADD_VATTR_TEXT( cdiag(ndId),'units',
368 & udiag(ndId), myThid )
369
370 C Missing values only for scalar diagnostics at mass points (so far)
371 useMisValForThisDiag = useMissingValue
372 & .AND.gdiag(ndId)(1:2).EQ.'SM'
373 IF ( useMisValForThisDiag ) THEN
374 C assign missing values and set flag for adding the netCDF atttibute
375 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,
376 I misval_r8, misval_r4, misval_int, myThid )
377 C and now use the missing values for masking out the land points
378 C note: better to use 2-D mask if kdiag <> Nr or vert.integral
379 DO bj = myByLo(myThid), myByHi(myThid)
380 DO bi = myBxLo(myThid), myBxHi(myThid)
381 DO k = 1,nLevOutp
382 klev = NINT(levs(k,listId))
383 IF ( fflags(listId)(2:2).EQ.'I' ) kLev = 1
384 DO j = 1-OLy,sNy+OLy
385 DO i = 1-OLx,sNx+OLx
386 IF ( maskC(i,j,klev,bi,bj) .EQ. 0. )
387 & qtmp(i,j,k,bi,bj) = misValLoc
388 ENDDO
389 ENDDO
390 ENDDO
391 ENDDO
392 ENDDO
393 ELSE
394 C suppress the missing value attribute (iflag = 0)
395 C Note: We have to call the following subroutine for each mnc that has
396 C been created "on the fly" by mnc_cw_add_vname and will be deleted
397 C by mnc_cw_del_vname, because all of these variables use the same
398 C identifier so that mnc_cw_vfmv(indv) needs to be overwritten for
399 C each of these variables
400 CALL MNC_CW_VATTR_MISSING( cdiag(ndId), 0,
401 I misval_r8, misval_r4, misval_int, myThid )
402 ENDIF
403
404 IF ( ((writeBinaryPrec .EQ. precFloat32).AND.
405 & (fflags(listId)(1:1) .NE. 'D'))
406 & .OR. (fflags(listId)(1:1) .EQ. 'R') ) THEN
407 CALL MNC_CW_RL_W( 'R',diag_mnc_bn,0,0,
408 & cdiag(ndId), qtmp, myThid)
409 ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
410 & .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN
411 CALL MNC_CW_RL_W( 'D',diag_mnc_bn,0,0,
412 & cdiag(ndId), qtmp, myThid)
413 ENDIF
414
415 CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)
416 CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
417
418 _END_MASTER( myThid )
419
420 c ENDIF
421 #endif /* ALLOW_MNC */
422
423 RETURN
424 END

  ViewVC Help
Powered by ViewVC 1.1.22