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