/[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.16 by edhill, Thu Jul 7 15:32:35 2005 UTC revision 1.40 by jmc, Tue Nov 18 21:41:06 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 43  C     myThid  :: my Thread Id number Line 38  C     myThid  :: my Thread Id number
38        INTEGER listId, myIter, myThid        INTEGER listId, myIter, myThid
39  CEOP  CEOP
40    
41    C     !FUNCTIONS:
42          INTEGER ILNBLNK
43          EXTERNAL ILNBLNK
44    #ifdef ALLOW_FIZHI
45          _RL   getcon
46          EXTERNAL getcon
47    #endif
48    
49  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
50  C     i,j,k :: loop indices  C     i,j,k :: loop indices
51    C     lm    :: loop index (averageCycle)
52  C     md    :: field number in the list "listId".  C     md    :: field number in the list "listId".
53  C     ndId  :: diagnostics  Id number (in available diagnostics list)  C     ndId  :: diagnostics  Id number (in available diagnostics list)
54  C     mate  :: counter mate Id number (in available diagnostics list)  C     mate  :: counter mate Id number (in available diagnostics list)
55  C     ip    :: diagnostics  pointer to storage array  C     ip    :: diagnostics  pointer to storage array
56  C     im    :: counter-mate pointer to storage array  C     im    :: counter-mate pointer to storage array
57        INTEGER i, j, k  C
58    C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)
59    C     qtmp1 :: thread-shared temporary array (needs to be in common block):
60    C              to write a diagnostic field to file, copy it first from (big)
61    C              diagnostic storage qdiag into it.
62          COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1
63          _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
64    
65          INTEGER i, j, k, lm, klev
66        INTEGER bi, bj        INTEGER bi, bj
67        INTEGER md, ndId, ip, im        INTEGER md, ndId, ip, im
68        INTEGER mate, mVec        INTEGER mate, mVec
69        CHARACTER*8 parms1        CHARACTER*10 gcode
70        CHARACTER*3 mate_index        _RL undef
71        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)        _RL tmpLev
       _RL undef, getcon  
       EXTERNAL getcon  
       INTEGER ILNBLNK  
       EXTERNAL ILNBLNK  
72        INTEGER ilen        INTEGER ilen
73    
74        INTEGER ioUnit        INTEGER ioUnit
75        CHARACTER*(MAX_LEN_FNAM) fn        CHARACTER*(MAX_LEN_FNAM) fn
76        CHARACTER*(MAX_LEN_MBUF) suff        CHARACTER*(MAX_LEN_MBUF) suff
77        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
78          INTEGER prec, nRec
79    #ifdef ALLOW_MDSIO
80        LOGICAL glf        LOGICAL glf
81    #endif
82  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
83        INTEGER ii        INTEGER ii
84        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
       CHARACTER*(5) ctmp  
