/[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.30 by jmc, Sun Dec 24 20:15:42 2006 UTC revision 1.39 by mlosch, Tue May 27 08:37:19 2008 UTC
# Line 27  C     !USES: Line 27  C     !USES:
27  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
28    
29        INTEGER NrMax        INTEGER NrMax
30  #ifdef ALLOW_FIZHI        PARAMETER( NrMax = numLevels )
 #include "fizhi_SIZE.h"  
       PARAMETER( NrMax = Nr+Nrphys )  
 #else  
       PARAMETER( NrMax = Nr )  
 #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 52  C     ndId  :: diagnostics  Id number (i Line 46  C     ndId  :: diagnostics  Id number (i
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, lm  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
       _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)  
62        _RL undef, getcon        _RL undef, getcon
63        _RL tmpLev        _RL tmpLev
64        EXTERNAL getcon        EXTERNAL getcon
# Line 69  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  #ifdef ALLOW_MDSIO
75        LOGICAL glf        LOGICAL glf
       INTEGER nRec  
       INTEGER prec  
76  #endif  #endif
77  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
78        INTEGER ii        INTEGER ii
# Line 88  C     im    :: counter-mate pointer to s Line 88  C     im    :: counter-mate pointer to s
88        CHARACTER*(5) ctmp        CHARACTER*(5) ctmp
89        _RS ztmp(NrMax)        _RS ztmp(NrMax)
90  #endif  #endif
91          LOGICAL useMissingValue, useMisValForThisDiag
92          REAL*8 misvalLoc
93          REAL*8 misval_r8(2)
94          REAL*4 misval_r4(2)
95          INTEGER misvalIntLoc, misval_int(2)
96  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
97    
98  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
# Line 100  C---+----1----+----2----+----3----+----4 Line 105  C---+----1----+----2----+----3----+----4
105    
106  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
107        IF (useMNC .AND. diag_mnc) THEN        IF (useMNC .AND. diag_mnc) THEN
108    C     Handle missing value attribute (land points)
109           useMissingValue = .FALSE.
110    #ifdef DIAGNOSTICS_MISSING_VALUE
111           useMissingValue = .TRUE.
112    #endif /* DIAGNOSTICS_MISSING_VALUE */
113           IF ( misvalFlt(listId) .NE. UNSET_RL ) THEN
114            misvalLoc = misvalFlt(listId)
115           ELSE
116            misvalLoc = undef
117           ENDIF
118    C     Defaults to UNSET_I
119           misvalIntLoc = misvalInt(listId)
120           DO ii=1,2
121    C       misval_r4(ii)  = UNSET_FLOAT4
122    C       misval_r8(ii)  = UNSET_FLOAT8
123            misval_r4(ii)  = misvalLoc
124            misval_r8(ii)  = misvalLoc
125            misval_int(ii) = UNSET_I
126           ENDDO
127          DO i = 1,MAX_LEN_FNAM          DO i = 1,MAX_LEN_FNAM
128            diag_mnc_bn(i:i) = ' '            diag_mnc_bn(i:i) = ' '
129          ENDDO          ENDDO
# Line 131  C       beginning and ending times for e Line 155  C       beginning and ending times for e
155          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
156       &       'Idicies of vertical levels within the source arrays',       &       'Idicies of vertical levels within the source arrays',
157       &       myThid)       &       myThid)
158    C     suppress the missing value attribute (iflag = 0)
159            IF (useMissingValue)
160         &       CALL MNC_CW_VATTR_MISSING('diag_levels', 0,
161         I       misval_r8, misval_r4, misval_int,
162         I       myThid )
163    
164          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
165       &       'diag_levels', levs(1,listId), myThid)       &       'diag_levels', levs(1,listId), myThid)
# Line 189  C         for averaged levels. Line 218  C         for averaged levels.
218       &           'Dimensional coordinate value at the lower point',       &           'Dimensional coordinate value at the lower point',
219       &           myThid)       &           myThid)
220            ENDIF            ENDIF
221    C     suppress the missing value attribute (iflag = 0)
222              IF (useMissingValue)
223         &         CALL MNC_CW_VATTR_MISSING(dn(1), 0,
224         I         misval_r8, misval_r4, misval_int,
225         I         myThid )
226            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)
227            CALL MNC_CW_DEL_VNAME(dn(1), myThid)            CALL MNC_CW_DEL_VNAME(dn(1), myThid)
228            CALL MNC_CW_DEL_GNAME(dn(1), myThid)            CALL MNC_CW_DEL_GNAME(dn(1), myThid)
# Line 202  C---+----1----+----2----+----3----+----4 Line 236  C---+----1----+----2----+----3----+----4
236    
237        DO md = 1,nfields(listId)        DO md = 1,nfields(listId)
238          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
239          parms1 = gdiag(ndId)(1:8)          gcode = gdiag(ndId)(1:10)
240          mate = 0          mate = 0
241          mVec = 0          mVec = 0
242          IF ( parms1(5:5).EQ.'C' ) THEN          IF ( gcode(5:5).EQ.'C' ) THEN
243  C-      Check for Mate of a Counter Diagnostic  C-      Check for Mate of a Counter Diagnostic
244             READ(parms1,'(5X,I3)') mate             mate = hdiag(ndId)
245          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
246  C-      Check for Mate of a Vector Diagnostic  C-      Check for Mate of a Vector Diagnostic
247             READ(parms1,'(5X,I3)') mVec             mVec = hdiag(ndId)
248          ENDIF          ENDIF
249          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
250  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
251           DO lm=1,averageCycle(listId)           DO lm=1,averageCycle(listId)
252    
# Line 229  C-        Empty diagnostics case : Line 263  C-        Empty diagnostics case :
263       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
264              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
265       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
266              WRITE(msgBuf,'(A,I4,3A,I3,2A)')              WRITE(msgBuf,'(A,I6,3A,I4,2A)')
267       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),
268       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
269              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
270       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
271              IF ( averageCycle(listId).GT.1 ) THEN              IF ( averageCycle(listId).GT.1 ) THEN
272               WRITE(msgBuf,'(A,2(I2,A))')               WRITE(msgBuf,'(A,2(I3,A))')
273       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
274       &                                            ndiag(ip,1,1), ' )'       &                                            ndiag(ip,1,1), ' )'
275              ELSE              ELSE
276               WRITE(msgBuf,'(A,2(I2,A))')               WRITE(msgBuf,'(A,2(I3,A))')
277       &        '- WARNING -   has not been filled (ndiag=',       &        '- WARNING -   has not been filled (ndiag=',
278       &                                            ndiag(ip,1,1), ' )'       &                                            ndiag(ip,1,1), ' )'
279              ENDIF              ENDIF
# Line 266  C-        Empty diagnostics case : Line 300  C-        Empty diagnostics case :
300  C-        diagnostics is not empty :  C-        diagnostics is not empty :
301    
302              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN
303                WRITE(ioUnit,'(A,I3,3A,I8,2A)')                WRITE(ioUnit,'(A,I6,3A,I8,2A)')
304       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
305       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
306                IF ( mate.GT.0 ) THEN                IF ( mate.GT.0 ) THEN
307                 WRITE(ioUnit,'(3A,I3,2A)')                 WRITE(ioUnit,'(3A,I6,2A)')
308       &         '       use Counter Mate for  ', cdiag(ndId),       &         '       use Counter Mate for  ', cdiag(ndId),
309       &         '     Diagnostic # ',mate, '  ', cdiag(mate)       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
310                ELSEIF ( mVec.GT.0 ) THEN                ELSEIF ( mVec.GT.0 ) THEN
311                  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
312                   WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
313       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
314       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
315       &             ' exists '       &             ' exists '
316                  ELSE                  ELSE
317                   WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
318       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
319       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
320       &             ' not enabled'       &             ' not enabled'
# Line 337  C jmc: for now, this can only work in an Line 371  C jmc: for now, this can only work in an
371             ENDIF             ENDIF
372            ENDIF            ENDIF
373    
374  #ifdef ALLOW_MDSIO  C--    Ready to write field "md", element "lm" in averageCycle(listId)
375  C         Prepare for mdsio optionality  
376            IF (diag_mdsio) THEN  C-        write to binary file, using MDSIO pkg:
377              glf = globalFiles            IF ( diag_mdsio ) THEN
378              nRec = lm + (md-1)*averageCycle(listId)              nRec = lm + (md-1)*averageCycle(listId)
379  C           default precision for output files  C           default precision for output files
380              prec = writeBinaryPrec              prec = writeBinaryPrec
381  C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision  C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
382              IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32              IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
383              IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64              IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
384              CALL MDSWRITEFIELD_NEW(fn,prec,glf,.FALSE.,'RL',  C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
385       &              NrMax,nlevels(listId),qtmp1,nRec,myIter,myThid)              CALL WRITE_REC_LEV_RL(
386         I                            fn, prec,
387         I                            NrMax, 1, nlevels(listId),
388         I                            qtmp1, -nRec, myIter, myThid )
389            ENDIF            ENDIF
 #endif /*  ALLOW_MDSIO  */  
