/[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.28 by edhill, Tue Feb 7 15:52:02 2006 UTC revision 1.29 by jmc, Mon Jun 5 18:17:23 2006 UTC
# Line 45  CEOP Line 45  CEOP
45    
46  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
47  C     i,j,k :: loop indices  C     i,j,k :: loop indices
48    C     lm    :: loop index (averageCycle)
49  C     md    :: field number in the list "listId".  C     md    :: field number in the list "listId".
50  C     ndId  :: diagnostics  Id number (in available diagnostics list)  C     ndId  :: diagnostics  Id number (in available diagnostics list)
51  C     mate  :: counter mate Id number (in available diagnostics list)  C     mate  :: counter mate Id number (in available diagnostics list)
52  C     ip    :: diagnostics  pointer to storage array  C     ip    :: diagnostics  pointer to storage array
53  C     im    :: counter-mate pointer to storage array  C     im    :: counter-mate pointer to storage array
54        INTEGER i, j, k        INTEGER i, j, k, lm
55        INTEGER bi, bj        INTEGER bi, bj
56        INTEGER md, ndId, ip, im        INTEGER md, ndId, ip, im
57        INTEGER mate, mVec        INTEGER mate, mVec
58        CHARACTER*8 parms1        CHARACTER*8 parms1
       CHARACTER*3 mate_index  
59        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)        _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)
60        _RL undef, getcon        _RL undef, getcon
61        EXTERNAL getcon        EXTERNAL getcon
# Line 68  C     im    :: counter-mate pointer to s Line 68  C     im    :: counter-mate pointer to s
68        CHARACTER*(MAX_LEN_FNAM) fn        CHARACTER*(MAX_LEN_FNAM) fn
69        CHARACTER*(MAX_LEN_MBUF) suff        CHARACTER*(MAX_LEN_MBUF) suff
70        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
71    #ifdef ALLOW_MDSIO
72        LOGICAL glf        LOGICAL glf
73          INTEGER nRec
74    #endif
75  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
76        INTEGER ii        INTEGER ii
77        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn        CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
# Line 89  C---+----1----+----2----+----3----+----4 Line 92  C---+----1----+----2----+----3----+----4
92    
93        ioUnit= standardMessageUnit        ioUnit= standardMessageUnit
94        undef = getcon('UNDEF')        undef = getcon('UNDEF')
       glf = globalFiles  
