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