/[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.5 by molod, Thu Feb 26 22:20:36 2004 UTC revision 1.19 by jmc, Thu Feb 17 00:00:47 2005 UTC
# Line 1  Line 1 
1        subroutine getdiag (myThid,lev,ipoint,undef,qtmp)  C $Header$
2  C***********************************************************************          C $Name$
 C  PURPOSE                                                                        
 C     Retrieve averaged model diagnostic  
 C  INPUT:                                                                        
 C     lev ..... Diagnostic LEVEL  
 C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                      
 C   undef ..... UNDEFINED VALUE                                                  
 C      bi ..... X-direction process(or) number  
 C      bj ..... Y-direction process(or) number  
 C                                                                                
 C  OUTPUT:                                                                        
 C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY  
 C                                                                                
 C***********************************************************************          
       implicit none  
   
 #include "EEPARAMS.h"  
 #include "CPP_OPTIONS.h"  
 #include "SIZE.h"  
   
 #ifdef ALLOW_FIZHI  
 #include "fizhi_SIZE.h"  
 #else  
        integer Nrphys  
        parameter (Nrphys=1)  
 #endif  
   
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
   
       integer myThid,lev,ipoint  
       _RL undef  
       _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)  
   
       _RL factor  
       integer i,j,ipnt,klev  
       integer bi,bj  
   
       if (ipoint.lt.1) go to 999  
   
       klev = kdiag(ipoint)  
       if(klev.ge.lev) then  
       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).ne.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  
   
       enddo  
       enddo  
3    
4        endif  #include "DIAG_OPTIONS.h"
5    
6   999  return  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7        end  CBOP 0
8    C     !ROUTINE: GETDIAG
9    
10    C     !INTERFACE:
11          SUBROUTINE GETDIAG(
12         I                    levreal, undef,
13         O                    qtmp,
14         I                    ipoint, mate, bi, bj, myThid )
15    
16        subroutine getdiag2 (myThid,lev,ipoint,undef,qtmp)  C     !DESCRIPTION:
 C***********************************************************************          
 C  PURPOSE                                                                        
17  C     Retrieve averaged model diagnostic  C     Retrieve averaged model diagnostic
 C  INPUT:                                                                        
 C     lev ..... Diagnostic LEVEL  
 C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                      
 C   undef ..... UNDEFINED VALUE                                                  
 C                                                                                
 C  OUTPUT:                                                                        
 C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY  
 C                                                                                
 C***********************************************************************          
       implicit none  
18    
19    C     !USES:
20          IMPLICIT NONE
21  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
22  #include "SIZE.h"  #include "SIZE.h"
23    #include "DIAGNOSTICS_SIZE.h"
24    #include "DIAGNOSTICS.h"
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     ipoint ..... DIAGNOSTIC NUMBER FROM MENU
30         parameter (Nrphys=1)  C     mate   ..... counter DIAGNOSTIC NUMBER if any ; 0 otherwise
31  #endif  C     bi     ..... X-direction tile number
32    C     bj     ..... Y-direction tile number
33  #include "diagnostics_SIZE.h"  C     myThid ..... my thread Id number
34  #include "diagnostics.h"        _RL levreal
   
       integer myThid,lev,ipoint  
35        _RL undef        _RL undef
36        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)        INTEGER ipoint, mate
37          INTEGER bi,bj, myThid
       integer i,j,ipnt,klev  
       integer bi,bj  
38    
39        if (ipoint.lt.1) go to 999  C     !OUTPUT PARAMETERS:
40    C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
41          _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
42    CEOP
43    
44        klev = kdiag(ipoint)  C     !LOCAL VARIABLES:
45        if(klev.ge.lev) then        _RL factor
46        ipnt = idiag(ipoint) + lev - 1        INTEGER i, j, ipnt,ipCt
47          INTEGER lev, levCt, klev
48    
49        do bj=myByLo(myThid), myByHi(myThid)        IF (ipoint.GE.1) THEN
50        do bi=myBxLo(myThid), myBxHi(myThid)         lev = NINT(levreal)
51           klev = kdiag(ipoint)
52           IF (lev.LE.klev) THEN
53    
54            IF ( mate.EQ.0 ) THEN
55    C-      No counter diagnostics => average = Sum / ndiag :
56    
57              ipnt = idiag(ipoint) + lev - 1
58    c         factor = 1.0
59    c         if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)
60              factor = FLOAT(ndiag(ipoint))
61              IF (ndiag(ipoint).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 = idiag(ipoint) + lev - 1
77              levCt= MIN(lev,kdiag(mate))
78              ipCt = idiag(mate) + 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        do j = 1,sNy          ENDIF
91        do i = 1,sNx         ENDIF
92         if( qdiag(i,j,ipnt,bi,bj).ne.undef ) then        ENDIF
         qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)  
        else  
         qtmp(i,j,lev,bi,bj) = undef  
        endif  
       enddo  
       enddo  
