/[MITgcm]/MITgcm/eesupp/src/print.F
ViewVC logotype

Diff of /MITgcm/eesupp/src/print.F

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

revision 1.17 by cnh, Sun Feb 4 14:38:44 2001 UTC revision 1.30 by jmc, Tue Apr 28 22:00:46 2009 UTC
# Line 3  C $Name$ Line 3  C $Name$
3    
4  #include "CPP_EEOPTIONS.h"  #include "CPP_EEOPTIONS.h"
5    
6  C--   File printf.F: Routines for performing formatted textual I/O  C--  File printf.F: Routines for performing formatted textual I/O
7  C--                  in the MITgcm UV implementation environment.  C--                 in the MITgcm UV implementation environment.
8  C--    Contents  C--   Contents
9  C--    o print_error    Does IO with **ERROR** highlighted header  C--   o PRINT_MESSAGE  Does IO with unhighlighted header
10  C--    o print_list_i   Prints one-deimensional list of INTEGER  C--   o PRINT_ERROR    Does IO with **ERROR** highlighted header
11  C--                     numbers.  C--   o PRINT_LIST_I   Prints one-dimensional list of INTEGER
12  C--    o print_list_l   Prints one-deimensional list of LOGICAL  C--                    numbers.
13  C--                     variables.  C--   o PRINT_LIST_L   Prints one-dimensional list of LOGICAL
14  C--    o print_list_r8  Prints one-deimensional list of Real*8  C--                    variables.
15  C--                     numbers.  C--   o PRINT_LIST_RL  Prints one-dimensional list of Real(_RL)
16  C--    o print_mapr4    Formats ABCD... contour map of a Real*4 field  C--                    numbers.
17  C--                     Uses print_message for writing  C--   o PRINT_MAPRS    Formats ABCD... contour map of a Real(_RS) field
18  C--    o print_mapr8    Formats ABCD... contour map of a Real*8 field  C--                    Uses print_message for writing
19  C--                     Uses print_message for writing  C--   o PRINT_MAPRL    Formats ABCD... contour map of a Real(_RL) field
20  C--    o print_message  Does IO with unhighlighted header  C--                    Uses print_message for writing
21    
22    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
23    CBOP
24    C     !ROUTINE: PRINT_MESSAGE
25    C     !INTERFACE:
26          SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )
27    
28  CStartOfInterface  C     !DESCRIPTION:
29        SUBROUTINE PRINT_ERROR( message , myThid )  C     *============================================================*
30  C     /============================================================\  C     | SUBROUTINE PRINT\_MESSAGE
31  C     | SUBROUTINE PRINT_ERROR                                     |  C     | o Write out informational message using "standard" format.
32  C     | o Write out error message using "standard" format.         |  C     *============================================================*
33  C     | Notes                                                      |  C     | Notes
34  C     | =====                                                      |  C     | =====
35  C     | o Some system   I/O is not "thread-safe". For this reason  |  C     | o Some system   I/O is not "thread-safe". For this reason
36  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |  C     |   without the FMTFTN\_IO\_THREAD\_SAFE directive set a
37  C     |   critical region is defined around the write here. In some|  C     |   critical region is defined around the write here. In some
38  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |  C     |   cases  BEGIN\_CRIT() is approximated by only doing writes
39  C     |   for thread number 1 - writes for other threads are       |  C     |   for thread number 1 - writes for other threads are
40  C     |   ignored!                                                 |  C     |   ignored!
41  C     | o In a non-parallel form these routines can still be used. |  C     | o In a non-parallel form these routines can still be used.
42  C     |   to produce pretty printed output!                        |  C     |   to produce pretty printed output!
43  C     \============================================================/  C     *============================================================*
44    
45    C     !USES:
46        IMPLICIT NONE        IMPLICIT NONE
47    
48  C     == Global data ==  C     == Global data ==
49  #include "SIZE.h"  #include "SIZE.h"
50  #include "EEPARAMS.h"  #include "EEPARAMS.h"
51  #include "EESUPPORT.h"  #include "EESUPPORT.h"
 C     == Routine arguments ==  
       CHARACTER*(*) message  
       INTEGER       myThid  
 CEndOfInterface  
52        INTEGER  IFNBLNK        INTEGER  IFNBLNK
53        EXTERNAL IFNBLNK        EXTERNAL IFNBLNK
54        INTEGER  ILNBLNK        INTEGER  ILNBLNK
55        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
56    
57    C     !INPUT/OUTPUT PARAMETERS:
58    C     == Routine arguments ==
59    C     message :: Message to write
60    C     unit    :: Unit number to write to
61    C     sq      :: Justification option
62          CHARACTER*(*) message
63          INTEGER       unit
64          CHARACTER*(*) sq
65          INTEGER  myThid
66    
67    C     !LOCAL VARIABLES:
68  C     == Local variables ==  C     == Local variables ==
69    C     iStart, iEnd :: String indexing variables
70    C     idString     :: Temp. for building prefix.
71        INTEGER iStart        INTEGER iStart
72        INTEGER iEnd        INTEGER iEnd
73        CHARACTER*9 idString        CHARACTER*9 idString
74    CEOP
75    
76  C--   Find beginning and end of message  C--   Find beginning and end of message
77        iStart = IFNBLNK( message )        IF ( sq .EQ. SQUEEZE_BOTH .OR.
78        iEnd   = ILNBLNK( message )       &     sq .EQ. SQUEEZE_LEFT ) THEN
79           iStart = IFNBLNK( message )
80          ELSE
81           iStart = 1
82          ENDIF
83          IF ( sq .EQ. SQUEEZE_BOTH .OR.
84         &     sq .EQ. SQUEEZE_RIGHT ) THEN
85           iEnd   = ILNBLNK( message )
86          ELSE
87           iEnd   = LEN(message)
88          ENDIF
89  C--   Test to see if in multi-process ( or multi-threaded ) mode.  C--   Test to see if in multi-process ( or multi-threaded ) mode.
90  C     If so include process or thread identifier.  C     If so include process or thread identifier.
91        IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN        IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN
92  C--    Write single process format  C--    Write single process format
93         IF ( message .EQ. ' ' ) THEN         IF ( message .EQ. ' ' ) THEN
94          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '          WRITE(unit,'(A)') ' '
95         ELSE         ELSE
96          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER,          WRITE(unit,'(A)') message(iStart:iEnd)
      &   message(iStart:iEnd)  
97         ENDIF         ENDIF
98        ELSEIF ( pidIO .EQ. myProcId ) THEN        ELSEIF ( pidIO .EQ. myProcId ) THEN
99  C--    Write multi-process format  C--    Write multi-process format
# Line 75  C--    Write multi-process format Line 105  C--    Write multi-process format
105         _END_CRIT(myThid)         _END_CRIT(myThid)
106  #endif  #endif
107         IF ( message .EQ. ' ' ) THEN         IF ( message .EQ. ' ' ) THEN
108  C       PRINT_ERROR can be called by several threads simulataneously.  C       PRINT can be called by several threads simultaneously.
109  C       The write statement may need to be marked as a critical section.  C       The write statement may need to ne marked as a critical section.
110  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
111          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
112  #endif  #endif
113          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)           WRITE(unit,'(A,A,A,A,A,A)',ERR=999)
114       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &   '(',PROCESS_HEADER,' ',idString,')',' '
      &  ' '  
