/[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.3 by molod, Thu Feb 26 18:33:46 2004 UTC revision 1.29 by jmc, Fri Jan 15 00:25:58 2010 UTC
# Line 1  Line 1 
1        subroutine getdiag (myThid,lev,ipoint,undef,qtmp)  C $Header$
2  C***********************************************************************          C $Name$
3  C  PURPOSE                                                                        
4    #include "DIAG_OPTIONS.h"
5    
6    C--   File diagnostics_utils.F: General purpose support routines
7    C--    Contents:
8    C--    o GETDIAG
9    C--    o DIAGNOSTICS_COUNT
10    C--    o DIAGNOSTICS_GET_POINTERS
11    C--    o DIAGNOSTICS_SETKLEV
12    C--    o DIAGS_GET_PARMS_I (Function)
13    C--    o DIAGS_MK_UNITS (Function)
14    C--    o DIAGS_MK_TITLE (Function)
15    
16    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
17    CBOP 0
18    C     !ROUTINE: GETDIAG
19    
20    C     !INTERFACE:
21          SUBROUTINE GETDIAG(
22         I                    levreal, undef,
23         O                    qtmp,
24         I                    ndId, mate, ip, im, bi, bj, myThid )
25    
26    C     !DESCRIPTION:
27  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  
28    
29    C     !USES:
30          IMPLICIT NONE
31  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
32  #include "SIZE.h"  #include "SIZE.h"
33    #include "DIAGNOSTICS_SIZE.h"
34    #include "DIAGNOSTICS.h"
35    
36  #ifdef ALLOW_FIZHI  C     !INPUT PARAMETERS:
37  #include "fizhi_SIZE.h"  C     levreal :: Diagnostic LEVEL
38  #else  C     undef   :: UNDEFINED VALUE
39         integer Nrphys  C     ndId    :: DIAGNOSTIC NUMBER FROM MENU
40         parameter (Nrphys=1)  C     mate    :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise
41  #endif  C     ip      :: pointer to storage array location for diag.
42    C     im      :: pointer to storage array location for mate
43  #include "diagnostics_SIZE.h"  C     bi      :: X-direction tile number
44  #include "diagnostics.h"  C     bj      :: Y-direction tile number
45    C     myThid  :: my thread Id number
46        integer myThid,lev,ipoint        _RL levreal
47        _RL undef        _RL undef
48        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)        INTEGER ndId, mate, ip, im
49          INTEGER bi,bj, myThid
50    
51        _RL factor  C     !OUTPUT PARAMETERS:
52        integer i,j,ipnt,klev  C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
53        integer bi,bj        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
54    CEOP
       if (ipoint.lt.1) go to 999  
55    
56        klev = kdiag(ipoint)  C     !LOCAL VARIABLES:
57        if(klev.ge.lev) then        _RL factor
58        ipnt = idiag(ipoint) + lev - 1        INTEGER i, j, ipnt,ipCt
59        factor = 1.0        INTEGER lev, levCt, klev
       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  
   
       subroutine getdiag2 (myThid,lev,ipoint,undef,qtmp)  
 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***********************************************************************          
       implicit none  
60    
61  #include "EEPARAMS.h"        IF (ndId.GE.1) THEN
62  #include "CPP_OPTIONS.h"         lev = NINT(levreal)
63  #include "SIZE.h"         klev = kdiag(ndId)
64           IF (lev.LE.klev) THEN
65    
66            IF ( mate.EQ.0 ) THEN
67    C-      No counter diagnostics => average = Sum / ndiag :
68    
69              ipnt = ip + lev - 1
70              factor = FLOAT(ndiag(ip,bi,bj))
71              IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
72    
73  #ifdef ALLOW_FIZHI  #ifdef ALLOW_FIZHI
74  #include "fizhi_SIZE.h"            DO j = 1,sNy+1
75  #else              DO i = 1,sNx+1
76         integer Nrphys                IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
77         parameter (Nrphys=1)                  qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
78  #endif                ELSE
79                    qtmp(i,j) = undef
80                  ENDIF
81                ENDDO
82              ENDDO
83    #else /* ALLOW_FIZHI */
84              DO j = 1,sNy+1
85                DO i = 1,sNx+1
86                  qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
87                ENDDO
88              ENDDO
89    #endif /* ALLOW_FIZHI */
90    
91            ELSE
92    C-      With counter diagnostics => average = Sum / counter:
93    
94              ipnt = ip + lev - 1
95              levCt= MIN(lev,kdiag(mate))
96              ipCt = im + levCt - 1
97              DO j = 1,sNy+1
98                DO i = 1,sNx+1
99                  IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
100                    qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)
101         &                    / qdiag(i,j,ipCt,bi,bj)
102                  ELSE
103                    qtmp(i,j) = undef
104                  ENDIF
105                ENDDO
106              ENDDO
107    
108  #include "diagnostics_SIZE.h"          ENDIF
109  #include "diagnostics.h"         ENDIF
110          ENDIF
111    
112        integer myThid,lev,ipoint        RETURN
113        _RL undef        END
       _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nr+Nrphys,Nsx,Nsy)  
