/[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.26 by edhill, Thu Jan 26 04:15:05 2006 UTC revision 1.37 by mlosch, Thu May 22 08:35:44 2008 UTC
# Line 26  C     !USES: Line 26  C     !USES:
26  #include "DIAGNOSTICS_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
27  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
28    
29  #ifdef ALLOW_FIZHI        INTEGER NrMax
30  #include "fizhi_SIZE.h"        PARAMETER( NrMax = numLevels )
 #else  
       INTEGER Nrphys  
       PARAMETER (Nrphys=0)  
 #endif  
   
31    
32  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
33  C     listId  :: Diagnostics list number being written  C     listId  :: Diagnostics list number being written
# Line 45  CEOP Line 40  CEOP
40    
41  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
42  C     i,j,k :: loop indices  C     i,j,k :: loop indices
43    C     lm    :: loop index (averageCycle)
44  C     md    :: field number in the list "listId".  C     md    :: field number in the list "listId".
45  C     ndId  :: diagnostics  Id number (in available diagnostics list)  C     ndId  :: diagnostics  Id number (in available diagnostics list)
46  C     mate  :: counter mate Id number (in available diagnostics list)  C     mate  :: counter mate Id number (in available diagnostics list)
47  C     ip    :: diagnostics  pointer to storage array  C     ip    :: diagnostics  pointer to storage array
48  C     im    :: counter-mate pointer to storage array  C     im    :: counter-mate pointer to storage array
49        INTEGER i, j, k  C
50    C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)
51    C     qtmp1 :: thread-shared temporary array (needs to be in common block):
52    C              to write a diagnostic field to file, copy it first from (big)
53    C              diagnostic storage qdiag into it.
54          COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1
55          _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
56    
57          INTEGER i, j, k, lm, klev
58        INTEGER bi, bj        INTEGER bi, bj
59        INTEGER md, ndId, ip, im        INTEGER md, ndId, ip, im
60        INTEGER mate, mVec        INTEGER mate, mVec
61        CHARACTER*8 parms1        CHARACTER*10 gcode
       CHARACTER*3 mate_index  
       _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)  
62        _RL undef, getcon        _RL undef, getcon
63          _RL tmpLev
64        EXTERNAL getcon        EXTERNAL getcon
65        INTEGER ILNBLNK        INTEGER ILNBLNK
66        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
67        INTEGER ilen        INTEGER ilen
       INTEGER nlevsout  
68    
69        INTEGER ioUnit        INTEGER ioUnit
70        CHARACTER*(MAX_LEN_FNAM) fn        CHARACTER*(MAX_LEN_FNAM) fn
71        CHARACTER*(MAX_LEN_MBUF) suff        CHARACTER*(MAX_LEN_MBUF) suff
72        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
73          INTEGER prec, nRec
74    #ifdef ALLOW_MDSIO
75        LOGICAL glf        LOGICAL glf
76    #endif
77  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
78        INTEGER ii        INTEGER ii
79        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
# Line 81  C     im    :: counter-mate pointer to s Line 86  C     im    :: counter-mate pointer to s
86        CHARACTER*(NLEN) dn_blnk        CHARACTER*(NLEN) dn_blnk
87  #ifdef DIAG_MNC_COORD_NEEDSWORK  #ifdef DIAG_MNC_COORD_NEEDSWORK
88        CHARACTER*(5) ctmp        CHARACTER*(5) ctmp
89        _RS ztmp(Nr+Nrphys)        _RS ztmp(NrMax)
90  #endif  #endif
91          REAL*8 misvalLoc
92          REAL*8 misval_r8(2)
93          REAL*4 misval_r4(2)
94          INTEGER misvalIntLoc, misval_int(2)
95  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
96    
97  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
98    
99        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
100        undef = getcon('UNDEF')        undef = getcon('UNDEF')
       glf = globalFiles  
