/[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.27 by edhill, Mon Feb 6 21:20:23 2006 UTC revision 1.39 by mlosch, Tue May 27 08:37:19 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          LOGICAL useMissingValue, useMisValForThisDiag
92          REAL*8 misvalLoc
93          REAL*8 misval_r8(2)
94          REAL*4 misval_r4(2)
95          INTEGER misvalIntLoc, misval_int(2)
96  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
97    
98  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
99    
100        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
101        undef = getcon('UNDEF')        undef = getcon('UNDEF')
       glf = globalFiles  
102        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
103        ilen = ILNBLNK(fnames(listId))        ilen = ILNBLNK(fnames(listId))
104        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)
105    
106  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
107        IF (useMNC .AND. diag_mnc) THEN        IF (useMNC .AND. diag_mnc) THEN
108    C     Handle missing value attribute (land points)
109           useMissingValue = .FALSE.
110    #ifdef DIAGNOSTICS_MISSING_VALUE
111           useMissingValue = .TRUE.
112    #endif /* DIAGNOSTICS_MISSING_VALUE */
113           IF ( misvalFlt(listId) .NE. UNSET_RL ) THEN
114            misvalLoc = misvalFlt(listId)
115           ELSE
116            misvalLoc = undef
117           ENDIF
118    C     Defaults to UNSET_I
119           misvalIntLoc = misvalInt(listId)
120           DO ii=1,2
121    C       misval_r4(ii)  = UNSET_FLOAT4
122    C       misval_r8(ii)  = UNSET_FLOAT8
123            misval_r4(ii)  = misvalLoc
124            misval_r8(ii)  = misvalLoc
125            misval_int(ii) = UNSET_I
126           ENDDO
127          DO i = 1,MAX_LEN_FNAM          DO i = 1,MAX_LEN_FNAM
128            diag_mnc_bn(i:i) = ' '            diag_mnc_bn(i:i) = ' '
129          ENDDO          ENDDO
# Line 120  C       beginning and ending times for e Line 148  C       beginning and ending times for e
148          ib(1)  = 1          ib(1)  = 1
149          ie(1)  = nlevels(listId)          ie(1)  = nlevels(listId)
150    
151          CALL MNC_CW_ADD_GNAME('diag_levels', 1,          CALL MNC_CW_ADD_GNAME('diag_levels', 1,
152       &       dim, dn, ib, ie, myThid)       &       dim, dn, ib, ie, myThid)
153          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
154       &       0,0, myThid)       &       0,0, myThid)
155          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
156       &       'Idicies of vertical levels within the source arrays',       &       'Idicies of vertical levels within the source arrays',
157       &       myThid)       &       myThid)
158            C     suppress the missing value attribute (iflag = 0)
159            IF (useMissingValue)
160         &       CALL MNC_CW_VATTR_MISSING('diag_levels', 0,
161         I       misval_r8, misval_r4, misval_int,
162         I       myThid )
163    
164          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
165       &       'diag_levels', levs(1,listId), myThid)       &       'diag_levels', levs(1,listId), myThid)
166    
# Line 158  C       Now define:  Zmdxxxxxx, Zudxxxxx Line 191  C       Now define:  Zmdxxxxxx, Zudxxxxx
191  C         The following three ztmp() loops should eventually be modified  C         The following three ztmp() loops should eventually be modified
192  C         to reflect the fractional nature of levs(j,l) -- they should  C         to reflect the fractional nature of levs(j,l) -- they should
193  C         do something like:  C         do something like:
194  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))
195  C                      + ( rC(INT(FLOOR(levs(j,l))))  C                      + ( rC(INT(FLOOR(levs(j,l))))
196  C                          + rC(INT(CEIL(levs(j,l)))) )  C                          + rC(INT(CEIL(levs(j,l)))) )
197  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )
198  C         for averaged levels.  C         for averaged levels.
# Line 185  C         for averaged levels. Line 218  C         for averaged levels.
218       &           'Dimensional coordinate value at the lower point',       &           'Dimensional coordinate value at the lower point',
219       &           myThid)       &           myThid)
220            ENDIF            ENDIF
221    C     suppress the missing value attribute (iflag = 0)
222              IF (useMissingValue)
223         &         CALL MNC_CW_VATTR_MISSING(dn(1), 0,
224         I         misval_r8, misval_r4, misval_int,
225         I         myThid )
226            CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)            CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)
227            CALL MNC_CW_DEL_VNAME(dn(1), myThid)            CALL MNC_CW_DEL_VNAME(dn(1), myThid)
228            CALL MNC_CW_DEL_GNAME(dn(1), myThid)            CALL MNC_CW_DEL_GNAME(dn(1), myThid)
# Line 194  C         for averaged levels. Line 232  C         for averaged levels.
232        ENDIF        ENDIF
233  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
234    
235    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
236    
237        DO md = 1,nfields(listId)        DO md = 1,nfields(listId)
238          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
239          parms1 = gdiag(ndId)(1:8)          gcode = gdiag(ndId)(1:10)
240          IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN          mate = 0
241            mVec = 0
242            IF ( gcode(5:5).EQ.'C' ) THEN
243    C-      Check for Mate of a Counter Diagnostic
244               mate = hdiag(ndId)
245            ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN
246    C-      Check for Mate of a Vector Diagnostic
247               mVec = hdiag(ndId)
248            ENDIF
249            IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN
250  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
251             DO lm=1,averageCycle(listId)
252    
253            ip = ABS(idiag(md,listId))            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
254            im = mdiag(md,listId)            im = mdiag(md,listId)
255              IF (mate.GT.0) im = im + kdiag(mate)*(lm-1)
256              IF (mVec.GT.0) im = im + kdiag(mVec)*(lm-1)
257    
258            IF ( ndiag(ip,1,1).EQ.0 ) THEN            IF ( ndiag(ip,1,1).EQ.0 ) THEN
259  C-        Empty diagnostics case :  C-        Empty diagnostics case :
260    
# Line 210  C-        Empty diagnostics case : Line 263  C-        Empty diagnostics case :
263       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
264              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
265       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
266              WRITE(msgBuf,'(A,I4,3A,I3,2A)')              WRITE(msgBuf,'(A,I6,3A,I4,2A)')
267       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),
268       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
269              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
270       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
271              WRITE(msgBuf,'(A,I2,A)')              IF ( averageCycle(listId).GT.1 ) THEN
272       &       '- WARNING -   has not been filled (ndiag=',               WRITE(msgBuf,'(A,2(I3,A))')
273       &       ndiag(ip,1,1), ' )'       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
274         &                                            ndiag(ip,1,1), ' )'
275                ELSE
276                 WRITE(msgBuf,'(A,2(I3,A))')
277         &        '- WARNING -   has not been filled (ndiag=',
278         &                                            ndiag(ip,1,1), ' )'
279                ENDIF
280              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
281       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
282              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(A)')
# Line 240  C-        Empty diagnostics case : Line 299  C-        Empty diagnostics case :
299            ELSE            ELSE
300  C-        diagnostics is not empty :  C-        diagnostics is not empty :
301    
302              IF ( myThid.EQ.1 ) WRITE(ioUnit,'(A,I3,3A,I8,2A)')              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN
303                  WRITE(ioUnit,'(A,I6,3A,I8,2A)')
304       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
305       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
306                  IF ( mate.GT.0 ) THEN
307              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)')  
308       &         '       use Counter Mate for  ', cdiag(ndId),       &         '       use Counter Mate for  ', cdiag(ndId),
309       &         '     Diagnostic # ',mate, '  ', cdiag(mate)       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
310                  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  
311                  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
312                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
313       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
314       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
315       &             ' exists '       &             ' exists '
316                  ELSE                  ELSE
317                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
318       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
319       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
320       &             ' not enabled'       &             ' not enabled'
# Line 275  C             -------------------------- Line 322  C             --------------------------
322                ENDIF                ENDIF
323              ENDIF              ENDIF
324    
325              DO bj = myByLo(myThid), myByHi(myThid)              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
326               DO bi = myBxLo(myThid), myBxHi(myThid)  C-       get all the levels (for vertical interpolation)
327                DO k = 1,nlevels(listId)                DO bj = myByLo(myThid), myByHi(myThid)
328                  CALL GETDIAG(                 DO bi = myBxLo(myThid), myBxHi(myThid)
329       I                       levs(k,listId),undef,                  DO k = 1,kdiag(ndId)
330       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),                    tmpLev = k
331       I                       ndId,mate,ip,im,bi,bj,myThid)                    CALL GETDIAG(
332         I                         tmpLev,undef,
333         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
334         I                         ndId,mate,ip,im,bi,bj,myThid)
335                    ENDDO
336                   ENDDO
337                ENDDO                ENDDO
338               ENDDO              ELSE
339              ENDDO  C-       get only selected levels:
340                  DO bj = myByLo(myThid), myByHi(myThid)
341                   DO bi = myBxLo(myThid), myBxHi(myThid)
342                    DO k = 1,nlevels(listId)
343                      CALL GETDIAG(
344         I                         levs(k,listId),undef,
345         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
346         I                         ndId,mate,ip,im,bi,bj,myThid)
347                    ENDDO
348                   ENDDO
349                  ENDDO
350                ENDIF
351    
352  C-        end of empty diag / not empty block  C-        end of empty diag / not empty block
353            ENDIF            ENDIF
354    
           nlevsout = nlevels(listId)  
   
