/[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.18 by jmc, Mon Feb 7 03:07:49 2005 UTC revision 1.25 by jmc, Tue Feb 5 15:31:19 2008 UTC
# Line 3  C $Name$ Line 3  C $Name$
3    
4  #include "DIAG_OPTIONS.h"  #include "DIAG_OPTIONS.h"
5    
6    C--   File diagnostics_utils.F: General purpose support routines
7    C--    Contents:
8    C--    o GETDIAG
9    C--    o DIAGNOSTICS_COUNT
10    C--    o DIAGS_MK_UNITS (Function)
11    C--    o DIAGS_MK_TITLE (Function)
12    C--    o DIAGNOSTICS_GET_POINTERS
13    
14  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
15  CBOP 0  CBOP 0
16  C     !ROUTINE: GETDIAG  C     !ROUTINE: GETDIAG
# Line 11  C     !INTERFACE: Line 19  C     !INTERFACE:
19        SUBROUTINE GETDIAG(        SUBROUTINE GETDIAG(
20       I                    levreal, undef,       I                    levreal, undef,
21       O                    qtmp,       O                    qtmp,
22       I                    ipoint, mate, bi, bj, myThid )       I                    ndId, mate, ip, im, bi, bj, myThid )
23    
24  C     !DESCRIPTION:  C     !DESCRIPTION:
25  C     Retrieve averaged model diagnostic  C     Retrieve averaged model diagnostic
# Line 24  C     !USES: Line 32  C     !USES:
32  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
33    
34  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
35  C     levreal .... Diagnostic LEVEL  C     levreal :: Diagnostic LEVEL
36  C     undef  ..... UNDEFINED VALUE  C     undef   :: UNDEFINED VALUE
37  C     ipoint ..... DIAGNOSTIC NUMBER FROM MENU  C     ndId    :: DIAGNOSTIC NUMBER FROM MENU
38  C     mate   ..... counter DIAGNOSTIC NUMBER if any ; 0 otherwise  C     mate    :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise
39  C     bi     ..... X-direction tile number  C     ip      :: pointer to storage array location for diag.
40  C     bj     ..... Y-direction tile number  C     im      :: pointer to storage array location for mate
41  C     myThid ..... my thread Id number  C     bi      :: X-direction tile number
42    C     bj      :: Y-direction tile number
43    C     myThid  :: my thread Id number
44        _RL levreal        _RL levreal
45        _RL undef        _RL undef
46        INTEGER ipoint, mate        INTEGER ndId, mate, ip, im
47        INTEGER bi,bj, myThid        INTEGER bi,bj, myThid
48    
49  C     !OUTPUT PARAMETERS:  C     !OUTPUT PARAMETERS:
# Line 46  C     !LOCAL VARIABLES: Line 56  C     !LOCAL VARIABLES:
56        INTEGER i, j, ipnt,ipCt        INTEGER i, j, ipnt,ipCt
57        INTEGER lev, levCt, klev        INTEGER lev, levCt, klev
58    
59        IF (ipoint.GE.1) THEN        IF (ndId.GE.1) THEN
60         lev = NINT(levreal)         lev = NINT(levreal)
61         klev = kdiag(ipoint)         klev = kdiag(ndId)
62         IF (lev.LE.klev) THEN         IF (lev.LE.klev) THEN
63    
64          IF ( mate.EQ.0 ) THEN          IF ( mate.EQ.0 ) THEN
65  C-      No counter diagnostics => average = Sum / ndiag :  C-      No counter diagnostics => average = Sum / ndiag :
66    
67            ipnt = idiag(ipoint) + lev - 1            ipnt = ip + lev - 1
68  c         factor = 1.0            factor = FLOAT(ndiag(ip,bi,bj))
69  c         if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)            IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
           factor = FLOAT(ndiag(ipoint))  
           IF (ndiag(ipoint).NE.0) factor = 1. _d 0 / factor  
