/[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.32 by jmc, Wed Aug 14 00:54:06 2013 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          CHARACTER*8 diagName
242        equivalence (     parms1 , parse1(1) )        INTEGER listId
243        equivalence ( mate_index , parse1(6) )        INTEGER ndId, ip
244          INTEGER myThid
245        do n=1,nfields(listnum)  CEOP
246         do m=1,ndiagt  
247          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  C     !LOCAL VARIABLES:
248           call clrdiag (myThid,m)        INTEGER n,m
249    
250  c Check for Counter Diagnostic        ip   = 0
251  c ----------------------------        ndId = 0
252           parms1 =  gdiag(m)  
253           if( parse1(5).eq.'C' ) then        IF ( listId.LE.0 ) THEN
254            read (mate_index,100) mate  C--   select the 1rst one which name matches:
255            call clrdiag (myThid,mate)  
256           endif  C-    search for this diag. in the active 2D/3D diagnostics list
257          endif          DO n=1,nLists
258         enddo           DO m=1,nActive(n)
259        enddo             IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
260                           &                  .AND. idiag(m,n).NE.0 ) THEN
261    100 format(i3)              ip   = ABS(idiag(m,n))
262        RETURN                    ndId = jdiag(m,n)
263        END                       ENDIF
264             ENDDO
265            ENDDO
266        subroutine clrdiag (myThid,index)  
267  C***********************************************************************                ELSEIF ( listId.LE.nLists ) THEN
268  C  PURPOSE                                                                        C--   select the unique diagnostic with output-time identical to listId
269  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS  
270  C***********************************************************************          C-    search for this diag. in the active 2D/3D diagnostics list
271                                                                                            DO n=1,nLists
272        implicit none           IF ( ip.EQ.0
273         &        .AND. freq(n) .EQ. freq(listId)
274         &        .AND. phase(n).EQ.phase(listId)
275         &        .AND. averageFreq(n) .EQ.averageFreq(listId)
276         &        .AND. averagePhase(n).EQ.averagePhase(listId)
277         &        .AND. averageCycle(n).EQ.averageCycle(listId)
278         &      ) THEN
279              DO m=1,nActive(n)
280               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
281         &                  .AND. idiag(m,n).NE.0 ) THEN
282                ip   = ABS(idiag(m,n))
283                ndId = jdiag(m,n)
284               ENDIF
285              ENDDO
286             ELSEIF ( ip.EQ.0 ) THEN
287              DO m=1,nActive(n)
288               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
289         &                  .AND. idiag(m,n).NE.0 ) THEN
290                ndId = jdiag(m,n)
291               ENDIF
292              ENDDO
293             ENDIF
294            ENDDO
295    
296          ELSE
297            STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
298          ENDIF
299    
300          RETURN
301          END
302    
303    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
304    
305    CBOP 0
306    C     !ROUTINE: DIAGNOSTICS_SETKLEV
307    
308    C     !INTERFACE:
309          SUBROUTINE DIAGNOSTICS_SETKLEV(
310         I                                diagName, nLevDiag, myThid )
311    
312    C     !DESCRIPTION:
313    C     *==========================================================*
314    C     | S/R DIAGNOSTICS_SETKLEV
315    C     | o Define explicitly the number of level (stored in kdiag)
316    C     |   of a diagnostic field. For most diagnostics, the number
317    C     |   of levels is derived (in S/R SET_LEVELS) from gdiag(10)
318    C     |   but occasionally one may want to set it explicitly.
319    C     *==========================================================*
320    
321    C     !USES:
322          IMPLICIT NONE
323  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
324  #include "SIZE.h"  #include "SIZE.h"
325  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
326  #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  
327    
328        ndiag(index) = 0  C     !INPUT PARAMETERS:
329    C     diagName  :: diagnostic identificator name (8 characters long)
330    C     nLevDiag  :: number of level to set for this diagnostics field
331    C     myThid    :: my Thread Id number
332          CHARACTER*8  diagName
333          INTEGER nLevDiag
334          INTEGER myThid
335    CEOP
336    
337    C     !LOCAL VARIABLES:
338          CHARACTER*(MAX_LEN_MBUF) msgBuf
339          INTEGER n, ndId
340    
341    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
342    
343          _BEGIN_MASTER( myThid)
344    
345    C--   Check if this S/R is called from the right place ;
346    C     needs to be after DIAGNOSTICS_INIT_EARLY and before DIAGNOSTICS_INIT_FIXED
347          IF ( diag_pkgStatus.NE.ready2setDiags ) THEN
348            CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_SETKLEV',
349         &                   ' ', diagName, ready2setDiags, myThid )
350          ENDIF
351    
352        return  C--   Find this diagnostics in the list of available diag.
353        end        ndId = 0
354          DO n = 1,ndiagt
355            IF ( diagName.EQ.cdiag(n) ) THEN
356              ndId = n
357            ENDIF
358          ENDDO
359          IF ( ndId.EQ.0 ) THEN
360            WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SETKLEV: ',
361         &     'diagName="', diagName, '" not known.'
362            CALL PRINT_ERROR( msgBuf, myThid )
363            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
364          ENDIF
365    
366        subroutine setdiag (myThid,num,ndiagmx)  C-    Optional level number diagnostics (X): set number of levels
367  C***********************************************************************        IF ( kdiag(ndId).EQ.0
368  C       &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
369  C  PURPOSE          kdiag(ndId) = nLevDiag
370  C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM        ELSEIF ( kdiag(ndId).EQ.nLevDiag
371  C       &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
372  C***********************************************************************  C-    level number already set to same value: send warning
373            WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
374         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
375            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
376         &                      SQUEEZE_RIGHT , myThid )
377            WRITE(msgBuf,'(2A,I5,A)')'** WARNING ** DIAGNOSTICS_SETKLEV:',
378         &     ' level Nb (=', kdiag(ndId), ') already set.'
379            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
380         &                      SQUEEZE_RIGHT , myThid )
381          ELSEIF ( gdiag(ndId)(10:10).EQ.'X' ) THEN
382    C-    level number already set to a different value: do not reset but stop
383            WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
384         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
385            CALL PRINT_ERROR( msgBuf, myThid )
386            WRITE(msgBuf,'(2A,I5,3A)') 'DIAGNOSTICS_SETKLEV: ',
387         &     'level Nb already set to', kdiag(ndId), ' => STOP'
388            CALL PRINT_ERROR( msgBuf, myThid )
389          ELSE
390    C-    for now, do nothing but just send a warning
391            WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
392         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
393            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
394         &                      SQUEEZE_RIGHT , myThid )
395            WRITE(msgBuf,'(2A,I5,3A)') '** WARNING ** will set level Nb',
396         &     ' from diagCode(ndId=', ndId, ')="', gdiag(ndId)(1:10), '"'
397            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
398         &                      SQUEEZE_RIGHT , myThid )
399            WRITE(msgBuf,'(4A)') '** WARNING ** DIAGNOSTICS_SETKLEV',
400         &     '("', diagName, '") <== Ignore this call.'
401            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
402         &                      SQUEEZE_RIGHT , myThid )
403          ENDIF
404    
405          _END_MASTER( myThid)
406    
407        implicit none        RETURN
408  #include "CPP_OPTIONS.h"        END
409    
410    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
411    
412    CBOP 0
413    C     !ROUTINE: DIAGS_GET_PARMS_I
414    
415    C     !INTERFACE:
416          INTEGER FUNCTION DIAGS_GET_PARMS_I(
417         I                            parName, myThid )
418    
419    C     !DESCRIPTION:
420    C     *==========================================================*
421    C     | FUNCTION DIAGS_GET_PARMS_I
422    C     | o Return the value of integer parameter
423    C     |   from one of the DIAGNOSTICS.h common blocs
424    C     *==========================================================*
425    
426    C     !USES:
427          IMPLICIT NONE
428    #include "EEPARAMS.h"
429  #include "SIZE.h"  #include "SIZE.h"
430  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
431  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
432  #include "diagnostics.h"  
433    C     !INPUT PARAMETERS:
434        integer num,myThid,ndiagmx  C     parName   :: string used to identify which parameter to get
435        integer ipointer  C     myThid    :: my Thread Id number
436          CHARACTER*(*) parName
437        DATA IPOINTER / 1 /        INTEGER myThid
438    CEOP
439        character*8 parms1  
440        character*1 parse1(8)  C     !LOCAL VARIABLES:
441        character*3 mate_index        CHARACTER*(MAX_LEN_MBUF) msgBuf
442        integer     mate        INTEGER n
443    
444        equivalence (     parms1 , parse1(1) )  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
445        equivalence ( mate_index , parse1(6) )  
446          n = LEN(parName)
447  C **********************************************************************  c     write(0,'(3A,I4)')
448  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****  c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
449  C **********************************************************************  
450          IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
451        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  
452        ELSE        ELSE
453            if(myThid.eq.0) WRITE(6,3000) NUM, CDIAG(NUM)           WRITE(msgBuf,'(4A)') 'DIAGS_GET_PARMS_I: ',
454         &    ' parName="', parName, '" not known.'
455             CALL PRINT_ERROR( msgBuf, myThid )
456             STOP 'ABNORMAL END: S/R DIAGS_GET_PARMS_I'
457        ENDIF        ENDIF
458    
459  c Check for Counter Diagnostic        RETURN
460  c ----------------------------        END
461        if( parse1(5).eq.'C') then  
462        read (mate_index,100) mate  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
463    
464        IF( IDIAG(mate).EQ.0 ) THEN  CBOP 0
465         if(ndiagmx+kdiag(num).gt.numdiags) then  C     !ROUTINE: DIAGS_MK_UNITS
466          write(6,5000)num,cdiag(num)  
467         else  C     !INTERFACE:
468          IDIAG(mate) = IPOINTER        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
469          IPOINTER    = IPOINTER + KDIAG(mate)       I                            diagUnitsInPieces, myThid )
470          ndiagmx     = ndiagmx  + KDIAG(mate)  
471          if(myThid.eq.0)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     !DESCRIPTION:
472         endif  C     *==========================================================*
473        ELSE  C     | FUNCTION DIAGS_MK_UNITS
474            if(myThid.eq.0) WRITE(6,3000) mate, CDIAG(mate)  C     | o Return the diagnostic units string (16c) removing
475    C     |   blanks from the input string
476    C     *==========================================================*
477    
478    C     !USES:
479          IMPLICIT NONE
480    #include "EEPARAMS.h"
481    
482    C     !INPUT PARAMETERS:
483    C     diagUnitsInPieces :: string for diagnostic units: in several
484    C                          pieces, with blanks in between
485    C     myThid            ::  my thread Id number
486          CHARACTER*(*) diagUnitsInPieces
487          INTEGER      myThid
488    CEOP
489    
490    C     !LOCAL VARIABLES:
491          CHARACTER*(MAX_LEN_MBUF) msgBuf
492          INTEGER i,j,n
493    
494          DIAGS_MK_UNITS = '                '
495          n = LEN(diagUnitsInPieces)
496    
497          j = 0
498          DO i=1,n
499           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
500             j = j+1
501             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
502           ENDIF
503          ENDDO
504    
505          IF ( j.GT.16 ) THEN
506             WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
507         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
508            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
509         &       SQUEEZE_RIGHT , myThid)
510             WRITE(msgBuf,'(3A)') '** WARNING ** ',
511         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
512            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
513         &       SQUEEZE_RIGHT , myThid)
514        ENDIF        ENDIF
       endif  