93    
94        enddo        RETURN
95        enddo        END
96    
97        endif  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
98    
99   999  return        subroutine clrindx (listnum, myThid)
       end  
       subroutine clrindx (myThid,listnum)  
100  C***********************************************************************  C***********************************************************************
101  C  C
102  C  PURPOSE  C  PURPOSE
# Line 141  C*************************************** Line 109  C***************************************
109    
110        implicit none        implicit none
111  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
112  #include "SIZE.h"  #include "SIZE.h"
113    #include "DIAGNOSTICS_SIZE.h"
114  #ifdef ALLOW_FIZHI  #include "DIAGNOSTICS.h"
 #include "fizhi_SIZE.h"  
 #else  
        integer Nrphys  
        parameter (Nrphys=1)  
 #endif  
   
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
115    
116        integer myThid, listnum        integer myThid, listnum
117    
118        integer m, n        integer m, n
119        character*8 parms1        character*8 parms1
       character*1 parse1(8)  
120        character*3 mate_index        character*3 mate_index
121        integer mate        integer mate
122    
       equivalence (     parms1 , parse1(1) )  
       equivalence ( mate_index , parse1(6) )  
   
123        do n=1,nfields(listnum)        do n=1,nfields(listnum)
124         do m=1,ndiagt         do m=1,ndiagt
125          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then
126           call clrdiag (myThid,m)           call clrdiag (m, myThid)
127    
128  c Check for Counter Diagnostic  c Check for Counter Diagnostic
129  c ----------------------------  c ----------------------------
130           parms1 =  gdiag(m)           parms1 =  gdiag(m)(1:8)
131           if( parse1(5).eq.'C' ) then           if ( parms1(5:5).eq.'C' ) then
132            read (mate_index,100) mate            mate_index = parms1(6:8)
133            call clrdiag (myThid,mate)            read (mate_index,'(I3)') mate
134              call clrdiag (mate, myThid)
135           endif           endif
136          endif          endif
137         enddo         enddo
138        enddo        enddo
139                      
140    100 format(i3)        RETURN
141        RETURN              END
       END            
142    
143    
144        subroutine clrdiag (myThid,index)        subroutine clrdiag (index, myThid)
145  C***********************************************************************          C***********************************************************************
146  C  PURPOSE                                                                        C  PURPOSE
147  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS
148  C***********************************************************************          C***********************************************************************
149                                                                                    
150        implicit none        implicit none
151  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
152  #include "SIZE.h"  #include "SIZE.h"
153    #include "DIAGNOSTICS_SIZE.h"
154  #ifdef ALLOW_FIZHI  #include "DIAGNOSTICS.h"
 #include "fizhi_SIZE.h"  
 #else  
        integer Nrphys  
        parameter (Nrphys=1)  
 #endif  
   
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
155    
156        integer myThid, index        integer myThid, index
157    
158        integer bi,bj        integer bi,bj
159        integer i,j,k        integer i,j,k
160    
161  C **********************************************************************          C **********************************************************************
162  C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****          C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****
163  C **********************************************************************          C **********************************************************************
164                                                                                    
165        do bj=myByLo(myThid), myByHi(myThid)        do bj=myByLo(myThid), myByHi(myThid)
166        do bi=myBxLo(myThid), myBxHi(myThid)         do bi=myBxLo(myThid), myBxHi(myThid)
167         do k = 1,kdiag(index)          do k = 1,kdiag(index)
168          do j = 1,sNy           do j = 1-OLy,sNy+OLy
169          do i = 1,sNx            do i = 1-OLx,sNx+OLx
170           qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0             qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
171          enddo            enddo
172             enddo
173          enddo          enddo
174         enddo         enddo
175        enddo        enddo
       enddo  