70    
71            DO j = 1,sNy+1            DO j = 1,sNy+1
72              DO i = 1,sNx+1              DO i = 1,sNx+1
# Line 73  c         if (ndiag(ipoint).ne.0) factor Line 81  c         if (ndiag(ipoint).ne.0) factor
81          ELSE          ELSE
82  C-      With counter diagnostics => average = Sum / counter:  C-      With counter diagnostics => average = Sum / counter:
83    
84            ipnt = idiag(ipoint) + lev - 1            ipnt = ip + lev - 1
85            levCt= MIN(lev,kdiag(mate))            levCt= MIN(lev,kdiag(mate))
86            ipCt = idiag(mate) + levCt - 1            ipCt = im + levCt - 1
87            DO j = 1,sNy+1            DO j = 1,sNy+1
88              DO i = 1,sNx+1              DO i = 1,sNx+1
89                IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN                IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
# Line 96  C-      With counter diagnostics => aver Line 104  C-      With counter diagnostics => aver
104    
105  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
106    
107        subroutine clrindx (listnum, myThid)  CBOP 0
108    C     !ROUTINE: DIAGNOSTICS_COUNT
109    C     !INTERFACE:
110          SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
111         I                              biArg, bjArg, myThid)
112    
113    C     !DESCRIPTION:
114  C***********************************************************************  C***********************************************************************
115  C  C   routine to increment the diagnostic counter only
 C  PURPOSE  
 C     DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST  
 C  
 C  ARGUMENT DESCRIPTION  
 C     listnum ....  diagnostics list number  
 C  
116  C***********************************************************************  C***********************************************************************
117    C     !USES:
118          IMPLICIT NONE
119    
120        implicit none  C     == Global variables ===
121  #include "EEPARAMS.h"  #include "EEPARAMS.h"
122  #include "SIZE.h"  #include "SIZE.h"
123  #include "DIAGNOSTICS_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
124  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
125    
126        integer myThid, listnum  C     !INPUT PARAMETERS:
   
       integer m, n  
       character*8 parms1  
       character*3 mate_index  
       integer mate  
   
       do n=1,nfields(listnum)  
        do m=1,ndiagt  
         if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  
          call clrdiag (m, myThid)  
   
 c Check for Counter Diagnostic  
 c ----------------------------  
          parms1 =  gdiag(m)(1:8)  
          if ( parms1(5:5).eq.'C' ) then  
           mate_index = parms1(6:8)  
           read (mate_index,'(I3)') mate  
           call clrdiag (mate, myThid)  
          endif  
         endif  
        enddo  
       enddo  
   
       RETURN  
       END  
   
   
       subroutine clrdiag (index, myThid)  
127  C***********************************************************************  C***********************************************************************
128  C  PURPOSE  C  Arguments Description
129  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS  C  ----------------------
130    C     chardiag :: Character expression for diag to increment the counter
131    C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
132    C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
133    C     myThid   :: my thread Id number
134  C***********************************************************************  C***********************************************************************
135          CHARACTER*8 chardiag
136          INTEGER biArg, bjArg
137          INTEGER myThid
138    CEOP
139    
140        implicit none  C     !LOCAL VARIABLES:
141  #include "EEPARAMS.h"  C ===============
142  #include "SIZE.h"        INTEGER m, n
143  #include "DIAGNOSTICS_SIZE.h"        INTEGER bi, bj
144  #include "DIAGNOSTICS.h"        INTEGER ipt
145    c     CHARACTER*(MAX_LEN_MBUF) msgBuf
       integer myThid, index  
   
       integer bi,bj  
       integer i,j,k  
   
 C **********************************************************************  
 C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****  
 C **********************************************************************  
   
       do bj=myByLo(myThid), myByHi(myThid)  
        do bi=myBxLo(myThid), myBxHi(myThid)  
         do k = 1,kdiag(index)  
          do j = 1-OLy,sNy+OLy  
           do i = 1-OLx,sNx+OLx  
            qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0  
           enddo  
          enddo  
         enddo  
        enddo  
       enddo  
146    
147        ndiag(index) = 0  C--   Run through list of active diagnostics to find which counter
148    C     to increment (needs to be a valid & active diagnostic-counter)
149          DO n=1,nlists
150           DO m=1,nActive(n)
151            IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
152             ipt = idiag(m,n)
153             IF (ndiag(ipt,1,1).GE.0) THEN
154    C-    Increment the counter for the diagnostic
155              IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
156               DO bj=myByLo(myThid), myByHi(myThid)
157                DO bi=myBxLo(myThid), myBxHi(myThid)
158                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
159                ENDDO
160               ENDDO
161              ELSE
162                 bi = MIN(biArg,nSx)
163                 bj = MIN(bjArg,nSy)
164                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
165              ENDIF
166    C-    Increment is done
167             ENDIF
168            ENDIF
169           ENDDO
170          ENDDO
171    
172        RETURN        RETURN
173        END        END
# Line 182  C ************************************** Line 175  C **************************************
175  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
176    
177  CBOP 0  CBOP 0
178  C     !ROUTINE: DIAGNOSTICS_IS_ON  C     !ROUTINE: DIAGS_MK_UNITS
179    
180  C     !INTERFACE:  C     !INTERFACE:
181        LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
182         I                            diagUnitsInPieces, myThid )
183    
184  C     !DESCRIPTION:  C     !DESCRIPTION:
185  C     *==========================================================*  C     *==========================================================*
186  C     | FUNCTION DIAGNOSTIC_IS_ON  C     | FUNCTION DIAGS_MK_UNITS
187  C     | o Return TRUE if diagnostics "diagName" is Active  C     | o Return the diagnostic units string (16c) removing
188    C     |   blanks from the input string
189  C     *==========================================================*  C     *==========================================================*
190    
191  C     !USES:  C     !USES:
192        IMPLICIT NONE        IMPLICIT NONE
193  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "SIZE.h"  
 #include "DIAGNOSTICS_SIZE.h"  
 #include "DIAGNOSTICS.h"  
