/[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.34 by jmc, Tue Nov 13 19:43:44 2007 UTC revision 1.40 by jmc, Tue Nov 18 21:41:06 2008 UTC
# 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     lm    :: loop index (averageCycle)  C     lm    :: loop index (averageCycle)
# Line 54  C              diagnostic storage qdiag Line 62  C              diagnostic storage qdiag
62        COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1        COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1
63        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
64    
65        INTEGER i, j, k, lm        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        _RL undef, getcon        _RL undef
71        _RL tmpLev        _RL tmpLev
       EXTERNAL getcon  
       INTEGER ILNBLNK  
       EXTERNAL ILNBLNK  
72        INTEGER ilen        INTEGER ilen
73    
74        INTEGER ioUnit        INTEGER ioUnit
# Line 88  C              diagnostic storage qdiag Line 93  C              diagnostic storage qdiag
93        CHARACTER*(5) ctmp        CHARACTER*(5) ctmp
94        _RS ztmp(NrMax)        _RS ztmp(NrMax)
95  #endif  #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    #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 131  C       beginning and ending times for e Line 164  C       beginning and ending times for e
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)
# Line 189  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 202  C---+----1----+----2----+----3----+----4 Line 245  C---+----1----+----2----+----3----+----4
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          mate = 0          mate = 0
250          mVec = 0          mVec = 0
251          IF ( parms1(5:5).EQ.'C' ) THEN          IF ( gcode(5:5).EQ.'C' ) THEN
252  C-      Check for Mate of a Counter Diagnostic  C-      Check for Mate of a Counter Diagnostic
253             READ(parms1,'(5X,I3)') mate             mate = hdiag(ndId)
254          ELSEIF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN          ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN
255  C-      Check for Mate of a Vector Diagnostic  C-      Check for Mate of a Vector Diagnostic
256             READ(parms1,'(5X,I3)') mVec             mVec = hdiag(ndId)
257          ENDIF          ENDIF
258          IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN          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)           DO lm=1,averageCycle(listId)
261    
# Line 229  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              IF ( averageCycle(listId).GT.1 ) THEN              IF ( averageCycle(listId).GT.1 ) THEN
281               WRITE(msgBuf,'(A,2(I2,A))')               WRITE(msgBuf,'(A,2(I3,A))')
282       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
283       &                                            ndiag(ip,1,1), ' )'       &                                            ndiag(ip,1,1), ' )'
284              ELSE              ELSE
285               WRITE(msgBuf,'(A,2(I2,A))')               WRITE(msgBuf,'(A,2(I3,A))')
286       &        '- WARNING -   has not been filled (ndiag=',       &        '- WARNING -   has not been filled (ndiag=',
287       &                                            ndiag(ip,1,1), ' )'       &                                            ndiag(ip,1,1), ' )'
288              ENDIF              ENDIF
# Line 266  C-        Empty diagnostics case : Line 309  C-        Empty diagnostics case :
309  C-        diagnostics is not empty :  C-        diagnostics is not empty :
310    
311              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN
312                WRITE(ioUnit,'(A,I3,3A,I8,2A)')                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                IF ( mate.GT.0 ) THEN
316                 WRITE(ioUnit,'(3A,I3,2A)')                 WRITE(ioUnit,'(3A,I6,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                ELSEIF ( mVec.GT.0 ) THEN
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                   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                   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 433  C           Time dimension Line 476  C           Time dimension
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  C           Per the observations of Baylor, this has been commented out  C     Missing values only for scalar diagnostics at mass points (so far)
480  C           until we have code that can write missing_value attributes              useMisValForThisDiag = useMissingValue
481  C           in a way thats compatible with most of the more popular       &           .AND.gdiag(ndId)(1:2).EQ.'SM'
482  C           netCDF tools including ferret.  Using all-zeros completely              IF ( useMisValForThisDiag ) THEN
483  C           breaks ferret.  C     assign missing values and set flag for adding the netCDF atttibute
484                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,
485  C           CALL MNC_CW_ADD_VATTR_DBL(cdiag(ndId),'missing_value',       I            misval_r8, misval_r4, misval_int,
486  C           &             0.0 _d 0,myThid)       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)              IF ( ( (writeBinaryPrec .EQ. precFloat32)
514       &           .AND. (fflags(listId)(1:1) .NE. 'D')       &           .AND. (fflags(listId)(1:1) .NE. 'D')
Legend:
Removed from v.1.34  
changed lines
  Added in v.1.40
  ViewVC Help
Powered by ViewVC 1.1.22