515    
516        RETURN        RETURN
517          END
518    
519    100 format(i3)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
520   2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,  
521       .          ' (',A8,'),  Total Number of Diagnostics: ',I5)  CBOP 0
522   3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')  C     !ROUTINE: DIAGS_MK_TITLE
523   4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,  
524       .                      ' (',A8,')')  C     !INTERFACE:
525   5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',        CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
526       .    I3,' (',A8,')',' WARNING - Diag will not accumulate properly')       I                            diagTitleInPieces, myThid )
527    
528    C     !DESCRIPTION:
529    C     *==========================================================*
530    C     | FUNCTION DIAGS_MK_TITLE
531    C     | o Return the diagnostic title string (80c) removing
532    C     |   consecutive blanks from the input string
533    C     *==========================================================*
534    
535    C     !USES:
536          IMPLICIT NONE
537    #include "EEPARAMS.h"
538    
539    C     !INPUT PARAMETERS:
540    C     diagTitleInPieces :: string for diagnostic units: in several
541    C                          pieces, with blanks in between
542    C     myThid            ::  my Thread Id number
543          CHARACTER*(*) diagTitleInPieces
544          INTEGER      myThid
545    CEOP
546    
547    C     !LOCAL VARIABLES:
548          CHARACTER*(MAX_LEN_MBUF) msgBuf
549          LOGICAL flag
550          INTEGER i,j,n
551    
552    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
553    
554          DIAGS_MK_TITLE = '                                        '
555         &               //'                                        '
556          n = LEN(diagTitleInPieces)
557    
558          j = 0
559          flag = .FALSE.
560          DO i=1,n
561           IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
562             IF ( flag ) THEN
563               j = j+1
564               IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
565             ENDIF
566             j = j+1
567             IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
568             flag = .FALSE.
569           ELSE
570             flag = j.GE.1
571           ENDIF
572          ENDDO
573    
574          IF ( j.GT.80 ) THEN
575             WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
576         &   'DIAGS_MK_TITLE: too long (',j,' >80) input string'
577            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
578         &       SQUEEZE_RIGHT , myThid)
579             WRITE(msgBuf,'(3A)') '** WARNING ** ',
580         &   'DIAGS_MK_TITLE: input=', diagTitleInPieces
581            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
582         &       SQUEEZE_RIGHT , myThid)
583          ENDIF
584    
585          RETURN
586        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.32
  ViewVC Help
Powered by ViewVC 1.1.22