/[MITgcm]/MITgcm/pkg/diagnostics/diagnostics_utils.F
ViewVC logotype

Diff of /MITgcm/pkg/diagnostics/diagnostics_utils.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.2 by molod, Thu Feb 26 02:21:18 2004 UTC revision 1.26 by jmc, Sat Aug 16 17:28:29 2008 UTC
# Line 1  Line 1 
1        subroutine getdiag (lev,ipoint,bi,bj,undef,qtmp)  C $Header$
2  C***********************************************************************          C $Name$
 C  PURPOSE                                                                        
 C     Retrieve averaged model diagnostic  
 C  INPUT:                                                                        
 C     lev ..... Diagnostic LEVEL  
 C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                      
 C   undef ..... UNDEFINED VALUE                                                  
 C      bi ..... X-direction process(or) number  
 C      bj ..... Y-direction process(or) number  
 C                                                                                
 C  OUTPUT:                                                                        
 C    qtmp ..... AVERAGED DIAGNOSTIC QUANTITY  
 C                                                                                
 C***********************************************************************          
       implicit none  
3    
4  #include "CPP_OPTIONS.h"  #include "DIAG_OPTIONS.h"
 #include "SIZE.h"  
 #include "fizhi_SIZE.h"  
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
   
       integer bi,bj  
       integer lev,ipoint  
       integer i,j,ipnt,klev  
       _RL undef, factor  
       _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)  
   
       do j = 1,sNy  
       do i = 1,sNx  
        qtmp(i,j,bi,bj) = undef  
       enddo  
       enddo  
   
       IF (IPOINT.LT.1) GO TO 999  
   
       KLEV = KDIAG(IPOINT)  
       IF(KLEV.GE.LEV) THEN  
       IPNT = IDIAG(IPOINT) + LEV - 1  
                                 FACTOR = 1.0  
       IF( NDIAG(IPOINT).NE.0 )  FACTOR = 1.0   / NDIAG(IPOINT)  
       do j = 1,sNy  
       do i = 1,sNx  
       if( qdiag(i,j,ipnt,bi,bj).ne.undef )  
      .     qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)*factor  
       enddo  
       enddo  
       ENDIF  
5    
6   999  RETURN  C--   File diagnostics_utils.F: General purpose support routines
7        END  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        subroutine getdiag2 (lev,ipoint,bi,bj,undef,qtmp)  C     !DESCRIPTION:
26  C***********************************************************************          C     Retrieve averaged model diagnostic
 C                                                                                
 C  PURPOSE                                                                        
 C     Retrieve model diagnostic (No Averaging)  
 C  INPUT:                                                                        
 C     lev ..... Model LEVEL                                                      
 C  ipoint ..... DIAGNOSTIC NUMBER FROM MENU                                      
 C   undef ..... UNDEFINED VALUE                                                  
 C      im ..... X-DIMENSION  
 C      jm ..... Y-DIMENSION  
 C      nd ..... Number of 2-D Diagnostics  
 C                                                                                
 C  OUTPUT:                                                                        
 C    qtmp ..... DIAGNOSTIC QUANTITY                                              
 C                                                                                
 C***********************************************************************          
       implicit none  
27    
28  #include "CPP_OPTIONS.h"  C     !USES:
29          IMPLICIT NONE
30    #include "EEPARAMS.h"
31  #include "SIZE.h"  #include "SIZE.h"
32  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
33  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
 #include "diagnostics.h"  
   
       integer bi,bj  
