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

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

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

revision 1.14 by edhill, Wed May 25 04:03:09 2005 UTC revision 1.29 by jmc, Mon Jun 5 18:17:23 2006 UTC
# Line 9  C     !ROUTINE: DIAGNOSTICS_OUT Line 9  C     !ROUTINE: DIAGNOSTICS_OUT
9    
10  C     !INTERFACE:  C     !INTERFACE:
11        SUBROUTINE  DIAGNOSTICS_OUT(        SUBROUTINE  DIAGNOSTICS_OUT(
12       I     listnum,       I     listId,
13       I     myIter,       I     myIter,
14       I     myTime,       I     myTime,
15       I     myThid )       I     myThid )
16    
17  C     !DESCRIPTION:  C     !DESCRIPTION:
18  C     Write output for diagnostics fields.  C     Write output for diagnostics fields.
19          
20  C     !USES:  C     !USES:
21        IMPLICIT NONE        IMPLICIT NONE
22  #include "SIZE.h"  #include "SIZE.h"
# Line 35  C     !USES: Line 35  C     !USES:
35    
36    
37  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
38  C     listnum :: Diagnostics list number being written  C     listId  :: Diagnostics list number being written
39  C     myIter  :: current iteration number  C     myIter  :: current iteration number
40    C     myTime  :: current time of simulation (s)
41  C     myThid  :: my Thread Id number  C     myThid  :: my Thread Id number
42        _RL     myTime        _RL     myTime
43        INTEGER listnum, myIter, myThid        INTEGER listId, myIter, myThid
44  CEOP  CEOP
45    
46  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
47        INTEGER i, j, k, m, n, bi, bj  C     i,j,k :: loop indices
48        CHARACTER*8 parms1  C     lm    :: loop index (averageCycle)
49        CHARACTER*3 mate_index  C     md    :: field number in the list "listId".
50    C     ndId  :: diagnostics  Id number (in available diagnostics list)
51    C     mate  :: counter mate Id number (in available diagnostics list)
52    C     ip    :: diagnostics  pointer to storage array
53    C     im    :: counter-mate pointer to storage array
54          INTEGER i, j, k, lm
55          INTEGER bi, bj
56          INTEGER md, ndId, ip, im
57        INTEGER mate, mVec        INTEGER mate, mVec
58          CHARACTER*8 parms1
59        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)
60        _RL undef, getcon        _RL undef, getcon
61        EXTERNAL getcon        EXTERNAL getcon
62        INTEGER ILNBLNK        INTEGER ILNBLNK
63        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
64        INTEGER ilen        INTEGER ilen
65          INTEGER nlevsout
66    
67        INTEGER ioUnit        INTEGER ioUnit
68        CHARACTER*(MAX_LEN_FNAM) fn        CHARACTER*(MAX_LEN_FNAM) fn
69        CHARACTER*(MAX_LEN_MBUF) suff        CHARACTER*(MAX_LEN_MBUF) suff
70        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
71    #ifdef ALLOW_MDSIO
72        LOGICAL glf        LOGICAL glf
73          INTEGER nRec
74    #endif
75  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
76        INTEGER ii        INTEGER ii
77        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
       CHARACTER*(5) ctmp  
78        INTEGER CW_DIMS, NLEN        INTEGER CW_DIMS, NLEN
79        PARAMETER ( CW_DIMS = 10 )        PARAMETER ( CW_DIMS = 10 )
80        PARAMETER ( NLEN    = 80 )        PARAMETER ( NLEN    = 80 )
# Line 70  C     !LOCAL VARIABLES: Line 82  C     !LOCAL VARIABLES:
82        CHARACTER*(NLEN) dn(CW_DIMS)        CHARACTER*(NLEN) dn(CW_DIMS)
83        CHARACTER*(NLEN) d_cw_name        CHARACTER*(NLEN) d_cw_name
84        CHARACTER*(NLEN) dn_blnk        CHARACTER*(NLEN) dn_blnk
85    #ifdef DIAG_MNC_COORD_NEEDSWORK
86          CHARACTER*(5) ctmp
87        _RS ztmp(Nr+Nrphys)        _RS ztmp(Nr+Nrphys)
88    #endif
89  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
90    
91  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
92    
93        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
94        undef = getcon('UNDEF')        undef = getcon('UNDEF')
       glf = globalFiles  
