/[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.30 by jmc, Fri Jan 15 18:57:07 2010 UTC revision 1.33 by jmc, Fri Jul 18 22:04:10 2014 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)
# Line 14  C--    o DIAGS_MK_UNITS (Function) Line 14  C--    o DIAGS_MK_UNITS (Function)
14  C--    o DIAGS_MK_TITLE (Function)  C--    o DIAGS_MK_TITLE (Function)
15    
16  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  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  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
17    
18  CBOP 0  CBOP 0
19  C     !ROUTINE: DIAGNOSTICS_COUNT  C     !ROUTINE: DIAGNOSTICS_COUNT
20  C     !INTERFACE:  C     !INTERFACE:
21        SUBROUTINE DIAGNOSTICS_COUNT (chardiag,        SUBROUTINE DIAGNOSTICS_COUNT( diagName,
22       I                              biArg, bjArg, myThid)       I                              biArg, bjArg, myThid )
23    
24  C     !DESCRIPTION:  C     !DESCRIPTION:
25  C***********************************************************************  C***********************************************************************
# Line 137  C     !INPUT PARAMETERS: Line 38  C     !INPUT PARAMETERS:
38  C***********************************************************************  C***********************************************************************
39  C  Arguments Description  C  Arguments Description
40  C  ----------------------  C  ----------------------
41  C     chardiag :: Character expression for diag to increment the counter  C     diagName :: name of diagnostic to increment the counter
42  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
43  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
44  C     myThid   :: my thread Id number  C     myThid   :: my thread Id number
45  C***********************************************************************  C***********************************************************************
46        CHARACTER*8 chardiag        CHARACTER*8 diagName
47        INTEGER biArg, bjArg        INTEGER biArg, bjArg
48        INTEGER myThid        INTEGER myThid
49  CEOP  CEOP
# Line 164  c     CHARACTER*(MAX_LEN_MBUF) msgBuf Line 65  c     CHARACTER*(MAX_LEN_MBUF) msgBuf
65    
66  C--   Run through list of active diagnostics to find which counter  C--   Run through list of active diagnostics to find which counter
67  C     to increment (needs to be a valid & active diagnostic-counter)  C     to increment (needs to be a valid & active diagnostic-counter)
68        DO n=1,nlists        DO n=1,nLists
69         DO m=1,nActive(n)         DO m=1,nActive(n)
70          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
71           ipt = idiag(m,n)           ipt = idiag(m,n)
72           IF (ndiag(ipt,bi,bj).GE.0) THEN           IF (ndiag(ipt,bi,bj).GE.0) THEN
73            ndId = jdiag(m,n)            ndId = jdiag(m,n)
# Line 193  C-    Increment is done Line 94  C-    Increment is done
94  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
95    
96  CBOP 0  CBOP 0
97    C     !ROUTINE: DIAGNOSTICS_GET_DIAG
98    
99    C     !INTERFACE:
100          SUBROUTINE DIAGNOSTICS_GET_DIAG(
101         I                    kl, undefRL,
102         O                    qtmp,
103         I                    ndId, mate, ip, im, bi, bj, myThid )
104    
105    C     !DESCRIPTION:
106    C     Retrieve time-averaged (or snap-shot) diagnostic field
107    
108    C     !USES:
109          IMPLICIT NONE
110    #include "EEPARAMS.h"
111    #include "SIZE.h"
112    #include "DIAGNOSTICS_SIZE.h"
113    #include "DIAGNOSTICS.h"
114    
115    C     !INPUT PARAMETERS:
116    C     kl      :: level selection: >0 : single selected lev ; =0 : all kdiag levels
117    C     undefRL :: undefined "_RL" type value
118    C     ndId    :: diagnostic Id number (in available diagnostics list)
119    C     mate    :: counter diagnostic number if any ; 0 otherwise
120    C     ip      :: pointer to storage array location for diag.
121    C     im      :: pointer to storage array location for mate
122    C     bi      :: X-direction tile number
123    C     bj      :: Y-direction tile number
124    C     myThid  :: my thread Id number
125          INTEGER kl
126          _RL undefRL
127          INTEGER ndId, mate, ip, im
128          INTEGER bi, bj, myThid
129    
130    C     !OUTPUT PARAMETERS:
131    C     qtmp    :: time-averaged (or snap-shot) diagnostic field
132          _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,*)
133    CEOP
134    
135    C     !LOCAL VARIABLES:
136          _RL factor
137          INTEGER i, j, ipnt, ipCt
138          INTEGER k, kd, km, kLev
139    
140          IF (ndId.GE.1) THEN
141           kLev = kdiag(ndId)
142           IF ( kl.GE.1 .AND. kl.LE.kLev ) THEN
143            kLev = 1
144           ELSEIF ( kl.NE.0 ) THEN
145            kLev = 0
146           ENDIF
147    
148           DO k = 1,kLev
149            kd = k
150            IF ( kl.GE.1 ) kd = kl
151    
152            IF ( mate.EQ.0 ) THEN
153    C-      No counter diagnostics => average = Sum / ndiag :
154    
155              ipnt = ip + kd - 1
156              factor = FLOAT(ndiag(ip,bi,bj))
157              IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
158    
159    #ifdef ALLOW_FIZHI
160              DO j = 1,sNy+1
161                DO i = 1,sNx+1
162                  IF ( qdiag(i,j,ipnt,bi,bj) .LE. undefRL ) THEN
163                    qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
164                  ELSE
165                    qtmp(i,j,k) = undefRL
166                  ENDIF
167                ENDDO
168              ENDDO
169    #else /* ALLOW_FIZHI */
170              DO j = 1,sNy+1
171                DO i = 1,sNx+1
172                  qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
173                ENDDO
174              ENDDO
175    #endif /* ALLOW_FIZHI */
176    
177            ELSE
178    C-      With counter diagnostics => average = Sum / counter:
179    
180              ipnt = ip + kd - 1
181              km = MIN(kd,kdiag(mate))
182              ipCt = im + km - 1
183              DO j = 1,sNy+1
184                DO i = 1,sNx+1
185                  IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
186                    qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)
187         &                      / qdiag(i,j,ipCt,bi,bj)
188                  ELSE
189                    qtmp(i,j,k) = undefRL
190                  ENDIF
191                ENDDO
192              ENDDO
193    
194            ENDIF
195           ENDDO
196          ENDIF
197    
198          RETURN
199          END
200    
201    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
202    
203    CBOP 0
204  C     !ROUTINE: DIAGNOSTICS_GET_POINTERS  C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
205  C     !INTERFACE:  C     !INTERFACE:
206        SUBROUTINE DIAGNOSTICS_GET_POINTERS(        SUBROUTINE DIAGNOSTICS_GET_POINTERS(
# Line 230  C     !OUTPUT PARAMETERS: Line 238  C     !OUTPUT PARAMETERS:
238  C     ndId     :: diagnostics  Id number (in available diagnostics list)  C     ndId     :: diagnostics  Id number (in available diagnostics list)
239  C     ip       :: diagnostics  pointer to storage array  C     ip       :: diagnostics  pointer to storage array
240    
   
241        CHARACTER*8 diagName        CHARACTER*8 diagName
242        INTEGER listId        INTEGER listId
243        INTEGER ndId, ip        INTEGER ndId, ip
# Line 247  C     !LOCAL VARIABLES: Line 254  C     !LOCAL VARIABLES:
254  C--   select the 1rst one which name matches:  C--   select the 1rst one which name matches:
255    
256  C-    search for this diag. in the active 2D/3D diagnostics list  C-    search for this diag. in the active 2D/3D diagnostics list
257          DO n=1,nlists          DO n=1,nLists
258           DO m=1,nActive(n)           DO m=1,nActive(n)
259             IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)             IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
260       &                  .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 264  C-    search for this diag. in the activ
264           ENDDO           ENDDO
265          ENDDO          ENDDO
266    
267        ELSEIF ( listId.LE.nlists ) THEN        ELSEIF ( listId.LE.nLists ) THEN
268  C--   select the unique diagnostic with output-time identical to listId  C--   select the unique diagnostic with output-time identical to listId
269    
270  C-    search for this diag. in the active 2D/3D diagnostics list  C-    search for this diag. in the active 2D/3D diagnostics list
271          DO n=1,nlists          DO n=1,nLists
272           IF ( ip.EQ.0           IF ( ip.EQ.0
273       &        .AND. freq(n) .EQ. freq(listId)       &        .AND. freq(n) .EQ. freq(listId)
274       &        .AND. phase(n).EQ.phase(listId)       &        .AND. phase(n).EQ.phase(listId)
# Line 337  C---+----1----+----2----+----3----+----4 Line 344  C---+----1----+----2----+----3----+----4
344    
345  C--   Check if this S/R is called from the right place ;  C--   Check if this S/R is called from the right place ;
346  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
347        IF ( .NOT.settingDiags ) THEN        IF ( diag_pkgStatus.NE.ready2setDiags ) THEN
348          WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',          CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_SETKLEV',
349       &     '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'  
350        ENDIF        ENDIF
351    
352  C--   Find this diagnostics in the list of available diag.  C--   Find this diagnostics in the list of available diag.
# Line 493  CEOP Line 489  CEOP
489    
490  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
491        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
492        INTEGER i,j,n        INTEGER i,j,n,nbc
493    
494        DIAGS_MK_UNITS = '                '        DIAGS_MK_UNITS = '                '
495        n = LEN(diagUnitsInPieces)        n = LEN(diagUnitsInPieces)
# Line 505  C     !LOCAL VARIABLES: Line 501  C     !LOCAL VARIABLES:
501           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
502         ENDIF         ENDIF
503        ENDDO        ENDDO
504          nbc = j
505    
506          IF ( nbc.GT.16 ) THEN
507    C-    try to reduce length by changing m^2 & m^3 to m2 & m3:
508           DIAGS_MK_UNITS = '                '
509           j = 0
510           DO i=1,n
511            IF ( diagUnitsInPieces(i:i) .NE. ' ' ) THEN
512             IF ( j.GE.1 .AND. nbc.GT.16 .AND.
513         &         diagUnitsInPieces(i:i).EQ.'^' ) THEN
514              IF ( diagUnitsInPieces(i-1:i-1).EQ.'m' ) THEN
515                nbc = nbc - 1
516              ELSE
517               j = j+1
518               IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
519              ENDIF
520             ELSE
521              j = j+1
522              IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
523             ENDIF
524            ENDIF
525           ENDDO
526          ENDIF
527    
528        IF ( j.GT.16 ) THEN        IF ( j.GT.16 ) THEN
529           WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',           WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
Legend:
Removed from v.1.30  
changed lines
  Added in v.1.33
  ViewVC Help
Powered by ViewVC 1.1.22