101        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
102        ilen = ILNBLNK(fnames(listId))        ilen = ILNBLNK(fnames(listId))
103        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)
# Line 120  C       beginning and ending times for e Line 128  C       beginning and ending times for e
128          ib(1)  = 1          ib(1)  = 1
129          ie(1)  = nlevels(listId)          ie(1)  = nlevels(listId)
130    
131          CALL MNC_CW_ADD_GNAME('diag_levels', 1,          CALL MNC_CW_ADD_GNAME('diag_levels', 1,
132       &       dim, dn, ib, ie, myThid)       &       dim, dn, ib, ie, myThid)
133          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
134       &       0,0, myThid)       &       0,0, myThid)
135          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
136       &       'Idicies of vertical levels within the source arrays',       &       'Idicies of vertical levels within the source arrays',
137       &       myThid)       &       myThid)
138            
139          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
140       &       'diag_levels', levs(1,listId), myThid)       &       'diag_levels', levs(1,listId), myThid)
141    
# Line 158  C       Now define:  Zmdxxxxxx, Zudxxxxx Line 166  C       Now define:  Zmdxxxxxx, Zudxxxxx
166  C         The following three ztmp() loops should eventually be modified  C         The following three ztmp() loops should eventually be modified
167  C         to reflect the fractional nature of levs(j,l) -- they should  C         to reflect the fractional nature of levs(j,l) -- they should
168  C         do something like:  C         do something like:
169  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))
170  C                      + ( rC(INT(FLOOR(levs(j,l))))  C                      + ( rC(INT(FLOOR(levs(j,l))))
171  C                          + rC(INT(CEIL(levs(j,l)))) )  C                          + rC(INT(CEIL(levs(j,l)))) )
172  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )
173  C         for averaged levels.  C         for averaged levels.
# Line 194  C         for averaged levels. Line 202  C         for averaged levels.
202        ENDIF        ENDIF
203  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
204    
205    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
206    
207        DO md = 1,nfields(listId)        DO md = 1,nfields(listId)
208          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
209          parms1 = gdiag(ndId)(1:8)          gcode = gdiag(ndId)(1:10)
210          IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN          mate = 0
211            mVec = 0
212            IF ( gcode(5:5).EQ.'C' ) THEN
213    C-      Check for Mate of a Counter Diagnostic
214               mate = hdiag(ndId)
215            ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN
216    C-      Check for Mate of a Vector Diagnostic
217               mVec = hdiag(ndId)
218            ENDIF
219            IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN
220  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
221             DO lm=1,averageCycle(listId)
222    
223            ip = ABS(idiag(md,listId))            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
224            im = mdiag(md,listId)            im = mdiag(md,listId)
225              IF (mate.GT.0) im = im + kdiag(mate)*(lm-1)
226              IF (mVec.GT.0) im = im + kdiag(mVec)*(lm-1)
227    
228            IF ( ndiag(ip,1,1).EQ.0 ) THEN            IF ( ndiag(ip,1,1).EQ.0 ) THEN
229  C-        Empty diagnostics case :  C-        Empty diagnostics case :
230    
# Line 210  C-        Empty diagnostics case : Line 233  C-        Empty diagnostics case :
233       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
234              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
235       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
236              WRITE(msgBuf,'(A,I4,3A,I3,2A)')              WRITE(msgBuf,'(A,I6,3A,I4,2A)')
237       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),
238       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
239              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
240       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
241              WRITE(msgBuf,'(A,I2,A)')              IF ( averageCycle(listId).GT.1 ) THEN
242       &       '- WARNING -   has not been filled (ndiag=',               WRITE(msgBuf,'(A,2(I3,A))')
243       &       ndiag(ip,1,1), ' )'       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
244         &                                            ndiag(ip,1,1), ' )'
245                ELSE
246                 WRITE(msgBuf,'(A,2(I3,A))')
247         &        '- WARNING -   has not been filled (ndiag=',
248         &                                            ndiag(ip,1,1), ' )'
249                ENDIF
250              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
251       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
252              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(A)')
# Line 240  C-        Empty diagnostics case : Line 269  C-        Empty diagnostics case :
269            ELSE            ELSE
270  C-        diagnostics is not empty :  C-        diagnostics is not empty :
271    
272              IF ( myThid.EQ.1 ) WRITE(ioUnit,'(A,I3,3A,I8,2A)')              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN
273                  WRITE(ioUnit,'(A,I6,3A,I8,2A)')
274       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
275       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
276                  IF ( mate.GT.0 ) THEN
277              IF ( parms1(5:5).EQ.'C' ) THEN                 WRITE(ioUnit,'(3A,I6,2A)')
 C             Check for Mate of a Counter Diagnostic  
 C             --------------------------------------  
               mate_index = parms1(6:8)  
               READ (mate_index,'(I3)') mate  
               IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,2A)')  