115  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
116          _END_CRIT(myThid)          _END_CRIT(myThid)
117  #endif  #endif
# Line 90  C       The write statement may need to Line 119  C       The write statement may need to
119  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
120          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
121  #endif  #endif
122          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)           WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)
123       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',
124       &  message(iStart:iEnd)       &   message(iStart:iEnd)
125  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
126          _END_CRIT(myThid)          _END_CRIT(myThid)
127  #endif  #endif
128         ENDIF         ENDIF
129        ENDIF        ENDIF
130    
131    #ifndef DISABLE_WRITE_TO_UNIT_ZERO
132    C--   if error message, also write directly to unit 0 :
133          IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1
134         &     .AND. unit.EQ.errorMessageUnit ) THEN
135            iEnd   = ILNBLNK( message )
136            IF (iEnd.NE.0) WRITE(0,'(A)') message(1:iEnd)
137          ENDIF
138    #endif
139  C  C
140   1000 CONTINUE   1000 CONTINUE
141        RETURN        RETURN
   
142    999 CONTINUE    999 CONTINUE
143         ioErrorCount(myThid) = ioErrorCount(myThid)+1         ioErrorCount(myThid) = ioErrorCount(myThid)+1
144        GOTO 1000        GOTO 1000
145    
146          END
147    
148    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
149    CBOP
150    C     !ROUTINE: PRINT_ERROR
151    C     !INTERFACE:
152          SUBROUTINE PRINT_ERROR( message , myThid )
153    
154    C     !DESCRIPTION:
155    C     *============================================================*
156    C     | SUBROUTINE PRINT\_ERROR
157    C     | o Write out error message using "standard" format.
158    C     *============================================================*
159    C     | Notes
160    C     | =====
161    C     | o Some system   I/O is not "thread-safe". For this reason
162    C     |   without the FMTFTN\_IO\_THREAD\_SAFE directive set a
163    C     |   critical region is defined around the write here. In some
164    C     |   cases  BEGIN\_CRIT() is approximated by only doing writes
165    C     |   for thread number 1 - writes for other threads are
166    C     |   ignored!
167    C     | o In a non-parallel form these routines are still used
168    C     |   to produce pretty printed output. The process and thread
169    C     |   id prefix is omitted in this case.
170    C     *============================================================*
171    
172    C     !USES:
173          IMPLICIT NONE
174    
175    C     == Global data ==
176    #include "SIZE.h"
177    #include "EEPARAMS.h"
178    #include "EESUPPORT.h"
179          INTEGER  IFNBLNK
180          EXTERNAL IFNBLNK
181          INTEGER  ILNBLNK
182          EXTERNAL ILNBLNK
183    
184    C     !INPUT/OUTPUT PARAMETERS:
185    C     == Routine arguments ==
186    C     message :: Text string to print
187    C     myThid  :: Thread number of this instance
188          CHARACTER*(*) message
189          INTEGER       myThid
190    
191    C     !LOCAL VARIABLES:
192    C     == Local variables ==
193    C     iStart, iEnd :: Temps. for string indexing
194    C     idString     :: Temp. for building message prefix
195          INTEGER iStart
196          INTEGER iEnd
197          CHARACTER*9 idString
198    CEOP
199    
200    C--   Find beginning and end of message
201          iStart = IFNBLNK( message )
202          iEnd   = ILNBLNK( message )
203    C--   Test to see if in multi-process ( or multi-threaded ) mode.
204    C     If so include process or thread identifier.
205          IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN
206    C--    Write single process format
207           IF ( message .EQ. ' ' ) THEN
208            WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '
209           ELSE
210            WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER,
211         &   message(iStart:iEnd)
212           ENDIF
213          ELSE
214    C       PRINT_ERROR can be called by several threads simulataneously.
215    C       The write statement may need to be marked as a critical section.
216    #ifndef FMTFTN_IO_THREAD_SAFE
217    # ifdef USE_OMP_THREADING
218    C$OMP CRITICAL
219    # else
220           _BEGIN_CRIT(myThid)
221    # endif
222    #endif
223           IF ( pidIO .EQ. myProcId ) THEN
224    C--    Write multi-process format
225             WRITE(idString,'(I4.4,A,I4.4)') myProcId,'.',myThid
226    
227             IF ( iEnd.EQ.0 ) THEN
228    c         WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
229              WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')
230         &    '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
231         &    ' '
232             ELSE
233    c         WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
234              WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')
235         &    '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
236         &    message(iStart:iEnd)
237             ENDIF
238           ENDIF
239    
240    #ifndef DISABLE_WRITE_TO_UNIT_ZERO
241    C--    also write directly to unit 0 :
242           IF ( numberOfProcs.EQ.1 .AND. iEnd.NE.0 ) THEN
243            IF ( nThreads.LE.1 ) THEN
244              WRITE(0,'(A)') message(1:iEnd)
245            ELSE
246              WRITE(0,'(A,I4.4,A,A)') '(TID ', myThid, ') ',
247         &                   message(1:iEnd)
248            ENDIF
249           ENDIF
250    #endif
251    
252    #ifndef FMTFTN_IO_THREAD_SAFE
253    # ifdef USE_OMP_THREADING
254    C$OMP END CRITICAL
255    # else
256            _END_CRIT(myThid)
257    # endif
258    #endif
259          ENDIF
260    
261     1000 CONTINUE
262          RETURN
263    
264    c 999 CONTINUE
265    c      ioErrorCount(myThid) = ioErrorCount(myThid)+1
266    c     GOTO 1000
267        END        END
268    
269  CStartofinterface  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
270        SUBROUTINE PRINT_LIST_I( fld, lFld, index_type,  CBOP
271    C     !ROUTINE: PRINT_LIST_I
272    C     !INTERFACE:
273          SUBROUTINE PRINT_LIST_I( fld, iFirst, iLast, index_type,
274       &                         markEnd, compact, ioUnit )       &                         markEnd, compact, ioUnit )
275  C     /==========================================================\  
276  C     | o SUBROUTINE PRINT_LIST_I                                |  C     !DESCRIPTION:
277  C     |==========================================================|  C     *==========================================================*
278  C     | Routine for producing list of values for a field with    |  C     | o SUBROUTINE PRINT\_LIST\_I
279  C     | duplicate values collected into                          |  C     *==========================================================*
280  C     |    n @ value                                             |  C     | Routine for producing list of values for a field with
281  C     | record.                                                  |  C     | duplicate values collected into
282  C     \==========================================================/  C     |    n \@ value
283    C     | record.
284    C     *==========================================================*
285    
286    C     !USES:
287        IMPLICIT NONE        IMPLICIT NONE
288    
289  C     == Global data ==    C     == Global data ==
290  #include "SIZE.h"  #include "SIZE.h"
291  #include "EEPARAMS.h"  #include "EEPARAMS.h"
292    
293    C     !INPUT/OUTPUT PARAMETERS:
294  C     == Routine arguments ==  C     == Routine arguments ==
295  C     fld    -  Data to be printed  C     fld     :: Data to be printed
296  C     lFld   -  Number of elements to be printed  C     iFirst  :: First element to print
297  C     index_type - Flag indicating which type of index to print  C     iLast   :: Last element to print
298    C  index_type :: Flag indicating which type of index to print
299  C                  INDEX_K    => /* K = nnn */  C                  INDEX_K    => /* K = nnn */
300  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
301  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
302  C                  INDEX_NONE =>  C                  INDEX_NONE =>
303  C     compact -  Flag to control use of repeat symbol for same valued  C     markEnd :: Flag to control whether there is a separator after the
 C                fields.  
 C     markEnd -  Flag to control whether there is a separator after the  