114    
115        integer i,j,ipnt,klev  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
       integer bi,bj  
116    
117        if (ipoint.lt.1) go to 999  CBOP 0
118    C     !ROUTINE: DIAGNOSTICS_COUNT
119    C     !INTERFACE:
120          SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
121         I                              biArg, bjArg, myThid)
122    
123        klev = kdiag(ipoint)  C     !DESCRIPTION:
       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  
        if( qdiag(i,j,ipnt,bi,bj).ne.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  
   
  999  return  
       end  
       subroutine clrindx (myThid,listnum)  
124  C***********************************************************************  C***********************************************************************
125  C  C   routine to increment the diagnostic counter only
 C  PURPOSE  
 C     DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST  
 C  
 C  ARGUMENT DESCRIPTION  
 C     listnum ....  diagnostics list number  
 C  
126  C***********************************************************************  C***********************************************************************
127    C     !USES:
128          IMPLICIT NONE
129    
130        implicit none  C     == Global variables ===
131  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
132  #include "SIZE.h"  #include "SIZE.h"
133  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
134  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
135  #include "diagnostics.h"  
136    C     !INPUT PARAMETERS:
137        integer myThid, listnum  C***********************************************************************
138    C  Arguments Description
139        integer m, n  C  ----------------------
140        character*8 parms1  C     chardiag :: Character expression for diag to increment the counter
141        character*1 parse1(8)  C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
142        character*3 mate_index  C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
143        integer mate  C     myThid   :: my thread Id number
144    C***********************************************************************
145        equivalence (     parms1 , parse1(1) )        CHARACTER*8 chardiag
146        equivalence ( mate_index , parse1(6) )        INTEGER biArg, bjArg
147          INTEGER myThid
148        do n=1,nfields(listnum)  CEOP
149         do m=1,ndiagt  
150          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  C     !LOCAL VARIABLES:
151           call clrdiag (myThid,m)  C ===============
152          INTEGER m, n
153  c Check for Counter Diagnostic        INTEGER bi, bj
154  c ----------------------------        INTEGER ipt, ndId
155           parms1 =  gdiag(m)  c     CHARACTER*(MAX_LEN_MBUF) msgBuf
156           if( parse1(5).eq.'C' ) then  
157            read (mate_index,100) mate        IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
158            call clrdiag (myThid,mate)          bi = myBxLo(myThid)
159           endif          bj = myByLo(myThid)
160          endif        ELSE
161         enddo          bi = MIN(biArg,nSx)
162        enddo          bj = MIN(bjArg,nSy)
163                            ENDIF
164    100 format(i3)  
165        RETURN        C--   Run through list of active diagnostics to find which counter
166        END            C     to increment (needs to be a valid & active diagnostic-counter)
167          DO n=1,nlists
168           DO m=1,nActive(n)
169        subroutine clrdiag (myThid,index)          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
170  C***********************************************************************                   ipt = idiag(m,n)
171  C  PURPOSE                                                                                 IF (ndiag(ipt,bi,bj).GE.0) THEN
172  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS            ndId = jdiag(m,n)
173  C***********************************************************************                    ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
174                                                                                    C-    Increment the counter for the diagnostic
175        implicit none            IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
176               DO bj=myByLo(myThid), myByHi(myThid)
177                DO bi=myBxLo(myThid), myBxHi(myThid)
178                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
179                ENDDO
180               ENDDO
181              ELSE
182                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
183              ENDIF
184    C-    Increment is done
185             ENDIF
186            ENDIF
187           ENDDO
188          ENDDO
189    
190          RETURN
191          END
192    
193    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
194    
195    CBOP 0
196    C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
197    C     !INTERFACE:
198          SUBROUTINE DIAGNOSTICS_GET_POINTERS(
199         I                       diagName, listId,
200         O                       ndId, ip,
201         I                       myThid )
202    
203    C     !DESCRIPTION:
204    C     *================================================================*
205    C     | o Returns the diagnostic Id number and diagnostic
206    C     |   pointer to storage array for a specified diagnostic.
207    C     *================================================================*
208    C     | Note: A diagnostics field can be stored multiple times
209    C     |       (for different output frequency,phase, ...).
210    C     | operates in 2 ways:
211    C     | o listId =0 => find 1 diagnostics Id & pointer which name matches.
212    C     | o listId >0 => find the unique diagnostic Id & pointer with
213    C     |      the right name and same output time as "listId" output-list
214    C     | o return ip=0 if did not find the right diagnostic;
215    C     |   (ndId <>0 if diagnostic exist but output time does not match)
216    C     *================================================================*
217    
218    C     !USES:
219          IMPLICIT NONE
220  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
221  #include "SIZE.h"  #include "SIZE.h"
222  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
223  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
 #include "diagnostics.h"  
   
       integer myThid, index  
   
       integer bi,bj  
       integer i,j,k  
   
 C **********************************************************************          
 C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****          
 C **********************************************************************          
                                                                                   
       do bj=myByLo(myThid), myByHi(myThid)  
       do bi=myBxLo(myThid), myBxHi(myThid)  
        do k = 1,kdiag(index)  
         do j = 1,sNy  
         do i = 1,sNx  
          qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0  
         enddo  
         enddo  
        enddo  
       enddo  
       enddo  
224    
225        ndiag(index) = 0  C     !INPUT PARAMETERS:
226    C     diagName :: diagnostic identificator name (8 characters long)
227    C     listId   :: list number that specify the output frequency
228    C     myThid   :: my Thread Id number
229    C     !OUTPUT PARAMETERS:
230    C     ndId     :: diagnostics  Id number (in available diagnostics list)
231    C     ip       :: diagnostics  pointer to storage array
232    
233    
234          CHARACTER*8 diagName
235          INTEGER listId
236          INTEGER ndId, ip
237          INTEGER myThid
238    CEOP
239    
240    C     !LOCAL VARIABLES:
241          INTEGER n,m
242    
243          ip   = 0
244          ndId = 0
245    
246          IF ( listId.LE.0 ) THEN
247    C--   select the 1rst one which name matches:
248    
249    C-    search for this diag. in the active 2D/3D diagnostics list
250            DO n=1,nlists
251             DO m=1,nActive(n)
252               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
253         &                  .AND. idiag(m,n).NE.0 ) THEN
254                ip   = ABS(idiag(m,n))
255                ndId = jdiag(m,n)
256               ENDIF
257             ENDDO
258            ENDDO
259    
260          ELSEIF ( listId.LE.nlists ) THEN
261    C--   select the unique diagnostic with output-time identical to listId
262    
263    C-    search for this diag. in the active 2D/3D diagnostics list
264            DO n=1,nlists
265             IF ( ip.EQ.0
266         &        .AND. freq(n) .EQ. freq(listId)
267         &        .AND. phase(n).EQ.phase(listId)
268         &        .AND. averageFreq(n) .EQ.averageFreq(listId)
269         &        .AND. averagePhase(n).EQ.averagePhase(listId)
270         &        .AND. averageCycle(n).EQ.averageCycle(listId)
271         &      ) THEN
272              DO m=1,nActive(n)
273               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
274         &                  .AND. idiag(m,n).NE.0 ) THEN
275                ip   = ABS(idiag(m,n))
276                ndId = jdiag(m,n)
277               ENDIF
278              ENDDO
279             ELSEIF ( ip.EQ.0 ) THEN
280              DO m=1,nActive(n)
281               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
282         &                  .AND. idiag(m,n).NE.0 ) THEN
283                ndId = jdiag(m,n)
284               ENDIF
285              ENDDO
286             ENDIF
287            ENDDO
288    
289        return        ELSE
290        end          STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
291          ENDIF
292    
293        subroutine setdiag (myThid,num,ndiagmx)        RETURN
294  C***********************************************************************        END
295  C  
296  C  PURPOSE  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
297  C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM  
298  C  CBOP 0
299  C***********************************************************************  C     !ROUTINE: DIAGNOSTICS_SETKLEV
300    
301    C     !INTERFACE:
302          SUBROUTINE DIAGNOSTICS_SETKLEV(
303         I                                diagName, nLevDiag, myThid )
304    
305    C     !DESCRIPTION:
306    C     *==========================================================*
307    C     | S/R DIAGNOSTICS_SETKLEV
308    C     | o Define explicitly the number of level (stored in kdiag)
309    C     |   of a diagnostic field. For most diagnostics, the number
310    C     |   of levels is derived (in S/R SET_LEVELS) from gdiag(10)
311    C     |   but occasionally one may want to set it explicitly.
312    C     *==========================================================*
313    
314        implicit none  C     !USES:
315  #include "CPP_OPTIONS.h"        IMPLICIT NONE
316    #include "EEPARAMS.h"
317  #include "SIZE.h"  #include "SIZE.h"
318  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
319  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
320  #include "diagnostics.h"  
321    C     !INPUT PARAMETERS:
322        integer num,myThid,ndiagmx  C     diagName  :: diagnostic identificator name (8 characters long)
323        integer ipointer  C     nLevDiag  :: number of level to set for this diagnostics field
324    C     myThid    :: my Thread Id number
325        DATA IPOINTER / 1 /        CHARACTER*8  diagName
326          INTEGER nLevDiag
327        character*8 parms1        INTEGER myThid
328        character*1 parse1(8)  CEOP
329        character*3 mate_index  
330        integer     mate  C     !LOCAL VARIABLES:
331          CHARACTER*(MAX_LEN_MBUF) msgBuf
332        equivalence (     parms1 , parse1(1) )        INTEGER n, ndId
333        equivalence ( mate_index , parse1(6) )  
334    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
335  C **********************************************************************  
336  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****  C--   Check if this S/R is called from the right place ;
337  C **********************************************************************  C     needs to be after DIAGNOSTICS_INIT_EARLY and before DIAGNOSTICS_INIT_FIXED
338          IF ( .NOT.settingDiags ) THEN
339        parms1 = gdiag(num)          WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
340         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
341        IF( IDIAG(NUM).EQ.0 ) THEN          CALL PRINT_ERROR( msgBuf, myThid )
342          if(ndiagmx+kdiag(num).gt.numdiags) then          WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
343            write(6,4000)num,cdiag(num)       &     '<== called from the WRONG place, i.e.'
344          else          CALL PRINT_ERROR( msgBuf, myThid )
345            IDIAG(NUM) = IPOINTER          WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
346            IPOINTER   = IPOINTER + KDIAG(NUM)       &     'outside diagnostics setting section = from'
347            ndiagmx    = ndiagmx  + KDIAG(NUM)          CALL PRINT_ERROR( msgBuf, myThid )
348            if(myThid.eq.0) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx          WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
349          endif       &     '   Diag_INIT_EARLY down to Diag_INIT_FIXED'
350            CALL PRINT_ERROR( msgBuf, myThid )
351            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
352          ENDIF
353    
354    C--   Find this diagnostics in the list of available diag.
355          ndId = 0
356          DO n = 1,ndiagt
357            IF ( diagName.EQ.cdiag(n) ) THEN
358              ndId = n
359            ENDIF
360          ENDDO
361          IF ( ndId.EQ.0 ) THEN
362            WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SETKLEV: ',
363         &     'diagName="', diagName, '" not known.'
364            CALL PRINT_ERROR( msgBuf, myThid )
365            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
366          ENDIF
367    
368    C-    Optional level number diagnostics (X): set number of levels
369          IF ( kdiag(ndId).EQ.0
370         &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
371            kdiag(ndId) = nLevDiag
372          ELSEIF ( kdiag(ndId).EQ.nLevDiag
373         &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
374    C-    level number already set to same value: send warning
375            WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
376         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
377            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
378         &                      SQUEEZE_RIGHT , myThid )
379            WRITE(msgBuf,'(2A,I5,A)')'** WARNING ** DIAGNOSTICS_SETKLEV:',
380         &     ' level Nb (=', kdiag(ndId), ') already set.'
381            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
382         &                      SQUEEZE_RIGHT , myThid )
383          ELSEIF ( gdiag(ndId)(10:10).EQ.'X' ) THEN
384    C-    level number already set to a different value: do not reset but stop
385            WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
386         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
387            CALL PRINT_ERROR( msgBuf, myThid )
388            WRITE(msgBuf,'(2A,I5,3A)') 'DIAGNOSTICS_SETKLEV: ',
389         &     'level Nb already set to', kdiag(ndId), ' => STOP'
390            CALL PRINT_ERROR( msgBuf, myThid )
391        ELSE        ELSE
392            if(myThid.eq.0) WRITE(6,3000) NUM, CDIAG(NUM)  C-    for now, do nothing but just send a warning
393            WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
394         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
395            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
396         &                      SQUEEZE_RIGHT , myThid )
397            WRITE(msgBuf,'(2A,I5,3A)') '** WARNING ** will set level Nb',
398         &     ' from diagCode(ndId=', ndId, ')="', gdiag(ndId)(1:10), '"'
399            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
400         &                      SQUEEZE_RIGHT , myThid )
401            WRITE(msgBuf,'(4A)') '** WARNING ** DIAGNOSTICS_SETKLEV',
402         &     '("', diagName, '") <== Ignore this call.'
403            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
404         &                      SQUEEZE_RIGHT , myThid )
405        ENDIF        ENDIF
406    
407  c Check for Counter Diagnostic        RETURN
408  c ----------------------------        END
409        if( parse1(5).eq.'C') then  
410        read (mate_index,100) mate  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
411    
412        IF( IDIAG(mate).EQ.0 ) THEN  CBOP 0
413         if(ndiagmx+kdiag(num).gt.numdiags) then  C     !ROUTINE: DIAGS_GET_PARMS_I
414          write(6,5000)num,cdiag(num)  
415         else  C     !INTERFACE:
416          IDIAG(mate) = IPOINTER        INTEGER FUNCTION DIAGS_GET_PARMS_I(
417          IPOINTER    = IPOINTER + KDIAG(mate)       I                            parName, myThid )
418          ndiagmx     = ndiagmx  + KDIAG(mate)  
419          if(myThid.eq.0)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     !DESCRIPTION:
420         endif  C     *==========================================================*
421    C     | FUNCTION DIAGS_GET_PARMS_I
422    C     | o Return the value of integer parameter
423    C     |   from one of the DIAGNOSTICS.h common blocs
424    C     *==========================================================*
425    
426    C     !USES:
427          IMPLICIT NONE
428    #include "EEPARAMS.h"
429    #include "SIZE.h"
430    #include "DIAGNOSTICS_SIZE.h"
431    #include "DIAGNOSTICS.h"
432    
433    C     !INPUT PARAMETERS:
434    C     parName   :: string used to identify which parameter to get
435    C     myThid    :: my Thread Id number
436          CHARACTER*(*) parName
437          INTEGER myThid
438    CEOP
439    
440    C     !LOCAL VARIABLES:
441          CHARACTER*(MAX_LEN_MBUF) msgBuf
442          INTEGER n
443    
444    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
445    
446          n = LEN(parName)
447    c     write(0,'(3A,I4)')
448    c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
449    
450          IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
451             DIAGS_GET_PARMS_I = ndiagt
452        ELSE        ELSE
453            if(myThid.eq.0) WRITE(6,3000) mate, CDIAG(mate)           WRITE(msgBuf,'(4A)') 'DIAGS_GET_PARMS_I: ',
454         &    ' parName="', parName, '" not known.'
455             CALL PRINT_ERROR( msgBuf, myThid )
456             STOP 'ABNORMAL END: S/R DIAGS_GET_PARMS_I'
457        ENDIF        ENDIF
       endif  
