/[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.9 - (hide annotations) (download)
Mon Feb 28 19:38:30 2005 UTC (19 years, 2 months ago) by edhill
Branch: MAIN
Changes since 1.8: +2 -2 lines
 o write the "levs" variable as a real

1 edhill 1.9 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_out.F,v 1.8 2005/02/22 17:50:40 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     I listnum,
13     I myIter,
14     I myThid )
15    
16     C !DESCRIPTION:
17     C Write output for diagnostics fields.
18    
19     C !USES:
20 jmc 1.3 IMPLICIT NONE
21 jmc 1.1 #include "SIZE.h"
22     #include "EEPARAMS.h"
23     #include "PARAMS.h"
24 edhill 1.7 #include "GRID.h"
25 jmc 1.3 #include "DIAGNOSTICS_SIZE.h"
26     #include "DIAGNOSTICS.h"
27 jmc 1.1
28     #ifdef ALLOW_FIZHI
29     #include "fizhi_SIZE.h"
30     #else
31 jmc 1.3 INTEGER Nrphys
32     PARAMETER (Nrphys=0)
33 jmc 1.1 #endif
34    
35    
36     C !INPUT PARAMETERS:
37 jmc 1.3 C listnum :: Diagnostics list number being written
38     C myIter :: current iteration number
39     C myThid :: my Thread Id number
40     INTEGER listnum, myIter, myThid
41 jmc 1.1 CEOP
42    
43 jmc 1.3 C !LOCAL VARIABLES:
44     INTEGER i, j, k, m, n, bi, bj
45     CHARACTER*8 parms1
46     CHARACTER*3 mate_index
47 jmc 1.6 INTEGER mate, mVec
48 jmc 1.1 _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)
49     _RL undef, getcon
50 jmc 1.3 EXTERNAL getcon
51     INTEGER ILNBLNK
52     EXTERNAL ILNBLNK
53     INTEGER ilen
54 jmc 1.1
55 jmc 1.6 INTEGER ioUnit
56 jmc 1.1 CHARACTER*(MAX_LEN_FNAM) pref
57     CHARACTER*(MAX_LEN_MBUF) suff
58 jmc 1.3 CHARACTER*(MAX_LEN_MBUF) msgBuf
59 jmc 1.1 CHARACTER*(80) fn
60 jmc 1.3 LOGICAL glf
61 jmc 1.1 #ifdef ALLOW_MNC
62 jmc 1.3 INTEGER ii
63 jmc 1.1 CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
64 edhill 1.7 CHARACTER*(5) ctmp
65 jmc 1.3 INTEGER CW_DIMS, NLEN
66     PARAMETER ( CW_DIMS = 10 )
67     PARAMETER ( NLEN = 80 )
68     INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
69     CHARACTER*(NLEN) dn(CW_DIMS)
70 edhill 1.7 CHARACTER*(NLEN) d_cw_name
71 jmc 1.3 CHARACTER*(NLEN) dn_blnk
72 edhill 1.7 _RS ztmp(Nr+Nrphys)
73 jmc 1.1 #endif /* ALLOW_MNC */
74    
75 jmc 1.3 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
76    
77 jmc 1.6 ioUnit= standardMessageUnit
78 jmc 1.1 undef = getcon('UNDEF')
79     glf = globalFiles
80     WRITE(suff,'(I10.10)') myIter
81     pref = fnames(listnum)
82 jmc 1.3 ilen=ILNBLNK( pref )
83 jmc 1.1 WRITE( fn, '(A,A,A)' ) pref(1:ilen),'.',suff(1:10)
84    
85     #ifdef ALLOW_MNC
86     IF (useMNC .AND. diag_mnc) THEN
87     DO i = 1,MAX_LEN_FNAM
88     diag_mnc_bn(i:i) = ' '
89     ENDDO
90     DO i = 1,NLEN
91     dn_blnk(i:i) = ' '
92     ENDDO
93 jmc 1.2 c WRITE( diag_mnc_bn, '(A,A)' ) 'diag.', pref(1:ilen)
94     WRITE( diag_mnc_bn, '(A)' ) pref(1:ilen)
95 jmc 1.1
96     C Update the record dimension by writing the iteration number
97     CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
98 edhill 1.4 CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'T',myIter,myThid)
99 jmc 1.1 CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
100    
101     dn(1)(1:NLEN) = dn_blnk(1:NLEN)
102 edhill 1.7 WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listnum)
103 jmc 1.1 dim(1) = nlevels(listnum)
104     ib(1) = 1
105     ie(1) = nlevels(listnum)
106    
107     CALL MNC_CW_ADD_GNAME('diag_levels', 1,
108     & dim, dn, ib, ie, myThid)
109 edhill 1.7 CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
110 jmc 1.1 & 0,0, myThid)
111 edhill 1.7 CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
112     & 'Idicies of vertical levels within the source arrays',
113 jmc 1.1 & myThid)
114    
115 edhill 1.9 CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
116 edhill 1.7 & 'diag_levels', levs(1,listnum), myThid)
117 jmc 1.1
118 edhill 1.7 CALL MNC_CW_DEL_VNAME('diag_levels', myThid)
119 jmc 1.1 CALL MNC_CW_DEL_GNAME('diag_levels', myThid)
120 edhill 1.7
121     C Now define: Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
122     ctmp(1:5) = 'mul '
123     DO i = 1,3
124     dn(1)(1:NLEN) = dn_blnk(1:NLEN)
125     WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listnum)
126     CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)
127     CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)
128     DO j = 1,nlevels(listnum)
129     IF (i .EQ. 1) THEN
130     ztmp(j) = rC(levs(j,listnum))
131     CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
132     & 'Dimensional coordinate value at the mid point',
133     & myThid)
134     ELSEIF (i .EQ. 2) THEN
135 jmc 1.8 ztmp(j) = rF(levs(j,listnum) + 1)
136 edhill 1.7 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
137     & 'Dimensional coordinate value at the upper point',
138     & myThid)
139     ELSEIF (i .EQ. 3) THEN
140 jmc 1.8 ztmp(j) = rF(levs(j,listnum))
141 edhill 1.7 CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
142     & 'Dimensional coordinate value at the lower point',
143     & myThid)
144     ENDIF
145     ENDDO
146     CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)
147     CALL MNC_CW_DEL_VNAME(dn(1), myThid)
148     CALL MNC_CW_DEL_GNAME(dn(1), myThid)
149     ENDDO
150    
151 jmc 1.1 ENDIF
152     #endif /* ALLOW_MNC */
153    
154 jmc 1.3 DO n = 1,nfields(listnum)
155     m = jdiag(n,listnum)
156     parms1 = gdiag(m)(1:8)
157     IF ( idiag(m).NE.0 .AND. parms1(5:5).NE.'D' ) THEN
158     C-- Start processing 1 Fld :
159    
160     IF ( ndiag(m).EQ.0 ) THEN
161     C- Empty diagnostics case :
162    
163     _BEGIN_MASTER( myThid )
164     WRITE(msgBuf,'(A,I10)')
165     & '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
166     CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
167     & SQUEEZE_RIGHT, myThid)
168     WRITE(msgBuf,'(A,I4,3A,I3,2A)')
169     & '- WARNING - diag.#',m, ' : ',flds(n,listnum),
170     & ' (#',n,' ) in outp.Stream: ',fnames(listnum)
171     CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
172     & SQUEEZE_RIGHT, myThid)
173     WRITE(msgBuf,'(A,I2,A)')
174     & '- WARNING - has not been filled (ndiag=',ndiag(m),' )'
175     CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
176     & SQUEEZE_RIGHT, myThid)
177     WRITE(msgBuf,'(A)')
178     & 'WARNING DIAGNOSTICS_OUT => write ZEROS instead'
179     CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
180     & SQUEEZE_RIGHT, myThid)
181     _END_MASTER( myThid )
182     DO bj = myByLo(myThid), myByHi(myThid)
183     DO bi = myBxLo(myThid), myBxHi(myThid)
184     DO k = 1,nlevels(listnum)
185     DO j = 1-OLy,sNy+OLy
186     DO i = 1-OLx,sNx+OLx
187     qtmp1(i,j,k,bi,bj) = 0. _d 0
188     ENDDO
189     ENDDO
190     ENDDO
191     ENDDO
192     ENDDO
193    
194     ELSE
195     C- diagnostics is not empty :
196    
197     IF ( myThid.EQ.1 )
198 jmc 1.6 & WRITE(ioUnit,2000) m,cdiag(m),ndiag(m),gdiag(m)
199 jmc 1.3
200 jmc 1.6 IF ( parms1(5:5).EQ.'C' ) THEN
201     C Check for Mate of a Counter Diagnostic
202     C --------------------------------------
203     mate_index = parms1(6:8)
204     READ (mate_index,'(I3)') mate
205     IF ( myThid.EQ.1 )
206     & WRITE(ioUnit,2003) cdiag(m),mate,cdiag(mate)
207     ELSE
208     mate = 0
209 jmc 1.3
210     C Check for Mate of a Vector Diagnostic
211     C -------------------------------------
212     IF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN
213     mate_index = parms1(6:8)
214 jmc 1.6 READ (mate_index,'(I3)') mVec
215     IF ( idiag(mVec).NE.0 ) THEN
216 jmc 1.3 IF ( myThid.EQ.1 )
217 jmc 1.6 & WRITE(ioUnit,2001) cdiag(m),mVec,cdiag(mVec)
218 jmc 1.3 ELSE
219     IF ( myThid.EQ.1 )
220 jmc 1.6 & WRITE(ioUnit,2002) cdiag(m),mVec,cdiag(mVec)
221 jmc 1.3 ENDIF
222     ENDIF
223 jmc 1.6 ENDIF
224 jmc 1.3
225 jmc 1.6 DO bj = myByLo(myThid), myByHi(myThid)
226     DO bi = myBxLo(myThid), myBxHi(myThid)
227 jmc 1.3 DO k = 1,nlevels(listnum)
228 jmc 1.6 CALL GETDIAG(
229     I levs(k,listnum),undef,
230     O qtmp1(1-OLx,1-OLy,k,bi,bj),
231     I m,mate,bi,bj,myThid)
232 jmc 1.3 ENDDO
233 jmc 1.6 ENDDO
234     ENDDO
235 jmc 1.1
236 jmc 1.3 C- end of empty diag / not empty block
237     ENDIF
238 jmc 1.1
239     #ifdef ALLOW_MDSIO
240 jmc 1.3 C Prepare for mdsio optionality
241     IF (diag_mdsio) THEN
242     CALL mdswritefield_new(fn,writeBinaryPrec,glf,'RL',
243     & Nr+Nrphys,nlevels(listnum),qtmp1,n,myIter,myThid)
244     ENDIF
245 jmc 1.1 #endif /* ALLOW_MDSIO */
246    
247     #ifdef ALLOW_MNC
248 jmc 1.3 IF (useMNC .AND. diag_mnc) THEN
249 jmc 1.1
250 jmc 1.3 _BEGIN_MASTER( myThid )
251 jmc 1.1
252 jmc 1.3 DO ii = 1,CW_DIMS
253 edhill 1.7 d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
254 jmc 1.3 dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
255     ENDDO
256    
257 edhill 1.7 C Note that the "d_cw_name" variable is a hack that hides a
258     C subtlety within MNC. Basically, each MNC-wrapped file is
259     C caching its own concept of what each "grid name" (that is, a
260     C dimension group name) means. So one cannot re-use the same
261     C "grid" name for different collections of dimensions within a
262     C given file. By appending the "m" values to each name, we
263     C guarantee uniqueness within each MNC-produced file.
264     WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',m
265    
266 edhill 1.5 C XY dimensions
267     dim(1) = sNx + 2*OLx
268     dim(2) = sNy + 2*OLy
269     ib(1) = OLx + 1
270     ib(2) = OLy + 1
271 edhill 1.7 IF (gdiag(m)(2:2) .EQ. 'M') THEN
272 edhill 1.5 dn(1)(1:2) = 'X'
273     ie(1) = OLx + sNx
274     dn(2)(1:2) = 'Y'
275     ie(2) = OLy + sNy
276 edhill 1.7 ELSEIF (gdiag(m)(2:2) .EQ. 'U') THEN
277 edhill 1.5 dn(1)(1:3) = 'Xp1'
278     ie(1) = OLx + sNx + 1
279     dn(2)(1:2) = 'Y'
280     ie(2) = OLy + sNy
281 edhill 1.7 ELSEIF (gdiag(m)(2:2) .EQ. 'V') THEN
282 edhill 1.5 dn(1)(1:2) = 'X'
283     ie(1) = OLx + sNx
284     dn(2)(1:3) = 'Yp1'
285     ie(2) = OLy + sNy + 1
286 edhill 1.7 ELSEIF (gdiag(m)(2:2) .EQ. 'Z') THEN
287 edhill 1.5 dn(1)(1:3) = 'Xp1'
288     ie(1) = OLx + sNx + 1
289     dn(2)(1:3) = 'Yp1'
290     ie(2) = OLy + sNy + 1
291     ENDIF
292    
293 jmc 1.3 C Z is special since it varies
294     WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listnum)
295 edhill 1.7 IF ( (gdiag(m)(10:10) .EQ. 'R')
296     & .AND. (gdiag(m)(9:9) .EQ. 'M') ) THEN
297     WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevels(listnum)
298     ENDIF
299     IF ( (gdiag(m)(10:10) .EQ. 'R')
300     & .AND. (gdiag(m)(9:9) .EQ. 'L') ) THEN
301     WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listnum)
302     ENDIF
303     IF ( (gdiag(m)(10:10) .EQ. 'R')
304     & .AND. (gdiag(m)(9:9) .EQ. 'U') ) THEN
305     WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listnum)
306     ENDIF
307 jmc 1.3 dim(3) = Nr+Nrphys
308     ib(3) = 1
309     ie(3) = nlevels(listnum)
310 jmc 1.1
311 edhill 1.5 C Time dimension
312     dn(4)(1:1) = 'T'
313     dim(4) = -1
314     ib(4) = 1
315     ie(4) = 1
316    
317 edhill 1.7 CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
318 jmc 1.1 & dim, dn, ib, ie, myThid)
319 edhill 1.7 CALL MNC_CW_ADD_VNAME(cdiag(m), d_cw_name,
320 jmc 1.1 & 4,5, myThid)
321 jmc 1.3 CALL MNC_CW_ADD_VATTR_TEXT(cdiag(m),'description',
322 jmc 1.1 & tdiag(m),myThid)
323 jmc 1.3 CALL MNC_CW_ADD_VATTR_TEXT(cdiag(m),'units',
324 jmc 1.1 & udiag(m),myThid)
325    
326 jmc 1.3 CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
327 jmc 1.1 & cdiag(m), qtmp1, myThid)
328    
329 jmc 1.3 CALL MNC_CW_DEL_VNAME(cdiag(m), myThid)
330 edhill 1.7 CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
331 jmc 1.1
332 jmc 1.3 _END_MASTER( myThid )
333 jmc 1.1
334 jmc 1.3 ENDIF
335 jmc 1.1 #endif /* ALLOW_MNC */
336    
337 jmc 1.3 C-- end of Processing Fld # n
338     ENDIF
339     ENDDO
340 jmc 1.1
341     2000 format(1x,'Computing Diagnostic # ',i3,2x,a8,5x,'Counter: ',
342     & i4,6x,'Parms: ',a16)
343     2001 format(1x,' Vector Mate for ',a8,5x,
344     & 'Diagnostic # ',i3,2x,a8,' exists ')
345     2002 format(1x,' Vector Mate for ',a8,5x,
346     & 'Diagnostic # ',i3,2x,a8,' not enabled')
347     2003 format(1x,' use Counter Mate for ',a8,5x,
348     & 'Diagnostic # ',i3,2x,a8)
349    
350 jmc 1.3 RETURN
351     END
352 jmc 1.1
353     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

  ViewVC Help
Powered by ViewVC 1.1.22