/[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.12 by edhill, Thu Jul 8 00:30:45 2004 UTC revision 1.20 by jmc, Thu May 19 01:18:31 2005 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 (myThid,lev,ipoint,undef,qtmp)        SUBROUTINE GETDIAG(
12         I                    levreal, undef,
13         O                    qtmp,
14         I                    ipoint, mate, bi, bj, myThid )
15    
16  C     !DESCRIPTION:  C     !DESCRIPTION:
17        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"
 #include "CPP_OPTIONS.h"  
22  #include "SIZE.h"  #include "SIZE.h"
23  CEOP  #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=0)  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
   
 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  
       integer myThid,lev,ipoint  
35        _RL undef        _RL undef
36                INTEGER ipoint, mate
37  C     OUTPUT:        INTEGER bi,bj, myThid
 C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY  
       _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) .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  
               
           enddo  
         enddo  
           
       endif  
   
  999  return  
       end  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
 CBOP 0  
 C     !ROUTINE: GETDIAG2  
38    
39  C     !INTERFACE:  C     !OUTPUT PARAMETERS:
40        SUBROUTINE GETDIAG2 (myThid,lev,ipoint,undef,qtmp)  C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
41          _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
 C     !DESCRIPTION:  
 C***********************************************************************          
 C  PURPOSE                                                                        
 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***********************************************************************          
         
 C     !USES:  
       implicit none  
 #include "EEPARAMS.h"  
 #include "CPP_OPTIONS.h"  
 #include "SIZE.h"  
42  CEOP  CEOP
43    
44  #ifdef ALLOW_FIZHI  C     !LOCAL VARIABLES:
45  #include "fizhi_SIZE.h"        _RL factor
46  #else        INTEGER i, j, ipnt,ipCt
47         integer Nrphys        INTEGER lev, levCt, klev
        parameter (Nrphys=0)  
 #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)  
   
       integer i,j,ipnt,klev  
       integer bi,bj  
48    
49        if (ipoint.lt.1) go to 999        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
92          ipnt = idiag(ipoint) + lev - 1        ENDIF
           
         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  
               
           enddo  
         enddo  
           
       endif  
93    
94   999  return        RETURN
95        end        END
96    
97  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
98    
99        subroutine clrindx (myThid,listnum)        subroutine clrindx (listnum, myThid)
100  C***********************************************************************  C***********************************************************************
101  C  C
102  C  PURPOSE  C  PURPOSE
# Line 163  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"  #include "DIAGNOSTICS_SIZE.h"
114  #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 "diagnostics_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
154  #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    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        subroutine setdiag (myThid,num,ndiagmx)  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"  #include "DIAGNOSTICS_SIZE.h"
201  #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        DATA IPOINTER / 1 /  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        character*8 parms1  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
       character*1 parse1(8)  
       character*3 mate_index  
       integer     mate  
250    
251        equivalence (     parms1 , parse1(1) )  C-- note: counter could become a tiled array, and then it would be:
252        equivalence ( mate_index , parse1(6) )  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  C **********************************************************************        ENDIF
 C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****  
 C **********************************************************************  
265    
266        parms1 = gdiag(num)        RETURN
267          END
268    
269        IF( IDIAG(NUM).EQ.0 ) THEN  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
         if(ndiagmx+kdiag(num).gt.numdiags) then  
           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  
270    
271  c Check for Counter Diagnostic  CBOP 0
272  c ----------------------------  C     !ROUTINE: DIAGS_MK_UNITS
       if( parse1(5).eq.'C') then  
       read (mate_index,100) mate  
273    
274        IF( IDIAG(mate).EQ.0 ) THEN  C     !INTERFACE:
275         if(ndiagmx+kdiag(num).gt.numdiags) then        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
276          write(6,5000)num,cdiag(num)       I                            diagUnitsInPieces, myThid )
277         else  
278          IDIAG(mate) = IPOINTER  C     !DESCRIPTION:
279          IPOINTER    = IPOINTER + KDIAG(mate)  C     *==========================================================*
280          ndiagmx     = ndiagmx  + KDIAG(mate)  C     | FUNCTION DIAGS_MK_UNITS
281          if(myThid.eq.1)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     | o Return the diagnostic units string (16c) removing
282         endif  C     |   blanks from the input string
283        ELSE  C     *==========================================================*
284            if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)  
285    C     !USES:
286          IMPLICIT NONE
287    #include "EEPARAMS.h"
288    
289    C     !INPUT PARAMETERS:
290    C     diagUnitsInPieces :: string for diagnostic units: in several
291    C                          pieces, with blanks in between
292    C     myThid            ::  my thread Id number
293          CHARACTER*(*) diagUnitsInPieces
294          INTEGER      myThid
295    CEOP
296    
297    C     !LOCAL VARIABLES:
298          CHARACTER*(MAX_LEN_MBUF) msgBuf
299          INTEGER i,j,n
300    
301          DIAGS_MK_UNITS = '          '
302          n = LEN(diagUnitsInPieces)
303          
304          j = 0
305          DO i=1,n
306           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
307             j = j+1
308             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
309           ENDIF
310          ENDDO
311    
312          IF ( j.GT.16 ) THEN
313             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
314         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
315            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
316         &       SQUEEZE_RIGHT , myThid)
317             WRITE(msgBuf,'(3A)') '**WARNING** ',
318         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
319            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
320         &       SQUEEZE_RIGHT , myThid)
321        ENDIF        ENDIF
       endif  
322    
323        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')  
324        END        END
Legend:
Removed from v.1.12  
changed lines
  Added in v.1.20
  ViewVC Help
Powered by ViewVC 1.1.22