/[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.14 by molod, Mon Jul 26 21:16:18 2004 UTC revision 1.22 by molod, Mon Jul 11 16:20:10 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,levreal,ipoint,undef,qtmp)        SUBROUTINE GETDIAG(
12         I                    levreal, undef,
13         O                    qtmp,
14         I                    ndId, mate, ip, im, bi, bj, myThid )
15    
16  C     !DESCRIPTION:  C     !DESCRIPTION:
17  C     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     ndId    :: DIAGNOSTIC NUMBER FROM MENU
30        parameter (Nrphys=0)  C     mate    :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise
31  #endif  C     ip      :: pointer to storage array location for diag.
32    C     im      :: pointer to storage array location for mate
33  #include "diagnostics_SIZE.h"  C     bi      :: X-direction tile number
34  #include "diagnostics.h"  C     bj      :: Y-direction tile number
35    C     myThid  :: my thread Id number
36  C     INPUT:        _RL levreal
 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,ipoint  
37        _RL undef        _RL undef
38                INTEGER ndId, mate, ip, im
39  C     OUTPUT:        INTEGER bi,bj, myThid
40    
41    C     !OUTPUT PARAMETERS:
42  C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY  C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
43        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
44        _RL levreal  CEOP
45    
46    C     !LOCAL VARIABLES:
47        _RL factor        _RL factor
48        integer i,j,ipnt,klev        INTEGER i, j, ipnt,ipCt
49        integer bi,bj        INTEGER lev, levCt, klev
50        integer lev  
51          IF (ndId.GE.1) THEN
52        lev = levreal         lev = NINT(levreal)
53        if (ipoint.lt.1) go to 999         klev = kdiag(ndId)
54           IF (lev.LE.klev) THEN
55        klev = kdiag(ipoint)  
56        if (klev.ge.lev) then          IF ( mate.EQ.0 ) THEN
57          ipnt = idiag(ipoint) + lev - 1  C-      No counter diagnostics => average = Sum / ndiag :
58          factor = 1.0  
59          if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)            ipnt = ip + lev - 1
60              factor = FLOAT(ndiag(ip,bi,bj))
61          do bj=myByLo(myThid), myByHi(myThid)            IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
62            do bi=myBxLo(myThid), myBxHi(myThid)  
63                          DO j = 1,sNy+1
64              do j = 1,sNy              DO i = 1,sNx+1
65                do i = 1,sNx                IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
66                  if ( qdiag(i,j,ipnt,bi,bj) .le. undef ) then                  qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
67                    qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor                ELSE
68                  else                  qtmp(i,j) = undef
69                    qtmp(i,j,lev,bi,bj) = undef                ENDIF
70                  endif              ENDDO
71                enddo            ENDDO
72              enddo  
73                        ELSE
74            enddo  C-      With counter diagnostics => average = Sum / counter:
75          enddo  
76                      ipnt = ip + lev - 1
77        endif            levCt= MIN(lev,kdiag(mate))
78              ipCt = im + 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   999  return          ENDIF
91        end         ENDIF
92          ENDIF
93    
94          RETURN
95          END
96    
97  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
 CBOP 0  
 C     !ROUTINE: GETDIAG2  
98    
99    CBOP 0
100    C     !ROUTINE: DIAGNOSTICS_COUNT
101  C     !INTERFACE:  C     !INTERFACE:
102        SUBROUTINE GETDIAG2 (myThid,lev,ipoint,undef,qtmp)        SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
103         I                              biArg, bjArg, myThid)
104    
105  C     !DESCRIPTION:  C     !DESCRIPTION:
106  C***********************************************************************          C***********************************************************************
107  C  PURPOSE                                                                        C   routine to increment the diagnostic counter only
108  C     Retrieve averaged model diagnostic  C***********************************************************************
 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***********************************************************************          
         
109  C     !USES:  C     !USES:
110        implicit none        IMPLICIT NONE
111    
112    C     == Global variables ===
113  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
114  #include "SIZE.h"  #include "SIZE.h"
115  CEOP  #include "DIAGNOSTICS_SIZE.h"
116    #include "DIAGNOSTICS.h"
 #ifdef ALLOW_FIZHI  
 #include "fizhi_SIZE.h"  
 #else  
        integer Nrphys  
        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  
