/[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.4 by molod, Thu Feb 26 19:52:05 2004 UTC revision 1.18 by jmc, Mon Feb 7 03:07:49 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"  
3    
4  #ifdef ALLOW_FIZHI  #include "DIAG_OPTIONS.h"
 #include "fizhi_SIZE.h"  
 #else  
        integer Nrphys  
        parameter (Nrphys=1)  
 #endif  
5    
6  #include "diagnostics_SIZE.h"  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7  #include "diagnostics.h"  CBOP 0
8    C     !ROUTINE: GETDIAG
9        integer myThid,lev,ipoint  
10        _RL undef  C     !INTERFACE:
11        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)        SUBROUTINE GETDIAG(
12         I                    levreal, undef,
13        _RL factor       O                    qtmp,
14        integer i,j,ipnt,klev       I                    ipoint, mate, bi, bj, myThid )
       integer bi,bj  
15    
16        if (ipoint.lt.1) go to 999  C     !DESCRIPTION:
   
       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  
   
       endif  
   
  999  return  
       end  
   
       subroutine getdiag2 (myThid,lev,ipoint,undef,qtmp)  
 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 "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-|--+----|
 C***********************************************************************  
 C  
 C  PURPOSE  
 C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM  
 C  
 C***********************************************************************  
183    
184        implicit none  CBOP 0
185  #include "CPP_OPTIONS.h"  C     !ROUTINE: DIAGNOSTICS_IS_ON
 #include "SIZE.h"  
 #include "fizhi_SIZE.h"  
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
186    
187        integer num,myThid,ndiagmx  C     !INTERFACE:
188        integer ipointer        LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )
189    
190        DATA IPOINTER / 1 /  C     !DESCRIPTION:
191    C     *==========================================================*
192    C     | FUNCTION DIAGNOSTIC_IS_ON
193    C     | o Return TRUE if diagnostics "diagName" is Active
194    C     *==========================================================*
195    
196        character*8 parms1  C     !USES:
197        character*1 parse1(8)        IMPLICIT NONE
198        character*3 mate_index  #include "EEPARAMS.h"
199        integer     mate  #include "SIZE.h"
200    #include "DIAGNOSTICS_SIZE.h"
201    #include "DIAGNOSTICS.h"
202    
203        equivalence (     parms1 , parse1(1) )  C     !INPUT PARAMETERS:
204        equivalence ( mate_index , parse1(6) )  C     diagName   ::  diagnostic identificator name (8 characters long)
205    C     myThid     ::  my thread Id number
206          CHARACTER*8  diagName
207          INTEGER      myThid
208    CEOP
209    
210    C     !LOCAL VARIABLES:
211          INTEGER j,n,m
212    
213          DIAGNOSTICS_IS_ON = .FALSE.
214          DO n=1,nlists
215           DO m=1,nActive(n)
216            IF ( diagName.EQ.flds(m,n) ) THEN
217              j = jdiag(m,n)    
218              IF ( idiag(j).NE.0 .AND. ndiag(j).GE.0 )
219         &         DIAGNOSTICS_IS_ON = .TRUE.
220            ENDIF
221           ENDDO
222          ENDDO
223    
224  C **********************************************************************        RETURN
225  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****        END
 C **********************************************************************  
226    
227        parms1 = gdiag(num)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
228    
229        IF( IDIAG(NUM).EQ.0 ) THEN  CBOP 0
230          if(ndiagmx+kdiag(num).gt.numdiags) then  C     !ROUTINE: DIAGS_MK_UNITS
           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  
231    
232  c Check for Counter Diagnostic  C     !INTERFACE:
233  c ----------------------------        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
234        if( parse1(5).eq.'C') then       I                            diagUnitsInPieces, myThid )
235        read (mate_index,100) mate  
236    C     !DESCRIPTION:
237    C     *==========================================================*
238    C     | FUNCTION DIAGS_MK_UNITS
239    C     | o Return the diagnostic units string (16c) removing
240    C     |   blanks from the input string
241    C     *==========================================================*
242    
243    C     !USES:
244          IMPLICIT NONE
245    #include "EEPARAMS.h"
246    
247        IF( IDIAG(mate).EQ.0 ) THEN  C     !INPUT PARAMETERS:
248         if(ndiagmx+kdiag(num).gt.numdiags) then  C     diagUnitsInPieces :: string for diagnostic units: in several
249          write(6,5000)num,cdiag(num)  C                          pieces, with blanks in between
250         else  C     myThid            ::  my thread Id number
251          IDIAG(mate) = IPOINTER        CHARACTER*(*) diagUnitsInPieces
252          IPOINTER    = IPOINTER + KDIAG(mate)        INTEGER      myThid
253          ndiagmx     = ndiagmx  + KDIAG(mate)  CEOP
254          if(myThid.eq.1)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  
255         endif  C     !LOCAL VARIABLES:
256        ELSE        CHARACTER*(MAX_LEN_MBUF) msgBuf
257            if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)        INTEGER i,j,n
258    
259          DIAGS_MK_UNITS = '          '
260          n = LEN(diagUnitsInPieces)
261          
262          j = 0
263          DO i=1,n
264           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
265             j = j+1
266             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
267           ENDIF
268          ENDDO
269    
270          IF ( j.GT.16 ) THEN
271             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
272         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
273            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
274         &       SQUEEZE_RIGHT , myThid)
275             WRITE(msgBuf,'(3A)') '**WARNING** ',
276         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
277            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
278         &       SQUEEZE_RIGHT , myThid)
279        ENDIF        ENDIF
       endif  
280    
281        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')  
282        END        END
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.18
  ViewVC Help
Powered by ViewVC 1.1.22