/[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.42 by jmc, Tue Aug 4 18:00:29 2009 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*10 gcode        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 73  C              diagnostic storage qdiag Line 78  C              diagnostic storage qdiag
78        INTEGER prec, nRec        INTEGER prec, nRec
79  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
80        LOGICAL glf        LOGICAL glf
81          _RL timeRec(1)
82  #endif  #endif
83  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
84          INTEGER ll, llMx, jj, jjMx
85        INTEGER ii        INTEGER ii
86        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
87        INTEGER CW_DIMS, NLEN        INTEGER CW_DIMS, NLEN
# Line 88  C              diagnostic storage qdiag Line 95  C              diagnostic storage qdiag
95        CHARACTER*(5) ctmp        CHARACTER*(5) ctmp
96        _RS ztmp(NrMax)        _RS ztmp(NrMax)
97  #endif  #endif
98          LOGICAL useMissingValue, useMisValForThisDiag
99          REAL*8 misvalLoc
100          REAL*8 misval_r8(2)
101          REAL*4 misval_r4(2)
102          INTEGER misvalIntLoc, misval_int(2)
103  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
104    
105  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
106    
107        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
108          undef = UNSET_RL
109    #ifdef ALLOW_FIZHI
110    c     IF ( useFIZHI ) undef = getcon('UNDEF')
111        undef = getcon('UNDEF')        undef = getcon('UNDEF')
112    #endif
113        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
114        ilen = ILNBLNK(fnames(listId))        ilen = ILNBLNK(fnames(listId))
115        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)
116    
117  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
118    C-- this is a trick to reverse the order of the loops on md (= field)
119    C   and lm (= averagePeriod): binary output: lm loop inside md loop ;
120    C                                 mnc ouput: md loop inside lm loop.
121        IF (useMNC .AND. diag_mnc) THEN        IF (useMNC .AND. diag_mnc) THEN
122          DO i = 1,MAX_LEN_FNAM          jjMx = averageCycle(listId)
123            diag_mnc_bn(i:i) = ' '          llMx = 1
124          ENDDO        ELSE
125          DO i = 1,NLEN          jjMx = 1
126            dn_blnk(i:i) = ' '          llMx = averageCycle(listId)
127          ENDDO        ENDIF
128          WRITE( diag_mnc_bn, '(A)' ) fnames(listId)(1:ilen)        DO jj=1,jjMx
129    
130           IF (useMNC .AND. diag_mnc) THEN
131    C     Handle missing value attribute (land points)
132             useMissingValue = .FALSE.
133    #ifdef DIAGNOSTICS_MISSING_VALUE
134             useMissingValue = .TRUE.
135    #endif /* DIAGNOSTICS_MISSING_VALUE */
136             IF ( misvalFlt(listId) .NE. UNSET_RL ) THEN
137              misvalLoc = misvalFlt(listId)
138             ELSE
139              misvalLoc = undef
140             ENDIF
141    C     Defaults to UNSET_I
142             misvalIntLoc = misvalInt(listId)
143             DO ii=1,2
144    C         misval_r4(ii)  = UNSET_FLOAT4
145    C         misval_r8(ii)  = UNSET_FLOAT8
146              misval_r4(ii)  = misvalLoc
147              misval_r8(ii)  = misvalLoc
148              misval_int(ii) = UNSET_I
149             ENDDO
150             DO i = 1,MAX_LEN_FNAM
151               diag_mnc_bn(i:i) = ' '
152             ENDDO
153             DO i = 1,NLEN
154               dn_blnk(i:i) = ' '
155             ENDDO
156             WRITE( diag_mnc_bn, '(A)' ) fnames(listId)(1:ilen)
157    
158  C       Update the record dimension by writing the iteration number  C       Update the record dimension by writing the iteration number
159          CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)           klev = myIter + jj - jjMx
160          CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)           tmpLev = myTime + deltaTClock*(jj -jjMx)
161          CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)           CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)
162          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)
163             CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)
164             CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',klev,myThid)
165    
166  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
167  C       variable that has dimension (2,T) and clearly denotes the  C       variable that has dimension (2,T) and clearly denotes the
168  C       beginning and ending times for each diagnostics period  C       beginning and ending times for each diagnostics period
169    
170          dn(1)(1:NLEN) = dn_blnk(1:NLEN)           dn(1)(1:NLEN) = dn_blnk(1:NLEN)
171          WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listId)           WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listId)
172          dim(1) = nlevels(listId)           dim(1) = nlevels(listId)
173          ib(1)  = 1           ib(1)  = 1
174          ie(1)  = nlevels(listId)           ie(1)  = nlevels(listId)
175    
176          CALL MNC_CW_ADD_GNAME('diag_levels', 1,           CALL MNC_CW_ADD_GNAME('diag_levels', 1,
177       &       dim, dn, ib, ie, myThid)       &        dim, dn, ib, ie, myThid)
178          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',           CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
179       &       0,0, myThid)       &        0,0, myThid)
180          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',           CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
181       &       'Idicies of vertical levels within the source arrays',       &        'Idicies of vertical levels within the source arrays',
182       &       myThid)       &        myThid)
183    C     suppress the missing value attribute (iflag = 0)
184             IF (useMissingValue)
185         &       CALL MNC_CW_VATTR_MISSING('diag_levels', 0,
186         I       misval_r8, misval_r4, misval_int,
187         I       myThid )
188    
189          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,           CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
190       &       'diag_levels', levs(1,listId), myThid)       &        'diag_levels', levs(1,listId), myThid)
191    
192          CALL MNC_CW_DEL_VNAME('diag_levels', myThid)           CALL MNC_CW_DEL_VNAME('diag_levels', myThid)
193          CALL MNC_CW_DEL_GNAME('diag_levels', myThid)           CALL MNC_CW_DEL_GNAME('diag_levels', myThid)
194    
195  #ifdef DIAG_MNC_COORD_NEEDSWORK  #ifdef DIAG_MNC_COORD_NEEDSWORK
196  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 206  C       as: Z[uml]td000000 where the 't'
206  C       gdiag(10)  C       gdiag(10)
207    
208  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx  C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx
209          ctmp(1:5) = 'mul  '           ctmp(1:5) = 'mul  '
210          DO i = 1,3           DO i = 1,3
211            dn(1)(1:NLEN) = dn_blnk(1:NLEN)             dn(1)(1:NLEN) = dn_blnk(1:NLEN)
212            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)
213            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)
214            CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)             CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)
215    
216  C         The following three ztmp() loops should eventually be modified  C         The following three ztmp() loops should eventually be modified
217  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 221  C                      + ( rC(INT(FLOOR(
221  C                          + rC(INT(CEIL(levs(j,l)))) )  C                          + rC(INT(CEIL(levs(j,l)))) )
222  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )
223  C         for averaged levels.  C         for averaged levels.
224            IF (i .EQ. 1) THEN             IF (i .EQ. 1) THEN
225              DO j = 1,nlevels(listId)               DO j = 1,nlevels(listId)
226                ztmp(j) = rC(NINT(levs(j,listId)))                 ztmp(j) = rC(NINT(levs(j,listId)))
227              ENDDO               ENDDO
228              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',               CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
229       &           'Dimensional coordinate value at the mid point',       &            'Dimensional coordinate value at the mid point',
230       &           myThid)       &            myThid)
231            ELSEIF (i .EQ. 2) THEN             ELSEIF (i .EQ. 2) THEN
232              DO j = 1,nlevels(listId)               DO j = 1,nlevels(listId)
233                ztmp(j) = rF(NINT(levs(j,listId)) + 1)                 ztmp(j) = rF(NINT(levs(j,listId)) + 1)
234              ENDDO               ENDDO
235              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',               CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
236       &           'Dimensional coordinate value at the upper point',       &            'Dimensional coordinate value at the upper point',
237       &           myThid)       &            myThid)
238            ELSEIF (i .EQ. 3) THEN             ELSEIF (i .EQ. 3) THEN
239              DO j = 1,nlevels(listId)               DO j = 1,nlevels(listId)
240                ztmp(j) = rF(NINT(levs(j,listId)))                 ztmp(j) = rF(NINT(levs(j,listId)))
241              ENDDO               ENDDO
242              CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',               CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',
243       &           'Dimensional coordinate value at the lower point',       &            'Dimensional coordinate value at the lower point',
244       &           myThid)       &            myThid)
245            ENDIF             ENDIF
246            CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)  C     suppress the missing value attribute (iflag = 0)
247            CALL MNC_CW_DEL_VNAME(dn(1), myThid)             IF (useMissingValue)
248            CALL MNC_CW_DEL_GNAME(dn(1), myThid)       &          CALL MNC_CW_VATTR_MISSING(dn(1), 0,
249          ENDDO       I          misval_r8, misval_r4, misval_int,
250         I          myThid )
251               CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)
252               CALL MNC_CW_DEL_VNAME(dn(1), myThid)
253               CALL MNC_CW_DEL_GNAME(dn(1), myThid)
254             ENDDO
255  #endif /*  DIAG_MNC_COORD_NEEDSWORK  */  #endif /*  DIAG_MNC_COORD_NEEDSWORK  */
256    
257        ENDIF         ENDIF
258  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
259    
260  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
261    
262        DO md = 1,nfields(listId)         DO md = 1,nfields(listId)
263          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
264          gcode = gdiag(ndId)(1:10)          gcode = gdiag(ndId)(1:10)
265          mate = 0          mate = 0
# Line 210  C-      Check for Mate of a Counter Diag Line 269  C-      Check for Mate of a Counter Diag
269             mate = hdiag(ndId)             mate = hdiag(ndId)
270          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
271  C-      Check for Mate of a Vector Diagnostic  C-      Check for Mate of a Vector Diagnostic
272             mate = hdiag(ndId)             mVec = hdiag(ndId)
273          ENDIF          ENDIF
274          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
275  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
276    #ifdef ALLOW_MNC
277             DO ll=1,llMx
278              lm = jj+ll-1
279    #else
280           DO lm=1,averageCycle(listId)           DO lm=1,averageCycle(listId)
281    #endif
282    
283            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
284            im = mdiag(md,listId)            im = mdiag(md,listId)
# Line 433  C           Time dimension Line 497  C           Time dimension
497              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',
498       &             udiag(ndId),myThid)       &             udiag(ndId),myThid)
499    
500  C           Per the observations of Baylor, this has been commented out  C     Missing values only for scalar diagnostics at mass points (so far)
501  C           until we have code that can write missing_value attributes              useMisValForThisDiag = useMissingValue
502  C           in a way thats compatible with most of the more popular       &           .AND.gdiag(ndId)(1:2).EQ.'SM'
503  C           netCDF tools including ferret.  Using all-zeros completely              IF ( useMisValForThisDiag ) THEN
504  C           breaks ferret.  C     assign missing values and set flag for adding the netCDF atttibute
505                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,
506  C           CALL MNC_CW_ADD_VATTR_DBL(cdiag(ndId),'missing_value',       I            misval_r8, misval_r4, misval_int,
507  C           &             0.0 _d 0,myThid)       I            myThid )
508    C     and now use the missing values for masking out the land points
509              IF ( ( (writeBinaryPrec .EQ. precFloat32)               DO bj = myByLo(myThid), myByHi(myThid)
510       &           .AND. (fflags(listId)(1:1) .NE. 'D')                DO bi = myBxLo(myThid), myBxHi(myThid)
511       &           .AND. (fflags(listId)(1:1) .NE. 'R') )                 DO k = 1,nlevels(listId)
512       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN                  klev = NINT(levs(k,listId))
513                    DO j = 1-OLy,sNy+OLy
514                     DO i = 1-OLx,sNx+OLx
515                      IF ( _hFacC(I,J,klev,bi,bj) .EQ. 0. )
516         &                 qtmp1(i,j,k,bi,bj) = misvalLoc
517                     ENDDO
518                    ENDDO
519                   ENDDO
520                  ENDDO
521                 ENDDO
522                ELSE
523    C     suppress the missing value attribute (iflag = 0)
524    C     Note: We have to call the following subroutine for each mnc that has
525    C     been created "on the fly" by mnc_cw_add_vname and will be deleted
526    C     by mnc_cw_del_vname, because all of these variables use the same
527    C     identifier so that mnc_cw_vfmv(indv) needs to be overwritten for
528    C     each of these variables
529                 CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 0,
530         I            misval_r8, misval_r4, misval_int,
531         I            myThid )
532                ENDIF
533    
534                IF (  ((writeBinaryPrec .EQ. precFloat32)
535         &            .AND. (fflags(listId)(1:1) .NE. 'D'))
536         &             .OR. (fflags(listId)(1:1) .EQ. 'R') ) THEN
537                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
538       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
539              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
# Line 462  C           &             0.0 _d 0,myThi Line 550  C           &             0.0 _d 0,myThi
550            ENDIF            ENDIF
551  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
552    
553    C--      end loop on lm (or ll if ALLOW_MNC) counter
554           ENDDO           ENDDO
555  C--     end of Processing Fld # md  C--     end of Processing Fld # md
556          ENDIF          ENDIF
557           ENDDO
558    
559    #ifdef ALLOW_MNC
560    C--   end loop on jj counter
561        ENDDO        ENDDO
562    #endif
563    
564  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
565        IF (diag_mdsio) THEN        IF (diag_mdsio) THEN
# Line 474  C     all MDSIO S/R, uses instead this s Line 568  C     all MDSIO S/R, uses instead this s
568  C     meta files but with more informations in it.  C     meta files but with more informations in it.
569              glf = globalFiles              glf = globalFiles
570              nRec = nfields(listId)*averageCycle(listId)              nRec = nfields(listId)*averageCycle(listId)
571                timeRec(1) = myTime
572              CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,              CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
573       &              0, 0, nlevels(listId), ' ',       &              0, 0, nlevels(listId), ' ',
574       &              nfields(listId), flds(1,listId), 1, myTime,       &              nfields(listId), flds(1,listId), 1, timeRec,
575       &              nRec, myIter, myThid)       &              nRec, myIter, myThid)
576        ENDIF        ENDIF
577  #endif /*  ALLOW_MDSIO  */  #endif /*  ALLOW_MDSIO  */
Legend:
Removed from v.1.35  
changed lines
  Added in v.1.42
  ViewVC Help
Powered by ViewVC 1.1.22