/[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.2 by molod, Thu Feb 26 02:21:18 2004 UTC revision 1.19 by jmc, Thu Feb 17 00:00:47 2005 UTC
# Line 1  Line 1 
1        subroutine getdiag (lev,ipoint,bi,bj,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 "CPP_OPTIONS.h"  
 #include "SIZE.h"  
 #include "fizhi_SIZE.h"  
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
   
       integer bi,bj  
       integer lev,ipoint  
       integer i,j,ipnt,klev  
       _RL undef, factor  
       _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)  
   
       do j = 1,sNy  
       do i = 1,sNx  
        qtmp(i,j,bi,bj) = undef  
       enddo  
       enddo  
   
       IF (IPOINT.LT.1) GO TO 999  
3    
4        KLEV = KDIAG(IPOINT)  #include "DIAG_OPTIONS.h"
       IF(KLEV.GE.LEV) THEN  
       IPNT = IDIAG(IPOINT) + LEV - 1  
                                 FACTOR = 1.0  
       IF( NDIAG(IPOINT).NE.0 )  FACTOR = 1.0   / NDIAG(IPOINT)  
       do j = 1,sNy  
       do i = 1,sNx  
       if( qdiag(i,j,ipnt,bi,bj).ne.undef )  
      .     qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor  
       enddo  
       enddo  
       ENDIF  
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 (lev,ipoint,bi,bj,undef,qtmp)  C     !DESCRIPTION:
17  C***********************************************************************          C     Retrieve averaged model diagnostic
 C                                                                                
 C  PURPOSE                                                                        
 C     Retrieve model diagnostic (No Averaging)  
 C  INPUT:                                                                        
 C     lev ..... Model LEVEL                                                      
 C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                      
 C   undef ..... UNDEFINED VALUE                                                  
 C      im ..... X-DIMENSION  
 C      jm ..... Y-DIMENSION  
 C      nd ..... Number of 2-D Diagnostics  
 C                                                                                
 C  OUTPUT:                                                                        
 C    qtmp ..... DIAGNOSTIC QUANTITY                                              
 C                                                                                
 C***********************************************************************          
       implicit none  
18    
19  #include "CPP_OPTIONS.h"  C     !USES:
20          IMPLICIT NONE
21    #include "EEPARAMS.h"
22  #include "SIZE.h"  #include "SIZE.h"
23  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
24  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
 #include "diagnostics.h"  
   
       integer bi,bj  
25    
26        integer lev,ipoint  C     !INPUT PARAMETERS:
27        integer i,j,ipnt,klev  C     levreal .... Diagnostic LEVEL
28    C     undef  ..... UNDEFINED VALUE
29    C     ipoint ..... DIAGNOSTIC NUMBER FROM MENU
30    C     mate   ..... counter DIAGNOSTIC NUMBER if any ; 0 otherwise
31    C     bi     ..... X-direction tile number
32    C     bj     ..... Y-direction tile number
33    C     myThid ..... my thread Id number
34          _RL levreal
35        _RL undef        _RL undef
36        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)        INTEGER ipoint, mate
37          INTEGER bi,bj, myThid
38    
39        do j = 1,sNy  C     !OUTPUT PARAMETERS:
40        do i = 1,sNx  C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
41         qtmp(i,j,bi,bj) = undef        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
42        enddo  CEOP
43        enddo  
44    C     !LOCAL VARIABLES:
45        IF (IPOINT.LT.1) GO TO 999        _RL factor
46          INTEGER i, j, ipnt,ipCt
47          INTEGER lev, levCt, klev
48    
49          IF (ipoint.GE.1) THEN
50           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        KLEV = KDIAG(IPOINT)          ENDIF
91        IF(KLEV.GE.LEV) THEN         ENDIF
       IPNT = IDIAG(IPOINT) + LEV - 1  
       do j = 1,sNy  
       do i = 1,sNx  
        qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)  
       enddo  
       enddo  