304  C                last element  C                last element
305  C     ioUnit -  Unit number for IO.  C     compact :: Flag to control use of repeat symbol for same valued
306        INTEGER lFld  C                fields.
307    C     ioUnit  :: Unit number for IO.
308          INTEGER iFirst, iLast
309          INTEGER fld(iFirst:iLast)
310        INTEGER index_type        INTEGER index_type
       INTEGER fld(lFld)  
311        LOGICAL markEnd        LOGICAL markEnd
312        LOGICAL compact        LOGICAL compact
313        INTEGER ioUnit        INTEGER ioUnit
 CEndifinterface  
314    
315    C     !LOCAL VARIABLES:
316  C     == Local variables ==  C     == Local variables ==
317  C     iLo  - Range index holders for selecting elements with  C     iLo  - Range index holders for selecting elements with
318  C     iHi    with the same value  C     iHi    with the same value
# Line 162  C     K    - Loop counter Line 330  C     K    - Loop counter
330        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
331        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
332        CHARACTER*3 index_lab        CHARACTER*3 index_lab
333          CHARACTER*25 fmt1, fmt2
334        INTEGER K        INTEGER K
335    CEOP
336    
337        IF     ( index_type .EQ. INDEX_I ) THEN        IF     ( index_type .EQ. INDEX_I ) THEN
338         index_lab = 'I ='         index_lab = 'I ='
# Line 173  C     K    - Loop counter Line 343  C     K    - Loop counter
343        ELSE        ELSE
344         index_lab = '?='         index_lab = '?='
345        ENDIF        ENDIF
346    C-    fortran format to write 1 or 2 indices:
347          fmt1='(A,1X,A,I3,1X,A)'
348          fmt2='(A,1X,A,I3,A,I3,1X,A)'
349          IF ( iLast.GE.1000 ) THEN
350            K = 1+INT(LOG10(FLOAT(iLast)))
351            WRITE(fmt1,'(A,I1,A)')      '(A,1X,A,I',K,',1X,A)'
352            WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)'
353          ENDIF
354        commOpen  = '/*'        commOpen  = '/*'
355        commClose = '*/'        commClose = '*/'
356        iLo = 1        iLo = iFirst
357        iHi = 1        iHi = iFirst
358        punc = ','        punc = ','
359        xOld = fld(1)        xOld = fld(iFirst)
360        DO K=2,lFld        DO K = iFirst+1,iLast
361         xNew = fld(K  )         xNew = fld(K  )
362         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
363          nDup = iHi-iLo+1          nDup = iHi-iLo+1
364          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
365           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
366           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
367       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt1)
368       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
369          ELSE          ELSE
370           WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc
371           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
372       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt2)
373       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
374          ENDIF          ENDIF
375          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
# Line 207  C     K    - Loop counter Line 385  C     K    - Loop counter
385        nDup = iHi-iLo+1        nDup = iHi-iLo+1
386        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
387         WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
388         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
389       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
390       &  commOpen,index_lab,iLo,commClose       &  commOpen,index_lab,iLo,commClose
391        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
392         WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc
393         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
394       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
395       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
396        ENDIF        ENDIF
397        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
# Line 221  C     K    - Loop counter Line 399  C     K    - Loop counter
399        RETURN        RETURN
400        END        END
401    
402  CStartofinterface  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
403        SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd,  CBOP
404       &                         compact, ioUnit )  C     !ROUTINE: PRINT_LIST_L
405  C     /==========================================================\  C     !INTERFACE:
406  C     | o SUBROUTINE PRINT_LIST_L                                |        SUBROUTINE PRINT_LIST_L( fld, iFirst, iLast, index_type,
407  C     |==========================================================|       &                         markEnd, compact, ioUnit )
408  C     | Routine for producing list of values for a field with    |  
409  C     | duplicate values collected into                          |  C     !DESCRIPTION:
410  C     |    n @ value                                             |  C     *==========================================================*
411  C     | record.                                                  |  C     | o SUBROUTINE PRINT\_LIST\_L
412  C     \==========================================================/  C     *==========================================================*
413    C     | Routine for producing list of values for a field with
414    C     | duplicate values collected into
415    C     |    n \@ value
416    C     | record.
417    C     *==========================================================*
418    
419    C     !USES:
420        IMPLICIT NONE        IMPLICIT NONE
421    
422  C     == Global data ==    C     == Global data ==
423  #include "SIZE.h"  #include "SIZE.h"
424  #include "EEPARAMS.h"  #include "EEPARAMS.h"
425    
426    C     !INPUT/OUTPUT PARAMETERS:
427  C     == Routine arguments ==  C     == Routine arguments ==
428  C     fld    -  Data to be printed  C     fld     :: Data to be printed
429  C     lFld   -  Number of elements to be printed  C     iFirst  :: First element to print
430  C     index_type - Flag indicating which type of index to print  C     iLast   :: Last element to print
431    C  index_type :: Flag indicating which type of index to print
432  C                  INDEX_K    => /* K = nnn */  C                  INDEX_K    => /* K = nnn */
433  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
434  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
435  C                  INDEX_NONE =>  C                  INDEX_NONE =>
436  C     compact -  Flag to control use of repeat symbol for same valued  C     markEnd :: Flag to control whether there is a separator after the
 C                fields.  
 C     markEnd -  Flag to control whether there is a separator after the  
437  C                last element  C                last element
438  C     ioUnit -  Unit number for IO.  C     compact :: Flag to control use of repeat symbol for same valued
439        INTEGER lFld  C                fields.
440    C     ioUnit  :: Unit number for IO.
441          INTEGER iFirst, iLast
442          LOGICAL fld(iFirst:iLast)
443        INTEGER index_type        INTEGER index_type
       LOGICAL fld(lFld)  
444        LOGICAL markEnd        LOGICAL markEnd
445        LOGICAL compact        LOGICAL compact
446        INTEGER ioUnit        INTEGER ioUnit
 CEndifinterface  
