/[MITgcm]/MITgcm/pkg/diagnostics/diagnostics_utils.F
ViewVC logotype

Diff of /MITgcm/pkg/diagnostics/diagnostics_utils.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.2 by molod, Thu Feb 26 02:21:18 2004 UTC revision 1.31 by jmc, Sun Jun 12 19:08:21 2011 UTC
# Line 1  Line 1 
1        subroutine getdiag (lev,ipoint,bi,bj,undef,qtmp)  C $Header$
2  C***********************************************************************          C $Name$
 C  PURPOSE                                                                        
 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  
3    
4  #include "CPP_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-|--+----|
17    
18    CBOP 0
19    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"  #include "SIZE.h"
34  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
35  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
36  #include "diagnostics.h"  
37    C     !INPUT PARAMETERS:
38        integer bi,bj  C***********************************************************************
39        integer lev,ipoint  C  Arguments Description
40        integer i,j,ipnt,klev  C  ----------------------
41        _RL undef, factor  C     diagName :: name of diagnostic to increment the counter
42        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)  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        do j = 1,sNy  C     myThid   :: my thread Id number
45        do i = 1,sNx  C***********************************************************************
46         qtmp(i,j,bi,bj) = undef        CHARACTER*8 diagName
47        enddo        INTEGER biArg, bjArg
48        enddo        INTEGER myThid
49    CEOP
50        IF (IPOINT.LT.1) GO TO 999  
51    C     !LOCAL VARIABLES:
52        KLEV = KDIAG(IPOINT)  C ===============
53        IF(KLEV.GE.LEV) THEN        INTEGER m, n
54        IPNT = IDIAG(IPOINT) + LEV - 1        INTEGER bi, bj
55                                  FACTOR = 1.0        INTEGER ipt, ndId
56        IF( NDIAG(IPOINT).NE.0 )  FACTOR = 1.0   / NDIAG(IPOINT)  c     CHARACTER*(MAX_LEN_MBUF) msgBuf
57        do j = 1,sNy  
58        do i = 1,sNx        IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
59        if( qdiag(i,j,ipnt,bi,bj).ne.undef )          bi = myBxLo(myThid)
60       .     qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor          bj = myByLo(myThid)
61        enddo        ELSE
62        enddo          bi = MIN(biArg,nSx)
63            bj = MIN(bjArg,nSy)
64        ENDIF        ENDIF
65    
66   999  RETURN  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        END
93    
94        subroutine getdiag2 (lev,ipoint,bi,bj,undef,qtmp)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
95  C***********************************************************************          
96  C                                                                                CBOP 0
97  C  PURPOSE                                                                        C     !ROUTINE: DIAGNOSTICS_GET_DIAG
 C     Retrieve model diagnostic (No Averaging)  
 C  INPUT:                                                                        
 C     lev ..... Model LEVEL                                                      
 C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                      
 C   undef ..... UNDEFINED VALUE                                                  
 C      im ..... X-DIMENSION  
 C      jm ..... Y-DIMENSION  
 C      nd ..... Number of 2-D Diagnostics  
 C                                                                                
 C  OUTPUT:                                                                        
 C    qtmp ..... DIAGNOSTIC QUANTITY                                              
 C                                                                                
 C***********************************************************************          
       implicit none  
