/[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.39 by mlosch, Tue May 27 08:37:19 2008 UTC revision 1.50 by jmc, Sat Jun 11 23:29:44 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 38  C     myThid  :: my Thread Id number Line 38  C     myThid  :: my Thread Id number
38        INTEGER listId, myIter, myThid        INTEGER listId, myIter, myThid
39  CEOP  CEOP
40    
41    C     !FUNCTIONS:
42          INTEGER ILNBLNK
43          EXTERNAL ILNBLNK
44    #ifdef ALLOW_FIZHI
45          _RL   getcon
46          EXTERNAL getcon
47    #endif
48    
49  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
50  C     i,j,k :: loop indices  C     i,j,k :: loop indices
51    C     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  C
60  C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)  C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)
61  C     qtmp1 :: thread-shared temporary array (needs to be in common block):  C     qtmp1 :: thread-shared temporary array (needs to be in common block):
# Line 54  C              diagnostic storage qdiag Line 64  C              diagnostic storage qdiag
64        COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1        COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1
65        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
66    
67        INTEGER i, j, k, lm, klev        INTEGER i, j, k, lm
68        INTEGER bi, bj        INTEGER bi, bj
69        INTEGER md, ndId, ip, im        INTEGER md, ndId, ip, im
70        INTEGER mate, mVec        INTEGER mate, mVec
71        CHARACTER*10 gcode        CHARACTER*10 gcode
72        _RL undef, getcon        _RL undef
73        _RL tmpLev        _RL tmpLev
74        EXTERNAL getcon        INTEGER iLen
75        INTEGER ILNBLNK        INTEGER nLevOutp
       EXTERNAL ILNBLNK  
       INTEGER ilen  
76    
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        INTEGER prec, nRec, nTimRec
82          _RL     timeRec(2)
83  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
84        LOGICAL glf        LOGICAL glf
85  #endif  #endif
86  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
87        INTEGER ii        INTEGER ll, llMx, jj, jjMx
88        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
89        INTEGER CW_DIMS, NLEN        LOGICAL useMissingValue
90        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  
       LOGICAL useMissingValue, useMisValForThisDiag  
       REAL*8 misvalLoc  
       REAL*8 misval_r8(2)  
       REAL*4 misval_r4(2)  
       INTEGER misvalIntLoc, misval_int(2)  
