/[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.27 by edhill, Mon Feb 6 21:20:23 2006 UTC revision 1.56 by jmc, Thu Jun 23 15:29:01 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 26  C     !USES: Line 26  C     !USES:
26  #include "DIAGNOSTICS_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
27  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
28    
29  #ifdef ALLOW_FIZHI        INTEGER NrMax
30  #include "fizhi_SIZE.h"        PARAMETER( NrMax = numLevels )
 #else  
       INTEGER Nrphys  
       PARAMETER (Nrphys=0)  
 #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 43  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)
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        INTEGER i, j, k  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
69        INTEGER bi, bj        INTEGER bi, bj
70        INTEGER md, ndId, ip, im        INTEGER md, ndId, nn, ip, im
71        INTEGER mate, mVec        INTEGER mate, mDbl, mVec
72        CHARACTER*8 parms1        CHARACTER*10 gcode
73        CHARACTER*3 mate_index        _RL undefRL
74        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)        INTEGER nLevOutp, kLev
       _RL undef, getcon  
       EXTERNAL getcon  
       INTEGER ILNBLNK  
       EXTERNAL ILNBLNK  
       INTEGER ilen  
       INTEGER nlevsout  
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
85        LOGICAL glf        LOGICAL glf
86    #endif
87  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
       INTEGER ii  
88        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
89        INTEGER CW_DIMS, NLEN        LOGICAL missingValFillsMask
       PARAMETER ( CW_DIMS = 10 )  
       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(Nr+Nrphys)  
 #endif  
90  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
91    
92  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
93    
94    C---  set file properties
95        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
96        undef = getcon('UNDEF')        undefRL = UNSET_RL
97        glf = globalFiles  #ifdef ALLOW_FIZHI
98          IF ( useFIZHI ) undefRL = getcon('UNDEF')
99    #endif
100          IF ( misvalFlt(listId).NE.UNSET_RL ) undefRL = misvalFlt(listId)
101    
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  C--   Place the loop on lm (= averagePeriod) outside the loop on md (= field):
152        IF (useMNC .AND. diag_mnc) THEN        DO lm=1,averageCycle(listId)
         DO i = 1,MAX_LEN_FNAM  
           diag_mnc_bn(i:i) = ' '  
         ENDDO  
         DO i = 1,NLEN  
           dn_blnk(i:i) = ' '  
         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  */  