98    
99  #include "CPP_OPTIONS.h"  C     !INTERFACE:
100          SUBROUTINE DIAGNOSTICS_GET_DIAG(
101         I                    kl, undefRL,
102         O                    qtmp,
103         I                    ndId, mate, ip, im, bi, bj, myThid )
104    
105    C     !DESCRIPTION:
106    C     Retrieve time-averaged (or snap-shot) diagnostic field
107    
108    C     !USES:
109          IMPLICIT NONE
110    #include "EEPARAMS.h"
111  #include "SIZE.h"  #include "SIZE.h"
112  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
113  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
114  #include "diagnostics.h"  
115    C     !INPUT PARAMETERS:
116        integer bi,bj  C     kl      :: level selection: >0 : single selected lev ; =0 : all kdiag levels
117    C     undefRL :: undefined "_RL" type value
118        integer lev,ipoint  C     ndId    :: diagnostic Id number (in available diagnostics list)
119        integer i,j,ipnt,klev  C     mate    :: counter diagnostic number if any ; 0 otherwise
120        _RL undef  C     ip      :: pointer to storage array location for diag.
121        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)  C     im      :: pointer to storage array location for mate
122    C     bi      :: X-direction tile number
123        do j = 1,sNy  C     bj      :: Y-direction tile number
124        do i = 1,sNx  C     myThid  :: my thread Id number
125         qtmp(i,j,bi,bj) = undef        INTEGER kl
126        enddo        _RL undefRL
127        enddo        INTEGER ndId, mate, ip, im
128          INTEGER bi, bj, myThid
129        IF (IPOINT.LT.1) GO TO 999  
130    C     !OUTPUT PARAMETERS:
131        KLEV = KDIAG(IPOINT)  C     qtmp    :: time-averaged (or snap-shot) diagnostic field
132        IF(KLEV.GE.LEV) THEN        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,*)
133        IPNT = IDIAG(IPOINT) + LEV - 1  CEOP
134        do j = 1,sNy  
135        do i = 1,sNx  C     !LOCAL VARIABLES:
136         qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)        _RL factor
137        enddo        INTEGER i, j, ipnt, ipCt
138        enddo        INTEGER k, kd, km, kLev
139    
140          IF (ndId.GE.1) THEN
141           kLev = kdiag(ndId)
142           IF ( kl.GE.1 .AND. kl.LE.kLev ) THEN
143            kLev = 1
144           ELSEIF ( kl.NE.0 ) THEN
145            kLev = 0
146           ENDIF
147    
148           DO k = 1,kLev
149            kd = k
150            IF ( kl.GE.1 ) kd = kl
151    
152            IF ( mate.EQ.0 ) THEN
153    C-      No counter diagnostics => average = Sum / ndiag :
154    
155              ipnt = ip + kd - 1
156              factor = FLOAT(ndiag(ip,bi,bj))
157              IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
158    
159    #ifdef ALLOW_FIZHI
160              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
195           ENDDO
196        ENDIF        ENDIF
197    
198   999  RETURN        RETURN
199        END        END
                                                                                   
       subroutine clrindx (myThid,listnum)  
 C***********************************************************************  
 C  
 C  PURPOSE  
 C     DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST  
 C  
 C  ARGUMENT DESCRIPTION  
 C     listnum ....  diagnostics list number  
 C  
 C***********************************************************************  
