/[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.16 by edhill, Thu Jul 7 15:32:35 2005 UTC revision 1.54 by jmc, Tue Jun 21 18:00:48 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  
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
88        INTEGER ii        INTEGER ll, llMx, jj, jjMx
89        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
90        CHARACTER*(5) ctmp        LOGICAL useMissingValue
91        INTEGER CW_DIMS, NLEN        REAL*8 misValLoc
       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  
       _RS ztmp(Nr+Nrphys)  
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        glf = globalFiles  #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)  
   
         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       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        DO md = 1,nfields(listId)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
176    
177           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          IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN          mate = 0
181            mVec = 0
182            mDbl = 0
183            IF ( gcode(5:5).EQ.'C' ) THEN
184    C-      Check for Mate of a Counter Diagnostic
185               mate = hdiag(ndId)
186            ELSEIF ( gcode(5:5).EQ.'P' ) THEN
187    C-      Also load the mate (if stored) for Post-Processing
188               nn = ndId
189               DO WHILE ( gdiag(nn)(5:5).EQ.'P' )
190                 nn = hdiag(nn)
191               ENDDO
192               IF ( mdiag(md,listId).NE.0 ) mDbl = hdiag(nn)
193            ELSEIF ( gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V' ) THEN
194    C-      Check for Mate of a Vector Diagnostic
195               mVec = hdiag(ndId)
196            ENDIF
197            IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN
198  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
199    #ifdef ALLOW_MNC
200             DO ll=1,llMx
201              lm = jj+ll-1
202    #else
203             DO lm=1,averageCycle(listId)
204    #endif
205    
206            ip = ABS(idiag(md,listId))            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
207            im = mdiag(md,listId)            im = mdiag(md,listId)
208              IF (mate.GT.0) im = im + kdiag(mate)*(lm-1)
209              IF (mDbl.GT.0) im = im + kdiag(mDbl)*(lm-1)
210              IF (mVec.GT.0) im = im + kdiag(mVec)*(lm-1)
211    
212            IF ( ndiag(ip,1,1).EQ.0 ) THEN            IF ( ndiag(ip,1,1).EQ.0 ) THEN
213  C-        Empty diagnostics case :  C-        Empty diagnostics case :
214    
# Line 196  C-        Empty diagnostics case : Line 217  C-        Empty diagnostics case :
217       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter       &        '- WARNING - from DIAGNOSTICS_OUT at iter=', myIter
218              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
219       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
220              WRITE(msgBuf,'(A,I4,3A,I3,2A)')              WRITE(msgBuf,'(A,I6,3A,I4,2A)')
221       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),       &       '- WARNING -   diag.#',ndId, ' : ',flds(md,listId),
222       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
223              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
224       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
225              WRITE(msgBuf,'(A,I2,A)')              IF ( averageCycle(listId).GT.1 ) THEN
226       &       '- WARNING -   has not been filled (ndiag=',               WRITE(msgBuf,'(A,2(I3,A))')
227       &       ndiag(ip,1,1), ' )'       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
228         &                                            ndiag(ip,1,1), ' )'
229                ELSE
230                 WRITE(msgBuf,'(A,2(I3,A))')
231         &        '- WARNING -   has not been filled (ndiag=',
232         &                                            ndiag(ip,1,1), ' )'
233                ENDIF
234              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
235       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
236              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(A)')
# Line 213  C-        Empty diagnostics case : Line 240  C-        Empty diagnostics case :
240              _END_MASTER( myThid )              _END_MASTER( myThid )
241              DO bj = myByLo(myThid), myByHi(myThid)              DO bj = myByLo(myThid), myByHi(myThid)
242                DO bi = myBxLo(myThid), myBxHi(myThid)                DO bi = myBxLo(myThid), myBxHi(myThid)
243                  DO k = 1,nlevels(listId)                  DO k = 1,nLevOutp
244                    DO j = 1-OLy,sNy+OLy                    DO j = 1-OLy,sNy+OLy
245                      DO i = 1-OLx,sNx+OLx                      DO i = 1-OLx,sNx+OLx
246                        qtmp1(i,j,k,bi,bj) = 0. _d 0                        qtmp1(i,j,k,bi,bj) = 0. _d 0
# Line 226  C-        Empty diagnostics case : Line 253  C-        Empty diagnostics case :
253            ELSE            ELSE
254  C-        diagnostics is not empty :  C-        diagnostics is not empty :
255    
256              IF ( myThid.EQ.1 ) WRITE(ioUnit,'(A,I3,3A,I8,2A)')              IF ( debugLevel.GE.debLevB .AND. myThid.EQ.1 ) THEN
257                  IF ( gcode(5:5).EQ.'P' ) THEN
258                   WRITE(ioUnit,'(A,I6,7A,I8,2A)')
259         &         ' Post-Processing Diag # ', ndId, '  ', cdiag(ndId),
260         &         '   Parms: ',gdiag(ndId)
261                   IF ( mDbl.EQ.0 ) THEN
262                    WRITE(ioUnit,'(2(3A,I6,A,I8))') '   from diag: ',
263         &            cdiag(nn), ' (#', nn, ') Cnt=', ndiag(ip,1,1)
264                   ELSE
265                    WRITE(ioUnit,'(2(3A,I6,A,I8))') '   from diag: ',
266         &            cdiag(nn), ' (#', nn, ') Cnt=', ndiag(ip,1,1),
267         &          ' and diag: ',
268         &            cdiag(mDbl),' (#',mDbl,') Cnt=',ndiag(im,1,1)
269                   ENDIF
270                  ELSE
271                   WRITE(ioUnit,'(A,I6,3A,I8,2A)')
272       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
273       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
274                  ENDIF
275              IF ( parms1(5:5).EQ.'C' ) THEN                IF ( mate.GT.0 ) THEN
276  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)')  
277       &         '       use Counter Mate for  ', cdiag(ndId),       &         '       use Counter Mate for  ', cdiag(ndId),
278       &         '     Diagnostic # ',mate, '  ', cdiag(mate)       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
279                  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  
280                  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
281                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
282       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
283       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
284       &             ' exists '       &             ' exists '
285                  ELSE                  ELSE
286                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I6,3A)')
287       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
288       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
289       &             ' not enabled'       &             ' not enabled'
# Line 261  C             -------------------------- Line 291  C             --------------------------
291                ENDIF                ENDIF
292              ENDIF              ENDIF
293    
294              DO bj = myByLo(myThid), myByHi(myThid)              IF ( fflags(listId)(2:2).EQ.' ' ) THEN
295               DO bi = myBxLo(myThid), myBxHi(myThid)  C-       get only selected levels:
296                DO k = 1,nlevels(listId)                DO bj = myByLo(myThid), myByHi(myThid)
297                  CALL GETDIAG(                 DO bi = myBxLo(myThid), myBxHi(myThid)
298       I                       levs(k,listId),undef,                  DO k = 1,nlevels(listId)
299       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),                    kLev = NINT(levs(k,listId))
300       I                       ndId,mate,ip,im,bi,bj,myThid)                    CALL DIAGNOSTICS_GET_DIAG(
301         I                         kLev, undefRL,
302         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
303         I                         ndId, mate, ip, im, bi, bj, myThid )
304                    ENDDO
305                   ENDDO
306                ENDDO                ENDDO
307               ENDDO                IF ( mDbl.GT.0 ) THEN
308              ENDDO                 DO bj = myByLo(myThid), myByHi(myThid)
309                    DO bi = myBxLo(myThid), myBxHi(myThid)
310  C-        end of empty diag / not empty block                   DO k = 1,nlevels(listId)
311            ENDIF                    kLev = NINT(levs(k,listId))
312                      CALL DIAGNOSTICS_GET_DIAG(
313  #ifdef ALLOW_MDSIO       I                         kLev, undefRL,
314  C         Prepare for mdsio optionality       O                         qtmp2(1-OLx,1-OLy,k,bi,bj),
315            IF (diag_mdsio) THEN       I                         mDbl, 0, im, 0, bi, bj, myThid )
316              IF (fflags(listId)(1:1) .EQ. ' ') THEN                   ENDDO
317  C             This is the old default behavior                  ENDDO
318                CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,'RL',                 ENDDO
319       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)                ENDIF
320              ELSEIF (fflags(listId)(1:1) .EQ. 'R') THEN              ELSE
321  C             Force it to be 32-bit precision  C-       get all the levels (for vertical post-processing)
322                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,'RL',                DO bj = myByLo(myThid), myByHi(myThid)
323       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)                 DO bi = myBxLo(myThid), myBxHi(myThid)
324              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN                    CALL DIAGNOSTICS_GET_DIAG(
325  C             Force it to be 64-bit precision       I                         0, undefRL,
326                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,'RL',       O                         qtmp1(1-OLx,1-OLy,1,bi,bj),
327       &             Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid)       I                         ndId, mate, ip, im, bi, bj, myThid )
328                   ENDDO
329                  ENDDO
330                  IF ( mDbl.GT.0 ) THEN
331                   DO bj = myByLo(myThid), myByHi(myThid)
332                    DO bi = myBxLo(myThid), myBxHi(myThid)
333                     DO k = 1,nlevels(listId)
334                      CALL DIAGNOSTICS_GET_DIAG(
335         I                         0, undefRL,
336         O                         qtmp2(1-OLx,1-OLy,k,bi,bj),
337         I                         mDbl, 0, im, 0, bi, bj, myThid )
338                     ENDDO
339                    ENDDO
340                   ENDDO
341                  ENDIF
342              ENDIF              ENDIF
           ENDIF  
 #endif /*  ALLOW_MDSIO  */  
   
 #ifdef ALLOW_MNC  
           IF (useMNC .AND. diag_mnc) THEN  
