/[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.17 by jmc, Fri Jan 28 01:06:12 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 (levreal,ipoint,undef,qtmp,myThid)
12    
13    C     !DESCRIPTION:
14  C     Retrieve averaged model diagnostic  C     Retrieve averaged model diagnostic
15  C  INPUT:                                                                        
16  C     lev ..... Diagnostic LEVEL  C     !USES:
 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***********************************************************************          
17        implicit none        implicit none
18  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
19  #include "SIZE.h"  #include "SIZE.h"
20    #include "DIAGNOSTICS_SIZE.h"
21    #include "DIAGNOSTICS.h"
22    CEOP
23    
24  #ifdef ALLOW_FIZHI  #ifdef ALLOW_FIZHI
25  #include "fizhi_SIZE.h"  #include "fizhi_SIZE.h"
26  #else  #else
27        integer Nrphys        integer Nrphys
28        parameter (Nrphys=0)        parameter (Nrphys=0)
29  #endif  #endif
30    
31  #include "diagnostics_SIZE.h"  C     INPUT:
32  #include "diagnostics.h"  C     levreal .... Diagnostic LEVEL
33          C     ipoint ..... DIAGNOSTIC NUMBER FROM MENU
34        integer myThid,lev,ipoint  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        _RL undef
40        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)  
41          C     OUTPUT:
42    C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
43          _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)
44    
45        _RL factor        _RL factor
46        integer i,j,ipnt,klev        integer i,j,ipnt,klev
47        integer bi,bj        integer bi,bj
48                integer lev
49        if (ipoint.lt.1) go to 999  
50                if (ipoint.ge.1) then
51        klev = kdiag(ipoint)         lev = NINT(levreal)
52        if(klev.ge.lev) then  
53           klev = kdiag(ipoint)
54           if (klev.ge.lev) then
55          ipnt = idiag(ipoint) + lev - 1          ipnt = idiag(ipoint) + lev - 1
56          factor = 1.0          factor = 1.0
57          if(ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)          if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)
58    
59          do bj=myByLo(myThid), myByHi(myThid)          do bj=myByLo(myThid), myByHi(myThid)
60            do bi=myBxLo(myThid), myBxHi(myThid)            do bi=myBxLo(myThid), myBxHi(myThid)
61                
62              do j = 1,sNy              do j = 1,sNy
63                do i = 1,sNx                do i = 1,sNx
64                  if( qdiag(i,j,ipnt,bi,bj).ne.undef ) then                  if ( qdiag(i,j,ipnt,bi,bj) .le. undef ) then
65                    qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor                    qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor
66                  else                  else
67                    qtmp(i,j,lev,bi,bj) = undef                    qtmp(i,j,lev,bi,bj) = undef
68                  endif                  endif
69                enddo                enddo
70              enddo              enddo
71                
72            enddo            enddo
73          enddo          enddo
74    
75           endif
76        endif        endif
77    
78   999  return        RETURN
79        end        END
80    
81    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
82    CBOP 0
83    C     !ROUTINE: GETDIAG2
84    
85    C     !INTERFACE:
86          SUBROUTINE GETDIAG2 (levreal,ipoint,undef,qtmp,myThid)
87    
88        subroutine getdiag2 (myThid,lev,ipoint,undef,qtmp)  C     !DESCRIPTION:
89  C***********************************************************************          C***********************************************************************
90  C  PURPOSE                                                                        C  PURPOSE
91  C     Retrieve averaged model diagnostic  C     Retrieve averaged model diagnostic
92  C  INPUT:                                                                        C  INPUT:
93  C     lev ..... Diagnostic LEVEL  C  levreal .... Diagnostic LEVEL
94  C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                      C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU
95  C   undef ..... UNDEFINED VALUE                                                  C   undef ..... UNDEFINED VALUE
96  C                                                                                C
97  C  OUTPUT:                                                                        C  OUTPUT:
98  C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY  C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
99  C                                                                                C
100  C***********************************************************************          C***********************************************************************
       implicit none  
101    
102    C     !USES:
103          implicit none
104  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
105  #include "SIZE.h"  #include "SIZE.h"
106    #include "DIAGNOSTICS_SIZE.h"
107    #include "DIAGNOSTICS.h"
108    CEOP
109    
110  #ifdef ALLOW_FIZHI  #ifdef ALLOW_FIZHI
111  #include "fizhi_SIZE.h"  #include "fizhi_SIZE.h"
# Line 96  C*************************************** Line 114  C***************************************
114         parameter (Nrphys=0)         parameter (Nrphys=0)
115  #endif  #endif
116    
117  #include "diagnostics_SIZE.h"        _RL levreal
118  #include "diagnostics.h"        integer myThid,ipoint
   
       integer myThid,lev,ipoint  