278       &         '       use Counter Mate for  ', cdiag(ndId),       &         '       use Counter Mate for  ', cdiag(ndId),
279       &         '     Diagnostic # ',mate, '  ', cdiag(mate)       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
280                  ELSEIF ( mVec.GT.0 ) THEN
             ELSE  
               mate = 0  
   
 C             Check for Mate of a Vector Diagnostic  
 C             -------------------------------------  
               IF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN  
                 mate_index = parms1(6:8)  
                 READ (mate_index,'(I3)') mVec  
281                  IF ( im.GT.0 .AND. ndiag(MAX(1,im),1,1).GT.0 ) THEN                  IF ( im.GT.0 .AND. ndiag(MAX(1,im),1,1).GT.0 ) THEN
282                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
283       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
284       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
285       &             ' exists '       &             ' exists '
286                  ELSE                  ELSE
287                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
288       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
289       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
290       &             ' not enabled'       &             ' not enabled'
# Line 275  C             -------------------------- Line 292  C             --------------------------
292                ENDIF                ENDIF
293              ENDIF              ENDIF
294    
295              DO bj = myByLo(myThid), myByHi(myThid)              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
296               DO bi = myBxLo(myThid), myBxHi(myThid)  C-       get all the levels (for vertical interpolation)
297                DO k = 1,nlevels(listId)                DO bj = myByLo(myThid), myByHi(myThid)
298                  CALL GETDIAG(                 DO bi = myBxLo(myThid), myBxHi(myThid)
299       I                       levs(k,listId),undef,                  DO k = 1,kdiag(ndId)
300       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),                    tmpLev = k
301       I                       ndId,mate,ip,im,bi,bj,myThid)                    CALL GETDIAG(
302         I                         tmpLev,undef,
303         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
304         I                         ndId,mate,ip,im,bi,bj,myThid)
305                    ENDDO
306                   ENDDO
307                ENDDO                ENDDO
308               ENDDO              ELSE
309              ENDDO  C-       get only selected levels:
310                  DO bj = myByLo(myThid), myByHi(myThid)
311                   DO bi = myBxLo(myThid), myBxHi(myThid)
312                    DO k = 1,nlevels(listId)
313                      CALL GETDIAG(
314         I                         levs(k,listId),undef,
315         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
316         I                         ndId,mate,ip,im,bi,bj,myThid)
317                    ENDDO
318                   ENDDO
319                  ENDDO
320                ENDIF
321    
322  C-        end of empty diag / not empty block  C-        end of empty diag / not empty block
323            ENDIF            ENDIF
324    
           nlevsout = nlevels(listId)  
   