34    
35        integer lev,ipoint  C     !INPUT PARAMETERS:
36        integer i,j,ipnt,klev  C     levreal :: Diagnostic LEVEL
37    C     undef   :: UNDEFINED VALUE
38    C     ndId    :: DIAGNOSTIC NUMBER FROM MENU
39    C     mate    :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise
40    C     ip      :: pointer to storage array location for diag.
41    C     im      :: pointer to storage array location for mate
42    C     bi      :: X-direction tile number
43    C     bj      :: Y-direction tile number
44    C     myThid  :: my thread Id number
45          _RL levreal
46        _RL undef        _RL undef
47        _RL qtmp(1-OLx:sNx+Olx,1-Oly:sNy+Oly,Nsx,Nsy)        INTEGER ndId, mate, ip, im
48          INTEGER bi,bj, myThid
49    
50        do j = 1,sNy  C     !OUTPUT PARAMETERS:
51        do i = 1,sNx  C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
52         qtmp(i,j,bi,bj) = undef        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
53        enddo  CEOP
54        enddo  
55    C     !LOCAL VARIABLES:
56        IF (IPOINT.LT.1) GO TO 999        _RL factor
57          INTEGER i, j, ipnt,ipCt
58        KLEV = KDIAG(IPOINT)        INTEGER lev, levCt, klev
59        IF(KLEV.GE.LEV) THEN  
60        IPNT = IDIAG(IPOINT) + LEV - 1        IF (ndId.GE.1) THEN
61        do j = 1,sNy         lev = NINT(levreal)
62        do i = 1,sNx         klev = kdiag(ndId)
63         qtmp(i,j,bi,bj) = qdiag(i,j,ipnt,bi,bj)         IF (lev.LE.klev) THEN
64        enddo  
65        enddo          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              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
100           ENDIF
101        ENDIF        ENDIF
102    
103   999  RETURN        RETURN
104        END        END
105                                                                                    
106        subroutine clrindx (myThid,listnum)  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
107    
108    CBOP 0
109    C     !ROUTINE: DIAGNOSTICS_COUNT
110    C     !INTERFACE:
111          SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
112         I                              biArg, bjArg, myThid)
113    
114    C     !DESCRIPTION:
115  C***********************************************************************  C***********************************************************************
116  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  
117  C***********************************************************************  C***********************************************************************
118    C     !USES:
119          IMPLICIT NONE
120    
121        implicit none  C     == Global variables ===
122  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
123  #include "SIZE.h"  #include "SIZE.h"
124  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
125  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
126  #include "diagnostics.h"  
127    C     !INPUT PARAMETERS:
128        integer myThid, listnum  C***********************************************************************
129    C  Arguments Description
130        integer m, n  C  ----------------------
131        character*8 parms1  C     chardiag :: Character expression for diag to increment the counter
132        character*1 parse1(8)  C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
133        character*3 mate_index  C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
134        integer mate  C     myThid   :: my thread Id number
135    C***********************************************************************
136        equivalence (     parms1 , parse1(1) )        CHARACTER*8 chardiag
137        equivalence ( mate_index , parse1(6) )        INTEGER biArg, bjArg
138          INTEGER myThid
139        do n=1,nfields(listnum)  CEOP
140         do m=1,ndiagt  
141          if( flds(n,listnum).eq.cdiag(m) .and. idiag(m).ne.0 ) then  C     !LOCAL VARIABLES:
142           call clrdiag (myThid,m)  C ===============
143          INTEGER m, n
144  c Check for Counter Diagnostic        INTEGER bi, bj
145  c ----------------------------        INTEGER ipt
146           parms1 =  gdiag(m)  c     CHARACTER*(MAX_LEN_MBUF) msgBuf
147           if( parse1(5).eq.'C' ) then  
148            read (mate_index,100) mate  C--   Run through list of active diagnostics to find which counter
149            call clrdiag (myThid,mate)  C     to increment (needs to be a valid & active diagnostic-counter)
150           endif        DO n=1,nlists
151          endif         DO m=1,nActive(n)
152         enddo          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
153        enddo           ipt = idiag(m,n)
154                               IF (ndiag(ipt,1,1).GE.0) THEN
155    100 format(i3)  C-    Increment the counter for the diagnostic
156        RETURN                  IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
157        END                       DO bj=myByLo(myThid), myByHi(myThid)
158                DO bi=myBxLo(myThid), myBxHi(myThid)
159                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
160        subroutine clrdiag (myThid,index)              ENDDO
161  C***********************************************************************                     ENDDO
162  C  PURPOSE                                                                                  ELSE
163  C     ZERO OUT MODEL DIAGNOSTIC ARRAY ELEMENTS               bi = MIN(biArg,nSx)
164  C***********************************************************************                       bj = MIN(bjArg,nSy)
165                                                                                                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
166        implicit none            ENDIF
167    C-    Increment is done
168             ENDIF
169            ENDIF
170           ENDDO
171          ENDDO
172    
173          RETURN
174          END
175    
176    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
177    
178    CBOP 0
179    C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
180    C     !INTERFACE:
181          SUBROUTINE DIAGNOSTICS_GET_POINTERS(
182         I                       diagName, listId,
183         O                       ndId, ip,
184         I                       myThid )
185    
186    C     !DESCRIPTION:
187    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    C     !USES:
202          IMPLICIT NONE
203  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "CPP_OPTIONS.h"  
204  #include "SIZE.h"  #include "SIZE.h"
205  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
206  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
 #include "diagnostics.h"  
   
       integer myThid, index  
   
       integer bi,bj  
       integer i,j,k  
   
 C **********************************************************************          
 C ****              SET DIAGNOSTIC AND COUNTER TO ZERO              ****          
 C **********************************************************************          
                                                                                   
       do bj=myByLo(myThid), myByHi(myThid)  
       do bi=myBxLo(myThid), myBxHi(myThid)  
        do k = 1,kdiag(index)  
         do j = 1,sNy  
         do i = 1,sNx  
          qdiag(i,j,idiag(index)+k-1,bi,bj) = 0.0  
         enddo  
         enddo  
        enddo  
       enddo  
       enddo  
