/[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.6 by molod, Mon Mar 1 20:31:58 2004 UTC revision 1.28 by jmc, Sun Jan 25 17:00:20 2009 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=0)  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=0)                  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"  #include "DIAGNOSTICS_SIZE.h"
133  #include "diagnostics.h"  #include "DIAGNOSTICS.h"
134    
135    C     !INPUT PARAMETERS:
136    C***********************************************************************
137    C  Arguments Description
138    C  ----------------------
139    C     chardiag :: Character expression for diag to increment the counter
140    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    C     myThid   :: my thread Id number
143    C***********************************************************************
144          CHARACTER*8 chardiag
145          INTEGER biArg, bjArg
146          INTEGER myThid
147    CEOP
148    
149    C     !LOCAL VARIABLES:
150    C ===============
151          INTEGER m, n
152          INTEGER bi, bj
153          INTEGER ipt, ndId
154    c     CHARACTER*(MAX_LEN_MBUF) msgBuf
155    
156          IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
157            bi = myBxLo(myThid)
158            bj = myByLo(myThid)
159          ELSE
160            bi = MIN(biArg,nSx)
161            bj = MIN(bjArg,nSy)
162          ENDIF
163    
164        integer myThid, listnum  C--   Run through list of active diagnostics to find which counter
165    C     to increment (needs to be a valid & active diagnostic-counter)
166          DO n=1,nlists
167           DO m=1,nActive(n)
168            IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
169             ipt = idiag(m,n)
170             IF (ndiag(ipt,bi,bj).GE.0) THEN
171              ndId = jdiag(m,n)
172              ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
173    C-    Increment the counter for the diagnostic
174              IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
175               DO bj=myByLo(myThid), myByHi(myThid)
176                DO bi=myBxLo(myThid), myBxHi(myThid)
177                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
178                ENDDO
179               ENDDO
180              ELSE
181                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
182              ENDIF
183    C-    Increment is done
184             ENDIF
185            ENDIF
186           ENDDO
187          ENDDO
188    
189        integer m, n        RETURN
190        character*8 parms1        END
191        character*1 parse1(8)  
192        character*3 mate_index  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
193        integer mate  
194    CBOP 0
195        equivalence (     parms1 , parse1(1) )  C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
196        equivalence ( mate_index , parse1(6) )  C     !INTERFACE:
197          SUBROUTINE DIAGNOSTICS_GET_POINTERS(
198        do n=1,nfields(listnum)       I                       diagName, listId,
199         do m=1,ndiagt       O                       ndId, ip,
200          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then       I                       myThid )
201           call clrdiag (myThid,m)  
202    C     !DESCRIPTION:
203  c Check for Counter Diagnostic  C     *================================================================*
204  c ----------------------------  C     | o Returns the diagnostic Id number and diagnostic
205           parms1 =  gdiag(m)  C     |   pointer to storage array for a specified diagnostic.
206           if( parse1(5).eq.'C' ) then  C     *================================================================*
207            read (mate_index,100) mate  C     | Note: A diagnostics field can be stored multiple times
208            call clrdiag (myThid,mate)  C     |       (for different output frequency,phase, ...).
209           endif  C     | operates in 2 ways:
210          endif  C     | o listId =0 => find 1 diagnostics Id & pointer which name matches.
211         enddo  C     | o listId >0 => find the unique diagnostic Id & pointer with
212        enddo  C     |      the right name and same output time as "listId" output-list
213                      C     | o return ip=0 if did not find the right diagnostic;
214    100 format(i3)  C     |   (ndId <>0 if diagnostic exist but output time does not match)
215        RETURN        C     *================================================================*
216        END            
217    C     !USES:
218          IMPLICIT NONE
       subroutine clrdiag (myThid,index)  
 C***********************************************************************          
 C  PURPOSE                                                                        
 C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS  
 C***********************************************************************          
                                                                                   
       implicit none  