447    
448    C     !LOCAL VARIABLES:
449  C     == Local variables ==  C     == Local variables ==
450  C     iLo  - Range index holders for selecting elements with  C     iLo  - Range index holders for selecting elements with
451  C     iHi    with the same value  C     iHi    with the same value
# Line 276  C     K    - Loop counter Line 463  C     K    - Loop counter
463        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
464        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
465        CHARACTER*3 index_lab        CHARACTER*3 index_lab
466          CHARACTER*25 fmt1, fmt2
467        INTEGER K        INTEGER K
468    CEOP
469    
470        IF     ( index_type .EQ. INDEX_I ) THEN        IF     ( index_type .EQ. INDEX_I ) THEN
471         index_lab = 'I ='         index_lab = 'I ='
# Line 287  C     K    - Loop counter Line 476  C     K    - Loop counter
476        ELSE        ELSE
477         index_lab = '?='         index_lab = '?='
478        ENDIF        ENDIF
479    C-    fortran format to write 1 or 2 indices:
480          fmt1='(A,1X,A,I3,1X,A)'
481          fmt2='(A,1X,A,I3,A,I3,1X,A)'
482          IF ( iLast.GE.1000 ) THEN
483            K = 1+INT(LOG10(FLOAT(iLast)))
484            WRITE(fmt1,'(A,I1,A)')      '(A,1X,A,I',K,',1X,A)'
485            WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)'
486          ENDIF
487        commOpen  = '/*'        commOpen  = '/*'
488        commClose = '*/'        commClose = '*/'
489        iLo = 1        iLo = iFirst
490        iHi = 1        iHi = iFirst
491        punc = ','        punc = ','
492        xOld = fld(1)        xOld = fld(iFirst)
493        DO K=2,lFld        DO K = iFirst+1,iLast
494         xNew = fld(K  )         xNew = fld(K  )
495         IF ( .NOT. compact .OR. (xNew .NEQV. xOld) ) THEN         IF ( .NOT. compact .OR. (xNew .NEQV. xOld) ) THEN
496          nDup = iHi-iLo+1          nDup = iHi-iLo+1
497          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
498           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
499           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
500       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt1)
501       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
502          ELSE          ELSE
503           WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc
504           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
505       &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt2)
506       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
507          ENDIF          ENDIF
508          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
# Line 321  C     K    - Loop counter Line 518  C     K    - Loop counter
518        nDup = iHi-iLo+1        nDup = iHi-iLo+1
519        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
520         WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
521         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
522       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
523       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
524        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
525         WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc
526         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
527       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
528       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
529        ENDIF        ENDIF
530        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
# Line 335  C     K    - Loop counter Line 532  C     K    - Loop counter
532        RETURN        RETURN
533        END        END
534    
535  CStartofinterface  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
536        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type,  CBOP
537       &    markEnd, compact, ioUnit )  C     !ROUTINE: PRINT_LIST_RL
538  C     /==========================================================\  C     !INTERFACE:
539  C     | o SUBROUTINE PRINT_LIST_R8                               |        SUBROUTINE PRINT_LIST_RL( fld, iFirst, iLast, index_type,
540  C     |==========================================================|       &                          markEnd, compact, ioUnit )
541  C     | Routine for producing list of values for a field with    |  
542  C     | duplicate values collected into                          |  C     !DESCRIPTION:
543  C     |    n @ value                                             |  C     *==========================================================*
544  C     | record.                                                  |  C     | o SUBROUTINE PRINT\_LIST\_RL
545  C     \==========================================================/  C     *==========================================================*
546    C     | Routine for producing list of values for a field with
547    C     | duplicate values collected into
548    C     |    n \@ value
549    C     | record.
550    C     *==========================================================*
551    
552    C     !USES:
553        IMPLICIT NONE        IMPLICIT NONE
554    
555  C     == Global data ==    C     == Global data ==
556  #include "SIZE.h"  #include "SIZE.h"
557  #include "EEPARAMS.h"  #include "EEPARAMS.h"
558    
559    C     !INPUT/OUTPUT PARAMETERS:
560  C     == Routine arguments ==  C     == Routine arguments ==
561  C     fld    -  Data to be printed  C     fld     :: Data to be printed
562  C     lFld   -  Number of elements to be printed  C     iFirst  :: First element to print
563  C     index_type - Flag indicating which type of index to print  C     iLast   :: Last element to print
564    C  index_type :: Flag indicating which type of index to print
565  C                  INDEX_K    => /* K = nnn */  C                  INDEX_K    => /* K = nnn */
566  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
567  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
568  C                  INDEX_NONE =>  C                  INDEX_NONE =>
569  C     compact -  Flag to control use of repeat symbol for same valued  C     markEnd :: Flag to control whether there is a separator after the
 C                fields.  
 C     markEnd -  Flag to control whether there is a separator after the  
570  C                last element  C                last element
571  C     ioUnit -  Unit number for IO.  C     compact :: Flag to control use of repeat symbol for same valued
572        INTEGER lFld  C                fields.
573    C     ioUnit  :: Unit number for IO.
574          INTEGER iFirst, iLast
575          _RL     fld(iFirst:iLast)
576        INTEGER index_type        INTEGER index_type
       Real*8  fld(lFld)  
577        LOGICAL markEnd        LOGICAL markEnd
578        LOGICAL compact        LOGICAL compact
579        INTEGER ioUnit        INTEGER ioUnit
 CEndifinterface  
580    
581    C     !LOCA VARIABLES:
582  C     == Local variables ==  C     == Local variables ==
583  C     iLo  - Range index holders for selecting elements with  C     iLo  - Range index holders for selecting elements with
584  C     iHi    with the same value  C     iHi    with the same value
# Line 385  C     K    - Loop counter Line 591  C     K    - Loop counter
591        INTEGER iLo        INTEGER iLo
592        INTEGER iHi        INTEGER iHi
593        INTEGER nDup        INTEGER nDup
594        Real*8 xNew, xOld        _RL     xNew, xOld
595        CHARACTER punc        CHARACTER punc
596        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
597        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
598        CHARACTER*3 index_lab        CHARACTER*3 index_lab
599          CHARACTER*25 fmt1, fmt2
600        INTEGER K        INTEGER K
601    CEOP
602    
603        IF     ( index_type .EQ. INDEX_I ) THEN        IF     ( index_type .EQ. INDEX_I ) THEN
604         index_lab = 'I ='         index_lab = 'I ='
# Line 401  C     K    - Loop counter Line 609  C     K    - Loop counter
609        ELSE        ELSE
610         index_lab = '?='         index_lab = '?='
611        ENDIF        ENDIF
612    C-    fortran format to write 1 or 2 indices:
613          fmt1='(A,1X,A,I3,1X,A)'
614          fmt2='(A,1X,A,I3,A,I3,1X,A)'
615          IF ( iLast.GE.1000 ) THEN
616            K = 1+INT(LOG10(FLOAT(iLast)))
617            WRITE(fmt1,'(A,I1,A)')      '(A,1X,A,I',K,',1X,A)'
618            WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)'
619          ENDIF
620        commOpen  = '/*'        commOpen  = '/*'
621        commClose = '*/'        commClose = '*/'
622        iLo = 1        iLo = iFirst
623        iHi = 1        iHi = iFirst
624        punc = ','        punc = ','
625        xOld = fld(1)        xOld = fld(iFirst)
626        DO K=2,lFld        DO K = iFirst+1,iLast
627         xNew = fld(K  )         xNew = fld(K  )
628         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
629          nDup = iHi-iLo+1          nDup = iHi-iLo+1
630          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
631           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
632           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
633       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt1)
634       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
635          ELSE          ELSE
636           WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
637           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
638       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt2)
639       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
640          ENDIF          ENDIF
641          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
      &    SQUEEZE_RIGHT , 1)  