194    
195  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
196  C     diagName   ::  diagnostic identificator name (8 characters long)  C     diagUnitsInPieces :: string for diagnostic units: in several
197  C     myThid     ::  my thread Id number  C                          pieces, with blanks in between
198        CHARACTER*8  diagName  C     myThid            ::  my thread Id number
199          CHARACTER*(*) diagUnitsInPieces
200        INTEGER      myThid        INTEGER      myThid
201  CEOP  CEOP
202    
203  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
204        INTEGER j,n,m        CHARACTER*(MAX_LEN_MBUF) msgBuf
205          INTEGER i,j,n
206    
207        DIAGNOSTICS_IS_ON = .FALSE.        DIAGS_MK_UNITS = '          '
208        DO n=1,nlists        n = LEN(diagUnitsInPieces)
209         DO m=1,nActive(n)  
210          IF ( diagName.EQ.flds(m,n) ) THEN        j = 0
211            j = jdiag(m,n)            DO i=1,n
212            IF ( idiag(j).NE.0 .AND. ndiag(j).GE.0 )         IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
213       &         DIAGNOSTICS_IS_ON = .TRUE.           j = j+1
214          ENDIF           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
215         ENDDO         ENDIF
216        ENDDO        ENDDO
217    
218          IF ( j.GT.16 ) THEN
219             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
220         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
221            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
222         &       SQUEEZE_RIGHT , myThid)
223             WRITE(msgBuf,'(3A)') '**WARNING** ',
224         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
225            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
226         &       SQUEEZE_RIGHT , myThid)
227          ENDIF
228    
229        RETURN        RETURN
230        END        END
231    
232  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
233    
234  CBOP 0  CBOP 0
235  C     !ROUTINE: DIAGS_MK_UNITS  C     !ROUTINE: DIAGS_MK_TITLE
236    
237  C     !INTERFACE:  C     !INTERFACE:
238        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(        CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
239       I                            diagUnitsInPieces, myThid )       I                            diagTitleInPieces, myThid )
240    
241  C     !DESCRIPTION:  C     !DESCRIPTION:
242  C     *==========================================================*  C     *==========================================================*
243  C     | FUNCTION DIAGS_MK_UNITS  C     | FUNCTION DIAGS_MK_TITLE
244  C     | o Return the diagnostic units string (16c) removing  C     | o Return the diagnostic title string (80c) removing
245  C     |   blanks from the input string  C     |   consecutive blanks from the input string
246  C     *==========================================================*  C     *==========================================================*
247    
248  C     !USES:  C     !USES:
# Line 245  C     !USES: Line 250  C     !USES:
250  #include "EEPARAMS.h"  #include "EEPARAMS.h"
251    
252  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
253  C     diagUnitsInPieces :: string for diagnostic units: in several  C     diagTitleInPieces :: string for diagnostic units: in several
254  C                          pieces, with blanks in between  C                          pieces, with blanks in between
255  C     myThid            ::  my thread Id number  C     myThid            ::  my Thread Id number
256        CHARACTER*(*) diagUnitsInPieces        CHARACTER*(*) diagTitleInPieces
257        INTEGER      myThid        INTEGER      myThid
258  CEOP  CEOP
259    
260  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
261        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
262          LOGICAL flag
263        INTEGER i,j,n        INTEGER i,j,n
264    
265        DIAGS_MK_UNITS = '          '  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
266        n = LEN(diagUnitsInPieces)  
267                DIAGS_MK_TITLE = '                                        '
268         &               //'                                        '
269          n = LEN(diagTitleInPieces)
270    
271        j = 0        j = 0
272          flag = .FALSE.
273        DO i=1,n        DO i=1,n
274         IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN         IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
275             IF ( flag ) THEN
276               j = j+1
277               IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
278             ENDIF
279           j = j+1           j = j+1
280           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)           IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
281             flag = .FALSE.
282           ELSE
283             flag = j.GE.1
284         ENDIF         ENDIF
285        ENDDO        ENDDO
286    
287        IF ( j.GT.16 ) THEN        IF ( j.GT.80 ) THEN
288           WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',           WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
289       &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'       &   'DIAGS_MK_TITLE: too long (',j,' >80) input string'
290          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
291       &       SQUEEZE_RIGHT , myThid)       &       SQUEEZE_RIGHT , myThid)
292           WRITE(msgBuf,'(3A)') '**WARNING** ',           WRITE(msgBuf,'(3A)') '**WARNING** ',
293       &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces       &   'DIAGS_MK_TITLE: input=', diagTitleInPieces
294          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
295       &       SQUEEZE_RIGHT , myThid)       &       SQUEEZE_RIGHT , myThid)
296        ENDIF        ENDIF
297    
298        RETURN        RETURN
299          END
300    
301    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
302    
303    CBOP 0
304    C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
305    C     !INTERFACE:
306          SUBROUTINE DIAGNOSTICS_GET_POINTERS(
307         I                       diagName, listId,
308         O                       ndId, ip,
309         I                       myThid )
310    
311    C     !DESCRIPTION:
312    C     *================================================================*
313    C     | o Returns the diagnostic Id number and diagnostic
314    C     |   pointer to storage array for a specified diagnostic.
315    C     *================================================================*
316    C     | Note: A diagnostics field can be stored multiple times
317    C     |       (for different output frequency,phase, ...).
318    C     | operates in 2 ways:
319    C     | o listId =0 => find 1 diagnostics Id & pointer which name matches.
320    C     | o listId >0 => find the unique diagnostic Id & pointer with
321    C     |      the right name and same output time as "listId" output-list
322    C     | o return ip=0 if did not find the right diagnostic;
323    C     |   (ndId <>0 if diagnostic exist but output time does not match)
324    C     *================================================================*
325    
326    C     !USES:
327          IMPLICIT NONE
328    #include "EEPARAMS.h"
329    #include "SIZE.h"
330    #include "DIAGNOSTICS_SIZE.h"
331    #include "DIAGNOSTICS.h"
332    
333    C     !INPUT PARAMETERS:
334    C     diagName :: diagnostic identificator name (8 characters long)
335    C     listId   :: list number that specify the output frequency
336    C     myThid   :: my Thread Id number
337    C     !OUTPUT PARAMETERS:
338    C     ndId     :: diagnostics  Id number (in available diagnostics list)
339    C     ip       :: diagnostics  pointer to storage array
340    
341    
342          CHARACTER*8 diagName
343          INTEGER listId
344          INTEGER ndId, ip
345          INTEGER myThid
346    CEOP
347    
348    C     !LOCAL VARIABLES:
349          INTEGER n,m
350    
351          ip   = 0
352          ndId = 0
353    
354          IF ( listId.LE.0 ) THEN
355    C--   select the 1rst one which name matches:
356    
357    C-    search for this diag. in the active 2D/3D diagnostics list
358            DO n=1,nlists
359             DO m=1,nActive(n)
360               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
361         &                  .AND. idiag(m,n).NE.0 ) THEN
362                ip   = ABS(idiag(m,n))
363                ndId = jdiag(m,n)
364               ENDIF
365             ENDDO
366            ENDDO
367    
368          ELSEIF ( listId.LE.nlists ) THEN
369    C--   select the unique diagnostic with output-time identical to listId
370    
371    C-    search for this diag. in the active 2D/3D diagnostics list
372            DO n=1,nlists
373             IF ( ip.EQ.0
374         &        .AND. freq(n) .EQ. freq(listId)
375         &        .AND. phase(n).EQ.phase(listId)
376         &        .AND. averageFreq(n) .EQ.averageFreq(listId)
377         &        .AND. averagePhase(n).EQ.averagePhase(listId)
378         &        .AND. averageCycle(n).EQ.averageCycle(listId)
379         &      ) THEN
380              DO m=1,nActive(n)
381               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
382         &                  .AND. idiag(m,n).NE.0 ) THEN
383                ip   = ABS(idiag(m,n))
384                ndId = jdiag(m,n)
385               ENDIF
386              ENDDO
387             ELSEIF ( ip.EQ.0 ) THEN
388              DO m=1,nActive(n)
389               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
390         &                  .AND. idiag(m,n).NE.0 ) THEN
391                ndId = jdiag(m,n)
392               ENDIF
393              ENDDO
394             ENDIF
395            ENDDO
396    
397          ELSE
398            STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
399          ENDIF
400    
401          RETURN
402        END        END
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.25
  ViewVC Help
Powered by ViewVC 1.1.22