/[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.20 by jmc, Thu May 19 01:18:31 2005 UTC revision 1.30 by jmc, Fri Jan 15 18:57:07 2010 UTC
# Line 3  C $Name$ Line 3  C $Name$
3    
4  #include "DIAG_OPTIONS.h"  #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-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
17  CBOP 0  CBOP 0
18  C     !ROUTINE: GETDIAG  C     !ROUTINE: GETDIAG
# Line 11  C     !INTERFACE: Line 21  C     !INTERFACE:
21        SUBROUTINE GETDIAG(        SUBROUTINE GETDIAG(
22       I                    levreal, undef,       I                    levreal, undef,
23       O                    qtmp,       O                    qtmp,
24       I                    ipoint, mate, bi, bj, myThid )       I                    ndId, mate, ip, im, bi, bj, myThid )
25    
26  C     !DESCRIPTION:  C     !DESCRIPTION:
27  C     Retrieve averaged model diagnostic  C     Retrieve averaged model diagnostic
# Line 24  C     !USES: Line 34  C     !USES:
34  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
35    
36  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
37  C     levreal .... Diagnostic LEVEL  C     levreal :: Diagnostic LEVEL
38  C     undef  ..... UNDEFINED VALUE  C     undef   :: UNDEFINED VALUE
39  C     ipoint ..... DIAGNOSTIC NUMBER FROM MENU  C     ndId    :: DIAGNOSTIC NUMBER FROM MENU
40  C     mate   ..... counter DIAGNOSTIC NUMBER if any ; 0 otherwise  C     mate    :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise
41  C     bi     ..... X-direction tile number  C     ip      :: pointer to storage array location for diag.
42  C     bj     ..... Y-direction tile number  C     im      :: pointer to storage array location for mate
43  C     myThid ..... my thread Id number  C     bi      :: X-direction tile number
44    C     bj      :: Y-direction tile number
45    C     myThid  :: my thread Id number
46        _RL levreal        _RL levreal
47        _RL undef        _RL undef
48        INTEGER ipoint, mate        INTEGER ndId, mate, ip, im
49        INTEGER bi,bj, myThid        INTEGER bi,bj, myThid
50    
51  C     !OUTPUT PARAMETERS:  C     !OUTPUT PARAMETERS:
# Line 46  C     !LOCAL VARIABLES: Line 58  C     !LOCAL VARIABLES:
58        INTEGER i, j, ipnt,ipCt        INTEGER i, j, ipnt,ipCt
59        INTEGER lev, levCt, klev        INTEGER lev, levCt, klev
60    
61        IF (ipoint.GE.1) THEN        IF (ndId.GE.1) THEN
62         lev = NINT(levreal)         lev = NINT(levreal)
63         klev = kdiag(ipoint)         klev = kdiag(ndId)
64         IF (lev.LE.klev) THEN         IF (lev.LE.klev) THEN
65    
66          IF ( mate.EQ.0 ) THEN          IF ( mate.EQ.0 ) THEN
67  C-      No counter diagnostics => average = Sum / ndiag :  C-      No counter diagnostics => average = Sum / ndiag :
68    
69            ipnt = idiag(ipoint) + lev - 1            ipnt = ip + lev - 1
70  c         factor = 1.0            factor = FLOAT(ndiag(ip,bi,bj))
71  c         if (ndiag(ipoint).ne.0) factor = 1.0/ndiag(ipoint)            IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
           factor = FLOAT(ndiag(ipoint))  
           IF (ndiag(ipoint).NE.0) factor = 1. _d 0 / factor  
72    
73    #ifdef ALLOW_FIZHI
74            DO j = 1,sNy+1            DO j = 1,sNy+1
75              DO i = 1,sNx+1              DO i = 1,sNx+1
76                IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN                IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
# Line 69  c         if (ndiag(ipoint).ne.0) factor Line 80  c         if (ndiag(ipoint).ne.0) factor
80                ENDIF                ENDIF
81              ENDDO              ENDDO
82            ENDDO            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          ELSE
92  C-      With counter diagnostics => average = Sum / counter:  C-      With counter diagnostics => average = Sum / counter:
93    
94            ipnt = idiag(ipoint) + lev - 1            ipnt = ip + lev - 1
95            levCt= MIN(lev,kdiag(mate))            levCt= MIN(lev,kdiag(mate))
96            ipCt = idiag(mate) + levCt - 1            ipCt = im + levCt - 1
97            DO j = 1,sNy+1            DO j = 1,sNy+1
98              DO i = 1,sNx+1              DO i = 1,sNx+1
99                IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN                IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
# Line 96  C-      With counter diagnostics => aver Line 114  C-      With counter diagnostics => aver
114    
115  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
116    
117        subroutine clrindx (listnum, myThid)  CBOP 0
118    C     !ROUTINE: DIAGNOSTICS_COUNT
119    C     !INTERFACE:
120          SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
121         I                              biArg, bjArg, myThid)
122    
123    C     !DESCRIPTION:
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"
132  #include "SIZE.h"  #include "SIZE.h"
133  #include "DIAGNOSTICS_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
134  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
135    
136        integer myThid, listnum  C     !INPUT PARAMETERS:
137    C***********************************************************************
138    C  Arguments Description
139    C  ----------------------
140    C     chardiag :: Character expression for diag to increment the counter
141    C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
142    C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
143    C     myThid   :: my thread Id number
144    C***********************************************************************
145          CHARACTER*8 chardiag
146          INTEGER biArg, bjArg
147          INTEGER myThid
148    CEOP
149    
150    C     !LOCAL VARIABLES:
151    C ===============
152          INTEGER m, n
153          INTEGER bi, bj
154          INTEGER ipt, ndId
155    c     CHARACTER*(MAX_LEN_MBUF) msgBuf
156    
157        integer m, n        IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
158        character*8 parms1          bi = myBxLo(myThid)
159        character*3 mate_index          bj = myByLo(myThid)
160        integer mate        ELSE
161            bi = MIN(biArg,nSx)
162        do n=1,nfields(listnum)          bj = MIN(bjArg,nSy)
163         do m=1,ndiagt        ENDIF
164          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  
165           call clrdiag (m, myThid)  C--   Run through list of active diagnostics to find which counter
166    C     to increment (needs to be a valid & active diagnostic-counter)
167  c Check for Counter Diagnostic        DO n=1,nlists
168  c ----------------------------         DO m=1,nActive(n)
169           parms1 =  gdiag(m)(1:8)          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
170           if ( parms1(5:5).eq.'C' ) then           ipt = idiag(m,n)
171            mate_index = parms1(6:8)           IF (ndiag(ipt,bi,bj).GE.0) THEN
172            read (mate_index,'(I3)') mate            ndId = jdiag(m,n)
173            call clrdiag (mate, myThid)            ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
174           endif  C-    Increment the counter for the diagnostic
175          endif            IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
176         enddo             DO bj=myByLo(myThid), myByHi(myThid)
177        enddo              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        RETURN
191        END        END
192    
193    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
194    
195        subroutine clrdiag (index, myThid)  CBOP 0
196  C***********************************************************************  C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
197  C  PURPOSE  C     !INTERFACE:
198  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS        SUBROUTINE DIAGNOSTICS_GET_POINTERS(
199  C***********************************************************************       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        implicit none  C     !USES:
219          IMPLICIT NONE
220  #include "EEPARAMS.h"  #include "EEPARAMS.h"
221  #include "SIZE.h"  #include "SIZE.h"
222  #include "DIAGNOSTICS_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
223  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
224    
225        integer myThid, index  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    
       integer bi,bj  
       integer i,j,k  
233    
234  C **********************************************************************        CHARACTER*8 diagName
235  C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****        INTEGER listId
236  C **********************************************************************        INTEGER ndId, ip
237          INTEGER myThid
238        do bj=myByLo(myThid), myByHi(myThid)  CEOP
        do bi=myBxLo(myThid), myBxHi(myThid)  
         do k = 1,kdiag(index)  
          do j = 1-OLy,sNy+OLy  
           do i = 1-OLx,sNx+OLx  
            qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0  
           enddo  
          enddo  
         enddo  
        enddo  
       enddo  
239    
240        ndiag(index) = 0  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          ELSE
290            STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
291          ENDIF
292    
293        RETURN        RETURN
294        END        END
# Line 182  C ************************************** Line 296  C **************************************
296  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
297    
298  CBOP 0  CBOP 0
299  C     !ROUTINE: DIAGNOSTICS_COUNT  C     !ROUTINE: DIAGNOSTICS_SETKLEV
300    
301  C     !INTERFACE:  C     !INTERFACE:
302        SUBROUTINE DIAGNOSTICS_COUNT (chardiag,        SUBROUTINE DIAGNOSTICS_SETKLEV(
303       I                              biArg, bjArg, myThid)       I                                diagName, nLevDiag, myThid )
304    
305  C     !DESCRIPTION:  C     !DESCRIPTION:
306  C***********************************************************************  C     *==========================================================*
307  C   routine to increment the diagnostic counter only  C     | S/R DIAGNOSTICS_SETKLEV
308  C***********************************************************************  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  C     !USES:  C     !USES:
315        IMPLICIT NONE        IMPLICIT NONE
   
 C     == Global variables ===  
316  #include "EEPARAMS.h"  #include "EEPARAMS.h"
317  #include "SIZE.h"  #include "SIZE.h"
318  #include "DIAGNOSTICS_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
319  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
320    
321  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
322  C***********************************************************************  C     diagName  :: diagnostic identificator name (8 characters long)
323  C  Arguments Description  C     nLevDiag  :: number of level to set for this diagnostics field
324  C  ----------------------  C     myThid    :: my Thread Id number
325  C     chardiag :: Character expression for diag to increment the counter        CHARACTER*8  diagName
326  C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops        INTEGER nLevDiag
 C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops  
 C     myThid   :: my thread Id number  
 C***********************************************************************  
       CHARACTER*8 chardiag  
       INTEGER biArg, bjArg  
327        INTEGER myThid        INTEGER myThid
328  CEOP  CEOP
329    
330  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
331  C ===============        CHARACTER*(MAX_LEN_MBUF) msgBuf
332        INTEGER m, n        INTEGER n, ndId
       INTEGER ndiagnum, ipointer  
 c     INTEGER bi, bj  
 c     CHARACTER*(MAX_LEN_MBUF) msgBuf  
333    
334  C Run through list of active diagnostics to make sure  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
 C we are trying to increment a valid diagnostic-counter  
335    
336        ndiagnum = 0        _BEGIN_MASTER( myThid)
337        ipointer = 0  
338        DO n=1,nlists  C--   Check if this S/R is called from the right place ;
339         DO m=1,nActive(n)  C     needs to be after DIAGNOSTICS_INIT_EARLY and before DIAGNOSTICS_INIT_FIXED
340          IF ( chardiag.EQ.flds(m,n) ) THEN        IF ( .NOT.settingDiags ) THEN
341           ndiagnum = jdiag(m,n)          WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
342           IF (ndiag(ndiagnum).GE.0) ipointer = idiag(ndiagnum)       &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
343            CALL PRINT_ERROR( msgBuf, myThid )
344            WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
345         &     '<== called from the WRONG place, i.e.'
346            CALL PRINT_ERROR( msgBuf, myThid )
347            WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
348         &     'outside diagnostics setting section = from'
349            CALL PRINT_ERROR( msgBuf, myThid )
350            WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
351         &     '   Diag_INIT_EARLY down to Diag_INIT_FIXED'
352            CALL PRINT_ERROR( msgBuf, myThid )
353            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
354          ENDIF
355    
356    C--   Find this diagnostics in the list of available diag.
357          ndId = 0
358          DO n = 1,ndiagt
359            IF ( diagName.EQ.cdiag(n) ) THEN
360              ndId = n
361          ENDIF          ENDIF
        ENDDO  
362        ENDDO        ENDDO
363          IF ( ndId.EQ.0 ) THEN
364            WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SETKLEV: ',
365         &     'diagName="', diagName, '" not known.'
366            CALL PRINT_ERROR( msgBuf, myThid )
367            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
368          ENDIF
369    
370  C If-sequence to see if we are a valid and an active diagnostic  C-    Optional level number diagnostics (X): set number of levels
371          IF ( kdiag(ndId).EQ.0
372         &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
373            kdiag(ndId) = nLevDiag
374          ELSEIF ( kdiag(ndId).EQ.nLevDiag
375         &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
376    C-    level number already set to same value: send warning
377            WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
378         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
379            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
380         &                      SQUEEZE_RIGHT , myThid )
381            WRITE(msgBuf,'(2A,I5,A)')'** WARNING ** DIAGNOSTICS_SETKLEV:',
382         &     ' level Nb (=', kdiag(ndId), ') already set.'
383            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
384         &                      SQUEEZE_RIGHT , myThid )
385          ELSEIF ( gdiag(ndId)(10:10).EQ.'X' ) THEN
386    C-    level number already set to a different value: do not reset but stop
387            WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
388         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
389            CALL PRINT_ERROR( msgBuf, myThid )
390            WRITE(msgBuf,'(2A,I5,3A)') 'DIAGNOSTICS_SETKLEV: ',
391         &     'level Nb already set to', kdiag(ndId), ' => STOP'
392            CALL PRINT_ERROR( msgBuf, myThid )
393          ELSE
394    C-    for now, do nothing but just send a warning
395            WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
396         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
397            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
398         &                      SQUEEZE_RIGHT , myThid )
399            WRITE(msgBuf,'(2A,I5,3A)') '** WARNING ** will set level Nb',
400         &     ' from diagCode(ndId=', ndId, ')="', gdiag(ndId)(1:10), '"'
401            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
402         &                      SQUEEZE_RIGHT , myThid )
403            WRITE(msgBuf,'(4A)') '** WARNING ** DIAGNOSTICS_SETKLEV',
404         &     '("', diagName, '") <== Ignore this call.'
405            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
406         &                      SQUEEZE_RIGHT , myThid )
407          ENDIF
408    
409        IF ( ndiagnum.NE.0 .AND. ipointer.NE.0 ) THEN        _END_MASTER( myThid)
410    
411  C Increment the counter for the diagnostic (if we are at bi=bj=myThid=1)        RETURN
412         _BEGIN_MASTER(myThid)        END
         IF ( (biArg.EQ.1 .AND. bjArg.EQ.1) .OR.  
      &       (biArg.EQ.0 .AND. bjArg.EQ.0) )  
      &                     ndiag(ndiagnum) = ndiag(ndiagnum) + 1  
        _END_MASTER(myThid)  
