/[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.18 by jmc, Mon Feb 7 03:07:49 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
                     
   100 format(i3)  
       RETURN        
       END            
139    
140          RETURN
141          END
142    
143        subroutine clrdiag (myThid,index)  
144  C***********************************************************************                subroutine clrdiag (index, myThid)
145  C  PURPOSE                                                                        C***********************************************************************
146    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        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
186    
187    C     !INTERFACE:
188          LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )
189    
190    C     !DESCRIPTION:
191    C     *==========================================================*
192    C     | FUNCTION DIAGNOSTIC_IS_ON
193    C     | o Return TRUE if diagnostics "diagName" is Active
194    C     *==========================================================*
195    
196    C     !USES:
197          IMPLICIT NONE
198    #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     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        DATA IPOINTER / 1 /  C     !LOCAL VARIABLES:
211          INTEGER j,n,m
212    
213        character*8 parms1        DIAGNOSTICS_IS_ON = .FALSE.
214        character*1 parse1(8)        DO n=1,nlists
215        character*3 mate_index         DO m=1,nActive(n)
216        integer     mate          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        equivalence (     parms1 , parse1(1) )        RETURN
225        equivalence ( mate_index , parse1(6) )        END
226    
227  C **********************************************************************  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
 C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****  
 C **********************************************************************  
228    
229        parms1 = gdiag(num)  CBOP 0
230    C     !ROUTINE: DIAGS_MK_UNITS
231    
232        IF( IDIAG(NUM).EQ.0 ) THEN  C     !INTERFACE:
233          if(ndiagmx+kdiag(num).gt.numdiags) then        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
234            write(6,4000)num,cdiag(num)       I                            diagUnitsInPieces, myThid )
         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  
235    
236  c Check for Counter Diagnostic  C     !DESCRIPTION:
237  c ----------------------------  C     *==========================================================*
238        if( parse1(5).eq.'C') then  C     | FUNCTION DIAGS_MK_UNITS
239        read (mate_index,100) mate  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.12  
changed lines
  Added in v.1.18
  ViewVC Help
Powered by ViewVC 1.1.22