642          iLo  = K          iLo  = K
643          iHi  = K          iHi  = K
644          xOld = xNew          xOld = xNew
# Line 436  C     K    - Loop counter Line 651  C     K    - Loop counter
651        nDup = iHi-iLo+1        nDup = iHi-iLo+1
652        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
653         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
654         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
655       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &  WRITE(msgBuf(45:),fmt1)
656       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
657        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
658         WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
659         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
660       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),fmt2)
661       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
662        ENDIF        ENDIF
663        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
      &    SQUEEZE_RIGHT , 1)  
664    
665        RETURN        RETURN
666        END        END
667    
668  CStartOfInterface  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
669    CBOP
670    C     !ROUTINE: PRINT_MAPRS
671    C     !INTERFACE:
672        SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,
673       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
674       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
# Line 459  CStartOfInterface Line 676  CStartOfInterface
676       I       kMin, kMax,   kStr,       I       kMin, kMax,   kStr,
677       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
678       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
679  C     /==========================================================\  
680  C     | SUBROUTINE PRINT_MAPR4                                   |  C     !DESCRIPTION:
681  C     | o Does textual mapping printing of a field.              |  C     *==========================================================*
682  C     |==========================================================|  C     | SUBROUTINE PRINT\_MAPRS
683  C     | This routine does the actual formatting of the data      |  C     | o Does textual mapping printing of a field.
684  C     | and printing to a file. It assumes an array using the    |  C     *==========================================================*
685  C     | MITgcm UV indexing scheme and base index variables.      |  C     | This routine does the actual formatting of the data
686  C     | User code should call an interface routine like          |  C     | and printing to a file. It assumes an array using the
687  C     | PLOT_FIELD_XYR4( ... ) rather than this code directly.   |  C     | MITgcm UV indexing scheme and base index variables.
688  C     | Text plots can be oriented XY, YZ, XZ. An orientation    |  C     | User code should call an interface routine like
689  C     | is specficied through the "plotMode" argument. All the   |  C     | PLOT\_FIELD\_XYRS( ... ) rather than this code directly.
690  C     | plots made by a single call to this routine will use the |  C     | Text plots can be oriented XY, YZ, XZ. An orientation
691  C     | same contour interval. The plot range (iMin,...,byStr)   |  C     | is specficied through the "plotMode" argument. All the
692  C     | can be three-dimensional. A separate plot is made for    |  C     | plots made by a single call to this routine will use the
693  C     | each point in the plot range normal to the orientation.  |  C     | same contour interval. The plot range (iMin,...,byStr)
694  C     | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY). |  C     | can be three-dimensional. A separate plot is made for
695  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY|  C     | each point in the plot range normal to the orientation.
696  C     |      plots - one for K=1, one for K=3 and one for K=5.   |  C     | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY).
697  C     |      Each plot would have extents iMin:iMax step iStr    |  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY
698  C     |      and jMin:jMax step jStr.                            |  C     |      plots - one for K=1, one for K=3 and one for K=5.
699  C     \==========================================================/  C     |      Each plot would have extents iMin:iMax step iStr
700    C     |      and jMin:jMax step jStr.
701    C     *==========================================================*
702    
703    C     !USES:
704        IMPLICIT NONE        IMPLICIT NONE
705    
706  C     == Global variables ==  C     == Global variables ==
707  #include "SIZE.h"  #include "SIZE.h"
708  #include "EEPARAMS.h"  #include "EEPARAMS.h"
709  #include "EESUPPORT.h"        INTEGER  IFNBLNK
710          EXTERNAL IFNBLNK
711          INTEGER  ILNBLNK
712          EXTERNAL ILNBLNK
713    
714    C     !INPUT/OUTPUT PARAMETERS:
715  C     == Routine arguments ==  C     == Routine arguments ==
716  C     fld        - Real*4 array holding data to be plotted  C     fld        - Real*4 array holding data to be plotted
717  C     fldTitle   - Name of field to be plotted  C     fldTitle   - Name of field to be plotted
# Line 497  C     jLo, jHi     be five-dimensional. Line 722  C     jLo, jHi     be five-dimensional.
722  C     kLo, kHi  C     kLo, kHi
723  C     nBx, nBy  C     nBx, nBy
724  C     iMin, iMax - Indexing for points to plot. Points from  C     iMin, iMax - Indexing for points to plot. Points from
725  C     iStr         iMin -> iMax in steps of iStr are plotted  C     iStr         iMin -> iMax in steps of iStr are plotted
726  C     jMin. jMax   and similarly for jMin, jMax, jStr and  C     jMin. jMax   and similarly for jMin, jMax, jStr and
727  C     jStr         kMin, kMax, kStr and bxMin, bxMax, bxStr  C     jStr         kMin, kMax, kStr and bxMin, bxMax, bxStr
728  C     kMin, kMax   byMin, byMax, byStr.  C     kMin, kMax   byMin, byMax, byStr.
# Line 514  C     kStr Line 739  C     kStr
739        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
740        INTEGER bxMin, bxMax, bxStr        INTEGER bxMin, bxMax, bxStr
741        INTEGER byMin, byMax, byStr        INTEGER byMin, byMax, byStr
 CEndOfInterface  
 C     == Local variables ==  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
742    
743    C     !LOCAL VARIABLES:
744  C     == Local variables ==  C     == Local variables ==
745  C     plotBuf - Buffer for building plot record  C     plotBuf - Buffer for building plot record
746  C     chList  - Character string used for plot  C     chList  - Character string used for plot
# Line 544  C               Min  - Start index withi Line 764  C               Min  - Start index withi
764  C               Max  - End index within block  C               Max  - End index within block
765  C               Str  - stride within block  C               Str  - stride within block
766        INTEGER MAX_LEN_PLOTBUF        INTEGER MAX_LEN_PLOTBUF
767        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 )        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-20 )
768        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf
769        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
770        INTEGER lChList        INTEGER lChList
# Line 569  C               Str  - stride within blo Line 789  C               Str  - stride within blo
789        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx
790        INTEGER bi, bj, bk        INTEGER bi, bj, bk
791        LOGICAL validRange        LOGICAL validRange
792    CEOP
793    
794        chList = '-abcdefghijklmnopqrstuvwxyz+'        chList = '-abcdefghijklmnopqrstuvwxyz+'
795        small  =  1. _d -15        small  =  1. _d -15
# Line 583  C--   Calculate field range Line 804  C--   Calculate field range
804           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
805            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
806             IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN             IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN
807              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
808       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
809              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
810       &       fMax = fld(I,J,K,bi,bj)       &       fMax = fld(I,J,K,bi,bj)
811             ENDIF             ENDIF
812            ENDDO            ENDDO
# Line 594  C--   Calculate field range Line 815  C--   Calculate field range
815         ENDDO         ENDDO
816        ENDDO        ENDDO
817        fRange = fMax-fMin        fRange = fMax-fMin
818        IF ( fRange .GT. small ) THEN        IF ( fRange .GT. small ) validRange = .TRUE.
        validRange = .TRUE.  
       ENDIF  
