/[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.31 by jmc, Fri Dec 29 05:43:56 2006 UTC revision 1.52 by jmc, Sun Jun 12 19:16:09 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,
      I     myIter,  
13       I     myTime,       I     myTime,
14         I     myIter,
15       I     myThid )       I     myThid )
16    
17  C     !DESCRIPTION:  C     !DESCRIPTION:
# 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 44  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
60    C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)
61    C     qtmp1 :: temporary array; used to store a copy of diag. output field.
62    C     qtmp2 :: temporary array; used to store a copy of a 2nd diag. field.
63    C-  Note: local common block no longer needed.
64    c     COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1
65          _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
66          _RL qtmp2(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
67    
68        INTEGER i, j, k, lm        INTEGER i, j, k, lm
69        INTEGER bi, bj        INTEGER bi, bj
70        INTEGER md, ndId, ip, im        INTEGER md, ndId, ip, im
71        INTEGER mate, mVec        INTEGER mate, mVec
72        CHARACTER*8 parms1        CHARACTER*10 gcode
73        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)        _RL undefRL
74        _RL undef, getcon        INTEGER nLevOutp, kLev
       _RL tmpLev  
       EXTERNAL getcon  
       INTEGER ILNBLNK  
       EXTERNAL ILNBLNK  
       INTEGER ilen  
75    
76          INTEGER iLen
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, nTimRec
82          _RL     timeRec(2)
83          _RL     tmpLoc
84  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
85        LOGICAL glf        LOGICAL glf
       INTEGER nRec  
       INTEGER prec  
86  #endif  #endif
87  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
88        INTEGER ii        INTEGER ll, llMx, jj, jjMx
89        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
90        INTEGER CW_DIMS, NLEN        LOGICAL useMissingValue
91        PARAMETER ( CW_DIMS = 10 )        REAL*8 misValLoc
       PARAMETER ( NLEN    = 80 )  
       INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)  
       CHARACTER*(NLEN) dn(CW_DIMS)  
       CHARACTER*(NLEN) d_cw_name  
       CHARACTER*(NLEN) dn_blnk  
 #ifdef DIAG_MNC_COORD_NEEDSWORK  
       CHARACTER*(5) ctmp  
       _RS ztmp(NrMax)  
 #endif  