343    
344              _BEGIN_MASTER( myThid )  C-----------------------------------------------------------------------
345    C--     Apply specific post-processing (e.g., interpolate) before output
346              DO ii = 1,CW_DIMS  C-----------------------------------------------------------------------
347                d_cw_name(1:NLEN) = dn_blnk(1:NLEN)              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
348                dn(ii)(1:NLEN) = dn_blnk(1:NLEN)  C-          Do vertical interpolation:
349              ENDDO               IF ( fluidIsAir ) THEN
350    C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
351  C           Note that the "d_cw_name" variable is a hack that hides a                CALL DIAGNOSTICS_INTERP_VERT(
352  C           subtlety within MNC.  Basically, each MNC-wrapped file is       I                         listId, md, ndId, ip, im, lm,
353  C           caching its own concept of what each "grid name" (that is, a       U                         qtmp1, qtmp2,
354  C           dimension group name) means.  So one cannot re-use the same       I                         undefRL, myTime, myIter, myThid )
355  C           "grid" name for different collections of dimensions within a               ELSE
356  C           given file.  By appending the "ndId" values to each name, we                 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
357  C           guarantee uniqueness within each MNC-produced file.       &           'INTERP_VERT not allowed in this config'
358              WRITE(d_cw_name,'(a,i6.6)') 'd_cw_',ndId                 CALL PRINT_ERROR( msgBuf , myThid )
359                   STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
360  C           XY dimensions               ENDIF
             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)  