325  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
326  C         Check to see if we need to interpolate before output  C         Check to see if we need to interpolate before output
327  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
328           IF ( fflags(listId)(2:2).EQ.'P' ) THEN            IF ( fflags(listId)(2:2).EQ.'P' ) THEN
329  C-        Do vertical interpolation:  C-        Do vertical interpolation:
330            CALL DIAGNOSTICS_INTERP_VERT(             IF ( fluidIsAir ) THEN
331       I                     listId, md, ndId, ip, im,  C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
332       U                     nlevsout,              CALL DIAGNOSTICS_INTERP_VERT(
333         I                     listId, md, ndId, ip, im, lm,
334       U                     qtmp1,       U                     qtmp1,
335       I                     undef,       I                     undef, myTime, myIter, myThid )
336       I                     myTime, myIter, myThid )             ELSE
337           ENDIF               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
338         &         'INTERP_VERT not allowed in this config'
339                 CALL PRINT_ERROR( msgBuf , myThid )
340                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
341               ENDIF
342              ENDIF
343    
344  #ifdef ALLOW_MDSIO  C--    Ready to write field "md", element "lm" in averageCycle(listId)
345  C         Prepare for mdsio optionality  
346            IF (diag_mdsio) THEN  C-        write to binary file, using MDSIO pkg:
347              IF (fflags(listId)(1:1) .EQ. 'R') THEN            IF ( diag_mdsio ) THEN
348  C             Force it to be 32-bit precision              nRec = lm + (md-1)*averageCycle(listId)
349                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,  C           default precision for output files
350       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)              prec = writeBinaryPrec
351              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN  C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
352  C             Force it to be 64-bit precision              IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
353                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,              IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
354       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)  C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
355              ELSE              CALL WRITE_REC_LEV_RL(
356  C             This is the old default behavior       I                            fn, prec,
357                CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,       I                            NrMax, 1, nlevels(listId),
358       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)       I                            qtmp1, -nRec, myIter, myThid )
             ENDIF  
359            ENDIF            ENDIF
 #endif /*  ALLOW_MDSIO  */  