819    
820  C--   Write field title and statistics  C--   Write field title and statistics
821        msgBuf =        msgBuf =
822       & '// ======================================================='       & '// ======================================================='
823        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
824       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
# Line 658  C--   Write field title and statistics Line 877  C--   Write field title and statistics
877       &  ':',kStr,')'       &  ':',kStr,')'
878        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
879       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
880        msgBuf =        msgBuf =
881       & '// ======================================================='       & '// ======================================================='
882        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
883       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
884    
885    c     if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
886    c      msgBuf =
887    c    &  'Model domain too big to print to terminal - skipping I/O'
888    c      CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
889    c    &                   SQUEEZE_RIGHT, 1)
890    c      RETURN
891    c     endif
892    
893  C--   Write field  C--   Write field
894  C     Figure out slice type and set plotting parameters appropriately  C     Figure out slice type and set plotting parameters appropriately
895  C     acc = accross the page  C     acc = accross the page
# Line 755  C      X across, Z down slice Line 982  C      X across, Z down slice
982         pltStep = sNy         pltStep = sNy
983         pltLab  = 'J ='         pltLab  = 'J ='
984        ENDIF        ENDIF
985  C     IF ( validRange ) THEN  C-    check if it fits into buffer (-10 should be enough but -12 is safer):
986          IF ( (accMax-accMin+1)*(accBhi-accBlo+1).GT.MAX_LEN_PLOTBUF-12
987         &     .AND. validRange ) THEN
988           msgBuf =
989         &  'Model domain too big to print to terminal - skipping I/O'
990           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
991         &                   SQUEEZE_RIGHT, 1)
992           validRange = .FALSE.
993          ENDIF
994          IF ( validRange ) THEN
995  C      Header  C      Header
996  C      Data  C      Data
997         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
# Line 765  C      Data Line 1001  C      Data
1001           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1002       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
1003           plotBuf = ' '           plotBuf = ' '
1004           iBuf = 6           iBuf = 6
1005           DO bi=accBlo, accBhi, accBstr           DO bi=accBlo, accBhi, accBstr
1006            DO I=accMin, accMax, accStr            DO I=accMin, accMax, accStr
1007             iDx = accBase-1+(bi-1)*accStep+I             iDx = accBase-1+(bi-1)*accStep+I
# Line 787  C      Data Line 1023  C      Data
1023           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1024       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
1025           plotBuf = dwnLab           plotBuf = dwnLab
1026           iBuf = 7           iBuf = 7
1027           DO bi=accBlo, accBhi, accBstr           DO bi=accBlo, accBhi, accBstr
1028            DO I=accMin, accMax, accStr            DO I=accMin, accMax, accStr
1029             iDx = accBase-1+(bi-1)*accStep+I             iDx = accBase-1+(bi-1)*accStep+I
# Line 795  C      Data Line 1031  C      Data
1031             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
1032              WRITE(plotBuf(iBuf:),'(A)')  '|'              WRITE(plotBuf(iBuf:),'(A)')  '|'
1033             ELSE             ELSE
1034              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10)
1035             ENDIF             ENDIF
1036            ENDDO            ENDDO
1037           ENDDO           ENDDO
# Line 804  C      Data Line 1040  C      Data
1040       &                    SQUEEZE_RIGHT, 1)       &                    SQUEEZE_RIGHT, 1)
1041           DO bj=dwnBlo, dwnBhi, dwnBStr           DO bj=dwnBlo, dwnBhi, dwnBStr
1042            DO J=dwnMin, dwnMax, dwnStr            DO J=dwnMin, dwnMax, dwnStr
1043             WRITE(plotBuf,'(1X,I5,1X)')             WRITE(plotBuf,'(1X,I5,1X)')
1044       &      dwnBase-1+(bj-1)*dwnStep+J       &      dwnBase-1+(bj-1)*dwnStep+J
1045             iBuf = 7             iBuf = 7
1046             DO bi=accBlo,accBhi,accBstr             DO bi=accBlo,accBhi,accBstr
# Line 818  C      Data Line 1054  C      Data
1054                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
1055               ENDIF               ENDIF
1056               IF ( validRange .AND. val .NE. 0. ) THEN               IF ( validRange .AND. val .NE. 0. ) THEN
1057                IDX = NINT(                IDX = NINT(
1058       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1059       &             )+1       &             )+1
1060               ELSE               ELSE
1061                IDX = 1                IDX = 1
1062               ENDIF               ENDIF
1063               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1064       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1065               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
1066                IF ( iBuf .LE. MAX_LEN_PLOTBUF )                IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1067       &         plotBuf(iBuf:iBuf) = '.'       &         plotBuf(iBuf:iBuf) = '.'
1068               ENDIF               ENDIF
1069              ENDDO              ENDDO
# Line 839  C      Data Line 1075  C      Data
1075           ENDDO           ENDDO
1076          ENDDO          ENDDO
1077         ENDDO         ENDDO
1078  C     ENDIF        ENDIF
1079  C--   Write delimiter  C--   Write delimiter
1080        msgBuf =        msgBuf =
1081       & '// ======================================================='       & '// ======================================================='
1082        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1083       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1084        msgBuf =        msgBuf =
1085       & '// END OF FIELD                                          ='       & '// END OF FIELD                                          ='
1086        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1087       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1088        msgBuf =        msgBuf =
1089       & '// ======================================================='       & '// ======================================================='
1090        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1091       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
# Line 860  C--   Write delimiter Line 1096  C--   Write delimiter
1096        RETURN        RETURN
1097        END        END
1098    
1099  CStartOfInterface  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
1100    CBOP
1101    C     !ROUTINE: PRINT_MAPRL
1102    C     !INTERFACE:
1103        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
1104       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
1105       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
# Line 868  CStartOfInterface Line 1107  CStartOfInterface
1107       I       kMin, kMax,   kStr,       I       kMin, kMax,   kStr,
1108       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
1109       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
1110  C     /==========================================================\  
1111  C     | SUBROUTINE PRINT_MAPRL                                   |  C     !DESCRIPTION:
1112  C     | o Does textual mapping printing of a field.              |  C     *==========================================================*
1113  C     |==========================================================|  C     | SUBROUTINE PRINT\_MAPRL
1114  C     | This routine does the actual formatting of the data      |  C     | o Does textual mapping printing of a field.
1115  C     | and printing to a file. It assumes an array using the    |  C     *==========================================================*
1116  C     | MITgcm UV indexing scheme and base index variables.      |  C     | This routine does the actual formatting of the data
1117  C     | User code should call an interface routine like          |  C     | and printing to a file. It assumes an array using the
1118  C     | PLOT_FIELD_XYR8( ... ) rather than this code directly.   |  C     | MITgcm UV indexing scheme and base index variables.
1119  C     | Text plots can be oriented XY, YZ, XZ. An orientation    |  C     | User code should call an interface routine like
1120  C     | is specficied through the "plotMode" argument. All the   |  C     | PLOT\_FIELD\_XYRL( ... ) rather than this code directly.
1121  C     | plots made by a single call to this routine will use the |  C     | Text plots can be oriented XY, YZ, XZ. An orientation
1122  C     | same contour interval. The plot range (iMin,...,byStr)   |  C     | is specficied through the "plotMode" argument. All the
1123  C     | can be three-dimensional. A separate plot is made for    |  C     | plots made by a single call to this routine will use the
1124  C     | each point in the plot range normal to the orientation.  |  C     | same contour interval. The plot range (iMin,...,byStr)
1125  C     | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY). |  C     | can be three-dimensional. A separate plot is made for
1126  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY|  C     | each point in the plot range normal to the orientation.
1127  C     |      plots - one for K=1, one for K=3 and one for K=5.   |  C     | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY).
1128  C     |      Each plot would have extents iMin:iMax step iStr    |  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY
1129  C     |      and jMin:jMax step jStr.                            |  C     |      plots - one for K=1, one for K=3 and one for K=5.
1130  C     \==========================================================/  C     |      Each plot would have extents iMin:iMax step iStr
1131    C     |      and jMin:jMax step jStr.
1132    C     *==========================================================*
1133    
1134    C     !USES:
1135        IMPLICIT NONE        IMPLICIT NONE
1136    
1137  C     == Global variables ==  C     == Global variables ==
1138  #include "SIZE.h"  #include "SIZE.h"
1139  #include "EEPARAMS.h"  #include "EEPARAMS.h"
1140  #include "EESUPPORT.h"        INTEGER  IFNBLNK
1141          EXTERNAL IFNBLNK
1142          INTEGER  ILNBLNK
1143          EXTERNAL ILNBLNK
1144    
1145    C     !INPUT/OUTPUT PARAMETERS:
1146  C     == Routine arguments ==  C     == Routine arguments ==
1147  C     fld        - Real*8 array holding data to be plotted  C     fld        - Real*8 array holding data to be plotted
1148  C     fldTitle   - Name of field to be plotted  C     fldTitle   - Name of field to be plotted
# Line 906  C     jLo, jHi     be five-dimensional. Line 1153  C     jLo, jHi     be five-dimensional.
1153  C     kLo, kHi  C     kLo, kHi
1154  C     nBx, nBy  C     nBx, nBy
1155  C     iMin, iMax - Indexing for points to plot. Points from  C     iMin, iMax - Indexing for points to plot. Points from
1156  C     iStr         iMin -> iMax in steps of iStr are plotted  C     iStr         iMin -> iMax in steps of iStr are plotted
1157  C     jMin. jMax   and similarly for jMin, jMax, jStr and  C     jMin. jMax   and similarly for jMin, jMax, jStr and
1158  C     jStr         kMin, kMax, kStr and bxMin, bxMax, bxStr  C     jStr         kMin, kMax, kStr and bxMin, bxMax, bxStr
1159  C     kMin, kMax   byMin, byMax, byStr.  C     kMin, kMax   byMin, byMax, byStr.
# Line 923  C     kStr Line 1170  C     kStr
1170        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
1171        INTEGER bxMin, bxMax, bxStr        INTEGER bxMin, bxMax, bxStr
1172        INTEGER byMin, byMax, byStr        INTEGER byMin, byMax, byStr
 CEndOfInterface  
 C     == Local variables ==  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