200    
201        implicit none  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
202    
203    CBOP 0
204    C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
205    C     !INTERFACE:
206          SUBROUTINE DIAGNOSTICS_GET_POINTERS(
207         I                       diagName, listId,
208         O                       ndId, ip,
209         I                       myThid )
210    
211    C     !DESCRIPTION:
212    C     *================================================================*
213    C     | o Returns the diagnostic Id number and diagnostic
214    C     |   pointer to storage array for a specified diagnostic.
215    C     *================================================================*
216    C     | Note: A diagnostics field can be stored multiple times
217    C     |       (for different output frequency,phase, ...).
218    C     | operates in 2 ways:
219    C     | o listId =0 => find 1 diagnostics Id & pointer which name matches.
220    C     | o listId >0 => find the unique diagnostic Id & pointer with
221    C     |      the right name and same output time as "listId" output-list
222    C     | o return ip=0 if did not find the right diagnostic;
223    C     |   (ndId <>0 if diagnostic exist but output time does not match)
224    C     *================================================================*
225    
226    C     !USES:
227          IMPLICIT NONE
228  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
229  #include "SIZE.h"  #include "SIZE.h"
230  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
231  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
232  #include "diagnostics.h"  
233    C     !INPUT PARAMETERS:
234        integer myThid, listnum  C     diagName :: diagnostic identificator name (8 characters long)
235    C     listId   :: list number that specify the output frequency
236        integer m, n  C     myThid   :: my Thread Id number
237        character*8 parms1  C     !OUTPUT PARAMETERS:
238        character*1 parse1(8)  C     ndId     :: diagnostics  Id number (in available diagnostics list)
239        character*3 mate_index  C     ip       :: diagnostics  pointer to storage array
240        integer mate  
241    
242        equivalence (     parms1 , parse1(1) )        CHARACTER*8 diagName
243        equivalence ( mate_index , parse1(6) )        INTEGER listId
244          INTEGER ndId, ip
245        do n=1,nfields(listnum)        INTEGER myThid
246         do m=1,ndiagt  CEOP
247          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  
248           call clrdiag (myThid,m)  C     !LOCAL VARIABLES:
249          INTEGER n,m
250  c Check for Counter Diagnostic  
251  c ----------------------------        ip   = 0
252           parms1 =  gdiag(m)        ndId = 0
253           if( parse1(5).eq.'C' ) then  
254            read (mate_index,100) mate        IF ( listId.LE.0 ) THEN
255            call clrdiag (myThid,mate)  C--   select the 1rst one which name matches:
256           endif  
257          endif  C-    search for this diag. in the active 2D/3D diagnostics list
258         enddo          DO n=1,nLists
259        enddo           DO m=1,nActive(n)
260                                 IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
261    100 format(i3)       &                  .AND. idiag(m,n).NE.0 ) THEN
262        RETURN                    ip   = ABS(idiag(m,n))
263        END                        ndId = jdiag(m,n)
264               ENDIF
265             ENDDO
266        subroutine clrdiag (myThid,index)          ENDDO
267  C***********************************************************************          
268  C  PURPOSE                                                                              ELSEIF ( listId.LE.nLists ) THEN
269  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS  C--   select the unique diagnostic with output-time identical to listId
270  C***********************************************************************          
271                                                                                    C-    search for this diag. in the active 2D/3D diagnostics list
272        implicit none          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
302          END
303    
304    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
305    
306    CBOP 0
307    C     !ROUTINE: DIAGNOSTICS_SETKLEV
308    
309    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"
 #include "CPP_OPTIONS.h"  
