/[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.2 by molod, Thu Feb 26 02:21:18 2004 UTC revision 1.17 by jmc, Fri Jan 28 01:06:12 2005 UTC
# Line 1  Line 1 
1        subroutine getdiag (lev,ipoint,bi,bj,undef,qtmp)  C $Header$
2  C***********************************************************************          C $Name$
3  C  PURPOSE                                                                        
4    #include "DIAG_OPTIONS.h"
5    
6    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7    CBOP 0
8    C     !ROUTINE: GETDIAG
9    
10    C     !INTERFACE:
11          SUBROUTINE GETDIAG (levreal,ipoint,undef,qtmp,myThid)
12    
13    C     !DESCRIPTION:
14  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      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  
15    
16  #include "CPP_OPTIONS.h"  C     !USES:
17          implicit none
18    #include "EEPARAMS.h"
19  #include "SIZE.h"  #include "SIZE.h"
20    #include "DIAGNOSTICS_SIZE.h"
21    #include "DIAGNOSTICS.h"
22    CEOP
23    
24    #ifdef ALLOW_FIZHI
25  #include "fizhi_SIZE.h"  #include "fizhi_SIZE.h"
26  #include "diagnostics_SIZE.h"  #else
27  #include "diagnostics.h"        integer Nrphys
28          parameter (Nrphys=0)
29    #endif
30    
31    C     INPUT:
32    C     levreal .... Diagnostic LEVEL
33    C     ipoint ..... DIAGNOSTIC NUMBER FROM MENU
34    C     undef  ..... UNDEFINED VALUE
35    C     bi     ..... X-direction process(or) number
36    C     bj     ..... Y-direction process(or) number
37          _RL levreal
38          integer myThid,ipoint
39          _RL undef
40    
41        integer bi,bj  C     OUTPUT:
42        integer lev,ipoint  C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
43          _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)
44    
45          _RL factor
46        integer i,j,ipnt,klev        integer i,j,ipnt,klev
47        _RL undef, factor        integer bi,bj
48        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)        integer lev
49    
50        do j = 1,sNy        if (ipoint.ge.1) then
51        do i = 1,sNx         lev = NINT(levreal)
        qtmp(i,j,bi,bj) = undef  
       enddo  
       enddo  
52    
53        IF (IPOINT.LT.1) GO TO 999         klev = kdiag(ipoint)
54           if (klev.ge.lev) then
55            ipnt = idiag(ipoint) + lev - 1
56            factor = 1.0
57            if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)
58    
59            do bj=myByLo(myThid), myByHi(myThid)
60              do bi=myBxLo(myThid), myBxHi(myThid)
61    
62                do j = 1,sNy
63                  do i = 1,sNx
64                    if ( qdiag(i,j,ipnt,bi,bj) .le. undef ) then
65                      qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor
66                    else
67                      qtmp(i,j,lev,bi,bj) = undef
68                    endif
69                  enddo
70                enddo
71    
72        KLEV = KDIAG(IPOINT)            enddo
73        IF(KLEV.GE.LEV) THEN          enddo
74        IPNT = IDIAG(IPOINT) + LEV - 1  
75                                  FACTOR = 1.0         endif
76        IF( NDIAG(IPOINT).NE.0 )  FACTOR = 1.0   / NDIAG(IPOINT)        endif
       do j = 1,sNy  
       do i = 1,sNx  
       if( qdiag(i,j,ipnt,bi,bj).ne.undef )  
      .     qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor  
       enddo  
       enddo  
       ENDIF  
77    
78   999  RETURN        RETURN
79        END        END
80    
81        subroutine getdiag2 (lev,ipoint,bi,bj,undef,qtmp)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
82  C***********************************************************************          CBOP 0
83  C                                                                                C     !ROUTINE: GETDIAG2
 C  PURPOSE                                                                        
 C     Retrieve model diagnostic (No Averaging)  
 C  INPUT:                                                                        
 C     lev ..... Model LEVEL                                                      
 C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                      
 C   undef ..... UNDEFINED VALUE                                                  
 C      im ..... X-DIMENSION  
 C      jm ..... Y-DIMENSION  
 C      nd ..... Number of 2-D Diagnostics  
 C                                                                                
 C  OUTPUT:                                                                        
 C    qtmp ..... DIAGNOSTIC QUANTITY                                              
 C                                                                                
 C***********************************************************************          
       implicit none  