95        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
96        ilen = ILNBLNK(fnames(listnum))        ilen = ILNBLNK(fnames(listId))
97        WRITE( fn, '(A,A,A)' ) fnames(listnum)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)
98    
99  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
100        IF (useMNC .AND. diag_mnc) THEN        IF (useMNC .AND. diag_mnc) THEN
# Line 90  C---+----1----+----2----+----3----+----4 Line 104  C---+----1----+----2----+----3----+----4
104          DO i = 1,NLEN          DO i = 1,NLEN
105            dn_blnk(i:i) = ' '            dn_blnk(i:i) = ' '
106          ENDDO          ENDDO
107          WRITE( diag_mnc_bn, '(A)' ) fnames(listnum)(1:ilen)          WRITE( diag_mnc_bn, '(A)' ) fnames(listId)(1:ilen)
108    
109  C       Update the record dimension by writing the iteration number  C       Update the record dimension by writing the iteration number
110          CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)          CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
111          CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)          CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)
112          CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)          CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
113            CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)
114    
115    C       NOTE: at some point it would be a good idea to add a time_bounds
116    C       variable that has dimension (2,T) and clearly denotes the
117    C       beginning and ending times for each diagnostics period
118    
119          dn(1)(1:NLEN) = dn_blnk(1:NLEN)          dn(1)(1:NLEN) = dn_blnk(1:NLEN)
120          WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listnum)          WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listId)
121          dim(1) = nlevels(listnum)          dim(1) = nlevels(listId)
122          ib(1)  = 1          ib(1)  = 1
123          ie(1)  = nlevels(listnum)          ie(1)  = nlevels(listId)
124    
125          CALL MNC_CW_ADD_GNAME('diag_levels', 1,          CALL MNC_CW_ADD_GNAME('diag_levels', 1,
126       &       dim, dn, ib, ie, myThid)       &       dim, dn, ib, ie, myThid)
127          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
128       &       0,0, myThid)       &       0,0, myThid)
129          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
130       &       'Idicies of vertical levels within the source arrays',       &       'Idicies of vertical levels within the source arrays',
131       &       myThid)       &       myThid)
132            
133          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
134       &       'diag_levels', levs(1,listnum), myThid)       &       'diag_levels', levs(1,listId), myThid)
135    
136          CALL MNC_CW_DEL_VNAME('diag_levels', myThid)          CALL MNC_CW_DEL_VNAME('diag_levels', myThid)
137          CALL MNC_CW_DEL_GNAME('diag_levels', myThid)          CALL MNC_CW_DEL_GNAME('diag_levels', myThid)
138    
139    #ifdef DIAG_MNC_COORD_NEEDSWORK
140    C       This part has been placed in an #ifdef because, as its currently
141    C       written, it will only work with variables defined on a dynamics
142    C       grid.  As we start using diagnostics for physics grids, ice
143    C       levels, land levels, etc. the different vertical coordinate
144    C       dimensions will have to be taken into account.
145    
146    C       20051021 JMC & EH3 : We need to extend this so that a few
147    C       variables each defined on different grids do not have the same
148    C       vertical dimension names so we should be using a pattern such
149    C       as: Z[uml]td000000 where the 't' is the type as specified by
150    C       gdiag(10)
151    
152  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
153          ctmp(1:5) = 'mul  '          ctmp(1:5) = 'mul  '
154          DO i = 1,3          DO i = 1,3
155            dn(1)(1:NLEN) = dn_blnk(1:NLEN)            dn(1)(1:NLEN) = dn_blnk(1:NLEN)
156            WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listnum)            WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listId)
157            CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)            CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)
158            CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)            CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)
159    
160  C         The following three ztmp() loops should eventually be modified  C         The following three ztmp() loops should eventually be modified
161  C         to reflect the fractional nature of levs(j,l) -- they should  C         to reflect the fractional nature of levs(j,l) -- they should
162  C         do something like:  C         do something like:
163  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))
164  C                      + ( rC(INT(FLOOR(levs(j,l))))  C                      + ( rC(INT(FLOOR(levs(j,l))))
165  C                          + rC(INT(CEIL(levs(j,l)))) )  C                          + rC(INT(CEIL(levs(j,l)))) )
166  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )
167  C         for averaged levels.  C         for averaged levels.
168            IF (i .EQ. 1) THEN            IF (i .EQ. 1) THEN
169              DO j = 1,nlevels(listnum)              DO j = 1,nlevels(listId)
170                ztmp(j) = rC(NINT(levs(j,listnum)))                ztmp(j) = rC(NINT(levs(j,listId)))
171              ENDDO              ENDDO
172              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
173       &           'Dimensional coordinate value at the mid point',       &           'Dimensional coordinate value at the mid point',
174       &           myThid)       &           myThid)
175            ELSEIF (i .EQ. 2) THEN            ELSEIF (i .EQ. 2) THEN
176              DO j = 1,nlevels(listnum)              DO j = 1,nlevels(listId)
177                ztmp(j) = rF(NINT(levs(j,listnum)) + 1)                ztmp(j) = rF(NINT(levs(j,listId)) + 1)
178              ENDDO              ENDDO
179              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
180       &           'Dimensional coordinate value at the upper point',       &           'Dimensional coordinate value at the upper point',
181       &           myThid)       &           myThid)
182            ELSEIF (i .EQ. 3) THEN            ELSEIF (i .EQ. 3) THEN
183              DO j = 1,nlevels(listnum)              DO j = 1,nlevels(listId)
184                ztmp(j) = rF(NINT(levs(j,listnum)))                ztmp(j) = rF(NINT(levs(j,listId)))
185              ENDDO              ENDDO
186              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
187       &           'Dimensional coordinate value at the lower point',       &           'Dimensional coordinate value at the lower point',
# Line 159  C         for averaged levels. Line 191  C         for averaged levels.
191            CALL MNC_CW_DEL_VNAME(dn(1), myThid)            CALL MNC_CW_DEL_VNAME(dn(1), myThid)
192            CALL MNC_CW_DEL_GNAME(dn(1), myThid)            CALL MNC_CW_DEL_GNAME(dn(1), myThid)
193          ENDDO          ENDDO
194    #endif /*  DIAG_MNC_COORD_NEEDSWORK  */
195    
196        ENDIF        ENDIF
197  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
198    
199        DO n = 1,nfields(listnum)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
200          m = jdiag(n,listnum)  
201          parms1 = gdiag(m)(1:8)        DO md = 1,nfields(listId)
202          IF ( idiag(m).NE.0 .AND. parms1(5:5).NE.'D' ) THEN          ndId = jdiag(md,listId)
203            parms1 = gdiag(ndId)(1:8)
204            mate = 0
205            mVec = 0
206            IF ( parms1(5:5).EQ.'C' ) THEN
207    C-      Check for Mate of a Counter Diagnostic
208               READ(parms1,'(5X,I3)') mate
209            ELSEIF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN
210    C-      Check for Mate of a Vector Diagnostic
211               READ(parms1,'(5X,I3)') mVec
212            ENDIF
213            IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN
214  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
215             DO lm=1,averageCycle(listId)
216    
217              ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
218              im = mdiag(md,listId)
219              IF (mate.GT.0) im = im + kdiag(mate)*(lm-1)
220              IF (mVec.GT.0) im = im + kdiag(mVec)*(lm-1)
221    
222            IF ( ndiag(m).EQ.0 ) THEN            IF ( ndiag(ip,1,1).EQ.0 ) THEN
223  C-        Empty diagnostics case :  C-        Empty diagnostics case :
224    
225              _BEGIN_MASTER( myThid )              _BEGIN_MASTER( myThid )
226              WRITE(msgBuf,'(A,I10)')              WRITE(msgBuf,'(A,I10)')
227       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
228              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
229       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
230              WRITE(msgBuf,'(A,I4,3A,I3,2A)')              WRITE(msgBuf,'(A,I4,3A,I3,2A)')
231       &       '- WARNING -   diag.#',m, ' : ',flds(n,listnum),       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),
232       &       ' (#',n,' ) in outp.Stream: ',fnames(listnum)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
233              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
234       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
235              WRITE(msgBuf,'(A,I2,A)')              IF ( averageCycle(listId).GT.1 ) THEN
236       &       '- WARNING -   has not been filled (ndiag=',ndiag(m),' )'               WRITE(msgBuf,'(A,2(I2,A))')
237              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
238         &                                            ndiag(ip,1,1), ' )'
239                ELSE
240                 WRITE(msgBuf,'(A,2(I2,A))')
241         &        '- WARNING -   has not been filled (ndiag=',
242         &                                            ndiag(ip,1,1), ' )'
243                ENDIF
244                CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
245       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
246              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(A)')
247       &       'WARNING DIAGNOSTICS_OUT  => write ZEROS instead'       &       'WARNING DIAGNOSTICS_OUT  => write ZEROS instead'
248              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
249       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
250              _END_MASTER( myThid )              _END_MASTER( myThid )
251              DO bj = myByLo(myThid), myByHi(myThid)              DO bj = myByLo(myThid), myByHi(myThid)
252                DO bi = myBxLo(myThid), myBxHi(myThid)                DO bi = myBxLo(myThid), myBxHi(myThid)
253                  DO k = 1,nlevels(listnum)                  DO k = 1,nlevels(listId)
254                    DO j = 1-OLy,sNy+OLy                    DO j = 1-OLy,sNy+OLy
255                      DO i = 1-OLx,sNx+OLx                      DO i = 1-OLx,sNx+OLx
256                        qtmp1(i,j,k,bi,bj) = 0. _d 0                        qtmp1(i,j,k,bi,bj) = 0. _d 0
# Line 206  C-        Empty diagnostics case : Line 263  C-        Empty diagnostics case :
263            ELSE            ELSE
264  C-        diagnostics is not empty :  C-        diagnostics is not empty :
265    
266              IF ( myThid.EQ.1 )              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN
267       &             WRITE(ioUnit,2000) m,cdiag(m),ndiag(m),gdiag(m)                WRITE(ioUnit,'(A,I3,3A,I8,2A)')
268         &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
269              IF ( parms1(5:5).EQ.'C' ) THEN       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
270  C             Check for Mate of a Counter Diagnostic                IF ( mate.GT.0 ) THEN
271  C             --------------------------------------                 WRITE(ioUnit,'(3A,I3,2A)')
272                mate_index = parms1(6:8)       &         '       use Counter Mate for  ', cdiag(ndId),
273                READ (mate_index,'(I3)') mate       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
274                IF ( myThid.EQ.1 )                ELSEIF ( mVec.GT.0 ) THEN
275       &                 WRITE(ioUnit,2003) cdiag(m),mate,cdiag(mate)                  IF ( im.GT.0 .AND. ndiag(MAX(1,im),1,1).GT.0 ) THEN
276              ELSE                   WRITE(ioUnit,'(3A,I3,3A)')
277                mate = 0       &             '           Vector  Mate for  ', cdiag(ndId),
278         &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
279  C             Check for Mate of a Vector Diagnostic       &             ' exists '
 C             -------------------------------------  
               IF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN  
                 mate_index = parms1(6:8)  
                 READ (mate_index,'(I3)') mVec  
                 IF ( idiag(mVec).NE.0 ) THEN  
                   IF ( myThid.EQ.1 )  
      &                 WRITE(ioUnit,2001) cdiag(m),mVec,cdiag(mVec)  
