/[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.34 by jmc, Tue Nov 13 19:43:44 2007 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  #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 51  C     ndId  :: diagnostics  Id number (i Line 46  C     ndId  :: diagnostics  Id number (i
46  C     mate  :: counter mate Id number (in available diagnostics list)  C     mate  :: counter mate Id number (in available diagnostics list)
47  C     ip    :: diagnostics  pointer to storage array  C     ip    :: diagnostics  pointer to storage array
48  C     im    :: counter-mate pointer to storage array  C     im    :: counter-mate pointer to storage array
49    C
50    C--   COMMON /LOCAL_DIAGNOSTICS_OUT/ local common block (for multi-threaded)
51    C     qtmp1 :: thread-shared temporary array (needs to be in common block):
52    C              to write a diagnostic field to file, copy it first from (big)
53    C              diagnostic storage qdiag into it.
54          COMMON /LOCAL_DIAGNOSTICS_OUT/ qtmp1
55          _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
56    
57        INTEGER i, j, k, lm        INTEGER i, j, k, lm
58        INTEGER bi, bj        INTEGER bi, bj
59        INTEGER md, ndId, ip, im        INTEGER md, ndId, ip, im
60        INTEGER mate, mVec        INTEGER mate, mVec
61        CHARACTER*8 parms1        CHARACTER*8 parms1
       _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)  
62        _RL undef, getcon        _RL undef, getcon
63          _RL tmpLev
64        EXTERNAL getcon        EXTERNAL getcon
65        INTEGER ILNBLNK        INTEGER ILNBLNK
66        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
67        INTEGER ilen        INTEGER ilen
       INTEGER nlevsout  
68    
69        INTEGER ioUnit        INTEGER ioUnit
70        CHARACTER*(MAX_LEN_FNAM) fn        CHARACTER*(MAX_LEN_FNAM) fn
71        CHARACTER*(MAX_LEN_MBUF) suff        CHARACTER*(MAX_LEN_MBUF) suff
72        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
73          INTEGER prec, nRec
74  #ifdef ALLOW_MDSIO  #ifdef ALLOW_MDSIO
75        LOGICAL glf        LOGICAL glf
       INTEGER nRec  
76  #endif  #endif
77  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
78        INTEGER ii        INTEGER ii
# Line 84  C     im    :: counter-mate pointer to s Line 86  C     im    :: counter-mate pointer to s
86        CHARACTER*(NLEN) dn_blnk        CHARACTER*(NLEN) dn_blnk
87  #ifdef DIAG_MNC_COORD_NEEDSWORK  #ifdef DIAG_MNC_COORD_NEEDSWORK
88        CHARACTER*(5) ctmp        CHARACTER*(5) ctmp
89        _RS ztmp(Nr+Nrphys)        _RS ztmp(NrMax)
90  #endif  #endif
91  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
92    
# Line 286  C-        diagnostics is not empty : Line 288  C-        diagnostics is not empty :
288                ENDIF                ENDIF
289              ENDIF              ENDIF
290    
291              DO bj = myByLo(myThid), myByHi(myThid)              IF ( fflags(listId)(2:2).EQ.'P' ) THEN
292               DO bi = myBxLo(myThid), myBxHi(myThid)  C-       get all the levels (for vertical interpolation)
293                DO k = 1,nlevels(listId)                DO bj = myByLo(myThid), myByHi(myThid)
294                  CALL GETDIAG(                 DO bi = myBxLo(myThid), myBxHi(myThid)
295       I                       levs(k,listId),undef,                  DO k = 1,kdiag(ndId)
296       O                       qtmp1(1-OLx,1-OLy,k,bi,bj),                    tmpLev = k
297       I                       ndId,mate,ip,im,bi,bj,myThid)                    CALL GETDIAG(
298         I                         tmpLev,undef,
299         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
300         I                         ndId,mate,ip,im,bi,bj,myThid)
301                    ENDDO
302                   ENDDO
303                ENDDO                ENDDO
304               ENDDO              ELSE
305              ENDDO  C-       get only selected levels:
306                  DO bj = myByLo(myThid), myByHi(myThid)
307                   DO bi = myBxLo(myThid), myBxHi(myThid)
308                    DO k = 1,nlevels(listId)
309                      CALL GETDIAG(
310         I                         levs(k,listId),undef,
311         O                         qtmp1(1-OLx,1-OLy,k,bi,bj),
312         I                         ndId,mate,ip,im,bi,bj,myThid)
313                    ENDDO
314                   ENDDO
315                  ENDDO
316                ENDIF
317    
318  C-        end of empty diag / not empty block  C-        end of empty diag / not empty block
319            ENDIF            ENDIF
320    
           nlevsout = nlevels(listId)  
   