84    
85  #include "CPP_OPTIONS.h"  C     !INTERFACE:
86          SUBROUTINE GETDIAG2 (levreal,ipoint,undef,qtmp,myThid)
87    
88    C     !DESCRIPTION:
89    C***********************************************************************
90    C  PURPOSE
91    C     Retrieve averaged model diagnostic
92    C  INPUT:
93    C  levreal .... Diagnostic LEVEL
94    C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU
95    C   undef ..... UNDEFINED VALUE
96    C
97    C  OUTPUT:
98    C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
99    C
100    C***********************************************************************
101    
102    C     !USES:
103          implicit none
104    #include "EEPARAMS.h"
105  #include "SIZE.h"  #include "SIZE.h"
106    #include "DIAGNOSTICS_SIZE.h"
107    #include "DIAGNOSTICS.h"
108    CEOP
109    
110    #ifdef ALLOW_FIZHI
111  #include "fizhi_SIZE.h"  #include "fizhi_SIZE.h"
112  #include "diagnostics_SIZE.h"  #else
113  #include "diagnostics.h"         integer Nrphys
114           parameter (Nrphys=0)
115    #endif
116    
117        integer bi,bj        _RL levreal
118          integer myThid,ipoint
119          _RL undef
120          _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)
121    
       integer lev,ipoint  
122        integer i,j,ipnt,klev        integer i,j,ipnt,klev
123        _RL undef        integer bi,bj
124        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)        integer lev
125    
126        do j = 1,sNy        if (ipoint.ge.1) then
127        do i = 1,sNx         lev = NINT(levreal)
        qtmp(i,j,bi,bj) = undef  
       enddo  
       enddo  
128    
129        IF (IPOINT.LT.1) GO TO 999         klev = kdiag(ipoint)
130           if (klev.ge.lev) then
131            ipnt = idiag(ipoint) + lev - 1
132    
133            do bj=myByLo(myThid), myByHi(myThid)
134              do bi=myBxLo(myThid), myBxHi(myThid)
135    
136                do j = 1,sNy
137                  do i = 1,sNx
138                    if ( qdiag(i,j,ipnt,bi,bj) .le. undef ) then
139                      qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)
140                    else
141                      qtmp(i,j,lev,bi,bj) = undef
142                    endif
143                  enddo
144                enddo
145    
146        KLEV = KDIAG(IPOINT)            enddo
147        IF(KLEV.GE.LEV) THEN          enddo
148        IPNT = IDIAG(IPOINT) + LEV - 1  
149        do j = 1,sNy         endif
150        do i = 1,sNx        endif
        qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)  
       enddo  
       enddo  
       ENDIF  
151    
152   999  RETURN        RETURN
153        END        END
154                                                                                    
155        subroutine clrindx (myThid,listnum)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
156    
157          subroutine clrindx (listnum, myThid)
158  C***********************************************************************  C***********************************************************************
159  C  C
160  C  PURPOSE  C  PURPOSE
# Line 117  C*************************************** Line 167  C***************************************
167    
168        implicit none        implicit none
169  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
170  #include "SIZE.h"  #include "SIZE.h"
171  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
172  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
 #include "diagnostics.h"  
173    
174        integer myThid, listnum        integer myThid, listnum
175    
176        integer m, n        integer m, n
177        character*8 parms1        character*8 parms1
       character*1 parse1(8)  
178        character*3 mate_index        character*3 mate_index
179        integer mate        integer mate
180    
       equivalence (     parms1 , parse1(1) )  
       equivalence ( mate_index , parse1(6) )  
   
181        do n=1,nfields(listnum)        do n=1,nfields(listnum)
182         do m=1,ndiagt         do m=1,ndiagt
183          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
184           call clrdiag (myThid,m)           call clrdiag (m, myThid)
185    
186  c Check for Counter Diagnostic  c Check for Counter Diagnostic
187  c ----------------------------  c ----------------------------
188           parms1 =  gdiag(m)           parms1 =  gdiag(m)(1:8)
189           if( parse1(5).eq.'C' ) then           if ( parms1(5:5).eq.'C' ) then
190            read (mate_index,100) mate            mate_index = parms1(6:8)
191            call clrdiag (myThid,mate)            read (mate_index,'(I3)') mate
192              call clrdiag (mate, myThid)
193           endif           endif
194          endif          endif
195         enddo         enddo
196        enddo        enddo
197                      
198    100 format(i3)        RETURN
199        RETURN              END
       END            
200    
201    
202        subroutine clrdiag (myThid,index)        subroutine clrdiag (index, myThid)
203  C***********************************************************************          C***********************************************************************
204  C  PURPOSE                                                                        C  PURPOSE
205  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS
206  C***********************************************************************          C***********************************************************************
207                                                                                    
208        implicit none        implicit none
209  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
210  #include "SIZE.h"  #include "SIZE.h"
211  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
212  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
 #include "diagnostics.h"  
213    
214        integer myThid, index        integer myThid, index
215    
216        integer bi,bj        integer bi,bj
217        integer i,j,k        integer i,j,k
218    
219  C **********************************************************************          C **********************************************************************
220  C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****          C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****
221  C **********************************************************************          C **********************************************************************
222                                                                                    
223        do bj=myByLo(myThid), myByHi(myThid)        do bj=myByLo(myThid), myByHi(myThid)
224        do bi=myBxLo(myThid), myBxHi(myThid)         do bi=myBxLo(myThid), myBxHi(myThid)
225         do k = 1,kdiag(index)          do k = 1,kdiag(index)
226          do j = 1,sNy           do j = 1-OLy,sNy+OLy
227          do i = 1,sNx            do i = 1-OLx,sNx+OLx
228           qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0             qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
229          enddo            enddo
230             enddo
231          enddo          enddo
232         enddo         enddo
233        enddo        enddo
       enddo  