355  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
356  C         Check to see if we need to interpolate before output  C         Check to see if we need to interpolate before output
357  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
358           IF ( fflags(listId)(2:2).EQ.'P' ) THEN            IF ( fflags(listId)(2:2).EQ.'P' ) THEN
359  C-        Do vertical interpolation:  C-        Do vertical interpolation:
360            CALL DIAGNOSTICS_INTERP_VERT(             IF ( fluidIsAir ) THEN
361       I                     listId, md, ndId, ip, im,  C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
362       U                     nlevsout,              CALL DIAGNOSTICS_INTERP_VERT(
363         I                     listId, md, ndId, ip, im, lm,
364       U                     qtmp1,       U                     qtmp1,
365       I                     undef,       I                     undef, myTime, myIter, myThid )
366       I                     myTime, myIter, myThid )             ELSE
367           ENDIF               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
368         &         'INTERP_VERT not allowed in this config'
369                 CALL PRINT_ERROR( msgBuf , myThid )
370                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
371               ENDIF
372              ENDIF
373    
374  #ifdef ALLOW_MDSIO  C--    Ready to write field "md", element "lm" in averageCycle(listId)
375  C         Prepare for mdsio optionality  
376            IF (diag_mdsio) THEN  C-        write to binary file, using MDSIO pkg:
377              IF (fflags(listId)(1:1) .EQ. 'R') THEN            IF ( diag_mdsio ) THEN
378  C             Force it to be 32-bit precision              nRec = lm + (md-1)*averageCycle(listId)
379                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,  C           default precision for output files
380       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)              prec = writeBinaryPrec
381              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN  C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
382  C             Force it to be 64-bit precision              IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
383                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,              IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
384       &             '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
385              ELSE              CALL WRITE_REC_LEV_RL(
386  C             This is the old default behavior       I                            fn, prec,
387                CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,       I                            NrMax, 1, nlevels(listId),
388       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)       I                            qtmp1, -nRec, myIter, myThid )
             ENDIF  
