/[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.29 by jmc, Mon Jun 5 18:17:23 2006 UTC revision 1.32 by jmc, Fri Dec 29 23:57:15 2006 UTC
# 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          INTEGER NrMax
30  #ifdef ALLOW_FIZHI  #ifdef ALLOW_FIZHI
31  #include "fizhi_SIZE.h"  #include "fizhi_SIZE.h"
32          PARAMETER( NrMax = Nr+Nrphys )
33  #else  #else
34        INTEGER Nrphys        PARAMETER( NrMax = Nr )
       PARAMETER (Nrphys=0)  
35  #endif  #endif
36    
   
37  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
38  C     listId  :: Diagnostics list number being written  C     listId  :: Diagnostics list number being written
39  C     myIter  :: current iteration number  C     myIter  :: current iteration number
# Line 51  C     ndId  :: diagnostics  Id number (i Line 51  C     ndId  :: diagnostics  Id number (i
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    C
55    C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)
56    C     qtmp1 :: thread-shared temporary array (needs to be in common block):
57    C              to write a diagnostic field to file, copy it first from (big)
58    C              diagnostic storage qdiag into it.
59          COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1
60          _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
61    
62        INTEGER i, j, k, lm        INTEGER i, j, k, lm
63        INTEGER bi, bj        INTEGER bi, bj
64        INTEGER md, ndId, ip, im        INTEGER md, ndId, ip, im
65        INTEGER mate, mVec        INTEGER mate, mVec
66        CHARACTER*8 parms1        CHARACTER*8 parms1
       _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)  
67        _RL undef, getcon        _RL undef, getcon
68          _RL tmpLev
69        EXTERNAL getcon        EXTERNAL getcon
70        INTEGER ILNBLNK        INTEGER ILNBLNK
71        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
72        INTEGER ilen        INTEGER ilen
       INTEGER nlevsout  
73    
74        INTEGER ioUnit        INTEGER ioUnit
75        CHARACTER*(MAX_LEN_FNAM) fn        CHARACTER*(MAX_LEN_FNAM) fn
# Line 71  C     im    :: counter-mate pointer to s Line 78  C     im    :: counter-mate pointer to s
78  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
79        LOGICAL glf        LOGICAL glf
80        INTEGER nRec        INTEGER nRec
81          INTEGER prec
82  #endif  #endif
83  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
84        INTEGER ii        INTEGER ii
# Line 84  C     im    :: counter-mate pointer to s Line 92  C     im    :: counter-mate pointer to s
92        CHARACTER*(NLEN) dn_blnk        CHARACTER*(NLEN) dn_blnk
93  #ifdef DIAG_MNC_COORD_NEEDSWORK  #ifdef DIAG_MNC_COORD_NEEDSWORK
94        CHARACTER*(5) ctmp        CHARACTER*(5) ctmp
95        _RS ztmp(Nr+Nrphys)        _RS ztmp(NrMax)
96  #endif  #endif
97  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
98    
# Line 286  C-        diagnostics is not empty : Line 294  C-        diagnostics is not empty :
294                ENDIF                ENDIF
295              ENDIF              ENDIF
296    
297              DO bj = myByLo(myThid), myByHi(myThid)              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
298               DO bi = myBxLo(myThid), myBxHi(myThid)  C-       get all the levels (for vertical interpolation)
299                DO k = 1,nlevels(listId)                DO bj = myByLo(myThid), myByHi(myThid)
300                  CALL GETDIAG(                 DO bi = myBxLo(myThid), myBxHi(myThid)
301       I                       levs(k,listId),undef,                  DO k = 1,kdiag(ndId)
302       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),                    tmpLev = k
303       I                       ndId,mate,ip,im,bi,bj,myThid)                    CALL GETDIAG(
304         I                         tmpLev,undef,
305         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
306         I                         ndId,mate,ip,im,bi,bj,myThid)
307                    ENDDO
308                   ENDDO
309                ENDDO                ENDDO
310               ENDDO              ELSE
311              ENDDO  C-       get only selected levels:
312                  DO bj = myByLo(myThid), myByHi(myThid)
313                   DO bi = myBxLo(myThid), myBxHi(myThid)
314                    DO k = 1,nlevels(listId)
315                      CALL GETDIAG(
316         I                         levs(k,listId),undef,
317         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
318         I                         ndId,mate,ip,im,bi,bj,myThid)
319                    ENDDO
320                   ENDDO
321                  ENDDO
322                ENDIF
323    
324  C-        end of empty diag / not empty block  C-        end of empty diag / not empty block
325            ENDIF            ENDIF
326    
           nlevsout = nlevels(listId)  
   