458    
459        RETURN        RETURN
460          END
461    
462    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
463    
464    100 format(i3)  CBOP 0
465   2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,  C     !ROUTINE: DIAGS_MK_UNITS
466       .          ' (',A8,'),  Total Number of Diagnostics: ',I5)  
467   3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')  C     !INTERFACE:
468   4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
469       .                      ' (',A8,')')       I                            diagUnitsInPieces, myThid )
470   5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',  
471       .    I3,' (',A8,')',' WARNING - Diag will not accumulate properly')  C     !DESCRIPTION:
472    C     *==========================================================*
473    C     | FUNCTION DIAGS_MK_UNITS
474    C     | o Return the diagnostic units string (16c) removing
475    C     |   blanks from the input string
476    C     *==========================================================*
477    
478    C     !USES:
479          IMPLICIT NONE
480    #include "EEPARAMS.h"
481    
482    C     !INPUT PARAMETERS:
483    C     diagUnitsInPieces :: string for diagnostic units: in several
484    C                          pieces, with blanks in between
485    C     myThid            ::  my thread Id number
486          CHARACTER*(*) diagUnitsInPieces
487          INTEGER      myThid
488    CEOP
489    
490    C     !LOCAL VARIABLES:
491          CHARACTER*(MAX_LEN_MBUF) msgBuf
492          INTEGER i,j,n
493    
494          DIAGS_MK_UNITS = '                '
495          n = LEN(diagUnitsInPieces)
496    
497          j = 0
498          DO i=1,n
499           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
500             j = j+1
501             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
502           ENDIF
503          ENDDO
504    
505          IF ( j.GT.16 ) THEN
506             WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
507         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
508            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
509         &       SQUEEZE_RIGHT , myThid)
510             WRITE(msgBuf,'(3A)') '** WARNING ** ',
511         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
512            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
513         &       SQUEEZE_RIGHT , myThid)
514          ENDIF
515    
516          RETURN
517          END
518    
519    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
520    
521    CBOP 0
522    C     !ROUTINE: DIAGS_MK_TITLE
523    
524    C     !INTERFACE:
525          CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
526         I                            diagTitleInPieces, myThid )
527    
528    C     !DESCRIPTION:
529    C     *==========================================================*
530    C     | FUNCTION DIAGS_MK_TITLE
531    C     | o Return the diagnostic title string (80c) removing
532    C     |   consecutive blanks from the input string
533    C     *==========================================================*
534    
535    C     !USES:
536          IMPLICIT NONE
537    #include "EEPARAMS.h"
538    
539    C     !INPUT PARAMETERS:
540    C     diagTitleInPieces :: string for diagnostic units: in several
541    C                          pieces, with blanks in between
542    C     myThid            ::  my Thread Id number
543          CHARACTER*(*) diagTitleInPieces
544          INTEGER      myThid
545    CEOP
546    
547    C     !LOCAL VARIABLES:
548          CHARACTER*(MAX_LEN_MBUF) msgBuf
549          LOGICAL flag
550          INTEGER i,j,n
551    
552    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
553    
554          DIAGS_MK_TITLE = '                                        '
555         &               //'                                        '
556          n = LEN(diagTitleInPieces)
557    
558          j = 0
559          flag = .FALSE.
560          DO i=1,n
561           IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
562             IF ( flag ) THEN
563               j = j+1
564               IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
565             ENDIF
566             j = j+1
567             IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
568             flag = .FALSE.
569           ELSE
570             flag = j.GE.1
571           ENDIF
572          ENDDO
573    
574          IF ( j.GT.80 ) THEN
575             WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
576         &   'DIAGS_MK_TITLE: too long (',j,' >80) input string'
577            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
578         &       SQUEEZE_RIGHT , myThid)
579             WRITE(msgBuf,'(3A)') '** WARNING ** ',
580         &   'DIAGS_MK_TITLE: input=', diagTitleInPieces
581            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
582         &       SQUEEZE_RIGHT , myThid)
583          ENDIF
584    
585          RETURN
586        END        END
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.29
  ViewVC Help
Powered by ViewVC 1.1.22