95        WRITE(suff,'(I10.10)') myIter        WRITE(suff,'(I10.10)') myIter
96        ilen = ILNBLNK(fnames(listId))        ilen = ILNBLNK(fnames(listId))
97        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)        WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10)
# Line 120  C       beginning and ending times for e Line 122  C       beginning and ending times for e
122          ib(1)  = 1          ib(1)  = 1
123          ie(1)  = nlevels(listId)          ie(1)  = nlevels(listId)
124    
125          CALL MNC_CW_ADD_GNAME('diag_levels', 1,          CALL MNC_CW_ADD_GNAME('diag_levels', 1,
126       &       dim, dn, ib, ie, myThid)       &       dim, dn, ib, ie, myThid)
127          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',          CALL MNC_CW_ADD_VNAME('diag_levels', 'diag_levels',
128       &       0,0, myThid)       &       0,0, myThid)
129          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',          CALL MNC_CW_ADD_VATTR_TEXT('diag_levels','description',
130       &       'Idicies of vertical levels within the source arrays',       &       'Idicies of vertical levels within the source arrays',
131       &       myThid)       &       myThid)
132            
133          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
134       &       'diag_levels', levs(1,listId), myThid)       &       'diag_levels', levs(1,listId), myThid)
135    
# Line 158  C       Now define:  Zmdxxxxxx, Zudxxxxx Line 160  C       Now define:  Zmdxxxxxx, Zudxxxxx
160  C         The following three ztmp() loops should eventually be modified  C         The following three ztmp() loops should eventually be modified
161  C         to reflect the fractional nature of levs(j,l) -- they should  C         to reflect the fractional nature of levs(j,l) -- they should
162  C         do something like:  C         do something like:
163  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))  C            ztmp(j) = rC(INT(FLOOR(levs(j,l))))
164  C                      + ( rC(INT(FLOOR(levs(j,l))))  C                      + ( rC(INT(FLOOR(levs(j,l))))
165  C                          + rC(INT(CEIL(levs(j,l)))) )  C                          + rC(INT(CEIL(levs(j,l)))) )
166  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )  C                        / ( levs(j,l) - FLOOR(levs(j,l)) )
167  C         for averaged levels.  C         for averaged levels.
# Line 194  C         for averaged levels. Line 196  C         for averaged levels.
196        ENDIF        ENDIF
197  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
198    
199    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
200    
201        DO md = 1,nfields(listId)        DO md = 1,nfields(listId)
202          ndId = jdiag(md,listId)          ndId = jdiag(md,listId)
203          parms1 = gdiag(ndId)(1:8)          parms1 = gdiag(ndId)(1:8)
204            mate = 0
205            mVec = 0
206            IF ( parms1(5:5).EQ.'C' ) THEN
207    C-      Check for Mate of a Counter Diagnostic
208               READ(parms1,'(5X,I3)') mate
209            ELSEIF ( parms1(1:1).EQ.'U' .OR. parms1(1:1).EQ.'V' ) THEN
210    C-      Check for Mate of a Vector Diagnostic
211               READ(parms1,'(5X,I3)') mVec
212            ENDIF
213          IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN          IF ( idiag(md,listId).NE.0 .AND. parms1(5:5).NE.'D' ) THEN
214  C--     Start processing 1 Fld :  C--     Start processing 1 Fld :
215             DO lm=1,averageCycle(listId)
216    
217            ip = ABS(idiag(md,listId))            ip = ABS(idiag(md,listId)) + kdiag(ndId)*(lm-1)
218            im = mdiag(md,listId)            im = mdiag(md,listId)
219              IF (mate.GT.0) im = im + kdiag(mate)*(lm-1)
220              IF (mVec.GT.0) im = im + kdiag(mVec)*(lm-1)
221    
222            IF ( ndiag(ip,1,1).EQ.0 ) THEN            IF ( ndiag(ip,1,1).EQ.0 ) THEN
223  C-        Empty diagnostics case :  C-        Empty diagnostics case :
224    
# Line 215  C-        Empty diagnostics case : Line 232  C-        Empty diagnostics case :
232       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)       &       ' (#',md,' ) in outp.Stream: ',fnames(listId)
233              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
234       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
235              WRITE(msgBuf,'(A,I2,A)')              IF ( averageCycle(listId).GT.1 ) THEN
236       &       '- WARNING -   has not been filled (ndiag=',               WRITE(msgBuf,'(A,2(I2,A))')
237       &       ndiag(ip,1,1), ' )'       &        '- WARNING -   has not been filled (ndiag(lm=',lm,')=',
238         &                                            ndiag(ip,1,1), ' )'
239                ELSE
240                 WRITE(msgBuf,'(A,2(I2,A))')
241         &        '- WARNING -   has not been filled (ndiag=',
242         &                                            ndiag(ip,1,1), ' )'
243                ENDIF
244              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
245       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
246              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(A)')
# Line 240  C-        Empty diagnostics case : Line 263  C-        Empty diagnostics case :
263            ELSE            ELSE
264  C-        diagnostics is not empty :  C-        diagnostics is not empty :
265    
266              IF ( myThid.EQ.1 ) WRITE(ioUnit,'(A,I3,3A,I8,2A)')              IF ( debugLevel.GE.debLevA .AND. myThid.EQ.1 ) THEN
267                  WRITE(ioUnit,'(A,I3,3A,I8,2A)')
268       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),       &         ' Computing Diagnostic # ', ndId, '  ', cdiag(ndId),
269       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)       &         '     Counter:',ndiag(ip,1,1),'   Parms: ',gdiag(ndId)
270                  IF ( mate.GT.0 ) THEN
271              IF ( parms1(5:5).EQ.'C' ) THEN                 WRITE(ioUnit,'(3A,I3,2A)')
 C             Check for Mate of a Counter Diagnostic  
 C             --------------------------------------  
               mate_index = parms1(6:8)  
               READ (mate_index,'(I3)') mate  
               IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,2A)')  