153    
154        ENDIF  #ifdef ALLOW_MNC
155           IF (useMNC .AND. diag_mnc) THEN
156             CALL DIAGNOSTICS_MNC_SET(
157         I                    nLevOutp, listId, lm,
158         O                    diag_mnc_bn, missingValFillsMask,
159         I                    undefRL, myTime, myIter, myThid )
160           ENDIF
161  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
162    
163        DO md = 1,nfields(listId)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
164    
165           DO md = 1,nfields(listId)
166          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
167          parms1 = gdiag(ndId)(1:8)          gcode = gdiag(ndId)(1:10)
168          IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN          mate = 0
169            mVec = 0
170            mDbl = 0
171            IF ( gcode(5:5).EQ.'C' ) THEN
172    C-      Check for Mate of a Counter Diagnostic
173               mate = hdiag(ndId)
174            ELSEIF ( gcode(5:5).EQ.'P' ) THEN
175    C-      Also load the mate (if stored) for Post-Processing
176               nn = ndId
177               DO WHILE ( gdiag(nn)(5:5).EQ.'P' )
178                 nn = hdiag(nn)
179               ENDDO
180               IF ( mdiag(md,listId).NE.0 ) mDbl = hdiag(nn)
181            ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN
182    C-      Check for Mate of a Vector Diagnostic
183               mVec = hdiag(ndId)
184            ENDIF
185            IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN
186  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
187    
188            ip = ABS(idiag(md,listId))            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
189            im = mdiag(md,listId)            im = mdiag(md,listId)
190              IF (mate.GT.0) im = im + kdiag(mate)*(lm-1)
191              IF (mDbl.GT.0) im = im + kdiag(mDbl)*(lm-1)
192              IF (mVec.GT.0) im = im + kdiag(mVec)*(lm-1)
193    
194            IF ( ndiag(ip,1,1).EQ.0 ) THEN            IF ( ndiag(ip,1,1).EQ.0 ) THEN
195  C-        Empty diagnostics case :  C-        Empty diagnostics case :
196    
# Line 210  C-        Empty diagnostics case : Line 199  C-        Empty diagnostics case :
199       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
200              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
201       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
202              WRITE(msgBuf,'(A,I4,3A,I3,2A)')              WRITE(msgBuf,'(A,I6,3A,I4,2A)')
203       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),
204       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
205              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
206       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
207              WRITE(msgBuf,'(A,I2,A)')              IF ( averageCycle(listId).GT.1 ) THEN
208       &       '- WARNING -   has not been filled (ndiag=',               WRITE(msgBuf,'(A,2(I3,A))')
209       &       ndiag(ip,1,1), ' )'       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
210         &                                            ndiag(ip,1,1), ' )'
211                ELSE
212                 WRITE(msgBuf,'(A,2(I3,A))')
213         &        '- WARNING -   has not been filled (ndiag=',
214         &                                            ndiag(ip,1,1), ' )'
215                ENDIF
216              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
217       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
218              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(A)')
# Line 227  C-        Empty diagnostics case : Line 222  C-        Empty diagnostics case :
222              _END_MASTER( myThid )              _END_MASTER( myThid )
223              DO bj = myByLo(myThid), myByHi(myThid)              DO bj = myByLo(myThid), myByHi(myThid)
224                DO bi = myBxLo(myThid), myBxHi(myThid)                DO bi = myBxLo(myThid), myBxHi(myThid)
225                  DO k = 1,nlevels(listId)                  DO k = 1,nLevOutp
226                    DO j = 1-OLy,sNy+OLy                    DO j = 1-OLy,sNy+OLy
227                      DO i = 1-OLx,sNx+OLx                      DO i = 1-OLx,sNx+OLx
228                        qtmp1(i,j,k,bi,bj) = 0. _d 0                        qtmp1(i,j,k,bi,bj) = 0. _d 0
# Line 240  C-        Empty diagnostics case : Line 235  C-        Empty diagnostics case :
235            ELSE            ELSE
236  C-        diagnostics is not empty :  C-        diagnostics is not empty :
237    
238              IF ( myThid.EQ.1 ) WRITE(ioUnit,'(A,I3,3A,I8,2A)')              IF ( debugLevel.GE.debLevB .AND. myThid.EQ.1 ) THEN
239                  IF ( gcode(5:5).EQ.'P' ) THEN
240                   WRITE(ioUnit,'(A,I6,7A,I8,2A)')
241         &         ' Post-Processing Diag # ', ndId, '  ', cdiag(ndId),
242         &         '   Parms: ',gdiag(ndId)
243                   IF ( mDbl.EQ.0 ) THEN
244                    WRITE(ioUnit,'(2(3A,I6,A,I8))') '   from diag: ',
245         &            cdiag(nn), ' (#', nn, ') Cnt=', ndiag(ip,1,1)
246                   ELSE
247                    WRITE(ioUnit,'(2(3A,I6,A,I8))') '   from diag: ',
248         &            cdiag(nn), ' (#', nn, ') Cnt=', ndiag(ip,1,1),
249         &          ' and diag: ',
250         &            cdiag(mDbl),' (#',mDbl,') Cnt=',ndiag(im,1,1)
251                   ENDIF
252                  ELSE
253                   WRITE(ioUnit,'(A,I6,3A,I8,2A)')
254       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
255       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
256                  ENDIF
257              IF ( parms1(5:5).EQ.'C' ) THEN                IF ( mate.GT.0 ) THEN
258  C             Check for Mate of a Counter Diagnostic                 WRITE(ioUnit,'(3A,I6,2A)')
 C             --------------------------------------  
               mate_index = parms1(6:8)  
               READ (mate_index,'(I3)') mate  
               IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,2A)')  
259       &         '       use Counter Mate for  ', cdiag(ndId),       &         '       use Counter Mate for  ', cdiag(ndId),
260       &         '     Diagnostic # ',mate, '  ', cdiag(mate)       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
261                  ELSEIF ( mVec.GT.0 ) THEN
             ELSE  
               mate = 0  
   
 C             Check for Mate of a Vector Diagnostic  
 C             -------------------------------------  
               IF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN  
                 mate_index = parms1(6:8)  
                 READ (mate_index,'(I3)') mVec  