360    
361  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
362            IF (useMNC .AND. diag_mnc) THEN            IF (useMNC .AND. diag_mnc) THEN
# Line 347  C           XY dimensions Line 382  C           XY dimensions
382              dim(2)       = sNy + 2*OLy              dim(2)       = sNy + 2*OLy
383              ib(1)        = OLx + 1              ib(1)        = OLx + 1
384              ib(2)        = OLy + 1              ib(2)        = OLy + 1
385              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN
386                dn(1)(1:2) = 'X'                dn(1)(1:2) = 'X'
387                ie(1)      = OLx + sNx                ie(1)      = OLx + sNx
388                dn(2)(1:2) = 'Y'                dn(2)(1:2) = 'Y'
# Line 368  C           XY dimensions Line 403  C           XY dimensions
403                dn(2)(1:3) = 'Yp1'                dn(2)(1:3) = 'Yp1'
404                ie(2)      = OLy + sNy + 1                ie(2)      = OLy + sNy + 1
405              ENDIF              ENDIF
406                
407  C           Z is special since it varies  C           Z is special since it varies
408              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)
409              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
410       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
411                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevels(listId)
412              ENDIF              ENDIF
413              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
414       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
415                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listId)
416              ENDIF              ENDIF
417              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
418       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
419                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)
420              ENDIF              ENDIF
421              dim(3) = Nr+Nrphys              dim(3) = NrMax
422              ib(3)  = 1              ib(3)  = 1
423              ie(3)  = nlevsout              ie(3)  = nlevels(listId)
424    
425  C           Time dimension  C           Time dimension
426              dn(4)(1:1) = 'T'              dn(4)(1:1) = 'T'
# Line 393  C           Time dimension Line 428  C           Time dimension
428              ib(4)  = 1              ib(4)  = 1
429              ie(4)  = 1              ie(4)  = 1
430    
431              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
432       &             dim, dn, ib, ie, myThid)       &             dim, dn, ib, ie, myThid)
433              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,
434       &             4,5, myThid)       &             4,5, myThid)
435              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',
436       &             tdiag(ndId),myThid)       &             tdiag(ndId),myThid)
437              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
438       &             udiag(ndId),myThid)       &             udiag(ndId),myThid)
439    
440    C     Handle missing value attribute (land points)
441                IF ( misvalFlt(listId) .NE. UNSET_RL ) THEN
442                 misvalLoc = misvalFlt(listId)
443                ELSE
444                 misvalLoc = undef
445                ENDIF
446    C     Defaults to UNSET_I
447                misvalIntLoc = misvalInt(listId)
448                DO ii=1,2
449    C            misval_r4(ii)  = UNSET_FLOAT4
450    C            misval_r8(ii)  = UNSET_FLOAT8
451                 misval_r4(ii)  = misvalLoc
452                 misval_r8(ii)  = misvalLoc
453                 misval_int(ii) = UNSET_I
454                ENDDO
455    C     Missing values only for scalar diagnostics at mass points (so far)
456                IF ( gdiag(ndId)(1:2) .EQ. 'SM' ) THEN
457    C     assign missing values and set flag for adding the netCDF atttibute
458                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,
459         I            misval_r8, misval_r4, misval_int,
460         I            myThid )
461    C     and now use the missing values for masking out the land points
462                 DO bj = myByLo(myThid), myByHi(myThid)
463                  DO bi = myBxLo(myThid), myBxHi(myThid)
464                   DO k = 1,nlevels(listId)
465                    klev = NINT(levs(k,listId))
466                    DO j = 1-OLy,sNy+OLy
467                     DO i = 1-OLx,sNx+OLx
468                      IF ( _hFacC(I,J,klev,bi,bj) .EQ. 0. )
469         &                 qtmp1(i,j,k,bi,bj) = misvalLoc
470                     ENDDO
471                    ENDDO
472                   ENDDO
473                  ENDDO
474                 ENDDO
475                ELSE
476    C     suppress the missing value attribute (iflag = 0)
477    C     Note: I have no idea, why we have to do this here, but if we do not
478    C     do it, variables get the missing_value attribute (the one of the
479    C     previous varable) that are not supposed to get one. These is something
480    C     fishy with the flag array mnc_cw_vfmv.
481                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 0,
482         I            misval_r8, misval_r4, misval_int,
483         I            myThid )
484                ENDIF
485    
486              IF ( ( (writeBinaryPrec .EQ. precFloat32)              IF ( ( (writeBinaryPrec .EQ. precFloat32)
487       &           .AND. (fflags(listId)(1:1) .NE. 'D')       &           .AND. (fflags(listId)(1:1) .NE. 'D')
488       &           .AND. (fflags(listId)(1:1) .NE. 'R') )       &           .AND. (fflags(listId)(1:1) .NE. 'R') )
489       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN
490                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
491       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
492              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
493       &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN       &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN
494                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
495       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
496              ENDIF              ENDIF
497                
498              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)
499              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
500    
# Line 422  C           Time dimension Line 503  C           Time dimension
503            ENDIF            ENDIF
504  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
505    
506             ENDDO
507  C--     end of Processing Fld # md  C--     end of Processing Fld # md
508          ENDIF          ENDIF
509        ENDDO        ENDDO
510    
511    #ifdef ALLOW_MDSIO
512          IF (diag_mdsio) THEN
513    C-    Note: temporary: since it's a pain to add more arguments to
514    C     all MDSIO S/R, uses instead this specific S/R to write only
515    C     meta files but with more informations in it.
516                glf = globalFiles
517                nRec = nfields(listId)*averageCycle(listId)
518                CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
519         &              0, 0, nlevels(listId), ' ',
520         &              nfields(listId), flds(1,listId), 1, myTime,
521         &              nRec, myIter, myThid)
522          ENDIF
523    #endif /*  ALLOW_MDSIO  */
524    
525        RETURN        RETURN
526        END        END
527    
Legend:
Removed from v.1.26  
changed lines
  Added in v.1.37
  ViewVC Help
Powered by ViewVC 1.1.22