219  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
220  #include "SIZE.h"  #include "SIZE.h"
221  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
222  #include "diagnostics.h"  #include "DIAGNOSTICS.h"
223    
224        integer myThid, index  C     !INPUT PARAMETERS:
225    C     diagName :: diagnostic identificator name (8 characters long)
226    C     listId   :: list number that specify the output frequency
227    C     myThid   :: my Thread Id number
228    C     !OUTPUT PARAMETERS:
229    C     ndId     :: diagnostics  Id number (in available diagnostics list)
230    C     ip       :: diagnostics  pointer to storage array
231    
232    
233          CHARACTER*8 diagName
234          INTEGER listId
235          INTEGER ndId, ip
236          INTEGER myThid
237    CEOP
238    
239    C     !LOCAL VARIABLES:
240          INTEGER n,m
241    
242          ip   = 0
243          ndId = 0
244    
245          IF ( listId.LE.0 ) THEN
246    C--   select the 1rst one which name matches:
247    
248    C-    search for this diag. in the active 2D/3D diagnostics list
249            DO n=1,nlists
250             DO m=1,nActive(n)
251               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
252         &                  .AND. idiag(m,n).NE.0 ) THEN
253                ip   = ABS(idiag(m,n))
254                ndId = jdiag(m,n)
255               ENDIF
256             ENDDO
257            ENDDO
258    
259          ELSEIF ( listId.LE.nlists ) THEN
260    C--   select the unique diagnostic with output-time identical to listId
261    
262    C-    search for this diag. in the active 2D/3D diagnostics list
263            DO n=1,nlists
264             IF ( ip.EQ.0
265         &        .AND. freq(n) .EQ. freq(listId)
266         &        .AND. phase(n).EQ.phase(listId)
267         &        .AND. averageFreq(n) .EQ.averageFreq(listId)
268         &        .AND. averagePhase(n).EQ.averagePhase(listId)
269         &        .AND. averageCycle(n).EQ.averageCycle(listId)
270         &      ) 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                ip   = ABS(idiag(m,n))
275                ndId = jdiag(m,n)
276               ENDIF
277              ENDDO
278             ELSEIF ( ip.EQ.0 ) 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                ndId = jdiag(m,n)
283               ENDIF
284              ENDDO
285             ENDIF
286            ENDDO
287    
288        integer bi,bj        ELSE
289        integer i,j,k          STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
290          ENDIF
291    
292  C **********************************************************************                RETURN
293  C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****                END
 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  
294    
295        ndiag(index) = 0  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
296    
297        return  CBOP 0
298        end  C     !ROUTINE: DIAGS_GET_PARMS_I
299    
300        subroutine setdiag (myThid,num,ndiagmx)  C     !INTERFACE:
301  C***********************************************************************        INTEGER FUNCTION DIAGS_GET_PARMS_I(
302  C       I                            parName, myThid )
303  C  PURPOSE  
304  C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM  C     !DESCRIPTION:
305  C  C     *==========================================================*
306  C***********************************************************************  C     | FUNCTION DIAGS_GET_PARMS_I
307    C     | o Return the value of integer parameter
308    C     |   from one of the DIAGNOSTICS.h common blocs
309    C     *==========================================================*
310    
311        implicit none  C     !USES:
312  #include "CPP_OPTIONS.h"        IMPLICIT NONE
313    #include "EEPARAMS.h"
314  #include "SIZE.h"  #include "SIZE.h"
315  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
316  #include "diagnostics.h"  #include "DIAGNOSTICS.h"
   
       integer num,myThid,ndiagmx  
       integer ipointer  
317    
318        DATA IPOINTER / 1 /  C     !INPUT PARAMETERS:
319    C     parName   :: string used to identify which parameter to get
320    C     myThid    :: my Thread Id number
321          CHARACTER*(*) parName
322          INTEGER myThid
323    CEOP
324    
325    C     !LOCAL VARIABLES:
326          CHARACTER*(MAX_LEN_MBUF) msgBuf
327          INTEGER n
328    
329    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
330    
331          n = LEN(parName)
332    c     write(0,'(3A,I4)')
333    c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
334    
335        character*8 parms1        IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
336        character*1 parse1(8)           DIAGS_GET_PARMS_I = ndiagt
       character*3 mate_index  
       integer     mate  
   
       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  