92        ENDIF        ENDIF
93    
94   999  RETURN        RETURN
95        END        END
96                                                                                    
97        subroutine clrindx (myThid,listnum)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
98    
99          subroutine clrindx (listnum, myThid)
100  C***********************************************************************  C***********************************************************************
101  C  C
102  C  PURPOSE  C  PURPOSE
# Line 117  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 "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
114  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.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 "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
154  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.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        subroutine setdiag (myThid,num,ndiagmx)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
183    
184    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 "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
201  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
 #include "diagnostics.h"  
202    
203        integer num,myThid,ndiagmx  C     !INPUT PARAMETERS:
204        integer ipointer  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        DATA IPOINTER / 1 /        ENDIF
265    
266        character*8 parms1        RETURN
267        character*1 parse1(8)        END
       character*3 mate_index  
       integer     mate  
268    
269        equivalence (     parms1 , parse1(1) )  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
       equivalence ( mate_index , parse1(6) )  
270    
271  C **********************************************************************  CBOP 0
272  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****  C     !ROUTINE: DIAGNOSTICS_IS_ON
 C **********************************************************************  
273    
274        parms1 = gdiag(num)  C     !INTERFACE:
275          LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )
276    
277        IF( IDIAG(NUM).EQ.0 ) THEN  C     !DESCRIPTION:
278          if(ndiagmx+kdiag(num).gt.numdiags) then  C     *==========================================================*
279            write(6,4000)num,cdiag(num)  C     | FUNCTION DIAGNOSTIC_IS_ON
280          else  C     | o Return TRUE if diagnostics "diagName" is Active
281            IDIAG(NUM) = IPOINTER  C     *==========================================================*
           IPOINTER   = IPOINTER + KDIAG(NUM)  
           ndiagmx    = ndiagmx  + KDIAG(NUM)  
           if(myThid.eq.0) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx  
         endif  
       ELSE  
           if(myThid.eq.0) WRITE(6,3000) NUM, CDIAG(NUM)  
       ENDIF  
282    
283  c Check for Counter Diagnostic  C     !USES:
284  c ----------------------------        IMPLICIT NONE
285        if( parse1(5).eq.'C') then  #include "EEPARAMS.h"
286        read (mate_index,100) mate  #include "SIZE.h"
287    #include "DIAGNOSTICS_SIZE.h"
288    #include "DIAGNOSTICS.h"
289    
290        IF( IDIAG(mate).EQ.0 ) THEN  C     !INPUT PARAMETERS:
291         if(ndiagmx+kdiag(num).gt.numdiags) then  C     diagName   ::  diagnostic identificator name (8 characters long)
292          write(6,5000)num,cdiag(num)  C     myThid     ::  my thread Id number
293         else        CHARACTER*8  diagName
294          IDIAG(mate) = IPOINTER        INTEGER      myThid
295          IPOINTER    = IPOINTER + KDIAG(mate)  CEOP
296          ndiagmx     = ndiagmx  + KDIAG(mate)  
297          if(myThid.eq.0)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     !LOCAL VARIABLES:
298         endif        INTEGER j,n,m
299        ELSE  
300            if(myThid.eq.0) WRITE(6,3000) mate, CDIAG(mate)        DIAGNOSTICS_IS_ON = .FALSE.
301        ENDIF        DO n=1,nlists
302        endif         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        RETURN        RETURN
312          END
313    
314    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
315    
316    CBOP 0
317    C     !ROUTINE: DIAGS_MK_UNITS
318    
319    100 format(i3)  C     !INTERFACE:
320   2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
321       .          ' (',A8,'),  Total Number of Diagnostics: ',I5)       I                            diagUnitsInPieces, myThid )
322   3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')  
323   4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,  C     !DESCRIPTION:
324       .                      ' (',A8,')')  C     *==========================================================*
325   5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',  C     | FUNCTION DIAGS_MK_UNITS
326       .    I3,' (',A8,')',' WARNING - Diag will not accumulate properly')  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
367    
368          RETURN
369        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.19
  ViewVC Help
Powered by ViewVC 1.1.22