92  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
93    
94  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
95    
96    C---  set file properties
97        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
98        undef = getcon('UNDEF')        undefRL = UNSET_RL
99    #ifdef ALLOW_FIZHI
100          IF ( useFIZHI ) undefRL = getcon('UNDEF')
101    #endif
102        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
103        ilen = ILNBLNK(fnames(listId))        iLen = ILNBLNK(fnames(listId))
104        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:iLen),'.',suff(1:10)
105    C-    for now, if integrate vertically, output field has just 1 level:
106          nLevOutp = nlevels(listId)
107          IF ( fflags(listId)(2:2).EQ.'I' ) nLevOutp = 1
108    
109    C--   Set time information:
110          IF ( freq(listId).LT.0. ) THEN
111    C-    Snap-shot: store a unique time (which is consistent with State-Var timing)
112            nTimRec = 1
113            timeRec(1) = myTime
114          ELSE
115    C-    Time-average: store the 2 edges of the time-averaging interval.
116    C      this time is consitent with intermediate Var (i.e., non-state, e.g, flux,
117    C      tendencies) timing. For State-Var, this is shifted by + halt time-step.
118            nTimRec = 2
119    
120    C-    end of time-averaging interval:
121            timeRec(2) = myTime
122    
123    C-    begining of time-averaging interval:
124    c       timeRec(1) = myTime - freq(listId)
125    C     a) find the time of the previous multiple of output freq:
126            timeRec(1) = myTime-deltaTClock*0.5 _d 0
127            timeRec(1) = (timeRec(1)-phase(listId))/freq(listId)
128            i = INT( timeRec(1) )
129            IF ( timeRec(1).LT.0. ) THEN
130              tmpLoc = FLOAT(i)
131              IF ( timeRec(1).NE.tmpLoc ) i = i - 1
132            ENDIF
133            timeRec(1) = phase(listId) + freq(listId)*FLOAT(i)
134    c       if ( listId.eq.2 ) write(0,*) 'f',i,timeRec(1)/deltaTClock
135            timeRec(1) = MAX( timeRec(1), startTime )
136    
137    C     b) round off to nearest multiple of time-step:
138            timeRec(1) = (timeRec(1)-baseTime)/deltaTClock
139            i = NINT( timeRec(1) )
140    C     if just half way, NINT will return the next time-step: correct this
141            tmpLoc = FLOAT(i) - 0.5 _d 0
142            IF ( timeRec(1).EQ.tmpLoc ) i = i - 1
143            timeRec(1) = baseTime + deltaTClock*FLOAT(i)
144    c       if ( listId.eq.2 ) write(0,*) i,timeRec(1)/deltaTClock
145          ENDIF
146    C--   Convert time to iteration number (debug)
147    c     DO i=1,nTimRec
148    c       timeRec(i) = timeRec(i)/deltaTClock
149    c     ENDDO
150    
151  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
152    C-- this is a trick to reverse the order of the loops on md (= field)
153    C   and lm (= averagePeriod): binary output: lm loop inside md loop ;
154    C                                 mnc ouput: md loop inside lm loop.
155        IF (useMNC .AND. diag_mnc) THEN        IF (useMNC .AND. diag_mnc) THEN
156          DO i = 1,MAX_LEN_FNAM          jjMx = averageCycle(listId)
157            diag_mnc_bn(i:i) = ' '          llMx = 1
158          ENDDO        ELSE
159          DO i = 1,NLEN          jjMx = 1
160            dn_blnk(i:i) = ' '          llMx = averageCycle(listId)
         ENDDO  
         WRITE( diag_mnc_bn, '(A)' ) fnames(listId)(1:ilen)  
   
 C       Update the record dimension by writing the iteration number  
         CALL MNC_CW_SET_UDIM(diag_mnc_bn, -1, myThid)  
         CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)  
         CALL MNC_CW_SET_UDIM(diag_mnc_bn, 0, myThid)  
         CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)  
   
 C       NOTE: at some point it would be a good idea to add a time_bounds  
 C       variable that has dimension (2,T) and clearly denotes the  
 C       beginning and ending times for each diagnostics period  
   
         dn(1)(1:NLEN) = dn_blnk(1:NLEN)  
         WRITE(dn(1),'(a,i6.6)') 'Zmd', nlevels(listId)  
         dim(1) = nlevels(listId)  
         ib(1)  = 1  
         ie(1)  = nlevels(listId)  
   
         CALL MNC_CW_ADD_GNAME('diag_levels', 1,  
      &       dim, dn, ib, ie, myThid)  
         CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',  
      &       0,0, myThid)  
         CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',  
      &       'Idicies of vertical levels within the source arrays',  
      &       myThid)  
   
         CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,  
      &       'diag_levels', levs(1,listId), myThid)  
   
         CALL MNC_CW_DEL_VNAME('diag_levels', myThid)  
         CALL MNC_CW_DEL_GNAME('diag_levels', myThid)  
   
 #ifdef DIAG_MNC_COORD_NEEDSWORK  
 C       This part has been placed in an #ifdef because, as its currently  
 C       written, it will only work with variables defined on a dynamics  
 C       grid.  As we start using diagnostics for physics grids, ice  
 C       levels, land levels, etc. the different vertical coordinate  
 C       dimensions will have to be taken into account.  
   
 C       20051021 JMC & EH3 : We need to extend this so that a few  
 C       variables each defined on different grids do not have the same  
 C       vertical dimension names so we should be using a pattern such  
 C       as: Z[uml]td000000 where the 't' is the type as specified by  
 C       gdiag(10)  
   
 C       Now define:  Zmdxxxxxx, Zudxxxxxx, Zldxxxxxx  
         ctmp(1:5) = 'mul  '  
         DO i = 1,3  
           dn(1)(1:NLEN) = dn_blnk(1:NLEN)  
           WRITE(dn(1),'(3a,i6.6)') 'Z',ctmp(i:i),'d',nlevels(listId)  
           CALL MNC_CW_ADD_GNAME(dn(1), 1, dim, dn, ib, ie, myThid)  
           CALL MNC_CW_ADD_VNAME(dn(1), dn(1), 0,0, myThid)  
   
 C         The following three ztmp() loops should eventually be modified  
 C         to reflect the fractional nature of levs(j,l) -- they should  
 C         do something like:  
 C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))  
 C                      + ( rC(INT(FLOOR(levs(j,l))))  
 C                          + rC(INT(CEIL(levs(j,l)))) )  
 C                        / ( levs(j,l) - FLOOR(levs(j,l)) )  
 C         for averaged levels.  
           IF (i .EQ. 1) THEN  
             DO j = 1,nlevels(listId)  
               ztmp(j) = rC(NINT(levs(j,listId)))  
             ENDDO  
             CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',  
      &           'Dimensional coordinate value at the mid point',  
      &           myThid)  
           ELSEIF (i .EQ. 2) THEN  
             DO j = 1,nlevels(listId)  
               ztmp(j) = rF(NINT(levs(j,listId)) + 1)  
             ENDDO  
             CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',  
      &           'Dimensional coordinate value at the upper point',  
      &           myThid)  
           ELSEIF (i .EQ. 3) THEN  
             DO j = 1,nlevels(listId)  
               ztmp(j) = rF(NINT(levs(j,listId)))  
             ENDDO  
             CALL MNC_CW_ADD_VATTR_TEXT(dn(1),'description',  
      &           'Dimensional coordinate value at the lower point',  
      &           myThid)  
           ENDIF  
           CALL MNC_CW_RS_W('D',diag_mnc_bn,0,0, dn(1), ztmp, myThid)  
           CALL MNC_CW_DEL_VNAME(dn(1), myThid)  
           CALL MNC_CW_DEL_GNAME(dn(1), myThid)  
         ENDDO  
 #endif /*  DIAG_MNC_COORD_NEEDSWORK  */  
   