361              ENDIF              ENDIF
362              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( fflags(listId)(2:2).EQ.'I' ) THEN
363       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN  C-          Integrate vertically: for now, output field has just 1 level:
364                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listId)                CALL DIAGNOSTICS_SUM_LEVELS(
365         I                         listId, md, ndId, ip, im, lm,
366         U                         qtmp1,
367         I                         undefRL, myTime, myIter, myThid )
368              ENDIF              ENDIF
369              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( gcode(5:5).EQ.'P' ) THEN
370       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN  C-          Do Post-Processing:
371                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)               IF ( flds(md,listId).EQ.'PhiVEL  '
372    c    &       .OR. flds(md,listId).EQ.'PsiVEL  '
373         &          ) THEN
374                  CALL DIAGNOSTICS_CALC_PHIVEL(
375         I                         listId, md, ndId, ip, im, lm,
376         U                         qtmp1, qtmp2,
377         I                         myTime, myIter, myThid )
378                 ELSE
379                   WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
380         &           'unknown Processing method for diag="',cdiag(ndId),'"'
381                   CALL PRINT_ERROR( msgBuf , myThid )
382                   STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
383                 ENDIF
384              ENDIF              ENDIF
             dim(3) = Nr+Nrphys  
             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)  
   
             IF ((fflags(listId)(1:1) .EQ. ' ')  
      &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN  
               CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,  
      &             cdiag(ndId), qtmp1, myThid)  
             ELSEIF (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)  
385    
386              _END_MASTER( myThid )  C--     End of empty diag / not-empty diag block
387              ENDIF
388    
389    C--     Ready to write field "md", element "lm" in averageCycle(listId)
390    
391    C-        write to binary file, using MDSIO pkg:
392              IF ( diag_mdsio ) THEN
393                nRec = lm + (md-1)*averageCycle(listId)
394    C           default precision for output files
395                prec = writeBinaryPrec
396    C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
397                IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
398                IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
399    C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
400                CALL WRITE_REC_LEV_RL(
401         I                            fn, prec,
402         I                            NrMax, 1, nLevOutp,
403         I                            qtmp1, -nRec, myIter, myThid )
404              ENDIF
405    
406    #ifdef ALLOW_MNC
407              IF (useMNC .AND. diag_mnc) THEN
408                CALL DIAGNOSTICS_MNC_OUT(
409         I                       NrMax, nLevOutp, listId, ndId,
410         I                       diag_mnc_bn,
411         I                       useMissingValue, misValLoc,
412         I                       qtmp1,
413         I                       myTime, myIter, myThid )
414            ENDIF            ENDIF
415  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
416    
417    C--      end loop on lm (or ll if ALLOW_MNC) counter
418             ENDDO
419  C--     end of Processing Fld # md  C--     end of Processing Fld # md
420          ENDIF          ENDIF
421           ENDDO
422    
423    #ifdef ALLOW_MNC
424    C--   end loop on jj counter
425        ENDDO        ENDDO
426    #endif
427    
428    #ifdef ALLOW_MDSIO
429          IF (diag_mdsio) THEN
430    C-    Note: temporary: since it is a pain to add more arguments to
431    C     all MDSIO S/R, uses instead this specific S/R to write only
432    C     meta files but with more informations in it.
433                glf = globalFiles
434                nRec = nfields(listId)*averageCycle(listId)
435                CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
436         &              0, 0, nLevOutp, ' ',
437         &              nfields(listId), flds(1,listId), nTimRec, timeRec,
438         &              nRec, myIter, myThid)
439          ENDIF
440    #endif /*  ALLOW_MDSIO  */
441    
442        RETURN        RETURN
443        END        END
Legend:
Removed from v.1.16  
changed lines
  Added in v.1.54
  ViewVC Help
Powered by ViewVC 1.1.22