176    
177        ndiag(index) = 0        ndiag(index) = 0
178    
179        return        RETURN
180        end        END
181    
182    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
183    
184        subroutine setdiag (myThid,num,ndiagmx)  CBOP 0
185    C     !ROUTINE: DIAGNOSTICS_COUNT
186    C     !INTERFACE:
187          SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
188         I                              biArg, bjArg, myThid)
189    
190    C     !DESCRIPTION:
191  C***********************************************************************  C***********************************************************************
192  C  C   routine to increment the diagnostic counter only
 C  PURPOSE  
 C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM  
 C  
193  C***********************************************************************  C***********************************************************************
194    C     !USES:
195          IMPLICIT NONE
196    
197        implicit none  C     == Global variables ===
198  #include "CPP_OPTIONS.h"  #include "EEPARAMS.h"
199  #include "SIZE.h"  #include "SIZE.h"
200    #include "DIAGNOSTICS_SIZE.h"
201    #include "DIAGNOSTICS.h"
202    
203    C     !INPUT PARAMETERS:
204    C***********************************************************************
205    C  Arguments Description
206    C  ----------------------
207    C     chardiag :: Character expression for diag to increment the counter
208    C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
209    C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
210    C     myThid   :: my thread Id number
211    C***********************************************************************
212          CHARACTER*8 chardiag
213          INTEGER biArg, bjArg
214          INTEGER myThid
215    CEOP
216    
217    C     !LOCAL VARIABLES:
218    C ===============
219          INTEGER m, n
220          INTEGER ndiagnum, ipointer
221    c     INTEGER bi, bj
222    c     CHARACTER*(MAX_LEN_MBUF) msgBuf
223    
224    C Run through list of active diagnostics to make sure
225    C we are trying to increment a valid diagnostic-counter
226    
227          ndiagnum = 0
228          ipointer = 0
229          DO n=1,nlists
230           DO m=1,nActive(n)
231            IF ( chardiag.EQ.flds(m,n) ) THEN
232             ndiagnum = jdiag(m,n)
233             IF (ndiag(ndiagnum).GE.0) ipointer = idiag(ndiagnum)
234            ENDIF
235           ENDDO
236          ENDDO
237    
238    C If-sequence to see if we are a valid and an active diagnostic
239    
240          IF ( ndiagnum.NE.0 .AND. ipointer.NE.0 ) THEN
241    
242    C Increment the counter for the diagnostic (if we are at bi=bj=myThid=1)
243           _BEGIN_MASTER(myThid)
244            IF ( (biArg.EQ.1 .AND. bjArg.EQ.1) .OR.
245         &       (biArg.EQ.0 .AND. bjArg.EQ.0) )
246         &                     ndiag(ndiagnum) = ndiag(ndiagnum) + 1
247           _END_MASTER(myThid)
248    
249    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
250    
251    C-- note: counter could become a tiled array, and then it would be:
252    c       IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
253    c        DO bj=myByLo(myThid), myByHi(myThid)
254    c         DO bi=myBxLo(myThid), myBxHi(myThid)
255    c          ndiag(ndiagnum,bi,bj) = ndiag(ndiagnum,bi,bj) + 1
256    c         ENDDO
257    c        ENDDO
258    c       ELSE
259    c          bi = MIN(biArg,nSx)
260    c          bj = MIN(bjArg,nSy)
261    c          ndiag(ndiagnum,bi,bj) = ndiag(ndiagnum,bi,bj) + 1
262    c       ENDIF
263    
264  #ifdef ALLOW_FIZHI        ENDIF
 #include "fizhi_SIZE.h"  
 #else  
        integer Nrphys  
        parameter (Nrphys=1)  
 #endif  
265    
266  #include "diagnostics_SIZE.h"        RETURN
267  #include "diagnostics.h"        END
268    
269        integer num,myThid,ndiagmx  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
       integer ipointer  
270    
271        DATA IPOINTER / 1 /  CBOP 0
272    C     !ROUTINE: DIAGNOSTICS_IS_ON
273    
274        character*8 parms1  C     !INTERFACE:
275        character*1 parse1(8)        LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )
       character*3 mate_index  
       integer     mate  