390    
391  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
392            IF (useMNC .AND. diag_mnc) THEN            IF (useMNC .AND. diag_mnc) THEN
# Line 431  C           Time dimension Line 467  C           Time dimension
467              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
468       &             udiag(ndId),myThid)       &             udiag(ndId),myThid)
469    
470  C           Per the observations of Baylor, this has been commented out  C     Missing values only for scalar diagnostics at mass points (so far)
471  C           until we have code that can write missing_value attributes              useMisValForThisDiag = useMissingValue
472  C           in a way thats compatible with most of the more popular       &           .AND.gdiag(ndId)(1:2).EQ.'SM'
473  C           netCDF tools including ferret.  Using all-zeros completely              IF ( useMisValForThisDiag ) THEN
474  C           breaks ferret.  C     assign missing values and set flag for adding the netCDF atttibute
475                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,
476  C           CALL MNC_CW_ADD_VATTR_DBL(cdiag(ndId),'missing_value',       I            misval_r8, misval_r4, misval_int,
477  C           &             0.0 _d 0,myThid)       I            myThid )
478    C     and now use the missing values for masking out the land points
479                 DO bj = myByLo(myThid), myByHi(myThid)
480                  DO bi = myBxLo(myThid), myBxHi(myThid)
481                   DO k = 1,nlevels(listId)
482                    klev = NINT(levs(k,listId))
483                    DO j = 1-OLy,sNy+OLy
484                     DO i = 1-OLx,sNx+OLx
485                      IF ( _hFacC(I,J,klev,bi,bj) .EQ. 0. )
486         &                 qtmp1(i,j,k,bi,bj) = misvalLoc
487                     ENDDO
488                    ENDDO
489                   ENDDO
490                  ENDDO
491                 ENDDO
492                ELSE
493    C     suppress the missing value attribute (iflag = 0)
494    C     Note: We have to call the following subroutine for each mnc that has
495    C     been created "on the fly" by mnc_cw_add_vname and will be deleted
496    C     by mnc_cw_del_vname, because all of these variables use the same
497    C     identifier so that mnc_cw_vfmv(indv) needs to be overwritten for
498    C     each of these variables
499                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 0,
500         I            misval_r8, misval_r4, misval_int,
501         I            myThid )
502                ENDIF
503    
504              IF ( ( (writeBinaryPrec .EQ. precFloat32)              IF ( ( (writeBinaryPrec .EQ. precFloat32)
505       &           .AND. (fflags(listId)(1:1) .NE. 'D')       &           .AND. (fflags(listId)(1:1) .NE. 'D')
# Line 465  C--     end of Processing Fld # md Line 526  C--     end of Processing Fld # md
526          ENDIF          ENDIF
527        ENDDO        ENDDO
528    
529    #ifdef ALLOW_MDSIO
530          IF (diag_mdsio) THEN
531    C-    Note: temporary: since it's a pain to add more arguments to
532    C     all MDSIO S/R, uses instead this specific S/R to write only
533    C     meta files but with more informations in it.
534                glf = globalFiles
535                nRec = nfields(listId)*averageCycle(listId)
536                CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
537         &              0, 0, nlevels(listId), ' ',
538         &              nfields(listId), flds(1,listId), 1, myTime,
539         &              nRec, myIter, myThid)
540          ENDIF
541    #endif /*  ALLOW_MDSIO  */
542    
543        RETURN        RETURN
544        END        END
545    
Legend:
Removed from v.1.30  
changed lines
  Added in v.1.39
  ViewVC Help
Powered by ViewVC 1.1.22