/[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.10 by edhill, Wed Jul 7 03:47:05 2004 UTC revision 1.18 by jmc, Mon Feb 7 03:07:49 2005 UTC
# Line 3  C $Name$ Line 3  C $Name$
3    
4  #include "DIAG_OPTIONS.h"  #include "DIAG_OPTIONS.h"
5    
6        subroutine getdiag (myThid,lev,ipoint,undef,qtmp)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7  C***********************************************************************          CBOP 0
8  C  PURPOSE                                                                        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    C     !DESCRIPTION:
17  C     Retrieve averaged model diagnostic  C     Retrieve averaged model diagnostic
18  C  INPUT:                                                                        
19  C     lev ..... Diagnostic LEVEL  C     !USES:
20  C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                            IMPLICIT NONE
 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  
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=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
         
       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
       _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).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  
38    
39        subroutine getdiag2 (myThid,lev,ipoint,undef,qtmp)  C     !OUTPUT PARAMETERS:
40  C***********************************************************************          C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
41  C  PURPOSE                                                                              _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
42  C     Retrieve averaged model diagnostic  CEOP
 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  
43    
44  #include "EEPARAMS.h"  C     !LOCAL VARIABLES:
45  #include "CPP_OPTIONS.h"        _RL factor
46  #include "SIZE.h"        INTEGER i, j, ipnt,ipCt
47          INTEGER lev, levCt, klev
 #ifdef ALLOW_FIZHI  
 #include "fizhi_SIZE.h"  
 #else  
        integer Nrphys  
        parameter (Nrphys=0)  
 #endif  
48    
49  #include "diagnostics_SIZE.h"        IF (ipoint.GE.1) THEN
50  #include "diagnostics.h"         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        integer myThid,lev,ipoint          ELSE
74        _RL undef  C-      With counter diagnostics => average = Sum / counter:
       _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)  
75    
76        integer i,j,ipnt,klev            ipnt = idiag(ipoint) + lev - 1
77        integer bi,bj            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        if (ipoint.lt.1) go to 999          ENDIF
91                 ENDIF
92        klev = kdiag(ipoint)        ENDIF
       if (klev .ge. lev) then  
         ipnt = idiag(ipoint) + lev - 1  
           
         do bj=myByLo(myThid), myByHi(myThid)  
           do bi=myBxLo(myThid), myBxHi(myThid)  
               
             do j = 1,sNy  
               do i = 1,sNx  
                 qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)  
               enddo  
             enddo  
               
           enddo  
         enddo  
           
       endif  
93    
94   999  return        RETURN
95        end        END
96    
97    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 143  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    
123        equivalence (     parms1 , parse1(1) )        do n=1,nfields(listnum)
124        equivalence ( mate_index , parse1(6) )         do m=1,ndiagt
125            if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then
126        do n = 1,nfields(listnum)           call clrdiag (m, myThid)
127          do m = 1,ndiagt  
128            if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  c Check for Counter Diagnostic
129              call clrdiag (myThid,m)  c ----------------------------
130             parms1 =  gdiag(m)(1:8)
131  C           Check for Counter Diagnostic           if ( parms1(5:5).eq.'C' ) then
132              parms1 =  gdiag(m)            mate_index = parms1(6:8)
133              if ( parse1(5).eq.'C' ) then            read (mate_index,'(I3)') mate
134                read (mate_index,100) mate            call clrdiag (mate, myThid)
135                call clrdiag (myThid,mate)           endif
136              endif          endif
137            endif         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. _d 0             qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
               enddo  
             enddo  
171            enddo            enddo
172             enddo
173          enddo          enddo
174           enddo
175        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        subroutine setdiag (myThid,num,ndiagmx)  CBOP 0
185  C***********************************************************************  C     !ROUTINE: DIAGNOSTICS_IS_ON
 C  
 C  PURPOSE  
 C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM  
 C  
 C***********************************************************************  
186    
187        implicit none  C     !INTERFACE:
188  #include "CPP_OPTIONS.h"        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    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        DATA IPOINTER / 1 /        RETURN
225          END
226    
227        character*8 parms1  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
       character*1 parse1(8)  
       character*3 mate_index  
       integer     mate  
228    
229        equivalence (     parms1 , parse1(1) )  CBOP 0
230        equivalence ( mate_index , parse1(6) )  C     !ROUTINE: DIAGS_MK_UNITS
231    
232  C **********************************************************************  C     !INTERFACE:
233  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
234  C **********************************************************************       I                            diagUnitsInPieces, myThid )
235    
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        parms1 = gdiag(num)  C     !USES:
244          IMPLICIT NONE
245    #include "EEPARAMS.h"
246    
247        IF( IDIAG(NUM).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,4000)num,cdiag(num)  C                          pieces, with blanks in between
250          else  C     myThid            ::  my thread Id number
251            IDIAG(NUM) = IPOINTER        CHARACTER*(*) diagUnitsInPieces
252            IPOINTER   = IPOINTER + KDIAG(NUM)        INTEGER      myThid
253            ndiagmx    = ndiagmx  + KDIAG(NUM)  CEOP
254            if (myThid.eq.1)  
255       &         WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx  C     !LOCAL VARIABLES:
256          endif        CHARACTER*(MAX_LEN_MBUF) msgBuf
257        ELSE        INTEGER i,j,n
           if (myThid.eq.1)  
      &       WRITE(6,3000) NUM, CDIAG(NUM)  
       ENDIF  
258    
259  C     Check for Counter Diagnostic        DIAGS_MK_UNITS = '          '
260        if ( parse1(5).eq.'C') then        n = LEN(diagUnitsInPieces)
261          read (mate_index,100) mate        
262          j = 0
263          IF( IDIAG(mate).EQ.0 ) THEN        DO i=1,n
264            if(ndiagmx+kdiag(num).gt.numdiags) then         IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
265              write(6,5000)num,cdiag(num)           j = j+1
266            else           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
267              IDIAG(mate) = IPOINTER         ENDIF
268              IPOINTER    = IPOINTER + KDIAG(mate)        ENDDO
269              ndiagmx     = ndiagmx  + KDIAG(mate)  
270              if (myThid.eq.1)        IF ( j.GT.16 ) THEN
271       &           WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx           WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
272            endif       &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
273          ELSE          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
274            if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)       &       SQUEEZE_RIGHT , myThid)
275          ENDIF           WRITE(msgBuf,'(3A)') '**WARNING** ',
276        endif       &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
277            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
278         &       SQUEEZE_RIGHT , myThid)
279          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.10  
changed lines
  Added in v.1.18
  ViewVC Help
Powered by ViewVC 1.1.22