161        ENDIF        ENDIF
162          DO jj=1,jjMx
163    
164           IF (useMNC .AND. diag_mnc) THEN
165             misValLoc = undefRL
166             IF ( misvalFlt(listId).NE.UNSET_RL )
167         &        misValLoc = misvalFlt(listId)
168             CALL DIAGNOSTICS_MNC_SET(
169         I                    nLevOutp, listId, jj,
170         O                    diag_mnc_bn, useMissingValue,
171         I                    misValLoc, myTime, myIter, myThid )
172           ENDIF
173  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
174    
175  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
176    
177        DO md = 1,nfields(listId)         DO md = 1,nfields(listId)
178          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
179          parms1 = gdiag(ndId)(1:8)          gcode = gdiag(ndId)(1:10)
180          mate = 0          mate = 0
181          mVec = 0          mVec = 0
182          IF ( parms1(5:5).EQ.'C' ) THEN          IF ( gcode(5:5).EQ.'C' ) THEN
183  C-      Check for Mate of a Counter Diagnostic  C-      Check for Mate of a Counter Diagnostic
184             READ(parms1,'(5X,I3)') mate             mate = hdiag(ndId)
185          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
186  C-      Check for Mate of a Vector Diagnostic  C-      Check for Mate of a Vector Diagnostic
187             READ(parms1,'(5X,I3)') mVec             mVec = hdiag(ndId)
188          ENDIF          ENDIF
189          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
190  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
191    #ifdef ALLOW_MNC
192             DO ll=1,llMx
193              lm = jj+ll-1
194    #else
195           DO lm=1,averageCycle(listId)           DO lm=1,averageCycle(listId)
196    #endif
197    
198            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
199            im = mdiag(md,listId)            im = mdiag(md,listId)
# Line 229  C-        Empty diagnostics case : Line 208  C-        Empty diagnostics case :
208       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
209              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
210       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
211              WRITE(msgBuf,'(A,I4,3A,I3,2A)')              WRITE(msgBuf,'(A,I6,3A,I4,2A)')
212       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),
213       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
214              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
215       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
216              IF ( averageCycle(listId).GT.1 ) THEN              IF ( averageCycle(listId).GT.1 ) THEN
217               WRITE(msgBuf,'(A,2(I2,A))')               WRITE(msgBuf,'(A,2(I3,A))')
218       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
219       &                                            ndiag(ip,1,1), ' )'       &                                            ndiag(ip,1,1), ' )'
220              ELSE              ELSE
221               WRITE(msgBuf,'(A,2(I2,A))')               WRITE(msgBuf,'(A,2(I3,A))')
222       &        '- WARNING -   has not been filled (ndiag=',       &        '- WARNING -   has not been filled (ndiag=',
223       &                                            ndiag(ip,1,1), ' )'       &                                            ndiag(ip,1,1), ' )'
224              ENDIF              ENDIF
# Line 252  C-        Empty diagnostics case : Line 231  C-        Empty diagnostics case :
231              _END_MASTER( myThid )              _END_MASTER( myThid )
232              DO bj = myByLo(myThid), myByHi(myThid)              DO bj = myByLo(myThid), myByHi(myThid)
233                DO bi = myBxLo(myThid), myBxHi(myThid)                DO bi = myBxLo(myThid), myBxHi(myThid)
234                  DO k = 1,nlevels(listId)                  DO k = 1,nLevOutp
235                    DO j = 1-OLy,sNy+OLy                    DO j = 1-OLy,sNy+OLy
236                      DO i = 1-OLx,sNx+OLx                      DO i = 1-OLx,sNx+OLx
237                        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 244  C-        Empty diagnostics case :
244            ELSE            ELSE
245  C-        diagnostics is not empty :  C-        diagnostics is not empty :
246    
247              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN              IF ( debugLevel.GE.debLevB .AND. myThid.EQ.1 ) THEN
248                WRITE(ioUnit,'(A,I3,3A,I8,2A)')                WRITE(ioUnit,'(A,I6,3A,I8,2A)')
249       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
250       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
251                IF ( mate.GT.0 ) THEN                IF ( mate.GT.0 ) THEN
252                 WRITE(ioUnit,'(3A,I3,2A)')                 WRITE(ioUnit,'(3A,I6,2A)')
253       &         '       use Counter Mate for  ', cdiag(ndId),       &         '       use Counter Mate for  ', cdiag(ndId),
254       &         '     Diagnostic # ',mate, '  ', cdiag(mate)       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
255                ELSEIF ( mVec.GT.0 ) THEN                ELSEIF ( mVec.GT.0 ) THEN
256                  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
257                   WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
258       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
259       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
260       &             ' exists '       &             ' exists '
261                  ELSE                  ELSE
262                   WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
263       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
264       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
265       &             ' not enabled'       &             ' not enabled'
# Line 288  C-        diagnostics is not empty : Line 267  C-        diagnostics is not empty :
267                ENDIF                ENDIF
268              ENDIF              ENDIF
269    
270              IF ( fflags(listId)(2:2).EQ.'P' ) THEN              IF ( fflags(listId)(2:2).EQ.' ' ) THEN
271  C-       get all the levels (for vertical interpolation)  C-       get only selected levels:
272                DO bj = myByLo(myThid), myByHi(myThid)                DO bj = myByLo(myThid), myByHi(myThid)
273                 DO bi = myBxLo(myThid), myBxHi(myThid)                 DO bi = myBxLo(myThid), myBxHi(myThid)
274                  DO k = 1,kdiag(ndId)                  DO k = 1,nlevels(listId)
275                    tmpLev = k                    kLev = NINT(levs(k,listId))
276                    CALL GETDIAG(                    CALL DIAGNOSTICS_GET_DIAG(
277       I                         tmpLev,undef,       I                         kLev, undefRL,
278       O                         qtmp1(1-OLx,1-OLy,k,bi,bj),       O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
279       I                         ndId,mate,ip,im,bi,bj,myThid)       I                         ndId,mate,ip,im,bi,bj,myThid)
280                  ENDDO                  ENDDO
281                 ENDDO                 ENDDO
282                ENDDO                ENDDO
283              ELSE              ELSE
284  C-       get only selected levels:  C-       get all the levels (for vertical post-processing)
285                DO bj = myByLo(myThid), myByHi(myThid)                DO bj = myByLo(myThid), myByHi(myThid)
286                 DO bi = myBxLo(myThid), myBxHi(myThid)                 DO bi = myBxLo(myThid), myBxHi(myThid)
287                  DO k = 1,nlevels(listId)                    CALL DIAGNOSTICS_GET_DIAG(
288                    CALL GETDIAG(       I                         0, undefRL,
289       I                         levs(k,listId),undef,       O                         qtmp1(1-OLx,1-OLy,1,bi,bj),
      O                         qtmp1(1-OLx,1-OLy,k,bi,bj),  
290       I                         ndId,mate,ip,im,bi,bj,myThid)       I                         ndId,mate,ip,im,bi,bj,myThid)
                 ENDDO  