262                  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
263                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
264       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
265       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
266       &             ' exists '       &             ' exists '
267                  ELSE                  ELSE
268                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
269       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
270       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
271       &             ' not enabled'       &             ' not enabled'
# Line 275  C             -------------------------- Line 273  C             --------------------------
273                ENDIF                ENDIF
274              ENDIF              ENDIF
275    
276              DO bj = myByLo(myThid), myByHi(myThid)              IF ( fflags(listId)(2:2).EQ.' ' ) THEN
277               DO bi = myBxLo(myThid), myBxHi(myThid)  C-       get only selected levels:
278                DO k = 1,nlevels(listId)                DO bj = myByLo(myThid), myByHi(myThid)
279                  CALL GETDIAG(                 DO bi = myBxLo(myThid), myBxHi(myThid)
280       I                       levs(k,listId),undef,                  DO k = 1,nlevels(listId)
281       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),                    kLev = NINT(levs(k,listId))
282       I                       ndId,mate,ip,im,bi,bj,myThid)                    CALL DIAGNOSTICS_GET_DIAG(
283         I                         kLev, undefRL,
284         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
285         I                         ndId, mate, ip, im, bi, bj, myThid )
286                    ENDDO
287                   ENDDO
288                ENDDO                ENDDO
289               ENDDO                IF ( mDbl.GT.0 ) THEN
290              ENDDO                 DO bj = myByLo(myThid), myByHi(myThid)
291                    DO bi = myBxLo(myThid), myBxHi(myThid)
292  C-        end of empty diag / not empty block                   DO k = 1,nlevels(listId)
293            ENDIF                    kLev = NINT(levs(k,listId))
294                      CALL DIAGNOSTICS_GET_DIAG(
295            nlevsout = nlevels(listId)       I                         kLev, undefRL,
296         O                         qtmp2(1-OLx,1-OLy,k,bi,bj),
297  C-----------------------------------------------------------------------       I                         mDbl, 0, im, 0, bi, bj, myThid )
298  C         Check to see if we need to interpolate before output                   ENDDO
299  C-----------------------------------------------------------------------                  ENDDO
300           IF ( fflags(listId)(2:2).EQ.'P' ) THEN                 ENDDO
301  C-        Do vertical interpolation:                ENDIF
           CALL DIAGNOSTICS_INTERP_VERT(  
      I                     listId, md, ndId, ip, im,  
      U                     nlevsout,  
      U                     qtmp1,  
      I                     undef,  
      I                     myTime, myIter, myThid )  
          ENDIF  
   
 #ifdef ALLOW_MDSIO  
 C         Prepare for mdsio optionality  
           IF (diag_mdsio) THEN  
             IF (fflags(listId)(1:1) .EQ. 'R') THEN  
 C             Force it to be 32-bit precision  
               CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,  
      &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)  
             ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN  
 C             Force it to be 64-bit precision  
               CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,  
      &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)  
302              ELSE              ELSE
303  C             This is the old default behavior  C-       get all the levels (for vertical post-processing)
304                CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,                DO bj = myByLo(myThid), myByHi(myThid)
305       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)                 DO bi = myBxLo(myThid), myBxHi(myThid)
306                      CALL DIAGNOSTICS_GET_DIAG(
307         I                         0, undefRL,
308         O                         qtmp1(1-OLx,1-OLy,1,bi,bj),
309         I                         ndId, mate, ip, im, bi, bj, myThid )
310                   ENDDO
311                  ENDDO
312                  IF ( mDbl.GT.0 ) THEN
313                   DO bj = myByLo(myThid), myByHi(myThid)
314                    DO bi = myBxLo(myThid), myBxHi(myThid)
315                     DO k = 1,nlevels(listId)
316                      CALL DIAGNOSTICS_GET_DIAG(
317         I                         0, undefRL,
318         O                         qtmp2(1-OLx,1-OLy,k,bi,bj),
319         I                         mDbl, 0, im, 0, bi, bj, myThid )
320                     ENDDO
321                    ENDDO
322                   ENDDO
323                  ENDIF
324              ENDIF              ENDIF
           ENDIF  
 #endif /*  ALLOW_MDSIO  */  
   
 #ifdef ALLOW_MNC  
           IF (useMNC .AND. diag_mnc) THEN  
   
             _BEGIN_MASTER( myThid )  