207    
208        ndiag(index) = 0  C     !INPUT PARAMETERS:
209    C     diagName :: diagnostic identificator name (8 characters long)
210    C     listId   :: list number that specify the output frequency
211    C     myThid   :: my Thread Id number
212    C     !OUTPUT PARAMETERS:
213    C     ndId     :: diagnostics  Id number (in available diagnostics list)
214    C     ip       :: diagnostics  pointer to storage array
215    
216    
217          CHARACTER*8 diagName
218          INTEGER listId
219          INTEGER ndId, ip
220          INTEGER myThid
221    CEOP
222    
223    C     !LOCAL VARIABLES:
224          INTEGER n,m
225    
226          ip   = 0
227          ndId = 0
228    
229          IF ( listId.LE.0 ) THEN
230    C--   select the 1rst one which name matches:
231    
232    C-    search for this diag. in the active 2D/3D diagnostics list
233            DO n=1,nlists
234             DO m=1,nActive(n)
235               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
236         &                  .AND. idiag(m,n).NE.0 ) THEN
237                ip   = ABS(idiag(m,n))
238                ndId = jdiag(m,n)
239               ENDIF
240             ENDDO
241            ENDDO
242    
243          ELSEIF ( listId.LE.nlists ) THEN
244    C--   select the unique diagnostic with output-time identical to listId
245    
246    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        return        ELSE
273        end          STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
274          ENDIF
275    
276        subroutine setdiag (myThid,num,ndiagmx)        RETURN
277  C***********************************************************************        END
278  C  
279  C  PURPOSE  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
280  C     SET POINTER LOCATIONS, NAMES, LEVELS and TITLES FOR DIAGNOSTIC NUM  
281  C  CBOP 0
282  C***********************************************************************  C     !ROUTINE: DIAGS_GET_PARMS_I
283    
284    C     !INTERFACE:
285          INTEGER FUNCTION DIAGS_GET_PARMS_I(
286         I                            parName, myThid )
287    
288    C     !DESCRIPTION:
289    C     *==========================================================*
290    C     | FUNCTION DIAGS_GET_PARMS_I
291    C     | o Return the value of integer parameter
292    C     |   from one of the DIAGNOSTICS.h common blocs
293    C     *==========================================================*
294    
295        implicit none  C     !USES:
296  #include "CPP_OPTIONS.h"        IMPLICIT NONE
297    #include "EEPARAMS.h"
298  #include "SIZE.h"  #include "SIZE.h"
299  #include "fizhi_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
300  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS.h"
301  #include "diagnostics.h"  
302    C     !INPUT PARAMETERS:
303        integer num,myThid,ndiagmx  C     parName   :: string used to identify which parameter to get
304        integer ipointer  C     myThid    :: my Thread Id number
305          CHARACTER*(*) parName
306        DATA IPOINTER / 1 /        INTEGER myThid
307    CEOP
308        character*8 parms1  
309        character*1 parse1(8)  C     !LOCAL VARIABLES:
310        character*3 mate_index        CHARACTER*(MAX_LEN_MBUF) msgBuf
311        integer     mate        INTEGER n
312    
313        equivalence (     parms1 , parse1(1) )  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
314        equivalence ( mate_index , parse1(6) )  
315          n = LEN(parName)
316  C **********************************************************************  c     write(0,'(3A,I4)')
317  C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****  c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
318  C **********************************************************************  
319          IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
320        parms1 = gdiag(num)           DIAGS_GET_PARMS_I = ndiagt
   
       IF( IDIAG(NUM).EQ.0 ) THEN  
         if(ndiagmx+kdiag(num).gt.numdiags) then  
           write(6,4000)num,cdiag(num)  
         else  
           IDIAG(NUM) = IPOINTER  
           IPOINTER   = IPOINTER + KDIAG(NUM)  
           ndiagmx    = ndiagmx  + KDIAG(NUM)  
           if(myThid.eq.0) WRITE(6,2000)KDIAG(NUM),NUM,CDIAG(NUM),ndiagmx  
         endif  