291                 ENDDO                 ENDDO
292                ENDDO                ENDDO
293              ENDIF              ENDIF
294    
 C-        end of empty diag / not empty block  
           ENDIF  
   
295  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
296  C         Check to see if we need to interpolate before output  C--     Apply specific post-processing (e.g., interpolate) before output
297  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
298            IF ( fflags(listId)(2:2).EQ.'P' ) THEN              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
299  C-        Do vertical interpolation:  C-          Do vertical interpolation:
300             IF ( fluidIsAir ) THEN               IF ( fluidIsAir ) THEN
301  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);
302              CALL DIAGNOSTICS_INTERP_VERT(                CALL DIAGNOSTICS_INTERP_VERT(
303       I                     listId, md, ndId, ip, im, lm,       I                         listId, md, ndId, ip, im, lm,
304       U                     qtmp1,       U                         qtmp1, qtmp2,
305       I                     undef, myTime, myIter, myThid )       I                         undefRL, myTime, myIter, myThid )
306             ELSE               ELSE
307               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',                 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
308       &         'INTERP_VERT not allowed in this config'       &           'INTERP_VERT not allowed in this config'
309               CALL PRINT_ERROR( msgBuf , myThid )                 CALL PRINT_ERROR( msgBuf , myThid )
310               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
311             ENDIF               ENDIF
312                ENDIF
313                IF ( fflags(listId)(2:2).EQ.'I' ) THEN
314    C-          Integrate vertically: for now, output field has just 1 level:
315                  CALL DIAGNOSTICS_SUM_LEVELS(
316         I                         listId, md, ndId, ip, im, lm,
317         U                         qtmp1,
318         I                         undefRL, myTime, myIter, myThid )
319                ENDIF
320    
321    C--     End of empty diag / not-empty diag block
322            ENDIF            ENDIF
323    
324  C--    Ready to write field "md", element "lm" in averageCycle(listId)  C--     Ready to write field "md", element "lm" in averageCycle(listId)
325    
 #ifdef ALLOW_MDSIO  
