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