/[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.16 by jmc, Mon Dec 20 01:53:54 2004 UTC revision 1.27 by jmc, Tue Nov 18 21:41:06 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         endif  #ifdef ALLOW_FIZHI
73        endif            DO j = 1,sNy+1
74                DO i = 1,sNx+1
75                  IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
76                    qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
77                  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            ENDIF
108           ENDIF
109          ENDIF
110    
111        RETURN        RETURN
112        END        END
113    
114  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
 CBOP 0  
 C     !ROUTINE: GETDIAG2  
115    
116    CBOP 0
117    C     !ROUTINE: DIAGNOSTICS_COUNT
118  C     !INTERFACE:  C     !INTERFACE:
119        SUBROUTINE GETDIAG2 (levreal,ipoint,undef,qtmp,myThid)        SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
120         I                              biArg, bjArg, myThid)
121    
122  C     !DESCRIPTION:  C     !DESCRIPTION:
123  C***********************************************************************  C***********************************************************************
124  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  
125  C***********************************************************************  C***********************************************************************
   
126  C     !USES:  C     !USES:
127        implicit none        IMPLICIT NONE
128    
129    C     == Global variables ===
130  #include "EEPARAMS.h"  #include "EEPARAMS.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  CEOP
148    
149  #ifdef ALLOW_FIZHI  C     !LOCAL VARIABLES:
150  #include "fizhi_SIZE.h"  C ===============
151  #else        INTEGER m, n
152         integer Nrphys        INTEGER bi, bj
153         parameter (Nrphys=0)        INTEGER ipt
154  #endif  c     CHARACTER*(MAX_LEN_MBUF) msgBuf
155    
156        _RL levreal  C--   Run through list of active diagnostics to find which counter
157        integer myThid,ipoint  C     to increment (needs to be a valid & active diagnostic-counter)
158        _RL undef        DO n=1,nlists
159        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy)         DO m=1,nActive(n)
160            IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
161             ipt = idiag(m,n)
162             IF (ndiag(ipt,1,1).GE.0) THEN
163    C-    Increment the counter for the diagnostic
164              IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
165               DO bj=myByLo(myThid), myByHi(myThid)
166                DO bi=myBxLo(myThid), myBxHi(myThid)
167                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
168                ENDDO
169               ENDDO
170              ELSE
171                 bi = MIN(biArg,nSx)
172                 bj = MIN(bjArg,nSy)
173                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
174              ENDIF
175    C-    Increment is done
176             ENDIF
177            ENDIF
178           ENDDO
179          ENDDO
180    
181        integer i,j,ipnt,klev        RETURN
182        integer bi,bj        END
       integer lev  
183    
184        if (ipoint.ge.1) then  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
185         lev = NINT(levreal)  
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"
212    #include "SIZE.h"
213    #include "DIAGNOSTICS_SIZE.h"
214    #include "DIAGNOSTICS.h"
215    
216    C     !INPUT PARAMETERS:
217    C     diagName :: diagnostic identificator name (8 characters long)
218    C     listId   :: list number that specify the output frequency
219    C     myThid   :: my Thread Id number
220    C     !OUTPUT PARAMETERS:
221    C     ndId     :: diagnostics  Id number (in available diagnostics list)
222    C     ip       :: diagnostics  pointer to storage array
223    
224    
225          CHARACTER*8 diagName
226          INTEGER listId
227          INTEGER ndId, ip
228          INTEGER myThid
229    CEOP
230    
231         klev = kdiag(ipoint)  C     !LOCAL VARIABLES:
232         if (klev.ge.lev) then        INTEGER n,m
233          ipnt = idiag(ipoint) + lev - 1  
234          ip   = 0
235          do bj=myByLo(myThid), myByHi(myThid)        ndId = 0
           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)  
                 else  
                   qtmp(i,j,lev,bi,bj) = undef  
                 endif  
               enddo  
             enddo  
236    
237            enddo        IF ( listId.LE.0 ) THEN
238          enddo  C--   select the 1rst one which name matches:
239    
240         endif  C-    search for this diag. in the active 2D/3D diagnostics list
241        endif          DO n=1,nlists
242             DO m=1,nActive(n)
243               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
244         &                  .AND. idiag(m,n).NE.0 ) THEN
245                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        RETURN        RETURN
285        END        END
286    
287  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
288    
289        subroutine clrindx (listnum, myThid)  CBOP 0
290  C***********************************************************************  C     !ROUTINE: DIAGS_GET_PARMS_I
291  C  
292  C  PURPOSE  C     !INTERFACE:
293  C     DRIVER TO CLEAR DIAGNOSTICS SPECIFIED IN DIAGNOSTIC INDEX LIST        INTEGER FUNCTION DIAGS_GET_PARMS_I(
294  C       I                            parName, myThid )
 C  ARGUMENT DESCRIPTION  
 C     listnum ....  diagnostics list number  
 C  
 C***********************************************************************  