272       &         '       use Counter Mate for  ', cdiag(ndId),       &         '       use Counter Mate for  ', cdiag(ndId),
273       &         '     Diagnostic # ',mate, '  ', cdiag(mate)       &         '     Diagnostic # ',mate, '  ', cdiag(mate)
274                  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  
275                  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
276                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I3,3A)')
277       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
278       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
279       &             ' exists '       &             ' exists '
280                  ELSE                  ELSE
281                   IF ( myThid.EQ.1 ) WRITE(ioUnit,'(3A,I3,3A)')                   WRITE(ioUnit,'(3A,I3,3A)')
282       &             '           Vector  Mate for  ', cdiag(ndId),       &             '           Vector  Mate for  ', cdiag(ndId),
283       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),       &             '     Diagnostic # ',mVec, '  ', cdiag(mVec),
284       &             ' not enabled'       &             ' not enabled'
# Line 294  C-        end of empty diag / not empty Line 305  C-        end of empty diag / not empty
305  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
306  C         Check to see if we need to interpolate before output  C         Check to see if we need to interpolate before output
307  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
308           IF ( fflags(listId)(2:2).EQ.'P' ) THEN            IF ( fflags(listId)(2:2).EQ.'P' ) THEN
309  C-        Do vertical interpolation:  C-        Do vertical interpolation:
310            CALL DIAGNOSTICS_INTERP_VERT(  c          IF ( fluidIsAir ) THEN
311    C jmc: for now, this can only work in an atmospheric set-up (fluidIsAir);
312    C      find some problems with 5-levels AIM => use it only with FIZHI
313               IF ( useFIZHI ) THEN
314                CALL DIAGNOSTICS_INTERP_VERT(
315       I                     listId, md, ndId, ip, im,       I                     listId, md, ndId, ip, im,
316       U                     nlevsout,       U                     nlevsout,
317       U                     qtmp1,       U                     qtmp1,
318       I                     undef,       I                     undef,
319       I                     myTime, myIter, myThid )       I                     myTime, myIter, myThid )
320           ENDIF             ELSE
321                 WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
322         &         'INTERP_VERT not safe in this config'
323                 CALL PRINT_ERROR( msgBuf , myThid )
324                 WRITE(msgBuf,'(2A,I3,2A)') 'DIAGNOSTICS_OUT: ',
325         &         ' for list l=', listId, ', filename: ', fnames(listId)
326                 CALL PRINT_ERROR( msgBuf , myThid )
327                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
328               ENDIF
329              ENDIF
330    
331  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
332  C         Prepare for mdsio optionality  C         Prepare for mdsio optionality
333            IF (diag_mdsio) THEN            IF (diag_mdsio) THEN
334                glf = globalFiles
335                nRec = lm + (md-1)*averageCycle(listId)
336              IF (fflags(listId)(1:1) .EQ. 'R') THEN              IF (fflags(listId)(1:1) .EQ. 'R') THEN
337  C             Force it to be 32-bit precision  C             Force it to be 32-bit precision
338                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,
339       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)
340              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN
341  C             Force it to be 64-bit precision  C             Force it to be 64-bit precision
342                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,
343       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)
344              ELSE              ELSE
345  C             This is the old default behavior  C             This is the old default behavior
346                CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,                CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,
347       &             'RL',Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid)       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)
348              ENDIF              ENDIF
349            ENDIF            ENDIF
350  #endif /*  ALLOW_MDSIO  */  #endif /*  ALLOW_MDSIO  */
# Line 347  C           XY dimensions Line 373  C           XY dimensions
373              dim(2)       = sNy + 2*OLy              dim(2)       = sNy + 2*OLy
374              ib(1)        = OLx + 1              ib(1)        = OLx + 1
375              ib(2)        = OLy + 1              ib(2)        = OLy + 1
376              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN              IF (gdiag(ndId)(2:2) .EQ. 'M') THEN
377                dn(1)(1:2) = 'X'                dn(1)(1:2) = 'X'
378                ie(1)      = OLx + sNx                ie(1)      = OLx + sNx
379                dn(2)(1:2) = 'Y'                dn(2)(1:2) = 'Y'
# Line 368  C           XY dimensions Line 394  C           XY dimensions
394                dn(2)(1:3) = 'Yp1'                dn(2)(1:3) = 'Yp1'
395                ie(2)      = OLy + sNy + 1                ie(2)      = OLy + sNy + 1
396              ENDIF              ENDIF
397                
398  C           Z is special since it varies  C           Z is special since it varies
399              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout
400              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
# Line 393  C           Time dimension Line 419  C           Time dimension
419              ib(4)  = 1              ib(4)  = 1
420              ie(4)  = 1              ie(4)  = 1
421    
422              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,              CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
423       &             dim, dn, ib, ie, myThid)       &             dim, dn, ib, ie, myThid)
424              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,              CALL MNC_CW_ADD_VNAME(cdiag(ndId), d_cw_name,
425       &             4,5, myThid)       &             4,5, myThid)
426              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',              CALL MNC_CW_ADD_VATTR_TEXT(cdiag(ndId),'description',
427       &             tdiag(ndId),myThid)       &             tdiag(ndId),myThid)
# Line 417  C           &             0.0 _d 0,myThi Line 443  C           &             0.0 _d 0,myThi
443       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN       &           .OR. (fflags(listId)(1:1) .EQ. 'R')) THEN
444                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('R',diag_mnc_bn,0,0,
445       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
446              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)              ELSEIF ( (writeBinaryPrec .EQ. precFloat64)
447       &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN       &             .OR. (fflags(listId)(1:1) .EQ. 'D') ) THEN
448                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,                CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
449       &             cdiag(ndId), qtmp1, myThid)       &             cdiag(ndId), qtmp1, myThid)
450              ENDIF              ENDIF
451                
452              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)              CALL MNC_CW_DEL_VNAME(cdiag(ndId), myThid)
453              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)              CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
454    
# Line 431  C           &             0.0 _d 0,myThi Line 457  C           &             0.0 _d 0,myThi
457            ENDIF            ENDIF
458  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
459    
460             ENDDO
461  C--     end of Processing Fld # md  C--     end of Processing Fld # md
462          ENDIF          ENDIF
463        ENDDO        ENDDO
Legend:
Removed from v.1.28  
changed lines
  Added in v.1.29
  ViewVC Help
Powered by ViewVC 1.1.22