85        INTEGER CW_DIMS, NLEN        INTEGER CW_DIMS, NLEN
86        PARAMETER ( CW_DIMS = 10 )        PARAMETER ( CW_DIMS = 10 )
87        PARAMETER ( NLEN    = 80 )        PARAMETER ( NLEN    = 80 )
# Line 79  C     im    :: counter-mate pointer to s Line 89  C     im    :: counter-mate pointer to s
89        CHARACTER*(NLEN) dn(CW_DIMS)        CHARACTER*(NLEN) dn(CW_DIMS)
90        CHARACTER*(NLEN) d_cw_name        CHARACTER*(NLEN) d_cw_name
91        CHARACTER*(NLEN) dn_blnk        CHARACTER*(NLEN) dn_blnk
92        _RS ztmp(Nr+Nrphys)  #ifdef DIAG_MNC_COORD_NEEDSWORK
93          CHARACTER*(5) ctmp
94          _RS ztmp(NrMax)
95    #endif
96          LOGICAL useMissingValue, useMisValForThisDiag
97          REAL*8 misvalLoc
98          REAL*8 misval_r8(2)
99          REAL*4 misval_r4(2)
100          INTEGER misvalIntLoc, misval_int(2)
101  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
102    
103  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
104    
105        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
106          undef = UNSET_RL
107    #ifdef ALLOW_FIZHI
108    c     IF ( useFIZHI ) undef = getcon('UNDEF')
109        undef = getcon('UNDEF')        undef = getcon('UNDEF')
110        glf = globalFiles  #endif
111        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
112        ilen = ILNBLNK(fnames(listId))        ilen = ILNBLNK(fnames(listId))
113        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)
114    
115  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
116        IF (useMNC .AND. diag_mnc) THEN        IF (useMNC .AND. diag_mnc) THEN
117    C     Handle missing value attribute (land points)
118           useMissingValue = .FALSE.
119    #ifdef DIAGNOSTICS_MISSING_VALUE
120           useMissingValue = .TRUE.
121    #endif /* DIAGNOSTICS_MISSING_VALUE */
122           IF ( misvalFlt(listId) .NE. UNSET_RL ) THEN
123            misvalLoc = misvalFlt(listId)
124           ELSE
125            misvalLoc = undef
126           ENDIF
127    C     Defaults to UNSET_I
128           misvalIntLoc = misvalInt(listId)
129           DO ii=1,2
130    C       misval_r4(ii)  = UNSET_FLOAT4
131    C       misval_r8(ii)  = UNSET_FLOAT8
132            misval_r4(ii)  = misvalLoc
133            misval_r8(ii)  = misvalLoc
134            misval_int(ii) = UNSET_I
135           ENDDO
136          DO i = 1,MAX_LEN_FNAM          DO i = 1,MAX_LEN_FNAM
137            diag_mnc_bn(i:i) = ' '            diag_mnc_bn(i:i) = ' '
138          ENDDO          ENDDO
# Line 105  C       Update the record dimension by w Line 145  C       Update the record dimension by w
145          CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)          CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
146          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)
147          CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)          CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
148            CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)
149    
150    C       NOTE: at some point it would be a good idea to add a time_bounds
151    C       variable that has dimension (2,T) and clearly denotes the
152    C       beginning and ending times for each diagnostics period
153    
154          dn(1)(1:NLEN) = dn_blnk(1:NLEN)          dn(1)(1:NLEN) = dn_blnk(1:NLEN)
155          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 157  C       Update the record dimension by w
157          ib(1)  = 1          ib(1)  = 1
158          ie(1)  = nlevels(listId)          ie(1)  = nlevels(listId)
159    
160          CALL MNC_CW_ADD_GNAME('diag_levels', 1,          CALL MNC_CW_ADD_GNAME('diag_levels', 1,
161       &       dim, dn, ib, ie, myThid)       &       dim, dn, ib, ie, myThid)
162          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
163       &       0,0, myThid)       &       0,0, myThid)
164          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
165       &       'Idicies of vertical levels within the source arrays',       &       'Idicies of vertical levels within the source arrays',
166       &       myThid)       &       myThid)
167            C     suppress the missing value attribute (iflag = 0)
168            IF (useMissingValue)
169         &       CALL MNC_CW_VATTR_MISSING('diag_levels', 0,
170         I       misval_r8, misval_r4, misval_int,
171         I       myThid )
172    
173          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
174       &       'diag_levels', levs(1,listId), myThid)       &       'diag_levels', levs(1,listId), myThid)
175    
# Line 133  C       grid.  As we start using diagnos Line 183  C       grid.  As we start using diagnos
183  C       levels, land levels, etc. the different vertical coordinate  C       levels, land levels, etc. the different vertical coordinate
184  C       dimensions will have to be taken into account.  C       dimensions will have to be taken into account.
185    
186    C       20051021 JMC & EH3 : We need to extend this so that a few
187    C       variables each defined on different grids do not have the same
188    C       vertical dimension names so we should be using a pattern such
189    C       as: Z[uml]td000000 where the 't' is the type as specified by
190    C       gdiag(10)
191    
192  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
193          ctmp(1:5) = 'mul  '          ctmp(1:5) = 'mul  '
194          DO i = 1,3          DO i = 1,3
# Line 144  C       Now define:  Zmdxxxxxx, Zudxxxxx Line 200  C       Now define:  Zmdxxxxxx, Zudxxxxx
200  C         The following three ztmp() loops should eventually be modified  C         The following three ztmp() loops should eventually be modified
201  C         to reflect the fractional nature of levs(j,l) -- they should  C         to reflect the fractional nature of levs(j,l) -- they should
202  C         do something like:  C         do something like:
203  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))
204  C                      + ( rC(INT(FLOOR(levs(j,l))))  C                      + ( rC(INT(FLOOR(levs(j,l))))
205  C                          + rC(INT(CEIL(levs(j,l)))) )  C                          + rC(INT(CEIL(levs(j,l)))) )
206  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )
207  C         for averaged levels.  C         for averaged levels.
# Line 171  C         for averaged levels. Line 227  C         for averaged levels.
227       &           'Dimensional coordinate value at the lower point',       &           'Dimensional coordinate value at the lower point',
228       &           myThid)       &           myThid)
229            ENDIF            ENDIF
230    C     suppress the missing value attribute (iflag = 0)
231              IF (useMissingValue)
232         &         CALL MNC_CW_VATTR_MISSING(dn(1), 0,
233         I         misval_r8, misval_r4, misval_int,
234         I         myThid )
235            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)
236            CALL MNC_CW_DEL_VNAME(dn(1), myThid)            CALL MNC_CW_DEL_VNAME(dn(1), myThid)
237            CALL MNC_CW_DEL_GNAME(dn(1), myThid)            CALL MNC_CW_DEL_GNAME(dn(1), myThid)
# Line 180  C         for averaged levels. Line 241  C         for averaged levels.
241        ENDIF        ENDIF
242  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
243    
244    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
245    
246        DO md = 1,nfields(listId)        DO md = 1,nfields(listId)
247          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
248          parms1 = gdiag(ndId)(1:8)          gcode = gdiag(ndId)(1:10)
249          IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN          mate = 0
250            mVec = 0
251            IF ( gcode(5:5).EQ.'C' ) THEN
252    C-      Check for Mate of a Counter Diagnostic
253               mate = hdiag(ndId)
254            ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN
255    C-      Check for Mate of a Vector Diagnostic
256               mVec = hdiag(ndId)
257            ENDIF
258            IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN
259  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
260             DO lm=1,averageCycle(listId)
261    
262            ip = ABS(idiag(md,listId))            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
263            im = mdiag(md,listId)            im = mdiag(md,listId)
264              IF (mate.GT.0) im = im + kdiag(mate)*(lm-1)
265              IF (mVec.GT.0) im = im + kdiag(mVec)*(lm-1)
266    
267            IF ( ndiag(ip,1,1).EQ.0 ) THEN            IF ( ndiag(ip,1,1).EQ.0 ) THEN
268  C-        Empty diagnostics case :  C-        Empty diagnostics case :
269    
# Line 196  C-        Empty diagnostics case : Line 272  C-        Empty diagnostics case :
272       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
273              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
274       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
275              WRITE(msgBuf,'(A,I4,3A,I3,2A)')              WRITE(msgBuf,'(A,I6,3A,I4,2A)')
276       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),
277       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
278              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
279       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
280              WRITE(msgBuf,'(A,I2,A)')              IF ( averageCycle(listId).GT.1 ) THEN
281       &       '- WARNING -   has not been filled (ndiag=',               WRITE(msgBuf,'(A,2(I3,A))')
282       &       ndiag(ip,1,1), ' )'       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
283         &                                            ndiag(ip,1,1), ' )'
284                ELSE
285                 WRITE(msgBuf,'(A,2(I3,A))')
286         &        '- WARNING -   has not been filled (ndiag=',
287         &                                            ndiag(ip,1,1), ' )'
288                ENDIF
289              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
290       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
291              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(A)')
# Line 226  C-        Empty diagnostics case : Line 308  C-        Empty diagnostics case :
308            ELSE            ELSE
309  C-        diagnostics is not empty :  C-        diagnostics is not empty :
310    
311              IF ( myThid.EQ.1 ) WRITE(ioUnit,'(A,I3,3A,I8,2A)')              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN
312                  WRITE(ioUnit,'(A,I6,3A,I8,2A)')
313       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
314       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
315                  IF ( mate.GT.0 ) THEN
316              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)')  
317       &         '       use Counter Mate for  ', cdiag(ndId),       &         '       use Counter Mate for  ', cdiag(ndId),
318       &         '     Diagnostic # ',mate, '  ', cdiag(mate)       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
319                  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  
320                  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
321                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
322       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
323       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
324       &             ' exists '       &             ' exists '
325                  ELSE                  ELSE
326                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
327       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
328       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
329       &             ' not enabled'       &             ' not enabled'
# Line 261  C             -------------------------- Line 331  C             --------------------------
331                ENDIF                ENDIF
332              ENDIF              ENDIF
333    
334              DO bj = myByLo(myThid), myByHi(myThid)              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
335               DO bi = myBxLo(myThid), myBxHi(myThid)  C-       get all the levels (for vertical interpolation)
336                DO k = 1,nlevels(listId)                DO bj = myByLo(myThid), myByHi(myThid)
337                  CALL GETDIAG(                 DO bi = myBxLo(myThid), myBxHi(myThid)
338       I                       levs(k,listId),undef,                  DO k = 1,kdiag(ndId)
339       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),                    tmpLev = k
340       I                       ndId,mate,ip,im,bi,bj,myThid)                    CALL GETDIAG(
341         I                         tmpLev,undef,
342         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
343         I                         ndId,mate,ip,im,bi,bj,myThid)
344                    ENDDO
345                   ENDDO
346                ENDDO                ENDDO
347               ENDDO              ELSE
348              ENDDO  C-       get only selected levels:
349                  DO bj = myByLo(myThid), myByHi(myThid)
350                   DO bi = myBxLo(myThid), myBxHi(myThid)
351                    DO k = 1,nlevels(listId)
352                      CALL GETDIAG(
353         I                         levs(k,listId),undef,
354         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
355         I                         ndId,mate,ip,im,bi,bj,myThid)
356                    ENDDO
357                   ENDDO
358                  ENDDO
359                ENDIF
360    
361  C-        end of empty diag / not empty block  C-        end of empty diag / not empty block
362            ENDIF            ENDIF
363    
364  #ifdef ALLOW_MDSIO  C-----------------------------------------------------------------------
365  C         Prepare for mdsio optionality  C         Check to see if we need to interpolate before output
366            IF (diag_mdsio) THEN  C-----------------------------------------------------------------------
367              IF (fflags(listId)(1:1) .EQ. ' ') THEN            IF ( fflags(listId)(2:2).EQ.'P' ) THEN
368  C             This is the old default behavior  C-        Do vertical interpolation:
369                CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,'RL',             IF ( fluidIsAir ) THEN
370       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)  C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
371              ELSEIF (fflags(listId)(1:1) .EQ. 'R') THEN              CALL DIAGNOSTICS_INTERP_VERT(
372  C             Force it to be 32-bit precision       I                     listId, md, ndId, ip, im, lm,
373                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,'RL',       U                     qtmp1,
374       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)       I                     undef, myTime, myIter, myThid )
375              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN             ELSE
376  C             Force it to be 64-bit precision               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
377                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,'RL',       &         'INTERP_VERT not allowed in this config'
378       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)               CALL PRINT_ERROR( msgBuf , myThid )
379              ENDIF               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
380               ENDIF
381              ENDIF
382    
383    C--    Ready to write field "md", element "lm" in averageCycle(listId)
384    
385    C-        write to binary file, using MDSIO pkg:
386              IF ( diag_mdsio ) THEN
387                nRec = lm + (md-1)*averageCycle(listId)
388    C           default precision for output files
389                prec = writeBinaryPrec
390    C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
391                IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
392                IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
393    C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
394                CALL WRITE_REC_LEV_RL(
395         I                            fn, prec,
396         I                            NrMax, 1, nlevels(listId),
397         I                            qtmp1, -nRec, myIter, myThid )
398            ENDIF            ENDIF
 #endif /*  ALLOW_MDSIO  */  