234    
235        ndiag(index) = 0        ndiag(index) = 0
236    
237        return        RETURN
238        end        END
239    
240        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***********************************************************************  
241    
242        implicit none  CBOP 0
243  #include "CPP_OPTIONS.h"  C     !ROUTINE: DIAGNOSTICS_IS_ON
 #include "SIZE.h"  
 #include "fizhi_SIZE.h"  
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
244    
245        integer num,myThid,ndiagmx  C     !INTERFACE:
246        integer ipointer        LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )
247    
248        DATA IPOINTER / 1 /  C     !DESCRIPTION:
249    C     *==========================================================*
250    C     | FUNCTION DIAGNOSTIC_IS_ON
251    C     | o Return TRUE if diagnostics "diagName" is Active
252    C     *==========================================================*
253    
254        character*8 parms1  C     !USES:
255        character*1 parse1(8)        IMPLICIT NONE
256        character*3 mate_index  #include "EEPARAMS.h"
257        integer     mate  #include "SIZE.h"
258    #include "DIAGNOSTICS_SIZE.h"
259    #include "DIAGNOSTICS.h"
260    
261        equivalence (     parms1 , parse1(1) )  C     !INPUT PARAMETERS:
262        equivalence ( mate_index , parse1(6) )  C     diagName   ::  diagnostic identificator name (8 characters long)
263    C     myThid     ::  my thread Id number
264          CHARACTER*8  diagName
265          INTEGER      myThid
266    CEOP
267    
268    C     !LOCAL VARIABLES:
269          INTEGER j,n,m
270    
271          DIAGNOSTICS_IS_ON = .FALSE.
272          DO n=1,nlists
273           DO m=1,nActive(n)
274            IF ( diagName.EQ.flds(m,n) ) THEN
275              j = jdiag(m,n)    
276              IF ( idiag(j).NE.0 .AND. ndiag(j).GE.0 )
277         &         DIAGNOSTICS_IS_ON = .TRUE.
278            ENDIF
279           ENDDO
280          ENDDO
281    
282  C **********************************************************************        RETURN
283  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****        END
 C **********************************************************************  
284    
285        parms1 = gdiag(num)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
286    
287        IF( IDIAG(NUM).EQ.0 ) THEN  CBOP 0
288          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.0) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx  
         endif  
       ELSE  
           if(myThid.eq.0) WRITE(6,3000) NUM, CDIAG(NUM)  
       ENDIF  
289    
290  c Check for Counter Diagnostic  C     !INTERFACE:
291  c ----------------------------        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
292        if( parse1(5).eq.'C') then       I                            diagUnitsInPieces, myThid )
293        read (mate_index,100) mate  
294    C     !DESCRIPTION:
295    C     *==========================================================*
296    C     | FUNCTION DIAGS_MK_UNITS
297    C     | o Return the diagnostic units string (16c) removing
298    C     |   blanks from the input string
299    C     *==========================================================*
300    
301        IF( IDIAG(mate).EQ.0 ) THEN  C     !USES:
302         if(ndiagmx+kdiag(num).gt.numdiags) then        IMPLICIT NONE
303          write(6,5000)num,cdiag(num)  #include "EEPARAMS.h"
304         else  
305          IDIAG(mate) = IPOINTER  C     !INPUT PARAMETERS:
306          IPOINTER    = IPOINTER + KDIAG(mate)  C     diagUnitsInPieces :: string for diagnostic units: in several
307          ndiagmx     = ndiagmx  + KDIAG(mate)  C                          pieces, with blanks in between
308          if(myThid.eq.0)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     myThid            ::  my thread Id number
309         endif        CHARACTER*(*) diagUnitsInPieces
310        ELSE        INTEGER      myThid
311            if(myThid.eq.0) WRITE(6,3000) mate, CDIAG(mate)  CEOP
312    
313    C     !LOCAL VARIABLES:
314          CHARACTER*(MAX_LEN_MBUF) msgBuf
315          INTEGER i,j,n
316    
317          DIAGS_MK_UNITS = '          '
318          n = LEN(diagUnitsInPieces)
319          
320          j = 0
321          DO i=1,n
322           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
323             j = j+1
324             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
325           ENDIF
326          ENDDO
327    
328          IF ( j.GT.16 ) THEN
329             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
330         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
331            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
332         &       SQUEEZE_RIGHT , myThid)
333             WRITE(msgBuf,'(3A)') '**WARNING** ',
334         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
335            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
336         &       SQUEEZE_RIGHT , myThid)
337        ENDIF        ENDIF
       endif  
338    
339        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')  
340        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.17
  ViewVC Help
Powered by ViewVC 1.1.22