1173    
1174    C     !LOCAL VARIABLES:
1175  C     == Local variables ==  C     == Local variables ==
1176  C     plotBuf - Buffer for building plot record  C     plotBuf - Buffer for building plot record
1177  C     chList  - Character string used for plot  C     chList  - Character string used for plot
# Line 953  C               Min  - Start index withi Line 1195  C               Min  - Start index withi
1195  C               Max  - End index within block  C               Max  - End index within block
1196  C               Str  - stride within block  C               Str  - stride within block
1197        INTEGER MAX_LEN_PLOTBUF        INTEGER MAX_LEN_PLOTBUF
1198        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 )        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-20 )
1199        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf
1200        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
1201        INTEGER lChList        INTEGER lChList
# Line 978  C               Str  - stride within blo Line 1220  C               Str  - stride within blo
1220        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx
1221        INTEGER bi, bj, bk        INTEGER bi, bj, bk
1222        LOGICAL validRange        LOGICAL validRange
1223    CEOP
1224    
1225        chList = '-abcdefghijklmnopqrstuvwxyz+'        chList = '-abcdefghijklmnopqrstuvwxyz+'
1226        small  = 1. _d -15        small  = 1. _d -15
# Line 991  C--   Calculate field range Line 1234  C--   Calculate field range
1234          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
1235           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
1236            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
1237             IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )             IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )
1238       &     THEN       &     THEN
1239              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
1240       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
1241              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
1242       &       fMax = fld(I,J,K,bi,bj)       &       fMax = fld(I,J,K,bi,bj)
1243             ENDIF             ENDIF
1244            ENDDO            ENDDO
# Line 1004  C--   Calculate field range Line 1247  C--   Calculate field range
1247         ENDDO         ENDDO
1248        ENDDO        ENDDO
1249        fRange = fMax-fMin        fRange = fMax-fMin
1250        IF ( fRange .GT. small ) THEN        IF ( fRange .GT. small ) validRange = .TRUE.
        validRange = .TRUE.  
       ENDIF  