91  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
92    
93  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
94    
95    C---  set file properties
96        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
97        undef = getcon('UNDEF')        undef = UNSET_RL
98    #ifdef ALLOW_FIZHI
99          IF ( useFIZHI ) undef = getcon('UNDEF')
100    #endif
101        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
102        ilen = ILNBLNK(fnames(listId))        iLen = ILNBLNK(fnames(listId))
103        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:iLen),'.',suff(1:10)
104    C-    for now, if integrate vertically, output field has just 1 level:
105          nLevOutp = nlevels(listId)
106          IF ( fflags(listId)(2:2).EQ.'I' ) nLevOutp = 1
107    
108    C--   Set time information:
109          IF ( freq(listId).LT.0. ) THEN
110    C-    Snap-shot: store a unique time (which is consistent with State-Var timing)
111            nTimRec = 1
112            timeRec(1) = myTime
113          ELSE
114    C-    Time-average: store the 2 edges of the time-averaging interval.
115    C      this time is consitent with intermediate Var (i.e., non-state, e.g, flux,
116    C      tendencies) timing. For State-Var, this is shifted by + halt time-step.
117            nTimRec = 2
118    
119    C-    end of time-averaging interval:
120            timeRec(2) = myTime
121    
122    C-    begining of time-averaging interval:
123    c       timeRec(1) = myTime - freq(listId)
124    C     a) find the time of the previous multiple of output freq:
125            timeRec(1) = myTime-deltaTClock*0.5 _d 0
126            timeRec(1) = (timeRec(1)-phase(listId))/freq(listId)
127            i = INT( timeRec(1) )
128            IF ( timeRec(1).LT.0. ) THEN
129              tmpLev = FLOAT(i)
130              IF ( timeRec(1).NE.tmpLev ) i = i - 1
131            ENDIF
132            timeRec(1) = phase(listId) + freq(listId)*FLOAT(i)
133    c       if ( listId.eq.2 ) write(0,*) 'f',i,timeRec(1)/deltaTClock
134            timeRec(1) = MAX( timeRec(1), startTime )
135    
136    C     b) round off to nearest multiple of time-step:
137            timeRec(1) = (timeRec(1)-baseTime)/deltaTClock
138            i = NINT( timeRec(1) )
139    C     if just half way, NINT will return the next time-step: correct this
140            tmpLev = FLOAT(i) - 0.5 _d 0
141            IF ( timeRec(1).EQ.tmpLev ) i = i - 1
142            timeRec(1) = baseTime + deltaTClock*FLOAT(i)
143    c       if ( listId.eq.2 ) write(0,*) i,timeRec(1)/deltaTClock
144          ENDIF
145    C--   Convert time to iteration number (debug)
146    c     DO i=1,nTimRec
147    c       timeRec(i) = timeRec(i)/deltaTClock
148    c     ENDDO
149    
150  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
151    C-- this is a trick to reverse the order of the loops on md (= field)
152    C   and lm (= averagePeriod): binary output: lm loop inside md loop ;
153    C                                 mnc ouput: md loop inside lm loop.
154        IF (useMNC .AND. diag_mnc) THEN        IF (useMNC .AND. diag_mnc) THEN
155  C     Handle missing value attribute (land points)          jjMx = averageCycle(listId)
156         useMissingValue = .FALSE.          llMx = 1
157  #ifdef DIAGNOSTICS_MISSING_VALUE        ELSE
158         useMissingValue = .TRUE.          jjMx = 1
159  #endif /* DIAGNOSTICS_MISSING_VALUE */          llMx = averageCycle(listId)
        IF ( misvalFlt(listId) .NE. UNSET_RL ) THEN  
         misvalLoc = misvalFlt(listId)  
        ELSE  
         misvalLoc = undef  
        ENDIF  
 C     Defaults to UNSET_I  
        misvalIntLoc = misvalInt(listId)  
        DO ii=1,2  
 C       misval_r4(ii)  = UNSET_FLOAT4  
 C       misval_r8(ii)  = UNSET_FLOAT8  
         misval_r4(ii)  = misvalLoc  
         misval_r8(ii)  = misvalLoc  
         misval_int(ii) = UNSET_I  
        ENDDO  
         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)  
 C     suppress the missing value attribute (iflag = 0)  
         IF (useMissingValue)  
      &       CALL MNC_CW_VATTR_MISSING('diag_levels', 0,  
      I       misval_r8, misval_r4, misval_int,  
      I       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  
 C     suppress the missing value attribute (iflag = 0)  
           IF (useMissingValue)  
      &         CALL MNC_CW_VATTR_MISSING(dn(1), 0,  
      I         misval_r8, misval_r4, misval_int,  
      I         myThid )  
           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  */  
   
160        ENDIF        ENDIF
161          DO jj=1,jjMx
162    
163           IF (useMNC .AND. diag_mnc) THEN
164             CALL DIAGNOSTICS_MNC_SET(
165         I                    nLevOutp, listId, jj,
166         O                    diag_mnc_bn,
167         O                    useMissingValue, misValLoc,
168         I                    myTime, myIter, myThid )
169           ENDIF
170  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
171    
172  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
173    
174        DO md = 1,nfields(listId)         DO md = 1,nfields(listId)
175          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
176          gcode = gdiag(ndId)(1:10)          gcode = gdiag(ndId)(1:10)
177          mate = 0          mate = 0
# Line 248  C-      Check for Mate of a Vector Diagn Line 185  C-      Check for Mate of a Vector Diagn
185          ENDIF          ENDIF
186          IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN          IF ( idiag(md,listId).NE.0 .AND. gcode(5:5).NE.'D' ) THEN
187  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
188    #ifdef ALLOW_MNC
189             DO ll=1,llMx
190              lm = jj+ll-1
191    #else
192           DO lm=1,averageCycle(listId)           DO lm=1,averageCycle(listId)
193    #endif
194    
195            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
196            im = mdiag(md,listId)            im = mdiag(md,listId)
# Line 286  C-        Empty diagnostics case : Line 228  C-        Empty diagnostics case :
228              _END_MASTER( myThid )              _END_MASTER( myThid )
229              DO bj = myByLo(myThid), myByHi(myThid)              DO bj = myByLo(myThid), myByHi(myThid)
230                DO bi = myBxLo(myThid), myBxHi(myThid)                DO bi = myBxLo(myThid), myBxHi(myThid)
231                  DO k = 1,nlevels(listId)                  DO k = 1,nLevOutp
232                    DO j = 1-OLy,sNy+OLy                    DO j = 1-OLy,sNy+OLy
233                      DO i = 1-OLx,sNx+OLx                      DO i = 1-OLx,sNx+OLx
234                        qtmp1(i,j,k,bi,bj) = 0. _d 0                        qtmp1(i,j,k,bi,bj) = 0. _d 0
# Line 299  C-        Empty diagnostics case : Line 241  C-        Empty diagnostics case :
241            ELSE            ELSE
242  C-        diagnostics is not empty :  C-        diagnostics is not empty :
243    
244              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN              IF ( debugLevel.GE.debLevB .AND. myThid.EQ.1 ) THEN
245                WRITE(ioUnit,'(A,I6,3A,I8,2A)')                WRITE(ioUnit,'(A,I6,3A,I8,2A)')
246       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
247       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
# Line 322  C-        diagnostics is not empty : Line 264  C-        diagnostics is not empty :
264                ENDIF                ENDIF
265              ENDIF              ENDIF
266    
267              IF ( fflags(listId)(2:2).EQ.'P' ) THEN              IF ( fflags(listId)(2:2).NE.' ' ) THEN
268  C-       get all the levels (for vertical interpolation)  C-       get all the levels (for vertical post-processing)
269                DO bj = myByLo(myThid), myByHi(myThid)                DO bj = myByLo(myThid), myByHi(myThid)
270                 DO bi = myBxLo(myThid), myBxHi(myThid)                 DO bi = myBxLo(myThid), myBxHi(myThid)
271                  DO k = 1,kdiag(ndId)                  DO k = 1,kdiag(ndId)
# Line 349  C-       get only selected levels: Line 291  C-       get only selected levels:
291                ENDDO                ENDDO
292              ENDIF              ENDIF
293    
 C-        end of empty diag / not empty block  
           ENDIF  
   
294  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
295  C         Check to see if we need to interpolate before output  C--     Apply specific post-processing (e.g., interpolate) before output
296  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
297            IF ( fflags(listId)(2:2).EQ.'P' ) THEN              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
298  C-        Do vertical interpolation:  C-          Do vertical interpolation:
299             IF ( fluidIsAir ) THEN               IF ( fluidIsAir ) THEN
300  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);
301              CALL DIAGNOSTICS_INTERP_VERT(                CALL DIAGNOSTICS_INTERP_VERT(
302       I                     listId, md, ndId, ip, im, lm,       I                         listId, md, ndId, ip, im, lm,
303       U                     qtmp1,       U                         qtmp1,
304       I                     undef, myTime, myIter, myThid )       I                         undef, myTime, myIter, myThid )
305             ELSE               ELSE
306               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',                 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
307       &         'INTERP_VERT not allowed in this config'       &           'INTERP_VERT not allowed in this config'
308               CALL PRINT_ERROR( msgBuf , myThid )                 CALL PRINT_ERROR( msgBuf , myThid )
309               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
310             ENDIF               ENDIF
311                ENDIF
312                IF ( fflags(listId)(2:2).EQ.'I' ) THEN
313    C-          Integrate vertically: for now, output field has just 1 level:
314                  CALL DIAGNOSTICS_SUM_LEVELS(
315         I                         listId, md, ndId, ip, im, lm,
316         U                         qtmp1,
317         I                         undef, myTime, myIter, myThid )
318                ENDIF
319    
320    C--     End of empty diag / not-empty diag block
321            ENDIF            ENDIF
322    
323  C--    Ready to write field "md", element "lm" in averageCycle(listId)  C--     Ready to write field "md", element "lm" in averageCycle(listId)
324    
325  C-        write to binary file, using MDSIO pkg:  C-        write to binary file, using MDSIO pkg:
326            IF ( diag_mdsio ) THEN            IF ( diag_mdsio ) THEN
# Line 384  C           fFlag(1)=R(or D): force it t Line 333  C           fFlag(1)=R(or D): force it t
333  C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R  C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
334              CALL WRITE_REC_LEV_RL(              CALL WRITE_REC_LEV_RL(
335       I                            fn, prec,       I                            fn, prec,
336       I                            NrMax, 1, nlevels(listId),       I                            NrMax, 1, nLevOutp,
337       I                            qtmp1, -nRec, myIter, myThid )       I                            qtmp1, -nRec, myIter, myThid )
338            ENDIF            ENDIF
339    
340  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
341            IF (useMNC .AND. diag_mnc) THEN            IF (useMNC .AND. diag_mnc) THEN
342                CALL DIAGNOSTICS_MNC_OUT(
343              _BEGIN_MASTER( myThid )       I                       NrMax, nLevOutp, listId, ndId,
344         I                       diag_mnc_bn,
345              DO ii = 1,CW_DIMS       I                       useMissingValue, misValLoc,
346                d_cw_name(1:NLEN) = dn_blnk(1:NLEN)       I                       qtmp1,
347                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     Missing values only for scalar diagnostics at mass points (so far)  
             useMisValForThisDiag = useMissingValue  
      &           .AND.gdiag(ndId)(1:2).EQ.'SM'  
             IF ( useMisValForThisDiag ) THEN  
 C     assign missing values and set flag for adding the netCDF atttibute  
              CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 2,  
      I            misval_r8, misval_r4, misval_int,  
      I            myThid )  
 C     and now use the missing values for masking out the land points  
              DO bj = myByLo(myThid), myByHi(myThid)  
               DO bi = myBxLo(myThid), myBxHi(myThid)  
                DO k = 1,nlevels(listId)  
                 klev = NINT(levs(k,listId))  
                 DO j = 1-OLy,sNy+OLy  
                  DO i = 1-OLx,sNx+OLx  
                   IF ( _hFacC(I,J,klev,bi,bj) .EQ. 0. )  
      &                 qtmp1(i,j,k,bi,bj) = misvalLoc  
                  ENDDO  
                 ENDDO  
                ENDDO  
               ENDDO  
              ENDDO  
             ELSE  
 C     suppress the missing value attribute (iflag = 0)  
 C     Note: We have to call the following subroutine for each mnc that has  
 C     been created "on the fly" by mnc_cw_add_vname and will be deleted  
 C     by mnc_cw_del_vname, because all of these variables use the same  
 C     identifier so that mnc_cw_vfmv(indv) needs to be overwritten for  
 C     each of these variables  
              CALL MNC_CW_VATTR_MISSING(cdiag(ndId), 0,  
      I            misval_r8, misval_r4, misval_int,  
      I            myThid )  
             ENDIF  
   
             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 )  
   