389            ENDIF            ENDIF
 #endif /*  ALLOW_MDSIO  */  
390    
391  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
392            IF (useMNC .AND. diag_mnc) THEN            IF (useMNC .AND. diag_mnc) THEN
# Line 347  C           XY dimensions Line 412  C           XY dimensions
412              dim(2)       = sNy + 2*OLy              dim(2)       = sNy + 2*OLy
413              ib(1)        = OLx + 1              ib(1)        = OLx + 1
414              ib(2)        = OLy + 1              ib(2)        = OLy + 1
415              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN
416                dn(1)(1:2) = 'X'                dn(1)(1:2) = 'X'
417                ie(1)      = OLx + sNx                ie(1)      = OLx + sNx
418                dn(2)(1:2) = 'Y'                dn(2)(1:2) = 'Y'
# Line 368  C           XY dimensions Line 433  C           XY dimensions
433                dn(2)(1:3) = 'Yp1'                dn(2)(1:3) = 'Yp1'
434                ie(2)      = OLy + sNy + 1                ie(2)      = OLy + sNy + 1
435              ENDIF              ENDIF
436                
437  C           Z is special since it varies  C           Z is special since it varies
438              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)
439              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
440       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
441                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevels(listId)
442              ENDIF              ENDIF
443              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
444       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
445                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listId)
446              ENDIF              ENDIF
447              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
448       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
449                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)
450              ENDIF              ENDIF
451              dim(3) = Nr+Nrphys              dim(3) = NrMax
452              ib(3)  = 1              ib(3)  = 1
453              ie(3)  = nlevsout              ie(3)  = nlevels(listId)
454    
455  C           Time dimension  C           Time dimension
456              dn(4)(1:1) = 'T'              dn(4)(1:1) = 'T'
# Line 393  C           Time dimension Line 458  C           Time dimension
458              ib(4)  = 1              ib(4)  = 1
459              ie(4)  = 1              ie(4)  = 1
460    
461              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
462       &             dim, dn, ib, ie, myThid)       &             dim, dn, ib, ie, myThid)
463              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,
464       &             4,5, myThid)       &             4,5, myThid)
465              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',
466       &             tdiag(ndId),myThid)       &             tdiag(ndId),myThid)
467              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
468       &             udiag(ndId),myThid)       &             udiag(ndId),myThid)
469              CALL MNC_CW_ADD_VATTR_DBL(cdiag(ndId),'missing_value',  
470       &             0.0 _d 0,myThid)  C     Missing values only for scalar diagnostics at mass points (so far)
471                useMisValForThisDiag = useMissingValue
472         &           .AND.gdiag(ndId)(1:2).EQ.'SM'
473                IF ( useMisValForThisDiag ) THEN
474    C     assign missing values and set flag for adding the netCDF atttibute
475                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,
476         I            misval_r8, misval_r4, misval_int,
477         I            myThid )
478    C     and now use the missing values for masking out the land points
479                 DO bj = myByLo(myThid), myByHi(myThid)
480                  DO bi = myBxLo(myThid), myBxHi(myThid)
481                   DO k = 1,nlevels(listId)
482                    klev = NINT(levs(k,listId))
483                    DO j = 1-OLy,sNy+OLy
484                     DO i = 1-OLx,sNx+OLx
485                      IF ( _hFacC(I,J,klev,bi,bj) .EQ. 0. )
486         &                 qtmp1(i,j,k,bi,bj) = misvalLoc
487                     ENDDO
488                    ENDDO
489                   ENDDO
490                  ENDDO
491                 ENDDO
492                ELSE
493    C     suppress the missing value attribute (iflag = 0)
494    C     Note: We have to call the following subroutine for each mnc that has
495    C     been created "on the fly" by mnc_cw_add_vname and will be deleted
496    C     by mnc_cw_del_vname, because all of these variables use the same
497    C     identifier so that mnc_cw_vfmv(indv) needs to be overwritten for
498    C     each of these variables
499                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 0,
500         I            misval_r8, misval_r4, misval_int,
501         I            myThid )
502                ENDIF
503    
504              IF ( ( (writeBinaryPrec .EQ. precFloat32)              IF ( ( (writeBinaryPrec .EQ. precFloat32)
505       &           .AND. (fflags(listId)(1:1) .NE. 'D')       &           .AND. (fflags(listId)(1:1) .NE. 'D')
# Line 410  C           Time dimension Line 507  C           Time dimension
507       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN
508                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
509       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
510              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
511       &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN       &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN
512                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
513       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
514              ENDIF              ENDIF
515                
516              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)
517              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
518    
# Line 424  C           Time dimension Line 521  C           Time dimension
521            ENDIF            ENDIF
522  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
523    
524             ENDDO
525  C--     end of Processing Fld # md  C--     end of Processing Fld # md
526          ENDIF          ENDIF
527        ENDDO        ENDDO
528    
529    #ifdef ALLOW_MDSIO
530          IF (diag_mdsio) THEN
531    C-    Note: temporary: since it's a pain to add more arguments to
532    C     all MDSIO S/R, uses instead this specific S/R to write only
533    C     meta files but with more informations in it.
534                glf = globalFiles
535                nRec = nfields(listId)*averageCycle(listId)
536                CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
537         &              0, 0, nlevels(listId), ' ',
538         &              nfields(listId), flds(1,listId), 1, myTime,
539         &              nRec, myIter, myThid)
540          ENDIF
541    #endif /*  ALLOW_MDSIO  */
542    
543        RETURN        RETURN
544        END        END
545    
Legend:
Removed from v.1.27  
changed lines
  Added in v.1.39
  ViewVC Help
Powered by ViewVC 1.1.22