337        ELSE        ELSE
338            if(myThid.eq.1) WRITE(6,3000) NUM, CDIAG(NUM)           WRITE(msgBuf,'(4A)') 'DIAGS_GET_PARMS_I: ',
339         &    ' parName="', parName, '" not known.'
340             CALL PRINT_ERROR( msgBuf, myThid )
341             STOP 'ABNORMAL END: S/R DIAGS_GET_PARMS_I'
342        ENDIF        ENDIF
343    
344  c Check for Counter Diagnostic        RETURN
345  c ----------------------------        END
346        if( parse1(5).eq.'C') then  
347        read (mate_index,100) mate  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
348    
349        IF( IDIAG(mate).EQ.0 ) THEN  CBOP 0
350         if(ndiagmx+kdiag(num).gt.numdiags) then  C     !ROUTINE: DIAGS_MK_UNITS
351          write(6,5000)num,cdiag(num)  
352         else  C     !INTERFACE:
353          IDIAG(mate) = IPOINTER        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
354          IPOINTER    = IPOINTER + KDIAG(mate)       I                            diagUnitsInPieces, myThid )
355          ndiagmx     = ndiagmx  + KDIAG(mate)  
356          if(myThid.eq.1)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     !DESCRIPTION:
357         endif  C     *==========================================================*
358        ELSE  C     | FUNCTION DIAGS_MK_UNITS
359            if(myThid.eq.1) WRITE(6,3000) mate, CDIAG(mate)  C     | o Return the diagnostic units string (16c) removing
360    C     |   blanks from the input string
361    C     *==========================================================*
362    
363    C     !USES:
364          IMPLICIT NONE
365    #include "EEPARAMS.h"
366    
367    C     !INPUT PARAMETERS:
368    C     diagUnitsInPieces :: string for diagnostic units: in several
369    C                          pieces, with blanks in between
370    C     myThid            ::  my thread Id number
371          CHARACTER*(*) diagUnitsInPieces
372          INTEGER      myThid
373    CEOP
374    
375    C     !LOCAL VARIABLES:
376          CHARACTER*(MAX_LEN_MBUF) msgBuf
377          INTEGER i,j,n
378    
379          DIAGS_MK_UNITS = '          '
380          n = LEN(diagUnitsInPieces)
381    
382          j = 0
383          DO i=1,n
384           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
385             j = j+1
386             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
387           ENDIF
388          ENDDO
389    
390          IF ( j.GT.16 ) THEN
391             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
392         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
393            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
394         &       SQUEEZE_RIGHT , myThid)
395             WRITE(msgBuf,'(3A)') '**WARNING** ',
396         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
397            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
398         &       SQUEEZE_RIGHT , myThid)
399        ENDIF        ENDIF
       endif  
400    
401        RETURN        RETURN
402          END
403    
404    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
405    
406    CBOP 0
407    C     !ROUTINE: DIAGS_MK_TITLE
408    
409    100 format(i3)  C     !INTERFACE:
410   2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,        CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
411       .          ' (',A8,'),  Total Number of Diagnostics: ',I5)       I                            diagTitleInPieces, myThid )
412   3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')  
413   4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,  C     !DESCRIPTION:
414       .                      ' (',A8,')')  C     *==========================================================*
415   5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',  C     | FUNCTION DIAGS_MK_TITLE
416       .    I3,' (',A8,')',' WARNING - Diag will not accumulate properly')  C     | o Return the diagnostic title string (80c) removing
417    C     |   consecutive blanks from the input string
418    C     *==========================================================*
419    
420    C     !USES:
421          IMPLICIT NONE
422    #include "EEPARAMS.h"
423    
424    C     !INPUT PARAMETERS:
425    C     diagTitleInPieces :: string for diagnostic units: in several
426    C                          pieces, with blanks in between
427    C     myThid            ::  my Thread Id number
428          CHARACTER*(*) diagTitleInPieces
429          INTEGER      myThid
430    CEOP
431    
432    C     !LOCAL VARIABLES:
433          CHARACTER*(MAX_LEN_MBUF) msgBuf
434          LOGICAL flag
435          INTEGER i,j,n
436    
437    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
438    
439          DIAGS_MK_TITLE = '                                        '
440         &               //'                                        '
441          n = LEN(diagTitleInPieces)
442    
443          j = 0
444          flag = .FALSE.
445          DO i=1,n
446           IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
447             IF ( flag ) THEN
448               j = j+1
449               IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
450             ENDIF
451             j = j+1
452             IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
453             flag = .FALSE.
454           ELSE
455             flag = j.GE.1
456           ENDIF
457          ENDDO
458    
459          IF ( j.GT.80 ) THEN
460             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
461         &   'DIAGS_MK_TITLE: too long (',j,' >80) input string'
462            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
463         &       SQUEEZE_RIGHT , myThid)
464             WRITE(msgBuf,'(3A)') '**WARNING** ',
465         &   'DIAGS_MK_TITLE: input=', diagTitleInPieces
466            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
467         &       SQUEEZE_RIGHT , myThid)
468          ENDIF
469    
470          RETURN
471        END        END
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.28
  ViewVC Help
Powered by ViewVC 1.1.22