280                  ELSE                  ELSE
281                    IF ( myThid.EQ.1 )                   WRITE(ioUnit,'(3A,I3,3A)')
282       &                 WRITE(ioUnit,2002) cdiag(m),mVec,cdiag(mVec)       &             '           Vector  Mate for  ', cdiag(ndId),
283         &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
284         &             ' not enabled'
285                  ENDIF                  ENDIF
286                ENDIF                ENDIF
287              ENDIF              ENDIF
288    
289              DO bj = myByLo(myThid), myByHi(myThid)              DO bj = myByLo(myThid), myByHi(myThid)
290               DO bi = myBxLo(myThid), myBxHi(myThid)               DO bi = myBxLo(myThid), myBxHi(myThid)
291                DO k = 1,nlevels(listnum)                DO k = 1,nlevels(listId)
292                  CALL GETDIAG(                  CALL GETDIAG(
293       I                       levs(k,listnum),undef,       I                       levs(k,listId),undef,
294       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),
295       I                       m,mate,bi,bj,myThid)       I                       ndId,mate,ip,im,bi,bj,myThid)
296                ENDDO                ENDDO
297               ENDDO               ENDDO
298              ENDDO              ENDDO
# Line 248  C             -------------------------- Line 300  C             --------------------------
300  C-        end of empty diag / not empty block  C-        end of empty diag / not empty block
301            ENDIF            ENDIF
302    
303              nlevsout = nlevels(listId)
304    
305    C-----------------------------------------------------------------------
306    C         Check to see if we need to interpolate before output
307    C-----------------------------------------------------------------------
308              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
309    C-        Do vertical interpolation:
310    c          IF ( fluidIsAir ) THEN
311    C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
312    C      find some problems with 5-levels AIM => use it only with FIZHI
313               IF ( useFIZHI ) THEN
314                CALL DIAGNOSTICS_INTERP_VERT(
315         I                     listId, md, ndId, ip, im,
316         U                     nlevsout,
317         U                     qtmp1,
318         I                     undef,
319         I                     myTime, myIter, myThid )
320               ELSE
321                 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
322         &         'INTERP_VERT not safe in this config'
323                 CALL PRINT_ERROR( msgBuf , myThid )
324                 WRITE(msgBuf,'(2A,I3,2A)') 'DIAGNOSTICS_OUT: ',
325         &         ' for list l=', listId, ', filename: ', fnames(listId)
326                 CALL PRINT_ERROR( msgBuf , myThid )
327                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
328               ENDIF
329              ENDIF
330    
331  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
332  C         Prepare for mdsio optionality  C         Prepare for mdsio optionality
333            IF (diag_mdsio) THEN            IF (diag_mdsio) THEN
334              IF (fflags(listnum)(1:1) .EQ. ' ') THEN              glf = globalFiles
335  C             This is the old default behavior              nRec = lm + (md-1)*averageCycle(listId)
336                CALL mdswritefield_new(fn,writeBinaryPrec,glf,'RL',              IF (fflags(listId)(1:1) .EQ. 'R') THEN
      &             Nr+Nrphys,nlevels(listnum),qtmp1,n,myIter,myThid)  
             ELSEIF (fflags(listnum)(1:1) .EQ. 'R') THEN  