119        _RL undef        _RL undef
120        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)
121    
122        integer i,j,ipnt,klev        integer i,j,ipnt,klev
123        integer bi,bj        integer bi,bj
124          integer lev
125    
126        if (ipoint.lt.1) go to 999        if (ipoint.ge.1) then
127                 lev = NINT(levreal)
128        klev = kdiag(ipoint)  
129        if (klev .ge. lev) then         klev = kdiag(ipoint)
130           if (klev.ge.lev) then
131          ipnt = idiag(ipoint) + lev - 1          ipnt = idiag(ipoint) + lev - 1
132            
133          do bj=myByLo(myThid), myByHi(myThid)          do bj=myByLo(myThid), myByHi(myThid)
134            do bi=myBxLo(myThid), myBxHi(myThid)            do bi=myBxLo(myThid), myBxHi(myThid)
135                
136              do j = 1,sNy              do j = 1,sNy
137                do i = 1,sNx                do i = 1,sNx
138                  qtmp(i,j,lev,bi,bj) = qdiag(i,j,ipnt,bi,bj)                  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                enddo
144              enddo              enddo
145                
146            enddo            enddo
147          enddo          enddo
148            
149           endif
150        endif        endif
151    
152   999  return        RETURN
153        end        END
154    
155    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
156    
157        subroutine clrindx (myThid,listnum)        subroutine clrindx (listnum, myThid)
158  C***********************************************************************  C***********************************************************************
159  C  C
160  C  PURPOSE  C  PURPOSE
# Line 143  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 "diagnostics_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
172  #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    
181        equivalence (     parms1 , parse1(1) )        do n=1,nfields(listnum)
182        equivalence ( mate_index , parse1(6) )         do m=1,ndiagt
183            if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then
184        do n = 1,nfields(listnum)           call clrdiag (m, myThid)
185          do m = 1,ndiagt  
186            if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  c Check for Counter Diagnostic
187              call clrdiag (myThid,m)  c ----------------------------
188             parms1 =  gdiag(m)(1:8)
189  C           Check for Counter Diagnostic           if ( parms1(5:5).eq.'C' ) then
190              parms1 =  gdiag(m)            mate_index = parms1(6:8)
191              if ( parse1(5).eq.'C' ) then            read (mate_index,'(I3)') mate
192                read (mate_index,100) mate            call clrdiag (mate, myThid)
193                call clrdiag (myThid,mate)           endif
194              endif          endif
195            endif         enddo
         enddo  
196        enddo        enddo
                     
   100 format(i3)  
       RETURN        
       END            
197    
198          RETURN
199          END
200    
201        subroutine clrdiag (myThid,index)  
202  C***********************************************************************                subroutine clrdiag (index, myThid)
203  C  PURPOSE                                                                        C***********************************************************************
204    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 "diagnostics_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
212  #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. _d 0             qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0
               enddo  
             enddo  
229            enddo            enddo
230             enddo
231          enddo          enddo
232           enddo
233        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
244    
245    C     !INTERFACE:
246          LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )
247    
248    C     !DESCRIPTION:
249    C     *==========================================================*
250    C     | FUNCTION DIAGNOSTIC_IS_ON
251    C     | o Return TRUE if diagnostics "diagName" is Active
252    C     *==========================================================*
253    
254    C     !USES:
255          IMPLICIT NONE
256    #include "EEPARAMS.h"
257  #include "SIZE.h"  #include "SIZE.h"
258  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
259  #include "diagnostics.h"  #include "DIAGNOSTICS.h"
260    
261        integer num,myThid,ndiagmx  C     !INPUT PARAMETERS:
262        integer ipointer  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        DATA IPOINTER / 1 /        RETURN
283          END
284    
285        character*8 parms1  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
       character*1 parse1(8)  
       character*3 mate_index  
       integer     mate  
286    
287        equivalence (     parms1 , parse1(1) )  CBOP 0
288        equivalence ( mate_index , parse1(6) )  C     !ROUTINE: DIAGS_MK_UNITS
289    
290  C **********************************************************************  C     !INTERFACE:
291  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
292  C **********************************************************************       I                            diagUnitsInPieces, myThid )
293    
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        parms1 = gdiag(num)  C     !USES:
302          IMPLICIT NONE
303    #include "EEPARAMS.h"
304    
305        IF( IDIAG(NUM).EQ.0 ) THEN  C     !INPUT PARAMETERS:
306          if(ndiagmx+kdiag(num).gt.numdiags) then  C     diagUnitsInPieces :: string for diagnostic units: in several
307            write(6,4000)num,cdiag(num)  C                          pieces, with blanks in between
308          else  C     myThid            ::  my thread Id number
309            IDIAG(NUM) = IPOINTER        CHARACTER*(*) diagUnitsInPieces
310            IPOINTER   = IPOINTER + KDIAG(NUM)        INTEGER      myThid
311            ndiagmx    = ndiagmx  + KDIAG(NUM)  CEOP
312            if (myThid.eq.1)  
313       &         WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx  C     !LOCAL VARIABLES:
314          endif        CHARACTER*(MAX_LEN_MBUF) msgBuf
315        ELSE        INTEGER i,j,n
           if (myThid.eq.1)  
      &       WRITE(6,3000) NUM, CDIAG(NUM)  
       ENDIF  
316    
317  C     Check for Counter Diagnostic        DIAGS_MK_UNITS = '          '
318        if ( parse1(5).eq.'C') then        n = LEN(diagUnitsInPieces)
319          read (mate_index,100) mate        
320          j = 0
321          IF( IDIAG(mate).EQ.0 ) THEN        DO i=1,n
322            if(ndiagmx+kdiag(num).gt.numdiags) then         IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
323              write(6,5000)num,cdiag(num)           j = j+1
324            else           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
325              IDIAG(mate) = IPOINTER         ENDIF
326              IPOINTER    = IPOINTER + KDIAG(mate)        ENDDO
327              ndiagmx     = ndiagmx  + KDIAG(mate)  
328              if (myThid.eq.1)        IF ( j.GT.16 ) THEN
329       &           WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx           WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
330            endif       &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
331          ELSE          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
332            if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)       &       SQUEEZE_RIGHT , myThid)
333          ENDIF           WRITE(msgBuf,'(3A)') '**WARNING** ',
334        endif       &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
335            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
336         &       SQUEEZE_RIGHT , myThid)
337          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.10  
changed lines
  Added in v.1.17
  ViewVC Help
Powered by ViewVC 1.1.22