/[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.35 by jmc, Tue Feb 5 15:13:01 2008 UTC revision 1.49 by jmc, Mon Jun 6 15:42:58 2011 UTC
# Line 8  CBOP 0 Line 8  CBOP 0
8  C     !ROUTINE: DIAGNOSTICS_OUT  C     !ROUTINE: DIAGNOSTICS_OUT
9    
10  C     !INTERFACE:  C     !INTERFACE:
11        SUBROUTINE  DIAGNOSTICS_OUT(        SUBROUTINE DIAGNOSTICS_OUT(
12       I     listId,       I     listId,
13       I     myIter,       I     myIter,
14       I     myTime,       I     myTime,
# Line 38  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     bi,bj :: tile indices
52  C     lm    :: loop index (averageCycle)  C     lm    :: loop index (averageCycle)
53  C     md    :: field number in the list "listId".  C     md    :: field number in the list "listId".
54  C     ndId  :: diagnostics  Id number (in available diagnostics list)  C     ndId  :: diagnostics  Id number (in available diagnostics list)
55  C     mate  :: counter mate Id number (in available diagnostics list)  C     mate  :: counter mate Id number (in available diagnostics list)
56  C     ip    :: diagnostics  pointer to storage array  C     ip    :: diagnostics  pointer to storage array
57  C     im    :: counter-mate pointer to storage array  C     im    :: counter-mate pointer to storage array
58    C     nLevOutp :: number of levels to write in output file
59  C  C
60  C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)  C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)
61  C     qtmp1 :: thread-shared temporary array (needs to be in common block):  C     qtmp1 :: thread-shared temporary array (needs to be in common block):
# Line 59  C              diagnostic storage qdiag Line 69  C              diagnostic storage qdiag
69        INTEGER md, ndId, ip, im        INTEGER md, ndId, ip, im
70        INTEGER mate, mVec        INTEGER mate, mVec
71        CHARACTER*10 gcode        CHARACTER*10 gcode
72        _RL undef, getcon        _RL undef
73        _RL tmpLev        _RL tmpLev
       EXTERNAL getcon  
       INTEGER ILNBLNK  
       EXTERNAL ILNBLNK  
74        INTEGER ilen        INTEGER ilen
75          INTEGER nLevOutp
76    
77        INTEGER ioUnit        INTEGER ioUnit
78        CHARACTER*(MAX_LEN_FNAM) fn        CHARACTER*(MAX_LEN_FNAM) fn
79        CHARACTER*(MAX_LEN_MBUF) suff        CHARACTER*(MAX_LEN_MBUF) suff
80        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
81        INTEGER prec, nRec        INTEGER prec, nRec, nTimRec
82          _RL     timeRec(2)
83  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
84        LOGICAL glf        LOGICAL glf
85  #endif  #endif
86  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
87        INTEGER ii        INTEGER ll, llMx, jj, jjMx
88          INTEGER ii, klev
89        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
90        INTEGER CW_DIMS, NLEN        INTEGER CW_DIMS, NLEN
91        PARAMETER ( CW_DIMS = 10 )        PARAMETER ( CW_DIMS = 10 )
# Line 88  C              diagnostic storage qdiag Line 98  C              diagnostic storage qdiag
98        CHARACTER*(5) ctmp        CHARACTER*(5) ctmp
99        _RS ztmp(NrMax)        _RS ztmp(NrMax)
100  #endif  #endif
101          LOGICAL useMissingValue, useMisValForThisDiag
102          REAL*8 misvalLoc
103          REAL*8 misval_r8(2)
104          REAL*4 misval_r4(2)
105          INTEGER misvalIntLoc, misval_int(2)
106  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
107    
108  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
109    
110    C---  set file properties
111        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
112          undef = UNSET_RL
113    #ifdef ALLOW_FIZHI
114    c     IF ( useFIZHI ) undef = getcon('UNDEF')
115        undef = getcon('UNDEF')        undef = getcon('UNDEF')
116    #endif
117        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
118        ilen = ILNBLNK(fnames(listId))        ilen = ILNBLNK(fnames(listId))
119        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)
120    C-    for now, if integrate vertically, output field has just 1 level:
121          nLevOutp = nlevels(listId)
122          IF ( fflags(listId)(2:2).EQ.'I' ) nLevOutp = 1
123    
124    C--   Set time information:
125          IF ( freq(listId).LT.0. ) THEN
126    C-    Snap-shot: store a unique time (which is consistent with State-Var timing)
127            nTimRec = 1
128            timeRec(1) = myTime
129          ELSE
130    C-    Time-average: store the 2 edges of the time-averaging interval.
131    C      this time is consitent with intermediate Var (i.e., non-state, e.g, flux,
132    C      tendencies) timing. For State-Var, this is shifted by + halt time-step.
133            nTimRec = 2
134    
135    C-    end of time-averaging interval:
136            timeRec(2) = myTime
137    
138    C-    begining of time-averaging interval:
139    c       timeRec(1) = myTime - freq(listId)
140    C     a) find the time of the previous multiple of output freq:
141            timeRec(1) = myTime-deltaTClock*0.5 _d 0
142            timeRec(1) = (timeRec(1)-phase(listId))/freq(listId)
143            i = INT( timeRec(1) )
144            IF ( timeRec(1).LT.0. ) THEN
145              tmpLev = FLOAT(i)
146              IF ( timeRec(1).NE.tmpLev ) i = i - 1
147            ENDIF
148            timeRec(1) = phase(listId) + freq(listId)*FLOAT(i)
149    c       if ( listId.eq.2 ) write(0,*) 'f',i,timeRec(1)/deltaTClock
150            timeRec(1) = MAX( timeRec(1), startTime )
151    
152    C     b) round off to nearest multiple of time-step:
153            timeRec(1) = (timeRec(1)-baseTime)/deltaTClock
154            i = NINT( timeRec(1) )
155    C     if just half way, NINT will return the next time-step: correct this
156            tmpLev = FLOAT(i) - 0.5 _d 0
157            IF ( timeRec(1).EQ.tmpLev ) i = i - 1
158            timeRec(1) = baseTime + deltaTClock*FLOAT(i)
159    c       if ( listId.eq.2 ) write(0,*) i,timeRec(1)/deltaTClock
160          ENDIF
161    C--   Convert time to iteration number (debug)
162    c     DO i=1,nTimRec
163    c       timeRec(i) = timeRec(i)/deltaTClock
164    c     ENDDO
165    
166  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
167    C-- this is a trick to reverse the order of the loops on md (= field)
168    C   and lm (= averagePeriod): binary output: lm loop inside md loop ;
169    C                                 mnc ouput: md loop inside lm loop.
170        IF (useMNC .AND. diag_mnc) THEN        IF (useMNC .AND. diag_mnc) THEN
171          DO i = 1,MAX_LEN_FNAM          jjMx = averageCycle(listId)
172            diag_mnc_bn(i:i) = ' '          llMx = 1
173          ENDDO        ELSE
174          DO i = 1,NLEN          jjMx = 1
175            dn_blnk(i:i) = ' '          llMx = averageCycle(listId)
176          ENDDO        ENDIF
177          WRITE( diag_mnc_bn, '(A)' ) fnames(listId)(1:ilen)        DO jj=1,jjMx
178    
179           IF (useMNC .AND. diag_mnc) THEN
180    C     Handle missing value attribute (land points)
181             useMissingValue = .FALSE.
182    #ifdef DIAGNOSTICS_MISSING_VALUE
183             useMissingValue = .TRUE.
184    #endif /* DIAGNOSTICS_MISSING_VALUE */
185             IF ( misvalFlt(listId) .NE. UNSET_RL ) THEN
186              misvalLoc = misvalFlt(listId)
187             ELSE
188              misvalLoc = undef
189             ENDIF
190    C     Defaults to UNSET_I
191             misvalIntLoc = misvalInt(listId)
192             DO ii=1,2
193    C         misval_r4(ii)  = UNSET_FLOAT4
194    C         misval_r8(ii)  = UNSET_FLOAT8
195              misval_r4(ii)  = misvalLoc
196              misval_r8(ii)  = misvalLoc
197              misval_int(ii) = UNSET_I
198             ENDDO
199             DO i = 1,MAX_LEN_FNAM
200               diag_mnc_bn(i:i) = ' '
201             ENDDO
202             DO i = 1,NLEN
203               dn_blnk(i:i) = ' '
204             ENDDO
205             WRITE( diag_mnc_bn, '(A)' ) fnames(listId)(1:ilen)
206    
207  C       Update the record dimension by writing the iteration number  C       Update the record dimension by writing the iteration number
208          CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)           klev = myIter + jj - jjMx
209          CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)           tmpLev = myTime + deltaTClock*(jj -jjMx)
210          CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)           CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
211          CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)           CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',tmpLev,myThid)
212             CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
213             CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',klev,myThid)
214    
215  C       NOTE: at some point it would be a good idea to add a time_bounds  C       NOTE: at some point it would be a good idea to add a time_bounds
216  C       variable that has dimension (2,T) and clearly denotes the  C       variable that has dimension (2,T) and clearly denotes the
217  C       beginning and ending times for each diagnostics period  C       beginning and ending times for each diagnostics period
218    
219          dn(1)(1:NLEN) = dn_blnk(1:NLEN)           dn(1)(1:NLEN) = dn_blnk(1:NLEN)
220          WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listId)           WRITE(dn(1),'(a,i6.6)') 'Zmd', nLevOutp
221          dim(1) = nlevels(listId)           dim(1) = nLevOutp
222          ib(1)  = 1           ib(1)  = 1
223          ie(1)  = nlevels(listId)           ie(1)  = nLevOutp
224    
225          CALL MNC_CW_ADD_GNAME('diag_levels', 1,           CALL MNC_CW_ADD_GNAME('diag_levels', 1,
226       &       dim, dn, ib, ie, myThid)       &        dim, dn, ib, ie, myThid)
227          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',           CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
228       &       0,0, myThid)       &        0,0, myThid)
229          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',           CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
230       &       'Idicies of vertical levels within the source arrays',       &        'Idicies of vertical levels within the source arrays',
231       &       myThid)       &        myThid)
232    C     suppress the missing value attribute (iflag = 0)
233             IF (useMissingValue)
234         &       CALL MNC_CW_VATTR_MISSING('diag_levels', 0,
235         I       misval_r8, misval_r4, misval_int,
236         I       myThid )
237    
238          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,           CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
239       &       'diag_levels', levs(1,listId), myThid)       &        'diag_levels', levs(1,listId), myThid)
240    
241          CALL MNC_CW_DEL_VNAME('diag_levels', myThid)           CALL MNC_CW_DEL_VNAME('diag_levels', myThid)
242          CALL MNC_CW_DEL_GNAME('diag_levels', myThid)           CALL MNC_CW_DEL_GNAME('diag_levels', myThid)
243    
244  #ifdef DIAG_MNC_COORD_NEEDSWORK  #ifdef DIAG_MNC_COORD_NEEDSWORK
245  C       This part has been placed in an #ifdef because, as its currently  C       This part has been placed in an #ifdef because, as its currently
# Line 152  C       as: Z[uml]td000000 where the 't' Line 255  C       as: Z[uml]td000000 where the 't'
255  C       gdiag(10)  C       gdiag(10)
256    
257  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
258          ctmp(1:5) = 'mul  '           ctmp(1:5) = 'mul  '
259          DO i = 1,3           DO i = 1,3
260            dn(1)(1:NLEN) = dn_blnk(1:NLEN)             dn(1)(1:NLEN) = dn_blnk(1:NLEN)
261            WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listId)             WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listId)
262            CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)             CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)
263            CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)             CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)
264    
265  C         The following three ztmp() loops should eventually be modified  C         The following three ztmp() loops should eventually be modified
266  C         to reflect the fractional nature of levs(j,l) -- they should  C         to reflect the fractional nature of levs(j,l) -- they should
# Line 167  C                      + ( rC(INT(FLOOR( Line 270  C                      + ( rC(INT(FLOOR(
270  C                          + rC(INT(CEIL(levs(j,l)))) )  C                          + rC(INT(CEIL(levs(j,l)))) )
271  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )
272  C         for averaged levels.  C         for averaged levels.
273            IF (i .EQ. 1) THEN             IF (i .EQ. 1) THEN
274              DO j = 1,nlevels(listId)               DO j = 1,nlevels(listId)
275                ztmp(j) = rC(NINT(levs(j,listId)))                 ztmp(j) = rC(NINT(levs(j,listId)))
276              ENDDO               ENDDO
277              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',               CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
278       &           'Dimensional coordinate value at the mid point',       &            'Dimensional coordinate value at the mid point',
279       &           myThid)       &            myThid)
280            ELSEIF (i .EQ. 2) THEN             ELSEIF (i .EQ. 2) THEN
281              DO j = 1,nlevels(listId)               DO j = 1,nlevels(listId)
282                ztmp(j) = rF(NINT(levs(j,listId)) + 1)                 ztmp(j) = rF(NINT(levs(j,listId)) + 1)
283              ENDDO               ENDDO
284              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',               CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
285       &           'Dimensional coordinate value at the upper point',       &            'Dimensional coordinate value at the upper point',
286       &           myThid)       &            myThid)
287            ELSEIF (i .EQ. 3) THEN             ELSEIF (i .EQ. 3) THEN
288              DO j = 1,nlevels(listId)               DO j = 1,nlevels(listId)
289                ztmp(j) = rF(NINT(levs(j,listId)))                 ztmp(j) = rF(NINT(levs(j,listId)))
290              ENDDO               ENDDO
291              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',               CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
292       &           'Dimensional coordinate value at the lower point',       &            'Dimensional coordinate value at the lower point',
293       &           myThid)       &            myThid)
294            ENDIF             ENDIF
295            CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)  C     suppress the missing value attribute (iflag = 0)
296            CALL MNC_CW_DEL_VNAME(dn(1), myThid)             IF (useMissingValue)
297            CALL MNC_CW_DEL_GNAME(dn(1), myThid)       &          CALL MNC_CW_VATTR_MISSING(dn(1), 0,
298          ENDDO       I          misval_r8, misval_r4, misval_int,
299         I          myThid )
300               CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)
301               CALL MNC_CW_DEL_VNAME(dn(1), myThid)
302               CALL MNC_CW_DEL_GNAME(dn(1), myThid)
303             ENDDO
304  #endif /*  DIAG_MNC_COORD_NEEDSWORK  */  #endif /*  DIAG_MNC_COORD_NEEDSWORK  */
305    
306        ENDIF         ENDIF
307  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
308    
309  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
310    
311        DO md = 1,nfields(listId)         DO md = 1,nfields(listId)
312          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
313          gcode = gdiag(ndId)(1:10)          gcode = gdiag(ndId)(1:10)
314          mate = 0          mate = 0
# Line 210  C-      Check for Mate of a Counter Diag Line 318  C-      Check for Mate of a Counter Diag
318             mate = hdiag(ndId)             mate = hdiag(ndId)
319          ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN          ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN
320  C-      Check for Mate of a Vector Diagnostic  C-      Check for Mate of a Vector Diagnostic
321             mate = hdiag(ndId)             mVec = hdiag(ndId)
322          ENDIF          ENDIF
323          IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN          IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN
324  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
325    #ifdef ALLOW_MNC
326             DO ll=1,llMx
327              lm = jj+ll-1
328    #else
329           DO lm=1,averageCycle(listId)           DO lm=1,averageCycle(listId)
330    #endif
331    
332            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
333            im = mdiag(md,listId)            im = mdiag(md,listId)
# Line 252  C-        Empty diagnostics case : Line 365  C-        Empty diagnostics case :
365              _END_MASTER( myThid )              _END_MASTER( myThid )
366              DO bj = myByLo(myThid), myByHi(myThid)              DO bj = myByLo(myThid), myByHi(myThid)
367                DO bi = myBxLo(myThid), myBxHi(myThid)                DO bi = myBxLo(myThid), myBxHi(myThid)
368                  DO k = 1,nlevels(listId)                  DO k = 1,nLevOutp
369                    DO j = 1-OLy,sNy+OLy                    DO j = 1-OLy,sNy+OLy
370                      DO i = 1-OLx,sNx+OLx                      DO i = 1-OLx,sNx+OLx
371                        qtmp1(i,j,k,bi,bj) = 0. _d 0                        qtmp1(i,j,k,bi,bj) = 0. _d 0
# Line 265  C-        Empty diagnostics case : Line 378  C-        Empty diagnostics case :
378            ELSE            ELSE
379  C-        diagnostics is not empty :  C-        diagnostics is not empty :
380    
381              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN              IF ( debugLevel.GE.debLevB .AND. myThid.EQ.1 ) THEN
382                WRITE(ioUnit,'(A,I6,3A,I8,2A)')                WRITE(ioUnit,'(A,I6,3A,I8,2A)')
383       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
384       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
# Line 288  C-        diagnostics is not empty : Line 401  C-        diagnostics is not empty :
401                ENDIF                ENDIF
402              ENDIF              ENDIF
403    
404              IF ( fflags(listId)(2:2).EQ.'P' ) THEN              IF ( fflags(listId)(2:2).NE.' ' ) THEN
405  C-       get all the levels (for vertical interpolation)  C-       get all the levels (for vertical post-processing)
406                DO bj = myByLo(myThid), myByHi(myThid)                DO bj = myByLo(myThid), myByHi(myThid)
407                 DO bi = myBxLo(myThid), myBxHi(myThid)                 DO bi = myBxLo(myThid), myBxHi(myThid)
408                  DO k = 1,kdiag(ndId)                  DO k = 1,kdiag(ndId)
# Line 315  C-       get only selected levels: Line 428  C-       get only selected levels:
428                ENDDO                ENDDO
429              ENDIF              ENDIF
430    
 C-        end of empty diag / not empty block  
           ENDIF  
   