321  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
322  C         Check to see if we need to interpolate before output  C         Check to see if we need to interpolate before output
323  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
324            IF ( fflags(listId)(2:2).EQ.'P' ) THEN            IF ( fflags(listId)(2:2).EQ.'P' ) THEN
325  C-        Do vertical interpolation:  C-        Do vertical interpolation:
326  c          IF ( fluidIsAir ) THEN             IF ( fluidIsAir ) THEN
327  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  
328              CALL DIAGNOSTICS_INTERP_VERT(              CALL DIAGNOSTICS_INTERP_VERT(
329       I                     listId, md, ndId, ip, im,       I                     listId, md, ndId, ip, im, lm,
      U                     nlevsout,  
330       U                     qtmp1,       U                     qtmp1,
331       I                     undef,       I                     undef, myTime, myIter, myThid )
      I                     myTime, myIter, myThid )  
332             ELSE             ELSE
333               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',               WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_OUT: ',
334       &         '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)  
335               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
336               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'               STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT'
337             ENDIF             ENDIF
338            ENDIF            ENDIF
339    
340  #ifdef ALLOW_MDSIO  C--    Ready to write field "md", element "lm" in averageCycle(listId)
341  C         Prepare for mdsio optionality  
342            IF (diag_mdsio) THEN  C-        write to binary file, using MDSIO pkg:
343              glf = globalFiles            IF ( diag_mdsio ) THEN
344              nRec = lm + (md-1)*averageCycle(listId)              nRec = lm + (md-1)*averageCycle(listId)
345              IF (fflags(listId)(1:1) .EQ. 'R') THEN  C           default precision for output files
346  C             Force it to be 32-bit precision              prec = writeBinaryPrec
347                CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,.FALSE.,  C           fFlag(1)=R(or D): force it to be 32-bit(or 64) precision
348       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)              IF ( fflags(listId)(1:1).EQ.'R' ) prec = precFloat32
349              ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN              IF ( fflags(listId)(1:1).EQ.'D' ) prec = precFloat64
350  C             Force it to be 64-bit precision  C         a hack not to write meta files now: pass -nRec < 0 to MDS_WRITE S/R
351                CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,.FALSE.,              CALL WRITE_REC_LEV_RL(
352       &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)       I                            fn, prec,
353              ELSE       I                            NrMax, 1, nlevels(listId),
354  C             This is the old default behavior       I                            qtmp1, -nRec, myIter, myThid )
               CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,.FALSE.,  
      &             'RL',Nr+Nrphys,nlevsout,qtmp1,nRec,myIter,myThid)  
             ENDIF  
355            ENDIF            ENDIF
 #endif /*  ALLOW_MDSIO  */  
356    
357  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
358            IF (useMNC .AND. diag_mnc) THEN            IF (useMNC .AND. diag_mnc) THEN
# Line 396  C           XY dimensions Line 401  C           XY dimensions
401              ENDIF              ENDIF
402    
403  C           Z is special since it varies  C           Z is special since it varies
404              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevsout              WRITE(dn(3),'(a,i6.6)') 'Zd', nlevels(listId)
405              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
406       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'M') ) THEN
407                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zmd', nlevels(listId)
408              ENDIF              ENDIF
409              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
410       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'L') ) THEN
411                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zld', nlevels(listId)
412              ENDIF              ENDIF
413              IF ( (gdiag(ndId)(10:10) .EQ. 'R')              IF ( (gdiag(ndId)(10:10) .EQ. 'R')
414       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN       &           .AND. (gdiag(ndId)(9:9) .EQ. 'U') ) THEN
415                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevsout                WRITE(dn(3),'(a,i6.6)') 'Zud', nlevels(listId)
416              ENDIF              ENDIF
417              dim(3) = Nr+Nrphys              dim(3) = NrMax
418              ib(3)  = 1              ib(3)  = 1
419              ie(3)  = nlevsout              ie(3)  = nlevels(listId)
420    
421  C           Time dimension  C           Time dimension
422              dn(4)(1:1) = 'T'              dn(4)(1:1) = 'T'
# Line 462  C--     end of Processing Fld # md Line 467  C--     end of Processing Fld # md
467          ENDIF          ENDIF
468        ENDDO        ENDDO
469    
470    #ifdef ALLOW_MDSIO
471          IF (diag_mdsio) THEN
472    C-    Note: temporary: since it's a pain to add more arguments to
473    C     all MDSIO S/R, uses instead this specific S/R to write only
474    C     meta files but with more informations in it.
475                glf = globalFiles
476                nRec = nfields(listId)*averageCycle(listId)
477                CALL MDS_WR_METAFILES(fn, prec, glf, .FALSE.,
478         &              0, 0, nlevels(listId), ' ',
479         &              nfields(listId), flds(1,listId), 1, myTime,
480         &              nRec, myIter, myThid)
481          ENDIF
482    #endif /*  ALLOW_MDSIO  */
483    
484        RETURN        RETURN
485        END        END
486    
Legend:
Removed from v.1.29  
changed lines
  Added in v.1.34
  ViewVC Help
Powered by ViewVC 1.1.22