413    
414  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
415    
416  C-- note: counter could become a tiled array, and then it would be:  CBOP 0
417  c       IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN  C     !ROUTINE: DIAGS_GET_PARMS_I
418  c        DO bj=myByLo(myThid), myByHi(myThid)  
419  c         DO bi=myBxLo(myThid), myBxHi(myThid)  C     !INTERFACE:
420  c          ndiag(ndiagnum,bi,bj) = ndiag(ndiagnum,bi,bj) + 1        INTEGER FUNCTION DIAGS_GET_PARMS_I(
421  c         ENDDO       I                            parName, myThid )
 c        ENDDO  
 c       ELSE  
 c          bi = MIN(biArg,nSx)  
 c          bj = MIN(bjArg,nSy)  
 c          ndiag(ndiagnum,bi,bj) = ndiag(ndiagnum,bi,bj) + 1  
 c       ENDIF  
422    
423    C     !DESCRIPTION:
424    C     *==========================================================*
425    C     | FUNCTION DIAGS_GET_PARMS_I
426    C     | o Return the value of integer parameter
427    C     |   from one of the DIAGNOSTICS.h common blocs
428    C     *==========================================================*
429    
430    C     !USES:
431          IMPLICIT NONE
432    #include "EEPARAMS.h"
433    #include "SIZE.h"
434    #include "DIAGNOSTICS_SIZE.h"
435    #include "DIAGNOSTICS.h"
436    
437    C     !INPUT PARAMETERS:
438    C     parName   :: string used to identify which parameter to get
439    C     myThid    :: my Thread Id number
440          CHARACTER*(*) parName
441          INTEGER myThid
442    CEOP
443    
444    C     !LOCAL VARIABLES:
445          CHARACTER*(MAX_LEN_MBUF) msgBuf
446          INTEGER n
447    
448    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
449    
450          n = LEN(parName)
451    c     write(0,'(3A,I4)')
452    c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
453    
454          IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
455             DIAGS_GET_PARMS_I = ndiagt
456          ELSE
457             WRITE(msgBuf,'(4A)') 'DIAGS_GET_PARMS_I: ',
458         &    ' parName="', parName, '" not known.'
459             CALL PRINT_ERROR( msgBuf, myThid )
460             STOP 'ABNORMAL END: S/R DIAGS_GET_PARMS_I'
461        ENDIF        ENDIF
462    
463        RETURN        RETURN
464        END        END
465    
466  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
# Line 272  CBOP 0 Line 469  CBOP 0
469  C     !ROUTINE: DIAGS_MK_UNITS  C     !ROUTINE: DIAGS_MK_UNITS
470    
471  C     !INTERFACE:  C     !INTERFACE:
472        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
473       I                            diagUnitsInPieces, myThid )       I                            diagUnitsInPieces, myThid )
474    
475  C     !DESCRIPTION:  C     !DESCRIPTION:
476  C     *==========================================================*  C     *==========================================================*
477  C     | FUNCTION DIAGS_MK_UNITS  C     | FUNCTION DIAGS_MK_UNITS
478  C     | o Return the diagnostic units string (16c) removing  C     | o Return the diagnostic units string (16c) removing
479  C     |   blanks from the input string  C     |   blanks from the input string
480  C     *==========================================================*  C     *==========================================================*
481    
# Line 287  C     !USES: Line 484  C     !USES:
484  #include "EEPARAMS.h"  #include "EEPARAMS.h"
485    
486  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
487  C     diagUnitsInPieces :: string for diagnostic units: in several  C     diagUnitsInPieces :: string for diagnostic units: in several
488  C                          pieces, with blanks in between  C                          pieces, with blanks in between
489  C     myThid            ::  my thread Id number  C     myThid            ::  my thread Id number
490        CHARACTER*(*) diagUnitsInPieces        CHARACTER*(*) diagUnitsInPieces
# Line 298  C     !LOCAL VARIABLES: Line 495  C     !LOCAL VARIABLES:
495        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
496        INTEGER i,j,n        INTEGER i,j,n
497    
498        DIAGS_MK_UNITS = '          '        DIAGS_MK_UNITS = '                '
499        n = LEN(diagUnitsInPieces)        n = LEN(diagUnitsInPieces)
500          
501        j = 0        j = 0
502        DO i=1,n        DO i=1,n
503         IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN         IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
# Line 310  C     !LOCAL VARIABLES: Line 507  C     !LOCAL VARIABLES:
507        ENDDO        ENDDO
508    
509        IF ( j.GT.16 ) THEN        IF ( j.GT.16 ) THEN
510           WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',           WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
511       &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'       &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
512          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
513       &       SQUEEZE_RIGHT , myThid)       &       SQUEEZE_RIGHT , myThid)
514           WRITE(msgBuf,'(3A)') '**WARNING** ',           WRITE(msgBuf,'(3A)') '** WARNING ** ',
515       &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces       &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
516          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
517       &       SQUEEZE_RIGHT , myThid)       &       SQUEEZE_RIGHT , myThid)
518        ENDIF        ENDIF
519    
520          RETURN
521          END
522    
523    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
524    
525    CBOP 0
526    C     !ROUTINE: DIAGS_MK_TITLE
527    
528    C     !INTERFACE:
529          CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
530         I                            diagTitleInPieces, myThid )
531    
532    C     !DESCRIPTION:
533    C     *==========================================================*
534    C     | FUNCTION DIAGS_MK_TITLE
535    C     | o Return the diagnostic title string (80c) removing
536    C     |   consecutive blanks from the input string
537    C     *==========================================================*
538    
539    C     !USES:
540          IMPLICIT NONE
541    #include "EEPARAMS.h"
542    
543    C     !INPUT PARAMETERS:
544    C     diagTitleInPieces :: string for diagnostic units: in several
545    C                          pieces, with blanks in between
546    C     myThid            ::  my Thread Id number
547          CHARACTER*(*) diagTitleInPieces
548          INTEGER      myThid
549    CEOP
550    
551    C     !LOCAL VARIABLES:
552          CHARACTER*(MAX_LEN_MBUF) msgBuf
553          LOGICAL flag
554          INTEGER i,j,n
555    
556    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
557    
558          DIAGS_MK_TITLE = '                                        '
559         &               //'                                        '
560          n = LEN(diagTitleInPieces)
561    
562          j = 0
563          flag = .FALSE.
564          DO i=1,n
565           IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
566             IF ( flag ) THEN
567               j = j+1
568               IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
569             ENDIF
570             j = j+1
571             IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
572             flag = .FALSE.
573           ELSE
574             flag = j.GE.1
575           ENDIF
576          ENDDO
577    
578          IF ( j.GT.80 ) THEN
579             WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
580         &   'DIAGS_MK_TITLE: too long (',j,' >80) input string'
581            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
582         &       SQUEEZE_RIGHT , myThid)
583             WRITE(msgBuf,'(3A)') '** WARNING ** ',
584         &   'DIAGS_MK_TITLE: input=', diagTitleInPieces
585            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
586         &       SQUEEZE_RIGHT , myThid)
587          ENDIF
588    
589        RETURN        RETURN
590        END        END
Legend:
Removed from v.1.20  
changed lines
  Added in v.1.30
  ViewVC Help
Powered by ViewVC 1.1.22