431  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
432  C         Check to see if we need to interpolate before output  C--     Apply specific post-processing (e.g., interpolate) before output
433  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
434            IF ( fflags(listId)(2:2).EQ.'P' ) THEN              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
435  C-        Do vertical interpolation:  C-          Do vertical interpolation:
436             IF ( fluidIsAir ) THEN               IF ( fluidIsAir ) THEN
437  C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);  C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
438              CALL DIAGNOSTICS_INTERP_VERT(                CALL DIAGNOSTICS_INTERP_VERT(
439       I                     listId, md, ndId, ip, im, lm,       I                         listId, md, ndId, ip, im, lm,
440       U                     qtmp1,       U                         qtmp1,
441       I                     undef, myTime, myIter, myThid )       I                         undef, myTime, myIter, myThid )
442             ELSE               ELSE
443               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',                 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
444       &         'INTERP_VERT not allowed in this config'       &           'INTERP_VERT not allowed in this config'
445               CALL PRINT_ERROR( msgBuf , myThid )                 CALL PRINT_ERROR( msgBuf , myThid )
446               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
447             ENDIF               ENDIF
448                ENDIF
449                IF ( fflags(listId)(2:2).EQ.'I' ) THEN
450    C-          Integrate vertically: for now, output field has just 1 level:
451                  CALL DIAGNOSTICS_SUM_LEVELS(
452         I                         listId, md, ndId, ip, im, lm,
453         U                         qtmp1,
454         I                         undef, myTime, myIter, myThid )
455                ENDIF
456    
457    C--     End of empty diag / not-empty diag block
458            ENDIF            ENDIF
459    
460  C--    Ready to write field "md", element "lm" in averageCycle(listId)  C--     Ready to write field "md", element "lm" in averageCycle(listId)
461    
462  C-        write to binary file, using MDSIO pkg:  C-        write to binary file, using MDSIO pkg:
463            IF ( diag_mdsio ) THEN            IF ( diag_mdsio ) THEN
# Line 350  C           fFlag(1)=R(or D): force it t Line 470  C           fFlag(1)=R(or D): force it t
470  C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R  C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
471              CALL WRITE_REC_LEV_RL(              CALL WRITE_REC_LEV_RL(
472       I                            fn, prec,       I                            fn, prec,
473       I                            NrMax, 1, nlevels(listId),       I                            NrMax, 1, nLevOutp,
474       I                            qtmp1, -nRec, myIter, myThid )       I                            qtmp1, -nRec, myIter, myThid )
475            ENDIF            ENDIF
476    
# Line 401  C           XY dimensions Line 521  C           XY dimensions
521              ENDIF              ENDIF
522    
523  C           Z is special since it varies  C           Z is special since it varies
524              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)              WRITE(dn(3),'(a,i6.6)') 'Zd', nLevOutp
525              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
526       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
527                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevels(listId)                WRITE(dn(3),'(a,i6.6)') 'Zmd', nLevOutp
528              ENDIF              ENDIF
529              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
530       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
531                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listId)                WRITE(dn(3),'(a,i6.6)') 'Zld', nLevOutp
532              ENDIF              ENDIF
533              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
534       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
535                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)                WRITE(dn(3),'(a,i6.6)') 'Zud', nLevOutp
536              ENDIF              ENDIF
537              dim(3) = NrMax              dim(3) = NrMax
538              ib(3)  = 1              ib(3)  = 1
539              ie(3)  = nlevels(listId)              ie(3)  = nLevOutp
540    
541  C           Time dimension  C           Time dimension
542              dn(4)(1:1) = 'T'              dn(4)(1:1) = 'T'
# Line 433  C           Time dimension Line 553  C           Time dimension
553              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
554       &             udiag(ndId),myThid)       &             udiag(ndId),myThid)
555    
556  C           Per the observations of Baylor, this has been commented out  C     Missing values only for scalar diagnostics at mass points (so far)
557  C           until we have code that can write missing_value attributes              useMisValForThisDiag = useMissingValue
558  C           in a way thats compatible with most of the more popular       &           .AND.gdiag(ndId)(1:2).EQ.'SM'
559  C           netCDF tools including ferret.  Using all-zeros completely              IF ( useMisValForThisDiag ) THEN
560  C           breaks ferret.  C     assign missing values and set flag for adding the netCDF atttibute
561                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,
562  C           CALL MNC_CW_ADD_VATTR_DBL(cdiag(ndId),'missing_value',       I            misval_r8, misval_r4, misval_int,
563  C           &             0.0 _d 0,myThid)       I            myThid )
564    C     and now use the missing values for masking out the land points
565              IF ( ( (writeBinaryPrec .EQ. precFloat32)  C     note: better to use 2-D mask if kdiag <> Nr or vert.integral
566       &           .AND. (fflags(listId)(1:1) .NE. 'D')               DO bj = myByLo(myThid), myByHi(myThid)
567       &           .AND. (fflags(listId)(1:1) .NE. 'R') )                DO bi = myBxLo(myThid), myBxHi(myThid)
568       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN                 DO k = 1,nLevOutp
569                    klev = NINT(levs(k,listId))
570                    IF ( fflags(listId)(2:2).EQ.'I' ) kLev = 1
571                    DO j = 1-OLy,sNy+OLy
572                     DO i = 1-OLx,sNx+OLx
573                      IF ( maskC(i,j,klev,bi,bj) .EQ. 0. )
574         &                 qtmp1(i,j,k,bi,bj) = misvalLoc
575                     ENDDO
576                    ENDDO
577                   ENDDO
578                  ENDDO
579                 ENDDO
580                ELSE
581    C     suppress the missing value attribute (iflag = 0)
582    C     Note: We have to call the following subroutine for each mnc that has
583    C     been created "on the fly" by mnc_cw_add_vname and will be deleted
584    C     by mnc_cw_del_vname, because all of these variables use the same
585    C     identifier so that mnc_cw_vfmv(indv) needs to be overwritten for
586    C     each of these variables
587                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 0,
588         I            misval_r8, misval_r4, misval_int,
589         I            myThid )
590                ENDIF
591    
592                IF (  ((writeBinaryPrec .EQ. precFloat32)
593         &            .AND. (fflags(listId)(1:1) .NE. 'D'))
594         &             .OR. (fflags(listId)(1:1) .EQ. 'R') ) THEN
595                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
596       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
597              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
# Line 462  C           &             0.0 _d 0,myThi Line 608  C           &             0.0 _d 0,myThi
608            ENDIF            ENDIF
609  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
610    
611    C--      end loop on lm (or ll if ALLOW_MNC) counter
612           ENDDO           ENDDO
613  C--     end of Processing Fld # md  C--     end of Processing Fld # md
614          ENDIF          ENDIF
615           ENDDO
616    
617    #ifdef ALLOW_MNC
618    C--   end loop on jj counter
619        ENDDO        ENDDO
620    #endif
621    
622  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
623        IF (diag_mdsio) THEN        IF (diag_mdsio) THEN
624  C-    Note: temporary: since it's a pain to add more arguments to  C-    Note: temporary: since it is a pain to add more arguments to
625  C     all MDSIO S/R, uses instead this specific S/R to write only  C     all MDSIO S/R, uses instead this specific S/R to write only
626  C     meta files but with more informations in it.  C     meta files but with more informations in it.
627              glf = globalFiles              glf = globalFiles
628              nRec = nfields(listId)*averageCycle(listId)              nRec = nfields(listId)*averageCycle(listId)
629              CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,              CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
630       &              0, 0, nlevels(listId), ' ',       &              0, 0, nLevOutp, ' ',
631       &              nfields(listId), flds(1,listId), 1, myTime,       &              nfields(listId), flds(1,listId), nTimRec, timeRec,
632       &              nRec, myIter, myThid)       &              nRec, myIter, myThid)
633        ENDIF        ENDIF
634  #endif /*  ALLOW_MDSIO  */  #endif /*  ALLOW_MDSIO  */
Legend:
Removed from v.1.35  
changed lines
  Added in v.1.49
  ViewVC Help
Powered by ViewVC 1.1.22