117    
118        if (ipoint.lt.1) go to 999  C     !INPUT PARAMETERS:
119    C***********************************************************************
120    C  Arguments Description
121    C  ----------------------
122    C     chardiag :: Character expression for diag to increment the counter
123    C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
124    C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
125    C     myThid   :: my thread Id number
126    C***********************************************************************
127          CHARACTER*8 chardiag
128          INTEGER biArg, bjArg
129          INTEGER myThid
130    CEOP
131    
132        klev = kdiag(ipoint)  C     !LOCAL VARIABLES:
133        if (klev.ge.lev) then  C ===============
134          ipnt = idiag(ipoint) + lev - 1        INTEGER m, n
135                  INTEGER bi, bj
136          do bj=myByLo(myThid), myByHi(myThid)        INTEGER ipt
137            do bi=myBxLo(myThid), myBxHi(myThid)  c     CHARACTER*(MAX_LEN_MBUF) msgBuf
138                
139              do j = 1,sNy  C--   Run through list of active diagnostics to find which counter
140                do i = 1,sNx  C     to increment (needs to be a valid & active diagnostic-counter)
141                  if ( qdiag(i,j,ipnt,bi,bj) .le. undef ) then        DO n=1,nlists
142                    qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)         DO m=1,nActive(n)
143                  else          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
144                    qtmp(i,j,lev,bi,bj) = undef           ipt = idiag(m,n)
145                  endif           IF (ndiag(ipt,1,1).GE.0) THEN
146                enddo  C-    Increment the counter for the diagnostic
147              enddo            IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
148                           DO bj=myByLo(myThid), myByHi(myThid)
149            enddo              DO bi=myBxLo(myThid), myBxHi(myThid)
150          enddo               ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
151                        ENDDO
152        endif             ENDDO
153              ELSE
154                 bi = MIN(biArg,nSx)
155                 bj = MIN(bjArg,nSy)
156                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
157              ENDIF
158    C-    Increment is done
159             ENDIF
160            ENDIF
161           ENDDO
162          ENDDO
163    
164   999  return        RETURN
165        end        END
166    
167  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
168    
169        subroutine clrindx (myThid,listnum)  CBOP 0
170  C***********************************************************************  C     !ROUTINE: DIAGS_MK_UNITS
 C  
 C  PURPOSE  
 C     DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST  
 C  
 C  ARGUMENT DESCRIPTION  
 C     listnum ....  diagnostics list number  
 C  
 C***********************************************************************  
171    
172        implicit none  C     !INTERFACE:
173  #include "EEPARAMS.h"        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
174  #include "CPP_OPTIONS.h"       I                            diagUnitsInPieces, myThid )
 #include "SIZE.h"  
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
175    
176        integer myThid, listnum  C     !DESCRIPTION:
177    C     *==========================================================*
178    C     | FUNCTION DIAGS_MK_UNITS
179    C     | o Return the diagnostic units string (16c) removing
180    C     |   blanks from the input string
181    C     *==========================================================*
182    
183        integer m, n  C     !USES:
184        character*8 parms1        IMPLICIT NONE
       character*1 parse1(8)  
       character*3 mate_index  
       integer mate  
   
       equivalence (     parms1 , parse1(1) )  
       equivalence ( mate_index , parse1(6) )  
   
       do n=1,nfields(listnum)  
        do m=1,ndiagt  
         if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  
          call clrdiag (myThid,m)  
   
 c Check for Counter Diagnostic  
 c ----------------------------  
          parms1 =  gdiag(m)  
          if( parse1(5).eq.'C' ) then  
           read (mate_index,100) mate  
           call clrdiag (myThid,mate)  
          endif  
         endif  
        enddo  
       enddo  
                     
   100 format(i3)  
       RETURN        
       END            
   
   
       subroutine clrdiag (myThid,index)  
 C***********************************************************************          
 C  PURPOSE                                                                        
 C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS  
 C***********************************************************************          
                                                                                   
       implicit none  
185  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
 #include "SIZE.h"  
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
   
       integer myThid, index  
   
       integer bi,bj  
       integer i,j,k  
186    
187  C **********************************************************************          C     !INPUT PARAMETERS:
188  C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****          C     diagUnitsInPieces :: string for diagnostic units: in several
189  C **********************************************************************          C                          pieces, with blanks in between
190                                                                                    C     myThid            ::  my thread Id number
191        do bj=myByLo(myThid), myByHi(myThid)        CHARACTER*(*) diagUnitsInPieces
192        do bi=myBxLo(myThid), myBxHi(myThid)        INTEGER      myThid
193         do k = 1,kdiag(index)  CEOP
         do j = 1,sNy  
         do i = 1,sNx  
          qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0  
         enddo  
         enddo  
        enddo  
       enddo  
       enddo  