276    
277        equivalence (     parms1 , parse1(1) )  C     !DESCRIPTION:
278        equivalence ( mate_index , parse1(6) )  C     *==========================================================*
279    C     | FUNCTION DIAGNOSTIC_IS_ON
280    C     | o Return TRUE if diagnostics "diagName" is Active
281    C     *==========================================================*
282    
283  C **********************************************************************  C     !USES:
284  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****        IMPLICIT NONE
285  C **********************************************************************  #include "EEPARAMS.h"
286    #include "SIZE.h"
287    #include "DIAGNOSTICS_SIZE.h"
288    #include "DIAGNOSTICS.h"
289    
290        parms1 = gdiag(num)  C     !INPUT PARAMETERS:
291    C     diagName   ::  diagnostic identificator name (8 characters long)
292    C     myThid     ::  my thread Id number
293          CHARACTER*8  diagName
294          INTEGER      myThid
295    CEOP
296    
297    C     !LOCAL VARIABLES:
298          INTEGER j,n,m
299    
300          DIAGNOSTICS_IS_ON = .FALSE.
301          DO n=1,nlists
302           DO m=1,nActive(n)
303            IF ( diagName.EQ.flds(m,n) ) THEN
304              j = jdiag(m,n)    
305              IF ( idiag(j).NE.0 .AND. ndiag(j).GE.0 )
306         &         DIAGNOSTICS_IS_ON = .TRUE.
307            ENDIF
308           ENDDO
309          ENDDO
310    
311        IF( IDIAG(NUM).EQ.0 ) THEN        RETURN
312          if(ndiagmx+kdiag(num).gt.numdiags) then        END
           write(6,4000)num,cdiag(num)  
         else  
           IDIAG(NUM) = IPOINTER  
           IPOINTER   = IPOINTER + KDIAG(NUM)  
           ndiagmx    = ndiagmx  + KDIAG(NUM)  
           if(myThid.eq.1) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx  
         endif  
       ELSE  
           if(myThid.eq.1) WRITE(6,3000) NUM, CDIAG(NUM)  
       ENDIF  
313    
314  c Check for Counter Diagnostic  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
 c ----------------------------  
       if( parse1(5).eq.'C') then  
       read (mate_index,100) mate  
315    
316        IF( IDIAG(mate).EQ.0 ) THEN  CBOP 0
317         if(ndiagmx+kdiag(num).gt.numdiags) then  C     !ROUTINE: DIAGS_MK_UNITS
318          write(6,5000)num,cdiag(num)  
319         else  C     !INTERFACE:
320          IDIAG(mate) = IPOINTER        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
321          IPOINTER    = IPOINTER + KDIAG(mate)       I                            diagUnitsInPieces, myThid )
322          ndiagmx     = ndiagmx  + KDIAG(mate)  
323          if(myThid.eq.1)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     !DESCRIPTION:
324         endif  C     *==========================================================*
325        ELSE  C     | FUNCTION DIAGS_MK_UNITS
326            if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)  C     | o Return the diagnostic units string (16c) removing
327    C     |   blanks from the input string
328    C     *==========================================================*
329    
330    C     !USES:
331          IMPLICIT NONE
332    #include "EEPARAMS.h"
333    
334    C     !INPUT PARAMETERS:
335    C     diagUnitsInPieces :: string for diagnostic units: in several
336    C                          pieces, with blanks in between
337    C     myThid            ::  my thread Id number
338          CHARACTER*(*) diagUnitsInPieces
339          INTEGER      myThid
340    CEOP
341    
342    C     !LOCAL VARIABLES:
343          CHARACTER*(MAX_LEN_MBUF) msgBuf
344          INTEGER i,j,n
345    
346          DIAGS_MK_UNITS = '          '
347          n = LEN(diagUnitsInPieces)
348          
349          j = 0
350          DO i=1,n
351           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
352             j = j+1
353             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
354           ENDIF
355          ENDDO
356    
357          IF ( j.GT.16 ) THEN
358             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
359         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
360            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
361         &       SQUEEZE_RIGHT , myThid)
362             WRITE(msgBuf,'(3A)') '**WARNING** ',
363         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
364            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
365         &       SQUEEZE_RIGHT , myThid)
366        ENDIF        ENDIF
       endif  
367    
368        RETURN        RETURN
   
   100 format(i3)  
  2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,  
      .          ' (',A8,'),  Total Number of Diagnostics: ',I5)  
  3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')  
  4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,  
      .                      ' (',A8,')')  
  5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',  
      .    I3,' (',A8,')',' WARNING - Diag will not accumulate properly')  
369        END        END
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.19
  ViewVC Help
Powered by ViewVC 1.1.22