337  C             Force it to be 32-bit precision  C             Force it to be 32-bit precision
338                CALL mdswritefield_new(fn,precFloat32,glf,'RL',                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,
339       &             Nr+Nrphys,nlevels(listnum),qtmp1,n,myIter,myThid)       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)
340              ELSEIF (fflags(listnum)(1:1) .EQ. 'D') THEN              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN
341  C             Force it to be 64-bit precision  C             Force it to be 64-bit precision
342                CALL mdswritefield_new(fn,precFloat64,glf,'RL',                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,
343       &             Nr+Nrphys,nlevels(listnum),qtmp1,n,myIter,myThid)       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)
344                ELSE
345    C             This is the old default behavior
346                  CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,
347         &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)
348              ENDIF              ENDIF
349            ENDIF            ENDIF
350  #endif /*  ALLOW_MDSIO  */  #endif /*  ALLOW_MDSIO  */
# Line 282  C           subtlety within MNC.  Basica Line 364  C           subtlety within MNC.  Basica
364  C           caching its own concept of what each "grid name" (that is, a  C           caching its own concept of what each "grid name" (that is, a
365  C           dimension group name) means.  So one cannot re-use the same  C           dimension group name) means.  So one cannot re-use the same
366  C           "grid" name for different collections of dimensions within a  C           "grid" name for different collections of dimensions within a
367  C           given file.  By appending the "m" values to each name, we  C           given file.  By appending the "ndId" values to each name, we
368  C           guarantee uniqueness within each MNC-produced file.  C           guarantee uniqueness within each MNC-produced file.
369              WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',m              WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',ndId
370    
371  C           XY dimensions  C           XY dimensions
372              dim(1)       = sNx + 2*OLx              dim(1)       = sNx + 2*OLx
373              dim(2)       = sNy + 2*OLy              dim(2)       = sNy + 2*OLy
374              ib(1)        = OLx + 1              ib(1)        = OLx + 1
375              ib(2)        = OLy + 1              ib(2)        = OLy + 1
376              IF (gdiag(m)(2:2) .EQ. 'M') THEN              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN
377                dn(1)(1:2) = 'X'                dn(1)(1:2) = 'X'
378                ie(1)      = OLx + sNx                ie(1)      = OLx + sNx
379                dn(2)(1:2) = 'Y'                dn(2)(1:2) = 'Y'
380                ie(2)      = OLy + sNy                ie(2)      = OLy + sNy
381              ELSEIF (gdiag(m)(2:2) .EQ. 'U') THEN              ELSEIF (gdiag(ndId)(2:2) .EQ. 'U') THEN
382                dn(1)(1:3) = 'Xp1'                dn(1)(1:3) = 'Xp1'
383                ie(1)      = OLx + sNx + 1                ie(1)      = OLx + sNx + 1
384                dn(2)(1:2) = 'Y'                dn(2)(1:2) = 'Y'
385                ie(2)      = OLy + sNy                ie(2)      = OLy + sNy
386              ELSEIF (gdiag(m)(2:2) .EQ. 'V') THEN              ELSEIF (gdiag(ndId)(2:2) .EQ. 'V') THEN
387                dn(1)(1:2) = 'X'                dn(1)(1:2) = 'X'
388                ie(1)      = OLx + sNx                ie(1)      = OLx + sNx
389                dn(2)(1:3) = 'Yp1'                dn(2)(1:3) = 'Yp1'
390                ie(2)      = OLy + sNy + 1                ie(2)      = OLy + sNy + 1
391              ELSEIF (gdiag(m)(2:2) .EQ. 'Z') THEN              ELSEIF (gdiag(ndId)(2:2) .EQ. 'Z') THEN
392                dn(1)(1:3) = 'Xp1'                dn(1)(1:3) = 'Xp1'
393                ie(1)      = OLx + sNx + 1                ie(1)      = OLx + sNx + 1
394                dn(2)(1:3) = 'Yp1'                dn(2)(1:3) = 'Yp1'
395                ie(2)      = OLy + sNy + 1                ie(2)      = OLy + sNy + 1
396              ENDIF              ENDIF
397                
398  C           Z is special since it varies  C           Z is special since it varies
399              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listnum)              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout
400              IF ( (gdiag(m)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
401       &           .AND. (gdiag(m)(9:9) .EQ. 'M') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
402                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevels(listnum)                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevsout
403              ENDIF              ENDIF
404              IF ( (gdiag(m)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
405       &           .AND. (gdiag(m)(9:9) .EQ. 'L') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
406                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listnum)                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevsout
407              ENDIF              ENDIF
408              IF ( (gdiag(m)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
409       &           .AND. (gdiag(m)(9:9) .EQ. 'U') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
410                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listnum)                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevsout
411              ENDIF              ENDIF
412              dim(3) = Nr+Nrphys              dim(3) = Nr+Nrphys
413              ib(3)  = 1              ib(3)  = 1
414              ie(3)  = nlevels(listnum)              ie(3)  = nlevsout
415    
416  C           Time dimension  C           Time dimension
417              dn(4)(1:1) = 'T'              dn(4)(1:1) = 'T'
# Line 337  C           Time dimension Line 419  C           Time dimension
419              ib(4)  = 1              ib(4)  = 1
420              ie(4)  = 1              ie(4)  = 1
421    
422              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
423       &             dim, dn, ib, ie, myThid)       &             dim, dn, ib, ie, myThid)
424              CALL MNC_CW_ADD_VNAME(cdiag(m), d_cw_name,              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,
425       &             4,5, myThid)       &             4,5, myThid)
426              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(m),'description',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',
427       &             tdiag(m),myThid)       &             tdiag(ndId),myThid)
428              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(m),'units',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
429       &             udiag(m),myThid)       &             udiag(ndId),myThid)
430    
431              IF ((fflags(listnum)(1:1) .EQ. ' ')  C           Per the observations of Baylor, this has been commented out
432       &           .OR. (fflags(listnum)(1:1) .EQ. 'R')) THEN  C           until we have code that can write missing_value attributes
433    C           in a way thats compatible with most of the more popular
434    C           netCDF tools including ferret.  Using all-zeros completely
435    C           breaks ferret.
436    
437    C           CALL MNC_CW_ADD_VATTR_DBL(cdiag(ndId),'missing_value',
438    C           &             0.0 _d 0,myThid)
439    
440                IF ( ( (writeBinaryPrec .EQ. precFloat32)
441         &           .AND. (fflags(listId)(1:1) .NE. 'D')
442         &           .AND. (fflags(listId)(1:1) .NE. 'R') )
443         &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN
444                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
445       &             cdiag(m), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
446              ELSEIF (fflags(listnum)(1:1) .EQ. 'D') THEN              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
447         &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN
448                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
449       &             cdiag(m), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
450              ENDIF              ENDIF
451                
452              CALL MNC_CW_DEL_VNAME(cdiag(m), myThid)              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)
453              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
454    
455              _END_MASTER( myThid )              _END_MASTER( myThid )
# Line 363  C           Time dimension Line 457  C           Time dimension
457            ENDIF            ENDIF
458  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
459    
460  C--     end of Processing Fld # n           ENDDO
461    C--     end of Processing Fld # md
462          ENDIF          ENDIF
463        ENDDO        ENDDO
464    
465   2000 format(1x,'Computing Diagnostic # ',i3,2x,a8,5x,        RETURN
      &     'Counter:',i8,3x,'Parms: ',a16)  
  2001 format(1x,'          Vector  Mate for  ',a8,5x,  
      &     'Diagnostic # ',i3,2x,a8,' exists ')  
  2002 format(1x,'          Vector  Mate for  ',a8,5x,  
      &     'Diagnostic # ',i3,2x,a8,' not enabled')  
  2003 format(1x,'      use Counter Mate for  ',a8,5x,  
      &     'Diagnostic # ',i3,2x,a8)  
         
       RETURN  
466        END        END
467                                                                        
468  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.29
  ViewVC Help
Powered by ViewVC 1.1.22