/[MITgcm]/MITgcm/pkg/diagnostics/diagnostics_utils.F
ViewVC logotype

Diff of /MITgcm/pkg/diagnostics/diagnostics_utils.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.29 by jmc, Fri Jan 15 00:25:58 2010 UTC revision 1.34 by jmc, Tue May 9 02:49:34 2017 UTC
# Line 5  C $Name$ Line 5  C $Name$
5    
6  C--   File diagnostics_utils.F: General purpose support routines  C--   File diagnostics_utils.F: General purpose support routines
7  C--    Contents:  C--    Contents:
 C--    o GETDIAG  
8  C--    o DIAGNOSTICS_COUNT  C--    o DIAGNOSTICS_COUNT
9    C--    o DIAGNOSTICS_GET_DIAG
10  C--    o DIAGNOSTICS_GET_POINTERS  C--    o DIAGNOSTICS_GET_POINTERS
11  C--    o DIAGNOSTICS_SETKLEV  C--    o DIAGNOSTICS_SETKLEV
12  C--    o DIAGS_GET_PARMS_I (Function)  C--    o DIAGS_GET_PARMS_I (Function)
13  C--    o DIAGS_MK_UNITS (Function)  C--    o DIAGS_MK_UNITS (Function)
14  C--    o DIAGS_MK_TITLE (Function)  C--    o DIAGS_MK_TITLE (Function)
15    C--    o DIAGS_RENAMED (Function)
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
 CBOP 0  
 C     !ROUTINE: GETDIAG  
   
 C     !INTERFACE:  
       SUBROUTINE GETDIAG(  
      I                    levreal, undef,  
      O                    qtmp,  
      I                    ndId, mate, ip, im, bi, bj, myThid )  
   
 C     !DESCRIPTION:  
 C     Retrieve averaged model diagnostic  
   
 C     !USES:  
       IMPLICIT NONE  
 #include "EEPARAMS.h"  
 #include "SIZE.h"  
 #include "DIAGNOSTICS_SIZE.h"  
 #include "DIAGNOSTICS.h"  
   
 C     !INPUT PARAMETERS:  
 C     levreal :: Diagnostic LEVEL  
 C     undef   :: UNDEFINED VALUE  
 C     ndId    :: DIAGNOSTIC NUMBER FROM MENU  
 C     mate    :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise  
 C     ip      :: pointer to storage array location for diag.  
 C     im      :: pointer to storage array location for mate  
 C     bi      :: X-direction tile number  
 C     bj      :: Y-direction tile number  
 C     myThid  :: my thread Id number  
       _RL levreal  
       _RL undef  
       INTEGER ndId, mate, ip, im  
       INTEGER bi,bj, myThid  
   
 C     !OUTPUT PARAMETERS:  
 C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY  
       _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)  
 CEOP  
   
 C     !LOCAL VARIABLES:  
       _RL factor  
       INTEGER i, j, ipnt,ipCt  
       INTEGER lev, levCt, klev  
   
       IF (ndId.GE.1) THEN  
        lev = NINT(levreal)  
        klev = kdiag(ndId)  
        IF (lev.LE.klev) THEN  
   
         IF ( mate.EQ.0 ) THEN  
 C-      No counter diagnostics => average = Sum / ndiag :  
   
           ipnt = ip + lev - 1  
           factor = FLOAT(ndiag(ip,bi,bj))  
           IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor  
   
 #ifdef ALLOW_FIZHI  
           DO j = 1,sNy+1  
             DO i = 1,sNx+1  
               IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN  
                 qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor  
               ELSE  
                 qtmp(i,j) = undef  
               ENDIF  
             ENDDO  
           ENDDO  
 #else /* ALLOW_FIZHI */  
           DO j = 1,sNy+1  
             DO i = 1,sNx+1  
               qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor  
             ENDDO  
           ENDDO  
 #endif /* ALLOW_FIZHI */  
   
         ELSE  
 C-      With counter diagnostics => average = Sum / counter:  
   
           ipnt = ip + lev - 1  
           levCt= MIN(lev,kdiag(mate))  
           ipCt = im + levCt - 1  
           DO j = 1,sNy+1  
             DO i = 1,sNx+1  
               IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN  
                 qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)  
      &                    / qdiag(i,j,ipCt,bi,bj)  
               ELSE  
                 qtmp(i,j) = undef  
               ENDIF  
             ENDDO  
           ENDDO  
   
         ENDIF  
        ENDIF  
       ENDIF  
   
       RETURN  
       END  