326  C-        write to binary file, using MDSIO pkg:  C-        write to binary file, using MDSIO pkg:
327            IF (diag_mdsio) THEN            IF ( diag_mdsio ) THEN
             glf = globalFiles  
328              nRec = lm + (md-1)*averageCycle(listId)              nRec = lm + (md-1)*averageCycle(listId)
329  C           default precision for output files  C           default precision for output files
330              prec = writeBinaryPrec              prec = writeBinaryPrec
331  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
332              IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32              IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
333              IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64              IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
334  c           CALL MDS_WRITE_FIELD(fn,prec,glf,.FALSE.,'RL',  C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
335  c    &              NrMax,nlevels(listId),qtmp1,nRec,myIter,myThid)              CALL WRITE_REC_LEV_RL(
336  C         a hack not to write meta files now:       I                            fn, prec,
337              CALL MDS_WRITE_FIELD(fn,prec,glf,.FALSE.,'RL',       I                            NrMax, 1, nLevOutp,
338       &              NrMax,nlevels(listId),qtmp1,-nRec,myIter,myThid)       I                            qtmp1, -nRec, myIter, myThid )
339            ENDIF            ENDIF
 #endif /*  ALLOW_MDSIO  */  
340    
341  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
342            IF (useMNC .AND. diag_mnc) THEN            IF (useMNC .AND. diag_mnc) THEN
343                CALL DIAGNOSTICS_MNC_OUT(
344              _BEGIN_MASTER( myThid )       I                       NrMax, nLevOutp, listId, ndId,
345         I                       diag_mnc_bn,
346              DO ii = 1,CW_DIMS       I                       useMissingValue, misValLoc,
347                d_cw_name(1:NLEN) = dn_blnk(1:NLEN)       I                       qtmp1,
348                dn(ii)(1:NLEN) = dn_blnk(1:NLEN)       I                       myTime, myIter, myThid )
             ENDDO  
   
 C           Note that the "d_cw_name" variable is a hack that hides a  
 C           subtlety within MNC.  Basically, each MNC-wrapped file is  
 C           caching its own concept of what each "grid name" (that is, a  
 C           dimension group name) means.  So one cannot re-use the same  
 C           "grid" name for different collections of dimensions within a  
 C           given file.  By appending the "ndId" values to each name, we  
 C           guarantee uniqueness within each MNC-produced file.  
             WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',ndId  
   
 C           XY dimensions  
             dim(1)       = sNx + 2*OLx  
             dim(2)       = sNy + 2*OLy  
             ib(1)        = OLx + 1  
             ib(2)        = OLy + 1  
             IF (gdiag(ndId)(2:2) .EQ. 'M') THEN  
               dn(1)(1:2) = 'X'  
               ie(1)      = OLx + sNx  
               dn(2)(1:2) = 'Y'  
               ie(2)      = OLy + sNy  
             ELSEIF (gdiag(ndId)(2:2) .EQ. 'U') THEN  
               dn(1)(1:3) = 'Xp1'  
               ie(1)      = OLx + sNx + 1  
               dn(2)(1:2) = 'Y'  
               ie(2)      = OLy + sNy  
             ELSEIF (gdiag(ndId)(2:2) .EQ. 'V') THEN  
               dn(1)(1:2) = 'X'  
               ie(1)      = OLx + sNx  
               dn(2)(1:3) = 'Yp1'  
               ie(2)      = OLy + sNy + 1  
             ELSEIF (gdiag(ndId)(2:2) .EQ. 'Z') THEN  
               dn(1)(1:3) = 'Xp1'  
               ie(1)      = OLx + sNx + 1  
               dn(2)(1:3) = 'Yp1'  
               ie(2)      = OLy + sNy + 1  
             ENDIF  
   
 C           Z is special since it varies  
             WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)  
             IF ( (gdiag(ndId)(10:10) .EQ. 'R')  
      &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN  
               WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevels(listId)  
             ENDIF  
             IF ( (gdiag(ndId)(10:10) .EQ. 'R')  
      &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN  
               WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listId)  
             ENDIF  
             IF ( (gdiag(ndId)(10:10) .EQ. 'R')  
      &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN  
               WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)  
             ENDIF  
             dim(3) = NrMax  
             ib(3)  = 1  
             ie(3)  = nlevels(listId)  
   
 C           Time dimension  
             dn(4)(1:1) = 'T'  
             dim(4) = -1  
             ib(4)  = 1  
             ie(4)  = 1  
   
             CALL MNC_CW_ADD_GNAME(d_cw_name, 4,  
      &             dim, dn, ib, ie, myThid)  
             CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,  
      &             4,5, myThid)  
             CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',  
      &             tdiag(ndId),myThid)  
             CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',  
      &             udiag(ndId),myThid)  
   
 C           Per the observations of Baylor, this has been commented out  
 C           until we have code that can write missing_value attributes  
 C           in a way thats compatible with most of the more popular  
 C           netCDF tools including ferret.  Using all-zeros completely  
 C           breaks ferret.  
   
 C           CALL MNC_CW_ADD_VATTR_DBL(cdiag(ndId),'missing_value',  
 C           &             0.0 _d 0,myThid)  
   
             IF ( ( (writeBinaryPrec .EQ. precFloat32)  
      &           .AND. (fflags(listId)(1:1) .NE. 'D')  
      &           .AND. (fflags(listId)(1:1) .NE. 'R') )  
      &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN  
               CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,  
      &             cdiag(ndId), qtmp1, myThid)  
             ELSEIF ( (writeBinaryPrec .EQ. precFloat64)  
      &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN  
               CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,  
      &             cdiag(ndId), qtmp1, myThid)  
             ENDIF  
   
             CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)  
             CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)  
   
             _END_MASTER( myThid )  
   