327  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
328  C         Check to see if we need to interpolate before output  C         Check to see if we need to interpolate before output
329  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
330            IF ( fflags(listId)(2:2).EQ.'P' ) THEN            IF ( fflags(listId)(2:2).EQ.'P' ) THEN
331  C-        Do vertical interpolation:  C-        Do vertical interpolation:
332  c          IF ( fluidIsAir ) THEN             IF ( fluidIsAir ) THEN
333  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);
 C      find some problems with 5-levels AIM => use it only with FIZHI  
            IF ( useFIZHI ) THEN  
334              CALL DIAGNOSTICS_INTERP_VERT(              CALL DIAGNOSTICS_INTERP_VERT(
335       I                     listId, md, ndId, ip, im,       I                     listId, md, ndId, ip, im, lm,
      U                     nlevsout,  
336       U                     qtmp1,       U                     qtmp1,
337       I                     undef,       I                     undef, myTime, myIter, myThid )
      I                     myTime, myIter, myThid )  
338             ELSE             ELSE
339               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
340       &         'INTERP_VERT not safe in this config'       &         'INTERP_VERT not allowed in this config'
              CALL PRINT_ERROR( msgBuf , myThid )  
              WRITE(msgBuf,'(2A,I3,2A)') 'DIAGNOSTICS_OUT: ',  
      &         ' for list l=', listId, ', filename: ', fnames(listId)  
341               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
342               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
343             ENDIF             ENDIF
344            ENDIF            ENDIF
345    
346    C--    Ready to write field "md", element "lm" in averageCycle(listId)
347    
348  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
349  C         Prepare for mdsio optionality  C-        write to binary file, using MDSIO pkg:
350            IF (diag_mdsio) THEN            IF (diag_mdsio) THEN
351              glf = globalFiles              glf = globalFiles
352              nRec = lm + (md-1)*averageCycle(listId)              nRec = lm + (md-1)*averageCycle(listId)
353              IF (fflags(listId)(1:1) .EQ. 'R') THEN  C           default precision for output files
354  C             Force it to be 32-bit precision              prec = writeBinaryPrec
355                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,  C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
356       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)              IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
357              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN              IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
358  C             Force it to be 64-bit precision  c           CALL MDS_WRITE_FIELD(fn,prec,glf,.FALSE.,'RL',
359                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,  c    &              NrMax,nlevels(listId),qtmp1,nRec,myIter,myThid)
360       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)  C         a hack not to write meta files now:
361              ELSE              CALL MDS_WRITE_FIELD(fn,prec,glf,.FALSE.,'RL',
362  C             This is the old default behavior       &              NrMax,nlevels(listId),qtmp1,-nRec,myIter,myThid)
               CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,  
      &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)  
             ENDIF  
363            ENDIF            ENDIF
364  #endif /*  ALLOW_MDSIO  */  #endif /*  ALLOW_MDSIO  */
365    
# Line 396  C           XY dimensions Line 410  C           XY dimensions
410              ENDIF              ENDIF
411    
412  C           Z is special since it varies  C           Z is special since it varies
413              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)
414              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
415       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
416                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevels(listId)
417              ENDIF              ENDIF
418              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
419       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
420                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listId)
421              ENDIF              ENDIF
422              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
423       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
424                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)
425              ENDIF              ENDIF
426              dim(3) = Nr+Nrphys              dim(3) = NrMax
427              ib(3)  = 1              ib(3)  = 1
428              ie(3)  = nlevsout              ie(3)  = nlevels(listId)
429    
430  C           Time dimension  C           Time dimension
431              dn(4)(1:1) = 'T'              dn(4)(1:1) = 'T'
# Line 462  C--     end of Processing Fld # md Line 476  C--     end of Processing Fld # md
476          ENDIF          ENDIF
477        ENDDO        ENDDO
478    
479    #ifdef ALLOW_MDSIO
480          IF (diag_mdsio) THEN
481    C-    Note: temporary: since it's a pain to add more arguments to
482    C     all MDSIO S/R, uses instead this specific S/R to write only
483    C     meta files but with more informations in it.
484                nRec = nfields(listId)*averageCycle(listId)
485                CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
486         &              0, 0, nlevels(listId), ' ',
487         &              nfields(listId), flds(1,listId), 1, myTime,
488         &              nRec, myIter, myThid)
489          ENDIF
490    #endif /*  ALLOW_MDSIO  */
491    
492        RETURN        RETURN
493        END        END
494    
Legend:
Removed from v.1.29  
changed lines
  Added in v.1.32
  ViewVC Help
Powered by ViewVC 1.1.22