399    
400  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
401            IF (useMNC .AND. diag_mnc) THEN            IF (useMNC .AND. diag_mnc) THEN
# Line 318  C           XY dimensions Line 421  C           XY dimensions
421              dim(2)       = sNy + 2*OLy              dim(2)       = sNy + 2*OLy
422              ib(1)        = OLx + 1              ib(1)        = OLx + 1
423              ib(2)        = OLy + 1              ib(2)        = OLy + 1
424              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN
425                dn(1)(1:2) = 'X'                dn(1)(1:2) = 'X'
426                ie(1)      = OLx + sNx                ie(1)      = OLx + sNx
427                dn(2)(1:2) = 'Y'                dn(2)(1:2) = 'Y'
# Line 339  C           XY dimensions Line 442  C           XY dimensions
442                dn(2)(1:3) = 'Yp1'                dn(2)(1:3) = 'Yp1'
443                ie(2)      = OLy + sNy + 1                ie(2)      = OLy + sNy + 1
444              ENDIF              ENDIF
445                
446  C           Z is special since it varies  C           Z is special since it varies
447              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)
448              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
# Line 354  C           Z is special since it varies Line 457  C           Z is special since it varies
457       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
458                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)
459              ENDIF              ENDIF
460              dim(3) = Nr+Nrphys              dim(3) = NrMax
461              ib(3)  = 1              ib(3)  = 1
462              ie(3)  = nlevels(listId)              ie(3)  = nlevels(listId)
463    
# Line 364  C           Time dimension Line 467  C           Time dimension
467              ib(4)  = 1              ib(4)  = 1
468              ie(4)  = 1              ie(4)  = 1
469    
470              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
471       &             dim, dn, ib, ie, myThid)       &             dim, dn, ib, ie, myThid)
472              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,
473       &             4,5, myThid)       &             4,5, myThid)
474              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',
475       &             tdiag(ndId),myThid)       &             tdiag(ndId),myThid)
476              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
477       &             udiag(ndId),myThid)       &             udiag(ndId),myThid)
478    
479              IF ((fflags(listId)(1:1) .EQ. ' ')  C     Missing values only for scalar diagnostics at mass points (so far)
480                useMisValForThisDiag = useMissingValue
481         &           .AND.gdiag(ndId)(1:2).EQ.'SM'
482                IF ( useMisValForThisDiag ) THEN
483    C     assign missing values and set flag for adding the netCDF atttibute
484                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,
485         I            misval_r8, misval_r4, misval_int,
486         I            myThid )
487    C     and now use the missing values for masking out the land points
488                 DO bj = myByLo(myThid), myByHi(myThid)
489                  DO bi = myBxLo(myThid), myBxHi(myThid)
490                   DO k = 1,nlevels(listId)
491                    klev = NINT(levs(k,listId))
492                    DO j = 1-OLy,sNy+OLy
493                     DO i = 1-OLx,sNx+OLx
494                      IF ( _hFacC(I,J,klev,bi,bj) .EQ. 0. )
495         &                 qtmp1(i,j,k,bi,bj) = misvalLoc
496                     ENDDO
497                    ENDDO
498                   ENDDO
499                  ENDDO
500                 ENDDO
501                ELSE
502    C     suppress the missing value attribute (iflag = 0)
503    C     Note: We have to call the following subroutine for each mnc that has
504    C     been created "on the fly" by mnc_cw_add_vname and will be deleted
505    C     by mnc_cw_del_vname, because all of these variables use the same
506    C     identifier so that mnc_cw_vfmv(indv) needs to be overwritten for
507    C     each of these variables
508                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 0,
509         I            misval_r8, misval_r4, misval_int,
510         I            myThid )
511                ENDIF
512    
513                IF ( ( (writeBinaryPrec .EQ. precFloat32)
514         &           .AND. (fflags(listId)(1:1) .NE. 'D')
515         &           .AND. (fflags(listId)(1:1) .NE. 'R') )
516       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN
517                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
518       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
519              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
520         &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN
521                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
522       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
523              ENDIF              ENDIF
524                
525              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)
526              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
527    
# Line 390  C           Time dimension Line 530  C           Time dimension
530            ENDIF            ENDIF
531  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
532    
533             ENDDO
534  C--     end of Processing Fld # md  C--     end of Processing Fld # md
535          ENDIF          ENDIF
536        ENDDO        ENDDO
537    
538    #ifdef ALLOW_MDSIO
539          IF (diag_mdsio) THEN
540    C-    Note: temporary: since it's a pain to add more arguments to
541    C     all MDSIO S/R, uses instead this specific S/R to write only
542    C     meta files but with more informations in it.
543                glf = globalFiles
544                nRec = nfields(listId)*averageCycle(listId)
545                CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
546         &              0, 0, nlevels(listId), ' ',
547         &              nfields(listId), flds(1,listId), 1, myTime,
548         &              nRec, myIter, myThid)
549          ENDIF
550    #endif /*  ALLOW_MDSIO  */
551    
552        RETURN        RETURN
553        END        END
554    
Legend:
Removed from v.1.16  
changed lines
  Added in v.1.40
  ViewVC Help
Powered by ViewVC 1.1.22