16    
17  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
18    
19  CBOP 0  CBOP 0
20  C     !ROUTINE: DIAGNOSTICS_COUNT  C     !ROUTINE: DIAGNOSTICS_COUNT
21  C     !INTERFACE:  C     !INTERFACE:
22        SUBROUTINE DIAGNOSTICS_COUNT (chardiag,        SUBROUTINE DIAGNOSTICS_COUNT( diagName,
23       I                              biArg, bjArg, myThid)       I                              biArg, bjArg, myThid )
24    
25  C     !DESCRIPTION:  C     !DESCRIPTION:
26  C***********************************************************************  C***********************************************************************
# Line 137  C     !INPUT PARAMETERS: Line 39  C     !INPUT PARAMETERS:
39  C***********************************************************************  C***********************************************************************
40  C  Arguments Description  C  Arguments Description
41  C  ----------------------  C  ----------------------
42  C     chardiag :: Character expression for diag to increment the counter  C     diagName :: name of diagnostic to increment the counter
43  C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops  C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
44  C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops  C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
45  C     myThid   :: my thread Id number  C     myThid   :: my thread Id number
46  C***********************************************************************  C***********************************************************************
47        CHARACTER*8 chardiag        CHARACTER*8 diagName
48        INTEGER biArg, bjArg        INTEGER biArg, bjArg
49        INTEGER myThid        INTEGER myThid
50  CEOP  CEOP
# Line 164  c     CHARACTER*(MAX_LEN_MBUF) msgBuf Line 66  c     CHARACTER*(MAX_LEN_MBUF) msgBuf
66    
67  C--   Run through list of active diagnostics to find which counter  C--   Run through list of active diagnostics to find which counter
68  C     to increment (needs to be a valid & active diagnostic-counter)  C     to increment (needs to be a valid & active diagnostic-counter)
69        DO n=1,nlists        DO n=1,nLists
70         DO m=1,nActive(n)         DO m=1,nActive(n)
71          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN          IF ( diagName.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
72           ipt = idiag(m,n)           ipt = idiag(m,n)
73           IF (ndiag(ipt,bi,bj).GE.0) THEN           IF (ndiag(ipt,bi,bj).GE.0) THEN
74            ndId = jdiag(m,n)            ndId = jdiag(m,n)
# Line 193  C-    Increment is done Line 95  C-    Increment is done
95  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
96    
97  CBOP 0  CBOP 0
98    C     !ROUTINE: DIAGNOSTICS_GET_DIAG
99    
100    C     !INTERFACE:
101          SUBROUTINE DIAGNOSTICS_GET_DIAG(
102         I                    kl, undefRL,
103         O                    qtmp,
104         I                    ndId, mate, ip, im, bi, bj, myThid )
105    
106    C     !DESCRIPTION:
107    C     Retrieve time-averaged (or snap-shot) diagnostic field
108    
109    C     !USES:
110          IMPLICIT NONE
111    #include "EEPARAMS.h"
112    #include "SIZE.h"
113    #include "DIAGNOSTICS_SIZE.h"
114    #include "DIAGNOSTICS.h"
115    
116    C     !INPUT PARAMETERS:
117    C     kl      :: level selection: >0 : single selected lev ; =0 : all kdiag levels
118    C     undefRL :: undefined "_RL" type value
119    C     ndId    :: diagnostic Id number (in available diagnostics list)
120    C     mate    :: counter diagnostic number if any ; 0 otherwise
121    C     ip      :: pointer to storage array location for diag.
122    C     im      :: pointer to storage array location for mate
123    C     bi      :: X-direction tile number
124    C     bj      :: Y-direction tile number
125    C     myThid  :: my thread Id number
126          INTEGER kl
127          _RL undefRL
128          INTEGER ndId, mate, ip, im
129          INTEGER bi, bj, myThid
130    
131    C     !OUTPUT PARAMETERS:
132    C     qtmp    :: time-averaged (or snap-shot) diagnostic field
133          _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,*)
134    CEOP
135    
136    C     !LOCAL VARIABLES:
137          _RL factor
138          INTEGER i, j, ipnt, ipCt
139          INTEGER k, kd, km, kLev
140    
141          IF (ndId.GE.1) THEN
142           kLev = kdiag(ndId)
143           IF ( kl.GE.1 .AND. kl.LE.kLev ) THEN
144            kLev = 1
145           ELSEIF ( kl.NE.0 ) THEN
146            kLev = 0
147           ENDIF
148    
149           DO k = 1,kLev
150            kd = k
151            IF ( kl.GE.1 ) kd = kl
152    
153            IF ( mate.EQ.0 ) THEN
154    C-      No counter diagnostics => average = Sum / ndiag :
155    
156              ipnt = ip + kd - 1
157              factor = FLOAT(ndiag(ip,bi,bj))
158              IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
159    
160    #ifdef ALLOW_FIZHI
161              DO j = 1,sNy+1
162                DO i = 1,sNx+1
163                  IF ( qdiag(i,j,ipnt,bi,bj) .LE. undefRL ) THEN
164                    qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
165                  ELSE
166                    qtmp(i,j,k) = undefRL
167                  ENDIF
168                ENDDO
169              ENDDO
170    #else /* ALLOW_FIZHI */
171              DO j = 1,sNy+1
172                DO i = 1,sNx+1
173                  qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
174                ENDDO
175              ENDDO
176    #endif /* ALLOW_FIZHI */
177    
178            ELSE
179    C-      With counter diagnostics => average = Sum / counter:
180    
181              ipnt = ip + kd - 1
182              km = MIN(kd,kdiag(mate))
183              ipCt = im + km - 1
184              DO j = 1,sNy+1
185                DO i = 1,sNx+1
186                  IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
187                    qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)
188         &                      / qdiag(i,j,ipCt,bi,bj)
189                  ELSE
190                    qtmp(i,j,k) = undefRL
191                  ENDIF
192                ENDDO
193              ENDDO
194    
195            ENDIF
196           ENDDO
197          ENDIF
198    
199          RETURN
200          END
201    
202    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
203    
204    CBOP 0
205  C     !ROUTINE: DIAGNOSTICS_GET_POINTERS  C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
206  C     !INTERFACE:  C     !INTERFACE:
207        SUBROUTINE DIAGNOSTICS_GET_POINTERS(        SUBROUTINE DIAGNOSTICS_GET_POINTERS(
# Line 230  C     !OUTPUT PARAMETERS: Line 239  C     !OUTPUT PARAMETERS:
239  C     ndId     :: diagnostics  Id number (in available diagnostics list)  C     ndId     :: diagnostics  Id number (in available diagnostics list)
240  C     ip       :: diagnostics  pointer to storage array  C     ip       :: diagnostics  pointer to storage array
241    
   
242        CHARACTER*8 diagName        CHARACTER*8 diagName
243        INTEGER listId        INTEGER listId
244        INTEGER ndId, ip        INTEGER ndId, ip
# Line 247  C     !LOCAL VARIABLES: Line 255  C     !LOCAL VARIABLES:
255  C--   select the 1rst one which name matches:  C--   select the 1rst one which name matches:
256    
257  C-    search for this diag. in the active 2D/3D diagnostics list  C-    search for this diag. in the active 2D/3D diagnostics list
258          DO n=1,nlists          DO n=1,nLists
259           DO m=1,nActive(n)           DO m=1,nActive(n)
260             IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)             IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
261       &                  .AND. idiag(m,n).NE.0 ) THEN       &                  .AND. idiag(m,n).NE.0 ) THEN
# Line 257  C-    search for this diag. in the activ Line 265  C-    search for this diag. in the activ
265           ENDDO           ENDDO
266          ENDDO          ENDDO
267    
268        ELSEIF ( listId.LE.nlists ) THEN        ELSEIF ( listId.LE.nLists ) THEN
269  C--   select the unique diagnostic with output-time identical to listId  C--   select the unique diagnostic with output-time identical to listId
270    
271  C-    search for this diag. in the active 2D/3D diagnostics list  C-    search for this diag. in the active 2D/3D diagnostics list
272          DO n=1,nlists          DO n=1,nLists
273           IF ( ip.EQ.0           IF ( ip.EQ.0
274       &        .AND. freq(n) .EQ. freq(listId)       &        .AND. freq(n) .EQ. freq(listId)
275       &        .AND. phase(n).EQ.phase(listId)       &        .AND. phase(n).EQ.phase(listId)
# Line 333  C     !LOCAL VARIABLES: Line 341  C     !LOCAL VARIABLES:
341    
342  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
343    
344          _BEGIN_MASTER( myThid)
345    
346  C--   Check if this S/R is called from the right place ;  C--   Check if this S/R is called from the right place ;
347  C     needs to be after DIAGNOSTICS_INIT_EARLY and before DIAGNOSTICS_INIT_FIXED  C     needs to be after DIAGNOSTICS_INIT_EARLY and before DIAGNOSTICS_INIT_FIXED
348        IF ( .NOT.settingDiags ) THEN        IF ( diag_pkgStatus.NE.ready2setDiags ) THEN
349          WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',          CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_SETKLEV',
350       &     'diagName="', diagName, '" , nLevDiag=', nLevDiag       &                   ' ', diagName, ready2setDiags, myThid )
         CALL PRINT_ERROR( msgBuf, myThid )  
         WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',  
      &     '<== called from the WRONG place, i.e.'  
         CALL PRINT_ERROR( msgBuf, myThid )  
         WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',  
      &     'outside diagnostics setting section = from'  
         CALL PRINT_ERROR( msgBuf, myThid )  
         WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',  
      &     '   Diag_INIT_EARLY down to Diag_INIT_FIXED'  
         CALL PRINT_ERROR( msgBuf, myThid )  
         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'  
351        ENDIF        ENDIF
352    
353  C--   Find this diagnostics in the list of available diag.  C--   Find this diagnostics in the list of available diag.
# Line 404  C-    for now, do nothing but just send Line 403  C-    for now, do nothing but just send
403       &                      SQUEEZE_RIGHT , myThid )       &                      SQUEEZE_RIGHT , myThid )
404        ENDIF        ENDIF
405    
406          _END_MASTER( myThid)
407    
408        RETURN        RETURN
409        END        END
410    
# Line 489  CEOP Line 490  CEOP
490    
491  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
492        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
493        INTEGER i,j,n        INTEGER i,j,n,nbc
494    
495        DIAGS_MK_UNITS = '                '        DIAGS_MK_UNITS = '                '
496        n = LEN(diagUnitsInPieces)        n = LEN(diagUnitsInPieces)
# Line 501  C     !LOCAL VARIABLES: Line 502  C     !LOCAL VARIABLES:
502           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
503         ENDIF         ENDIF
504        ENDDO        ENDDO
505          nbc = j
506    
507          IF ( nbc.GT.16 ) THEN
508    C-    try to reduce length by changing m^2 & m^3 to m2 & m3:
509           DIAGS_MK_UNITS = '                '
510           j = 0
511           DO i=1,n
512            IF ( diagUnitsInPieces(i:i) .NE. ' ' ) THEN
513             IF ( j.GE.1 .AND. nbc.GT.16 .AND.
514         &         diagUnitsInPieces(i:i).EQ.'^' ) THEN
515              IF ( diagUnitsInPieces(i-1:i-1).EQ.'m' ) THEN
516                nbc = nbc - 1
517              ELSE
518               j = j+1
519               IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
520              ENDIF
521             ELSE
522              j = j+1
523              IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
524             ENDIF
525            ENDIF
526           ENDDO
527          ENDIF
528    
529        IF ( j.GT.16 ) THEN        IF ( j.GT.16 ) THEN
530           WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',           WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
# Line 583  C---+----1----+----2----+----3----+----4 Line 607  C---+----1----+----2----+----3----+----4
607        ENDIF        ENDIF
608    
609        RETURN        RETURN
610          END
611    
612    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
613    
614    CBOP 0
615    C     !ROUTINE: DIAGS_RENAMED
616    
617    C     !INTERFACE:
618          CHARACTER*8 FUNCTION DIAGS_RENAMED(
619         I                           diagName, myThid )
620    
621    C     !DESCRIPTION:
622    C     *==========================================================*
623    C     | FUNCTION DIAGS_RENAMED
624    C     | o In case of an old diagnostics name,
625    C     |   provides the corresponding new name
626    C     *==========================================================*
627    
628    C     !USES:
629          IMPLICIT NONE
630    #include "EEPARAMS.h"
631    #include "SIZE.h"
632    #include "PARAMS.h"
633    #include "DIAGNOSTICS_SIZE.h"
634    #include "DIAGNOSTICS.h"
635    
636    C     !INPUT PARAMETERS:
637    C     diagName  :: name of diagnostic to rename (or not)
638    C     myThid    :: my Thread Id number
639          CHARACTER*8 diagName
640          INTEGER myThid
641    CEOP
642    
643    C     !LOCAL VARIABLES:
644          CHARACTER*8 newName
645          CHARACTER*(MAX_LEN_MBUF) msgBuf
646    
647    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
648    
649          newName = blkName
650    
651          IF ( useSEAICE ) THEN
652           IF ( diagName .EQ. 'SIfu    ' ) newName = 'oceTAUX '
653           IF ( diagName .EQ. 'SIfv    ' ) newName = 'oceTAUY '
654           IF ( diagName .EQ. 'SIuwind ' ) newName = 'EXFuwind'
655           IF ( diagName .EQ. 'SIvwind ' ) newName = 'EXFvwind'
656          ENDIF
657    
658          IF ( newName.EQ.blkName ) THEN
659            DIAGS_RENAMED = diagName
660          ELSE
661            DIAGS_RENAMED = newName
662            WRITE(msgBuf,'(6A)') '** WARNING ** (DIAGS_RENAMED):',
663         &    ' diagnostics "', diagName, '" replaced by "', newName, '"'
664            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
665         &                      SQUEEZE_RIGHT , myThid )
666            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
667         &                      SQUEEZE_RIGHT , myThid )
668          ENDIF
669    
670          RETURN
671        END        END
Legend:
Removed from v.1.29  
changed lines
  Added in v.1.34
  ViewVC Help
Powered by ViewVC 1.1.22