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