/[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.15 by jmc, Sun Jun 26 16:51:49 2005 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
# Line 67  C     im    :: counter-mate pointer to s Line 70  C     im    :: counter-mate pointer to s
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
       CHARACTER*(5) ctmp  
80        INTEGER CW_DIMS, NLEN        INTEGER CW_DIMS, NLEN
81        PARAMETER ( CW_DIMS = 10 )        PARAMETER ( CW_DIMS = 10 )
82        PARAMETER ( NLEN    = 80 )        PARAMETER ( NLEN    = 80 )
# Line 79  C     im    :: counter-mate pointer to s Line 84  C     im    :: counter-mate pointer to s
84        CHARACTER*(NLEN) dn(CW_DIMS)        CHARACTER*(NLEN) dn(CW_DIMS)
85        CHARACTER*(NLEN) d_cw_name        CHARACTER*(NLEN) d_cw_name
86        CHARACTER*(NLEN) dn_blnk        CHARACTER*(NLEN) dn_blnk
87        _RS ztmp(Nr+Nrphys)  #ifdef DIAG_MNC_COORD_NEEDSWORK
88          CHARACTER*(5) ctmp
89          _RS ztmp(NrMax)
90    #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 105  C       Update the record dimension by w Line 129  C       Update the record dimension by w
129          CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)          CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
130          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)
131          CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)          CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
132            CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)
133    
134    C       NOTE: at some point it would be a good idea to add a time_bounds
135    C       variable that has dimension (2,T) and clearly denotes the
136    C       beginning and ending times for each diagnostics period
137    
138          dn(1)(1:NLEN) = dn_blnk(1:NLEN)          dn(1)(1:NLEN) = dn_blnk(1:NLEN)
139          WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listId)          WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listId)
# Line 112  C       Update the record dimension by w Line 141  C       Update the record dimension by w
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    
160          CALL MNC_CW_DEL_VNAME('diag_levels', myThid)          CALL MNC_CW_DEL_VNAME('diag_levels', myThid)
161          CALL MNC_CW_DEL_GNAME('diag_levels', myThid)          CALL MNC_CW_DEL_GNAME('diag_levels', myThid)
162    
163    #ifdef DIAG_MNC_COORD_NEEDSWORK
164    C       This part has been placed in an #ifdef because, as its currently
165    C       written, it will only work with variables defined on a dynamics
166    C       grid.  As we start using diagnostics for physics grids, ice
167    C       levels, land levels, etc. the different vertical coordinate
168    C       dimensions will have to be taken into account.
169    
170    C       20051021 JMC & EH3 : We need to extend this so that a few
171    C       variables each defined on different grids do not have the same
172    C       vertical dimension names so we should be using a pattern such
173    C       as: Z[uml]td000000 where the 't' is the type as specified by
174    C       gdiag(10)
175    
176  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
177          ctmp(1:5) = 'mul  '          ctmp(1:5) = 'mul  '
178          DO i = 1,3          DO i = 1,3
# Line 137  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 164  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)
222          ENDDO          ENDDO
223    #endif /*  DIAG_MNC_COORD_NEEDSWORK  */
224    
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 188  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 218  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 253  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    
348  #ifdef ALLOW_MDSIO  C-----------------------------------------------------------------------
349  C         Prepare for mdsio optionality  C         Check to see if we need to interpolate before output
350            IF (diag_mdsio) THEN  C-----------------------------------------------------------------------
351              IF (fflags(listId)(1:1) .EQ. ' ') THEN            IF ( fflags(listId)(2:2).EQ.'P' ) THEN
352  C             This is the old default behavior  C-        Do vertical interpolation:
353                CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,'RL',             IF ( fluidIsAir ) THEN
354       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)  C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
355              ELSEIF (fflags(listId)(1:1) .EQ. 'R') THEN              CALL DIAGNOSTICS_INTERP_VERT(
356  C             Force it to be 32-bit precision       I                     listId, md, ndId, ip, im, lm,
357                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,'RL',       U                     qtmp1,
358       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)       I                     undef, myTime, myIter, myThid )
359              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN             ELSE
360  C             Force it to be 64-bit precision               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
361                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,'RL',       &         'INTERP_VERT not allowed in this config'
362       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)               CALL PRINT_ERROR( msgBuf , myThid )
363              ENDIF               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
364               ENDIF
365              ENDIF
366    
367    C--    Ready to write field "md", element "lm" in averageCycle(listId)
368    
369    C-        write to binary file, using MDSIO pkg:
370              IF ( diag_mdsio ) THEN
371                nRec = lm + (md-1)*averageCycle(listId)
372    C           default precision for output files
373                prec = writeBinaryPrec
374    C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
375                IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
376                IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
377    C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
378                CALL WRITE_REC_LEV_RL(
379         I                            fn, prec,
380         I                            NrMax, 1, nlevels(listId),
381         I                            qtmp1, -nRec, myIter, myThid )
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 310  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 331  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', nlevels(listId)              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)
432              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
# Line 346  C           Z is special since it varies Line 441  C           Z is special since it varies
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', nlevels(listId)                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)  = nlevels(listId)              ie(3)  = nlevels(listId)
447    
# Line 356  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    
463              IF ((fflags(listId)(1:1) .EQ. ' ')  #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)
513         &           .AND. (fflags(listId)(1:1) .NE. 'D')
514         &           .AND. (fflags(listId)(1:1) .NE. 'R') )
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 (fflags(listId)(1:1) .EQ. 'D') THEN              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
519         &             .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 382  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.15  
changed lines
  Added in v.1.38
  ViewVC Help
Powered by ViewVC 1.1.22