295    
296        implicit none  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    C     !USES:
304          IMPLICIT NONE
305  #include "EEPARAMS.h"  #include "EEPARAMS.h"
306  #include "SIZE.h"  #include "SIZE.h"
307  #include "DIAGNOSTICS_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
308  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
309    
310        integer myThid, listnum  C     !INPUT PARAMETERS:
311    C     parName   :: string used to identify which parameter to get
312    C     myThid    :: my Thread Id number
313          CHARACTER*(*) parName
314          INTEGER myThid
315    CEOP
316    
317    C     !LOCAL VARIABLES:
318          CHARACTER*(MAX_LEN_MBUF) msgBuf
319          INTEGER n
320    
321    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
322    
323        integer m, n        n = LEN(parName)
324        character*8 parms1  c     write(0,'(3A,I4)')
325        character*3 mate_index  c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
326        integer mate  
327          IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
328        do n=1,nfields(listnum)           DIAGS_GET_PARMS_I = ndiagt
329         do m=1,ndiagt        ELSE
330          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then           WRITE(msgBuf,'(4A)') 'DIAGS_GET_PARMS_I: ',
331           call clrdiag (m, myThid)       &    ' parName="', parName, '" not known.'
332             CALL PRINT_ERROR( msgBuf, myThid )
333  c Check for Counter Diagnostic           STOP 'ABNORMAL END: S/R DIAGS_GET_PARMS_I'
334  c ----------------------------        ENDIF
          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  
335    
336        RETURN        RETURN
337        END        END
338    
339    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
340    
341        subroutine clrdiag (index, myThid)  CBOP 0
342  C***********************************************************************  C     !ROUTINE: DIAGS_MK_UNITS
343  C  PURPOSE  
344  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS  C     !INTERFACE:
345  C***********************************************************************        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
346         I                            diagUnitsInPieces, myThid )
347    
348        implicit none  C     !DESCRIPTION:
349    C     *==========================================================*
350    C     | FUNCTION DIAGS_MK_UNITS
351    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"  #include "EEPARAMS.h"
 #include "SIZE.h"  
 #include "DIAGNOSTICS_SIZE.h"  
 #include "DIAGNOSTICS.h"  
358    
359        integer myThid, index  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        integer bi,bj  C     !LOCAL VARIABLES:
368        integer i,j,k        CHARACTER*(MAX_LEN_MBUF) msgBuf
369          INTEGER i,j,n
370    
371  C **********************************************************************        DIAGS_MK_UNITS = '          '
372  C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****        n = LEN(diagUnitsInPieces)
 C **********************************************************************  
   
       do bj=myByLo(myThid), myByHi(myThid)  
        do bi=myBxLo(myThid), myBxHi(myThid)  
         do k = 1,kdiag(index)  
          do j = 1-OLy,sNy+OLy  
           do i = 1-OLx,sNx+OLx  
            qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0  
           enddo  
          enddo  
         enddo  
        enddo  
       enddo  
373    
374        ndiag(index) = 0        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
392    
393        RETURN        RETURN
394        END        END
# Line 240  C ************************************** Line 396  C **************************************
396  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
397    
398  CBOP 0  CBOP 0
399  C     !ROUTINE: DIAGNOSTICS_IS_ON  C     !ROUTINE: DIAGS_MK_TITLE
400    
401  C     !INTERFACE:  C     !INTERFACE:
402        LOGICAL FUNCTION DIAGNOSTICS_IS_ON( diagName, myThid )        CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
403         I                            diagTitleInPieces, myThid )
404    
405  C     !DESCRIPTION:  C     !DESCRIPTION:
406  C     *==========================================================*  C     *==========================================================*
407  C     | FUNCTION DIAGNOSTIC_IS_ON  C     | FUNCTION DIAGS_MK_TITLE
408  C     | o Return TRUE if diagnostics "diagName" is Active  C     | o Return the diagnostic title string (80c) removing
409    C     |   consecutive blanks from the input string
410  C     *==========================================================*  C     *==========================================================*
411    
412  C     !USES:  C     !USES:
413        IMPLICIT NONE        IMPLICIT NONE
414  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "SIZE.h"  
 #include "DIAGNOSTICS_SIZE.h"  
 #include "DIAGNOSTICS.h"  
415    
416  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
417  C     diagName   ::  diagnostic identificator name (8 characters long)  C     diagTitleInPieces :: string for diagnostic units: in several
418  C     myThid     ::  my thread Id number  C                          pieces, with blanks in between
419        CHARACTER*8  diagName  C     myThid            ::  my Thread Id number
420          CHARACTER*(*) diagTitleInPieces
421        INTEGER      myThid        INTEGER      myThid
422  CEOP  CEOP
423    
424  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
425        INTEGER j,n,m        CHARACTER*(MAX_LEN_MBUF) msgBuf
426          LOGICAL flag
427          INTEGER i,j,n
428    
429        DIAGNOSTICS_IS_ON = .FALSE.  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
430        DO n=1,nlists  
431         DO m=1,nActive(n)        DIAGS_MK_TITLE = '                                        '
432          IF ( diagName.EQ.flds(m,n) ) THEN       &               //'                                        '
433            j = jdiag(m,n)            n = LEN(diagTitleInPieces)
434            IF ( idiag(j).NE.0 .AND. ndiag(j).GE.0 )  
435       &         DIAGNOSTICS_IS_ON = .TRUE.        j = 0
436          ENDIF        flag = .FALSE.
437         ENDDO        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        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        RETURN
463        END        END
Legend:
Removed from v.1.16  
changed lines
  Added in v.1.27
  ViewVC Help
Powered by ViewVC 1.1.22