349            ENDIF            ENDIF
350  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
351    
352    C--      end loop on lm (or ll if ALLOW_MNC) counter
353           ENDDO           ENDDO
354  C--     end of Processing Fld # md  C--     end of Processing Fld # md
355          ENDIF          ENDIF
356           ENDDO
357    
358    #ifdef ALLOW_MNC
359    C--   end loop on jj counter
360        ENDDO        ENDDO
361    #endif
362    
363  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
364        IF (diag_mdsio) THEN        IF (diag_mdsio) THEN
365  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
366  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
367  C     meta files but with more informations in it.  C     meta files but with more informations in it.
368              glf = globalFiles              glf = globalFiles
369              nRec = nfields(listId)*averageCycle(listId)              nRec = nfields(listId)*averageCycle(listId)
370              CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,              CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
371       &              0, 0, nlevels(listId), ' ',       &              0, 0, nLevOutp, ' ',
372       &              nfields(listId), flds(1,listId), 1, myTime,       &              nfields(listId), flds(1,listId), nTimRec, timeRec,
373       &              nRec, myIter, myThid)       &              nRec, myIter, myThid)
374        ENDIF        ENDIF
375  #endif /*  ALLOW_MDSIO  */  #endif /*  ALLOW_MDSIO  */
Legend:
Removed from v.1.31  
changed lines
  Added in v.1.52
  ViewVC Help
Powered by ViewVC 1.1.22