348            ENDIF            ENDIF
349  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
350    
351    C--      end loop on lm (or ll if ALLOW_MNC) counter
352           ENDDO           ENDDO
353  C--     end of Processing Fld # md  C--     end of Processing Fld # md
354          ENDIF          ENDIF
355           ENDDO
356    
357    #ifdef ALLOW_MNC
358    C--   end loop on jj counter
359        ENDDO        ENDDO
360    #endif
361    
362  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
363        IF (diag_mdsio) THEN        IF (diag_mdsio) THEN
364  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
365  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
366  C     meta files but with more informations in it.  C     meta files but with more informations in it.
367              glf = globalFiles              glf = globalFiles
368              nRec = nfields(listId)*averageCycle(listId)              nRec = nfields(listId)*averageCycle(listId)
369              CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,              CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
370       &              0, 0, nlevels(listId), ' ',       &              0, 0, nLevOutp, ' ',
371       &              nfields(listId), flds(1,listId), 1, myTime,       &              nfields(listId), flds(1,listId), nTimRec, timeRec,
372       &              nRec, myIter, myThid)       &              nRec, myIter, myThid)
373        ENDIF        ENDIF
374  #endif /*  ALLOW_MDSIO  */  #endif /*  ALLOW_MDSIO  */
Legend:
Removed from v.1.39  
changed lines
  Added in v.1.50
  ViewVC Help
Powered by ViewVC 1.1.22