325  #include "SIZE.h"  #include "SIZE.h"
326  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
327  #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  
328    
329        ndiag(index) = 0  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    C--   Check if this S/R is called from the right place ;
347    C     needs to be after DIAGNOSTICS_INIT_EARLY and before DIAGNOSTICS_INIT_FIXED
348          IF ( .NOT.settingDiags ) THEN
349            WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
350         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
351            CALL PRINT_ERROR( msgBuf, myThid )
352            WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
353         &     '<== called from the WRONG place, i.e.'
354            CALL PRINT_ERROR( msgBuf, myThid )
355            WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
356         &     'outside diagnostics setting section = from'
357            CALL PRINT_ERROR( msgBuf, myThid )
358            WRITE(msgBuf,'(2A)') 'DIAGNOSTICS_SETKLEV: ',
359         &     '   Diag_INIT_EARLY down to Diag_INIT_FIXED'
360            CALL PRINT_ERROR( msgBuf, myThid )
361            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
362          ENDIF
363    
364        return  C--   Find this diagnostics in the list of available diag.
365        end        ndId = 0
366          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        subroutine setdiag (myThid,num,ndiagmx)  C-    Optional level number diagnostics (X): set number of levels
379  C***********************************************************************        IF ( kdiag(ndId).EQ.0
380  C       &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
381  C  PURPOSE          kdiag(ndId) = nLevDiag
382  C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM        ELSEIF ( kdiag(ndId).EQ.nLevDiag
383  C       &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
384  C***********************************************************************  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        implicit none        RETURN
420  #include "CPP_OPTIONS.h"        END
421    
422    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
423    
424    CBOP 0
425    C     !ROUTINE: DIAGS_GET_PARMS_I
426    
427    C     !INTERFACE:
428          INTEGER FUNCTION DIAGS_GET_PARMS_I(
429         I                            parName, myThid )
430    
431    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    C     !USES:
439          IMPLICIT NONE
440    #include "EEPARAMS.h"
441  #include "SIZE.h"  #include "SIZE.h"
442  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
443  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
444  #include "diagnostics.h"  
445    C     !INPUT PARAMETERS:
446        integer num,myThid,ndiagmx  C     parName   :: string used to identify which parameter to get
447        integer ipointer  C     myThid    :: my Thread Id number
448          CHARACTER*(*) parName
449        DATA IPOINTER / 1 /        INTEGER myThid
450    CEOP
451        character*8 parms1  
452        character*1 parse1(8)  C     !LOCAL VARIABLES:
453        character*3 mate_index        CHARACTER*(MAX_LEN_MBUF) msgBuf
454        integer     mate        INTEGER n
455    
456        equivalence (     parms1 , parse1(1) )  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
457        equivalence ( mate_index , parse1(6) )  
458          n = LEN(parName)
459  C **********************************************************************  c     write(0,'(3A,I4)')
460  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****  c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
461  C **********************************************************************  
462          IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
463        parms1 = gdiag(num)           DIAGS_GET_PARMS_I = ndiagt
   
       IF( IDIAG(NUM).EQ.0 ) THEN  
         if(ndiagmx+kdiag(num).gt.numdiags) then  
           write(6,4000)num,cdiag(num)  
         else  
           IDIAG(NUM) = IPOINTER  
           IPOINTER   = IPOINTER + KDIAG(NUM)  
           ndiagmx    = ndiagmx  + KDIAG(NUM)  
           if(myThid.eq.0) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx  
         endif  
464        ELSE        ELSE
465            if(myThid.eq.0) WRITE(6,3000) NUM, CDIAG(NUM)           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        ENDIF
470    
471  c Check for Counter Diagnostic        RETURN
472  c ----------------------------        END
473        if( parse1(5).eq.'C') then  
474        read (mate_index,100) mate  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
475    
476        IF( IDIAG(mate).EQ.0 ) THEN  CBOP 0
477         if(ndiagmx+kdiag(num).gt.numdiags) then  C     !ROUTINE: DIAGS_MK_UNITS
478          write(6,5000)num,cdiag(num)  
479         else  C     !INTERFACE:
480          IDIAG(mate) = IPOINTER        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
481          IPOINTER    = IPOINTER + KDIAG(mate)       I                            diagUnitsInPieces, myThid )
482          ndiagmx     = ndiagmx  + KDIAG(mate)  
483          if(myThid.eq.0)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     !DESCRIPTION:
484         endif  C     *==========================================================*
485        ELSE  C     | FUNCTION DIAGS_MK_UNITS
486            if(myThid.eq.0) WRITE(6,3000) mate, CDIAG(mate)  C     | o Return the diagnostic units string (16c) removing
487    C     |   blanks from the input string
488    C     *==========================================================*
489    
490    C     !USES:
491          IMPLICIT NONE
492    #include "EEPARAMS.h"
493    
494    C     !INPUT PARAMETERS:
495    C     diagUnitsInPieces :: string for diagnostic units: in several
496    C                          pieces, with blanks in between
497    C     myThid            ::  my thread Id number
498          CHARACTER*(*) diagUnitsInPieces
499          INTEGER      myThid
500    CEOP
501    
502    C     !LOCAL VARIABLES:
503          CHARACTER*(MAX_LEN_MBUF) msgBuf
504          INTEGER i,j,n
505    
506          DIAGS_MK_UNITS = '                '
507          n = LEN(diagUnitsInPieces)
508    
509          j = 0
510          DO i=1,n
511           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
512             j = j+1
513             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
514           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        ENDIF
       endif  
527    
528        RETURN        RETURN
529          END
530    
531    100 format(i3)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
532   2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,  
533       .          ' (',A8,'),  Total Number of Diagnostics: ',I5)  CBOP 0
534   3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')  C     !ROUTINE: DIAGS_MK_TITLE
535   4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,  
536       .                      ' (',A8,')')  C     !INTERFACE:
537   5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',        CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
538       .    I3,' (',A8,')',' WARNING - Diag will not accumulate properly')       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
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
598        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.31
  ViewVC Help
Powered by ViewVC 1.1.22