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