321        ELSE        ELSE
322            if(myThid.eq.0) WRITE(6,3000) NUM, CDIAG(NUM)           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        ENDIF
327    
328  c Check for Counter Diagnostic        RETURN
329  c ----------------------------        END
330        if( parse1(5).eq.'C') then  
331        read (mate_index,100) mate  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
332    
333        IF( IDIAG(mate).EQ.0 ) THEN  CBOP 0
334         if(ndiagmx+kdiag(num).gt.numdiags) then  C     !ROUTINE: DIAGS_MK_UNITS
335          write(6,5000)num,cdiag(num)  
336         else  C     !INTERFACE:
337          IDIAG(mate) = IPOINTER        CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
338          IPOINTER    = IPOINTER + KDIAG(mate)       I                            diagUnitsInPieces, myThid )
339          ndiagmx     = ndiagmx  + KDIAG(mate)  
340          if(myThid.eq.0)WRITE(6,2000)KDIAG(mate),mate,CDIAG(mate),ndiagmx  C     !DESCRIPTION:
341         endif  C     *==========================================================*
342        ELSE  C     | FUNCTION DIAGS_MK_UNITS
343            if(myThid.eq.0) WRITE(6,3000) mate, CDIAG(mate)  C     | o Return the diagnostic units string (16c) removing
344    C     |   blanks from the input string
345    C     *==========================================================*
346    
347    C     !USES:
348          IMPLICIT NONE
349    #include "EEPARAMS.h"
350    
351    C     !INPUT PARAMETERS:
352    C     diagUnitsInPieces :: string for diagnostic units: in several
353    C                          pieces, with blanks in between
354    C     myThid            ::  my thread Id number
355          CHARACTER*(*) diagUnitsInPieces
356          INTEGER      myThid
357    CEOP
358    
359    C     !LOCAL VARIABLES:
360          CHARACTER*(MAX_LEN_MBUF) msgBuf
361          INTEGER i,j,n
362    
363          DIAGS_MK_UNITS = '          '
364          n = LEN(diagUnitsInPieces)
365    
366          j = 0
367          DO i=1,n
368           IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
369             j = j+1
370             IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
371           ENDIF
372          ENDDO
373    
374          IF ( j.GT.16 ) THEN
375             WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
376         &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
377            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
378         &       SQUEEZE_RIGHT , myThid)
379             WRITE(msgBuf,'(3A)') '**WARNING** ',
380         &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
381            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
382         &       SQUEEZE_RIGHT , myThid)
383        ENDIF        ENDIF
       endif  
384    
385        RETURN        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    100 format(i3)  C     !INTERFACE:
394   2000 FORMAT(1X,'Allocating ',I2,' Level(s) for Diagnostic # ',I3,        CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
395       .          ' (',A8,'),  Total Number of Diagnostics: ',I5)       I                            diagTitleInPieces, myThid )
396   3000 FORMAT(1X,'Diagnostic # ',I3,' (',A8,') has already been set')  
397   4000 FORMAT(1X,'Unable to allocate space for Diagnostic # ',I3,  C     !DESCRIPTION:
398       .                      ' (',A8,')')  C     *==========================================================*
399   5000 FORMAT(1X,'Unable to allocate space for Counter Diagnostic # ',  C     | FUNCTION DIAGS_MK_TITLE
400       .    I3,' (',A8,')',' WARNING - Diag will not accumulate properly')  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
455        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.26
  ViewVC Help
Powered by ViewVC 1.1.22