325    
326              DO ii = 1,CW_DIMS  C-----------------------------------------------------------------------
327                d_cw_name(1:NLEN) = dn_blnk(1:NLEN)  C--     Apply specific post-processing (e.g., interpolate) before output
328                dn(ii)(1:NLEN) = dn_blnk(1:NLEN)  C-----------------------------------------------------------------------
329              ENDDO              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
330    C-          Do vertical interpolation:
331  C           Note that the "d_cw_name" variable is a hack that hides a               IF ( fluidIsAir ) THEN
332  C           subtlety within MNC.  Basically, each MNC-wrapped file is  C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
333  C           caching its own concept of what each "grid name" (that is, a                CALL DIAGNOSTICS_INTERP_VERT(
334  C           dimension group name) means.  So one cannot re-use the same       I                         listId, md, ndId, ip, im, lm,
335  C           "grid" name for different collections of dimensions within a       U                         qtmp1, qtmp2,
336  C           given file.  By appending the "ndId" values to each name, we       I                         undefRL, myTime, myIter, myThid )
337  C           guarantee uniqueness within each MNC-produced file.               ELSE
338              WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',ndId                 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
339         &           'INTERP_VERT not allowed in this config'
340  C           XY dimensions                 CALL PRINT_ERROR( msgBuf , myThid )
341              dim(1)       = sNx + 2*OLx                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
342              dim(2)       = sNy + 2*OLy               ENDIF
             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', nlevsout  
             IF ( (gdiag(ndId)(10:10) .EQ. 'R')  
      &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN  
               WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevsout  
             ENDIF  
             IF ( (gdiag(ndId)(10:10) .EQ. 'R')  
      &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN  
               WRITE(dn(3),'(a,i6.6)') 'Zld', nlevsout  
343              ENDIF              ENDIF
344              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( fflags(listId)(2:2).EQ.'I' ) THEN
345       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN  C-          Integrate vertically: for now, output field has just 1 level:
346                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevsout                CALL DIAGNOSTICS_SUM_LEVELS(
347         I                         listId, md, ndId, ip, im, lm,
348         U                         qtmp1,
349         I                         undefRL, myTime, myIter, myThid )
350              ENDIF              ENDIF
351              dim(3) = Nr+Nrphys              IF ( gcode(5:5).EQ.'P' ) THEN
352              ib(3)  = 1  C-          Do Post-Processing:
353              ie(3)  = nlevsout               IF ( flds(md,listId).EQ.'PhiVEL  '
354    c    &       .OR. flds(md,listId).EQ.'PsiVEL  '
355  C           Time dimension       &          ) THEN
356              dn(4)(1:1) = 'T'                CALL DIAGNOSTICS_CALC_PHIVEL(
357              dim(4) = -1       I                         listId, md, ndId, ip, im, lm,
358              ib(4)  = 1       U                         qtmp1, qtmp2,
359              ie(4)  = 1       I                         myTime, myIter, myThid )
360                 ELSE
361              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,                 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
362       &             dim, dn, ib, ie, myThid)       &           'unknown Processing method for diag="',cdiag(ndId),'"'
363              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,                 CALL PRINT_ERROR( msgBuf , myThid )
364       &             4,5, myThid)                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
365              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',               ENDIF
      &             tdiag(ndId),myThid)  
             CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'units',  
      &             udiag(ndId),myThid)  
             CALL MNC_CW_ADD_VATTR_DBL(cdiag(ndId),'missing_value',  
      &             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)  
366              ENDIF              ENDIF
               
             CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)  
             CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)  
367    
368              _END_MASTER( myThid )  C--     End of empty diag / not-empty diag block
369              ENDIF
370    
371    C--     Ready to write field "md", element "lm" in averageCycle(listId)
372    
373    C-        write to binary file, using MDSIO pkg:
374              IF ( diag_mdsio ) THEN
375    c           nRec = lm + (md-1)*averageCycle(listId)
376                nRec = md + (lm-1)*nfields(listId)
377    C           default precision for output files
378                prec = writeBinaryPrec
379    C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
380                IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
381                IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
382    C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
383                CALL WRITE_REC_LEV_RL(
384         I                            fn, prec,
385         I                            NrMax, 1, nLevOutp,
386         I                            qtmp1, -nRec, myIter, myThid )
387              ENDIF
388    
389    #ifdef ALLOW_MNC
390              IF (useMNC .AND. diag_mnc) THEN
391                CALL DIAGNOSTICS_MNC_OUT(
392         I                       NrMax, nLevOutp, listId, ndId, mate,
393         I                       diag_mnc_bn,
394         I                       missingValFillsMask, undefRL,
395         I                       qtmp1,
396         I                       myTime, myIter, myThid )
397            ENDIF            ENDIF
398  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
399    
400  C--     end of Processing Fld # md  C--     end of Processing Fld # md
401          ENDIF          ENDIF
402           ENDDO
403    
404    C--   end loop on lm counter (= averagePeriod)
405        ENDDO        ENDDO
406    
407    #ifdef ALLOW_MDSIO
408          IF (diag_mdsio) THEN
409    C-    Note: temporary: since it is a pain to add more arguments to
410    C     all MDSIO S/R, uses instead this specific S/R to write only
411    C     meta files but with more informations in it.
412                glf = globalFiles
413                nRec = averageCycle(listId)*nfields(listId)
414                CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
415         &              0, 0, nLevOutp, ' ',
416         &              nfields(listId), flds(1,listId), nTimRec, timeRec,
417         &              nRec, myIter, myThid)
418          ENDIF
419    #endif /*  ALLOW_MDSIO  */
420    
421        RETURN        RETURN
422        END        END
423    
Legend:
Removed from v.1.27  
changed lines
  Added in v.1.56
  ViewVC Help
Powered by ViewVC 1.1.22