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

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

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

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