194    
195        ndiag(index) = 0  C     !LOCAL VARIABLES:
196          CHARACTER*(MAX_LEN_MBUF) msgBuf
197          INTEGER i,j,n
198    
199          DIAGS_MK_UNITS = '          '
200          n = LEN(diagUnitsInPieces)
201    
202          j = 0
203          DO i=1,n
204           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
205             j = j+1
206             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
207           ENDIF
208          ENDDO
209    
210          IF ( j.GT.16 ) THEN
211             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
212         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
213            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
214         &       SQUEEZE_RIGHT , myThid)
215             WRITE(msgBuf,'(3A)') '**WARNING** ',
216         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
217            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
218         &       SQUEEZE_RIGHT , myThid)
219          ENDIF
220    
221        return        RETURN
222        end        END
223    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
224    CBOP 0
225    C     !ROUTINE: diagnostics_get_pointers
226    C     !INTERFACE:
227          subroutine diagnostics_get_pointers(diagName,ipoint,jpoint,myThid)
228    
229        subroutine setdiag (myThid,num,ndiagmx)  C     !DESCRIPTION:
230  C***********************************************************************  C     *==========================================================*
231  C  C     | subroutine diagnostics_get_pointers
232  C  PURPOSE  C     | o Returns the idiag and jdiag pointers for a
233  C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM  C     |   specified diagnostic - returns 0 if not active
234  C  C     *==========================================================*
 C***********************************************************************  
235    
236        implicit none  C     !USES:
237  #include "CPP_OPTIONS.h"        IMPLICIT NONE
238    #include "EEPARAMS.h"
239  #include "SIZE.h"  #include "SIZE.h"
240  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
241  #include "diagnostics.h"  #include "DIAGNOSTICS.h"
242    
243        integer num,myThid,ndiagmx  C     !INPUT PARAMETERS:
244        integer ipointer  C     diagName   ::  diagnostic identificator name (8 characters long)
245    C     myThid     ::  my thread Id number
246    C     !OUTPUT PARAMETERS:
247    C     ipoint     ::  pointer value into qdiag array
248    C     jpoint     ::  pointer value into diagnostics list
249    
250        DATA IPOINTER / 1 /        CHARACTER*8 diagName
251          INTEGER ipoint, jpoint, myThid
252    CEOP
253    
254        character*8 parms1  C     !LOCAL VARIABLES:
255        character*1 parse1(8)        INTEGER n,m
       character*3 mate_index  
       integer     mate  
   
       equivalence (     parms1 , parse1(1) )  
       equivalence ( mate_index , parse1(6) )  
   
 C **********************************************************************  
 C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****  
 C **********************************************************************  
   
       parms1 = gdiag(num)  
   
       IF( IDIAG(NUM).EQ.0 ) THEN  
         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  
256    
257  c Check for Counter Diagnostic        ipoint = 0
258  c ----------------------------        jpoint = 0
       if( parse1(5).eq.'C') then  
       read (mate_index,100) mate  
   
       IF( IDIAG(mate).EQ.0 ) THEN  
        if(ndiagmx+kdiag(num).gt.numdiags) then  
         write(6,5000)num,cdiag(num)  
        else  
         IDIAG(mate) = IPOINTER  
         IPOINTER    = IPOINTER + KDIAG(mate)  
         ndiagmx     = ndiagmx  + KDIAG(mate)  
         if(myThid.eq.1)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  
        endif  
       ELSE  
           if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)  
       ENDIF  
       endif  
259    
260        RETURN  C-    search for this diag. in the active 2D/3D diagnostics list
261          DO n=1,nlists
262           DO m=1,nActive(n)
263            IF ( diagName.EQ.flds(m,n) .AND. idiag(m,n).NE.0 ) THEN
264              ipoint = abs(idiag(m,n))
265              jpoint = jdiag(m,n)
266            ENDIF
267           ENDDO
268          ENDDO
269    
270    100 format(i3)        RETURN
  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')  
271        END        END
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.22
  ViewVC Help
Powered by ViewVC 1.1.22