1251    
1252  C--   Write field title and statistics  C--   Write field title and statistics
1253        msgBuf =        msgBuf =
1254       & '// ======================================================='       & '// ======================================================='
1255        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1256       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
# Line 1068  C--   Write field title and statistics Line 1309  C--   Write field title and statistics
1309       &  ':',kStr,')'       &  ':',kStr,')'
1310        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1311       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1312        msgBuf =        msgBuf =
1313       & '// ======================================================='       & '// ======================================================='
1314        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1315       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1316    
1317    c     if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
1318    c      msgBuf =
1319    c    &  'Model domain too big to print to terminal - skipping I/O'
1320    c      CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1321    c    &                   SQUEEZE_RIGHT, 1)
1322    c      RETURN
1323    c     endif
1324    
1325  C--   Write field  C--   Write field
1326  C     Figure out slice type and set plotting parameters appropriately  C     Figure out slice type and set plotting parameters appropriately
1327  C     acc = accross the page  C     acc = accross the page
# Line 1165  C      X across, Z down slice Line 1414  C      X across, Z down slice
1414         pltStep = sNy         pltStep = sNy
1415         pltLab  = 'J ='         pltLab  = 'J ='
1416        ENDIF        ENDIF
1417  C     IF ( validRange ) THEN  C-    check if it fits into buffer (-10 should be enough but -12 is safer):
1418          IF ( (accMax-accMin+1)*(accBhi-accBlo+1).GT.MAX_LEN_PLOTBUF-12
1419         &     .AND. validRange ) THEN
1420           msgBuf =
1421         &  'Model domain too big to print to terminal - skipping I/O'
1422           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1423         &                   SQUEEZE_RIGHT, 1)
1424           validRange = .FALSE.
1425          ENDIF
1426          IF ( validRange ) THEN
1427  C      Header  C      Header
1428  C      Data  C      Data
1429         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
# Line 1175  C      Data Line 1433  C      Data
1433           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1434       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
1435           plotBuf = ' '           plotBuf = ' '
1436           iBuf = 6           iBuf = 6
1437           DO bi=accBlo, accBhi, accBstr           DO bi=accBlo, accBhi, accBstr
1438            DO I=accMin, accMax, accStr            DO I=accMin, accMax, accStr
1439             iDx = accBase-1+(bi-1)*accStep+I             iDx = accBase-1+(bi-1)*accStep+I
# Line 1196  C      Data Line 1454  C      Data
1454           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1455       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
1456           plotBuf = dwnLab           plotBuf = dwnLab
1457           iBuf = 7           iBuf = 7
1458           DO bi=accBlo, accBhi, accBstr           DO bi=accBlo, accBhi, accBstr
1459            DO I=accMin, accMax, accStr            DO I=accMin, accMax, accStr
1460             iDx = accBase-1+(bi-1)*accStep+I             iDx = accBase-1+(bi-1)*accStep+I
# Line 1204  C      Data Line 1462  C      Data
1462             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
1463              WRITE(plotBuf(iBuf:),'(A)')  '|'              WRITE(plotBuf(iBuf:),'(A)')  '|'
1464             ELSE             ELSE
1465              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10)
1466             ENDIF             ENDIF
1467            ENDDO            ENDDO
1468           ENDDO           ENDDO
# Line 1212  C      Data Line 1470  C      Data
1470       &                    SQUEEZE_RIGHT, 1)       &                    SQUEEZE_RIGHT, 1)
1471           DO bj=dwnBlo, dwnBhi, dwnBStr           DO bj=dwnBlo, dwnBhi, dwnBStr
1472            DO J=dwnMin, dwnMax, dwnStr            DO J=dwnMin, dwnMax, dwnStr
1473             WRITE(plotBuf,'(1X,I5,1X)')             WRITE(plotBuf,'(1X,I5,1X)')
1474       &      dwnBase-1+(bj-1)*dwnStep+J       &      dwnBase-1+(bj-1)*dwnStep+J
1475             iBuf = 7             iBuf = 7
1476             DO bi=accBlo,accBhi,accBstr             DO bi=accBlo,accBhi,accBstr
# Line 1226  C      Data Line 1484  C      Data
1484                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
1485               ENDIF               ENDIF
1486               IF ( validRange .AND. val .NE. 0. ) THEN               IF ( validRange .AND. val .NE. 0. ) THEN
1487                IDX = NINT(                IDX = NINT(
1488       &               FLOAT( lChList-1 )*( val-fMin ) / (fRange)       &               FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1489       &              )+1       &              )+1
1490               ELSE               ELSE
1491                IDX = 1                IDX = 1
1492               ENDIF               ENDIF
1493               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1494       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1495               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
1496                IF ( iBuf .LE. MAX_LEN_PLOTBUF )                IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1497       &         plotBuf(iBuf:iBuf) = '.'       &         plotBuf(iBuf:iBuf) = '.'
1498               ENDIF               ENDIF
1499              ENDDO              ENDDO
# Line 1246  C      Data Line 1504  C      Data
1504           ENDDO           ENDDO
1505          ENDDO          ENDDO
1506         ENDDO         ENDDO
1507  C     ENDIF        ENDIF
1508  C--   Write delimiter  C--   Write delimiter
1509        msgBuf =        msgBuf =
1510       & '// ======================================================='       & '// ======================================================='
1511        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1512       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1513        msgBuf =        msgBuf =
1514       & '// END OF FIELD                                          ='       & '// END OF FIELD                                          ='
1515        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1516       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1517        msgBuf =        msgBuf =
1518       & '// ======================================================='       & '// ======================================================='
1519        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1520       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
# Line 1266  C--   Write delimiter Line 1524  C--   Write delimiter
1524    
1525        RETURN        RETURN
1526        END        END
   
 CStartOfInterface  
       SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )  
 C     /============================================================\  
 C     | SUBROUTINE PRINT_MESSAGE                                   |  
 C     | o Write out informational message using "standard" format. |  
 C     | Notes                                                      |  
 C     | =====                                                      |  
 C     | o Some system   I/O is not "thread-safe". For this reason  |  
 C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |  
 C     |   critical region is defined around the write here. In some|  
 C     |   cases  BEGIN_CRIT() is approximated by only doing writes |  
 C     |   for thread number 1 - writes for other threads are       |  
 C     |   ignored!                                                 |  
 C     | o In a non-parallel form these routines can still be used. |  
 C     |   to produce pretty printed output!                        |  
 C     \============================================================/  
       IMPLICIT NONE  
 C     == Global data ==  
 #include "SIZE.h"  
 #include "EEPARAMS.h"  
 #include "EESUPPORT.h"  
 C     == Routine arguments ==  
 C     message - Message to write  
 C     unit    - Unit number to write to  
 C     sq      - Justification option  
       CHARACTER*(*) message  
       INTEGER       unit  
       CHARACTER*(*) sq  
       INTEGER  myThid  
 CEndOfInterface  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
 C     == Local variables ==  
       INTEGER iStart  
       INTEGER iEnd  
       CHARACTER*9 idString  
 C--   Find beginning and end of message  
       IF ( sq .EQ. SQUEEZE_BOTH .OR.  
      &     sq .EQ. SQUEEZE_LEFT ) THEN  
        iStart = IFNBLNK( message )  
       ELSE  
        iStart = 1  
       ENDIF  
       IF ( sq .EQ. SQUEEZE_BOTH .OR.  
      &     sq .EQ. SQUEEZE_RIGHT ) THEN  
        iEnd   = ILNBLNK( message )  
       ELSE  
        iEnd   = LEN(message)  
       ENDIF  
 C--   Test to see if in multi-process ( or multi-threaded ) mode.  
 C     If so include process or thread identifier.  
       IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN  
 C--    Write single process format  
        IF ( message .EQ. ' ' ) THEN  
         WRITE(unit,'(A)') ' '  
        ELSE  
         WRITE(unit,'(A)') message(iStart:iEnd)  
        ENDIF  
       ELSEIF ( pidIO .EQ. myProcId ) THEN  
 C--    Write multi-process format  
 #ifndef FMTFTN_IO_THREAD_SAFE  
        _BEGIN_CRIT(myThid)  
 #endif  
         WRITE(idString,'(I4.4,A,I4.4)') myProcId,'.',myThid  
 #ifndef FMTFTN_IO_THREAD_SAFE  
        _END_CRIT(myThid)  
 #endif  
        IF ( message .EQ. ' ' ) THEN  
 C       PRINT can be called by several threads simultaneously.  
 C       The write statement may need to ne marked as a critical section.  
 #ifndef FMTFTN_IO_THREAD_SAFE  
         _BEGIN_CRIT(myThid)  
 #endif  
          WRITE(unit,'(A,A,A,A,A,A)',ERR=999)  
      &   '(',PROCESS_HEADER,' ',idString,')',' '  
 #ifndef FMTFTN_IO_THREAD_SAFE  
         _END_CRIT(myThid)  
 #endif  
        ELSE  
 #ifndef FMTFTN_IO_THREAD_SAFE  
         _BEGIN_CRIT(myThid)  
 #endif  
          WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)  
      &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',  
      &   message(iStart:iEnd)  
 #ifndef FMTFTN_IO_THREAD_SAFE  
         _END_CRIT(myThid)  
 #endif  
        ENDIF  
       ENDIF  
 C  
  1000 CONTINUE  
       RETURN  
   999 CONTINUE  
        ioErrorCount(myThid) = ioErrorCount(myThid)+1  
       GOTO 1000  
   
       END  
Legend:
Removed from v.1.17  
changed lines
  Added in v.1.30
  ViewVC Help
Powered by ViewVC 1.1.22