/[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.20 by dimitri, Sat Jan 10 16:59:08 2004 UTC revision 1.31 by jmc, Fri Jun 19 03:05:13 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
   
 CBOP                
   
 C     !ROUTINE: PRINT_ERROR  
21    
22    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
23    CBOP
24    C     !ROUTINE: PRINT_MESSAGE
25  C     !INTERFACE:  C     !INTERFACE:
26        SUBROUTINE PRINT_ERROR( message , myThid )        SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )
       IMPLICIT NONE  
27    
28  C     !DESCRIPTION:  C     !DESCRIPTION:
29  C     *============================================================*  C     *============================================================*
30  C     | SUBROUTINE PRINT_ERROR                                        C     | SUBROUTINE PRINT\_MESSAGE
31  C     | o Write out error message using "standard" format.            C     | o Write out informational message using "standard" format.
32  C     *============================================================*  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 are still used    C     | o In a non-parallel form these routines can still be used.
42  C     |   to produce pretty printed output. The process and thread  C     |   to produce pretty printed output!
 C     |   id prefix is omitted in this case.  
43  C     *============================================================*  C     *============================================================*
44    
45  C     !USES:  C     !USES:
46          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"
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
52    
53  C     !INPUT/OUTPUT PARAMETERS:  C     !INPUT/OUTPUT PARAMETERS:
54  C     == Routine arguments ==  C     == Routine arguments ==
55  C     message :: Text string to print  C     message :: Message to write
56  C     myThid  :: Thread number of this instance  C     unit    :: Unit number to write to
57    C     sq      :: Justification option
58        CHARACTER*(*) message        CHARACTER*(*) message
59        INTEGER       myThid        INTEGER       unit
60          CHARACTER*(*) sq
61          INTEGER  myThid
62    
63    C     !FUNCTIONS:
64          INTEGER  IFNBLNK
65          EXTERNAL IFNBLNK
66          INTEGER  ILNBLNK
67          EXTERNAL ILNBLNK
68    
69  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
70  C     == Local variables ==  C     == Local variables ==
71  C     iStart, iEnd :: Temps. for string indexing  C     iStart, iEnd :: String indexing variables
72  C     idString     :: Temp. for building message prefix  C     idString     :: Temp. for building prefix.
73        INTEGER iStart        INTEGER iStart
74        INTEGER iEnd        INTEGER iEnd
75        CHARACTER*9 idString        CHARACTER*9 idString
76  CEOP  CEOP
77    
78  C--   Find beginning and end of message  C--   Find beginning and end of message
79        iStart = IFNBLNK( message )        IF ( sq .EQ. SQUEEZE_BOTH .OR.
80        iEnd   = ILNBLNK( message )       &     sq .EQ. SQUEEZE_LEFT ) THEN
81           iStart = IFNBLNK( message )
82          ELSE
83           iStart = 1
84          ENDIF
85          IF ( sq .EQ. SQUEEZE_BOTH .OR.
86         &     sq .EQ. SQUEEZE_RIGHT ) THEN
87           iEnd   = ILNBLNK( message )
88          ELSE
89           iEnd   = LEN(message)
90          ENDIF
91  C--   Test to see if in multi-process ( or multi-threaded ) mode.  C--   Test to see if in multi-process ( or multi-threaded ) mode.
92  C     If so include process or thread identifier.  C     If so include process or thread identifier.
93        IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN        IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN
94  C--    Write single process format  C--    Write single process format
95         IF ( message .EQ. ' ' ) THEN         IF ( message .EQ. ' ' ) THEN
96          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '          WRITE(unit,'(A)') ' '
97         ELSE         ELSE
98          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER,          WRITE(unit,'(A)') message(iStart:iEnd)
      &   message(iStart:iEnd)  
99         ENDIF         ENDIF
100        ELSEIF ( pidIO .EQ. myProcId ) THEN        ELSEIF ( pidIO .EQ. myProcId ) THEN
101  C--    Write multi-process format  C--    Write multi-process format
# Line 94  C--    Write multi-process format Line 107  C--    Write multi-process format
107         _END_CRIT(myThid)         _END_CRIT(myThid)
108  #endif  #endif
109         IF ( message .EQ. ' ' ) THEN         IF ( message .EQ. ' ' ) THEN
110  C       PRINT_ERROR can be called by several threads simulataneously.  C       PRINT can be called by several threads simultaneously.
111  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.
112  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
113          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
114  #endif  #endif
115          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)           WRITE(unit,'(A,A,A,A,A,A)',ERR=999)
116       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &   '(',PROCESS_HEADER,' ',idString,')',' '
      &  ' '  
117  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
118          _END_CRIT(myThid)          _END_CRIT(myThid)
119  #endif  #endif
# Line 109  C       The write statement may need to Line 121  C       The write statement may need to
121  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
122          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
123  #endif  #endif
124          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)           WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)
125       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',
126       &  message(iStart:iEnd)       &   message(iStart:iEnd)
127  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
128          _END_CRIT(myThid)          _END_CRIT(myThid)
129  #endif  #endif
130         ENDIF         ENDIF
131        ENDIF        ENDIF
132    
133    #ifndef DISABLE_WRITE_TO_UNIT_ZERO
134    C--   if error message, also write directly to unit 0 :
135          IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1
136         &     .AND. unit.EQ.errorMessageUnit ) THEN
137            iEnd   = ILNBLNK( message )
138            IF (iEnd.NE.0) WRITE(0,'(A)') message(1:iEnd)
139          ENDIF
140    #endif
141  C  C
142   1000 CONTINUE   1000 CONTINUE
143        RETURN        RETURN
   
144    999 CONTINUE    999 CONTINUE
145         ioErrorCount(myThid) = ioErrorCount(myThid)+1         ioErrorCount(myThid) = ioErrorCount(myThid)+1
146        GOTO 1000        GOTO 1000
147    
148        END        END
149    
150    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
151  CBOP  CBOP
152  C     !ROUTINE: PRINT_LIST_I  C     !ROUTINE: PRINT_ERROR
153    C     !INTERFACE:
154          SUBROUTINE PRINT_ERROR( message , myThid )
155    
156    C     !DESCRIPTION:
157    C     *============================================================*
158    C     | SUBROUTINE PRINT\_ERROR
159    C     | o Write out error message using "standard" format.
160    C     *============================================================*
161    C     | Notes
162    C     | =====
163    C     | o Some system   I/O is not "thread-safe". For this reason
164    C     |   without the FMTFTN\_IO\_THREAD\_SAFE directive set a
165    C     |   critical region is defined around the write here. In some
166    C     |   cases  BEGIN\_CRIT() is approximated by only doing writes
167    C     |   for thread number 1 - writes for other threads are
168    C     |   ignored!
169    C     | o In a non-parallel form these routines are still used
170    C     |   to produce pretty printed output. The process and thread
171    C     |   id prefix is omitted in this case.
172    C     *============================================================*
173    
174    C     !USES:
175          IMPLICIT NONE
176    
177    C     == Global data ==
178    #include "SIZE.h"
179    #include "EEPARAMS.h"
180    #include "EESUPPORT.h"
181    
182    C     !INPUT/OUTPUT PARAMETERS:
183    C     == Routine arguments ==
184    C     message :: Text string to print
185    C     myThid  :: Thread number of this instance
186          CHARACTER*(*) message
187          INTEGER       myThid
188    
189    C     !FUNCTIONS:
190    c     INTEGER  IFNBLNK
191    c     EXTERNAL IFNBLNK
192          INTEGER  ILNBLNK
193          EXTERNAL ILNBLNK
194    
195    C     !LOCAL VARIABLES:
196    C     == Local variables ==
197    C     iStart, iEnd :: Temps. for string indexing
198    C     idString     :: Temp. for building message prefix
199    c     INTEGER iStart
200          INTEGER iEnd
201          CHARACTER*9 idString
202    CEOP
203    
204    C--   Find beginning and end of message
205    c     iStart = IFNBLNK( message )
206          iEnd   = ILNBLNK( message )
207    C--   Test to see if in multi-process ( or multi-threaded ) mode.
208    C     If so include process or thread identifier.
209          IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN
210    C--    Write single process format
211           IF ( iEnd.EQ.0 ) THEN
212            WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '
213           ELSE
214            WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER,
215         &        message(1:iEnd)
216    c    &    message(iStart:iEnd)
217           ENDIF
218          ELSE
219    C       PRINT_ERROR can be called by several threads simulataneously.
220    C       The write statement may need to be marked as a critical section.
221    #ifndef FMTFTN_IO_THREAD_SAFE
222    # ifdef USE_OMP_THREADING
223    C$OMP CRITICAL
224    # else
225           _BEGIN_CRIT(myThid)
226    # endif
227    #endif
228           IF ( pidIO .EQ. myProcId ) THEN
229    C--    Write multi-process format
230             WRITE(idString,'(I4.4,A,I4.4)') myProcId,'.',myThid
231    
232             IF ( iEnd.EQ.0 ) THEN
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         &    ' '
237             ELSE
238    c         WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
239              WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')
240         &    '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
241         &        message(1:iEnd)
242    c    &    message(iStart:iEnd)
243             ENDIF
244           ENDIF
245    
246    #ifndef DISABLE_WRITE_TO_UNIT_ZERO
247    C--    also write directly to unit 0 :
248           IF ( numberOfProcs.EQ.1 .AND. iEnd.NE.0 ) THEN
249            IF ( nThreads.LE.1 ) THEN
250              WRITE(0,'(A)') message(1:iEnd)
251            ELSE
252              WRITE(0,'(A,I4.4,A,A)') '(TID ', myThid, ') ',
253         &                   message(1:iEnd)
254            ENDIF
255           ENDIF
256    #endif
257    
258    #ifndef FMTFTN_IO_THREAD_SAFE
259    # ifdef USE_OMP_THREADING
260    C$OMP END CRITICAL
261    # else
262            _END_CRIT(myThid)
263    # endif
264    #endif
265          ENDIF
266    
267     1000 CONTINUE
268          RETURN
269    
270    c 999 CONTINUE
271    c      ioErrorCount(myThid) = ioErrorCount(myThid)+1
272    c     GOTO 1000
273          END
274    
275    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
276    CBOP
277    C     !ROUTINE: PRINT_LIST_I
278  C     !INTERFACE:  C     !INTERFACE:
279        SUBROUTINE PRINT_LIST_I( fld, lFld, index_type,        SUBROUTINE PRINT_LIST_I( fld, iFirst, iLast, index_type,
280       &                         markEnd, compact, ioUnit )       &                         markEnd, compact, ioUnit )
281        IMPLICIT NONE  
282  C     !DESCRIPTION:  C     !DESCRIPTION:
283  C     *==========================================================*  C     *==========================================================*
284  C     | o SUBROUTINE PRINT_LIST_I                                  C     | o SUBROUTINE PRINT\_LIST\_I
285  C     *==========================================================*  C     *==========================================================*
286  C     | Routine for producing list of values for a field with      C     | Routine for producing list of values for a field with
287  C     | duplicate values collected into                            C     | duplicate values collected into
288  C     |    n @ value                                                C     |    n \@ value
289  C     | record.                                                    C     | record.
290  C     *==========================================================*  C     *==========================================================*
291    
292  C     !USES:  C     !USES:
293  C     == Global data ==          IMPLICIT NONE
294    
295    C     == Global data ==
296  #include "SIZE.h"  #include "SIZE.h"
297  #include "EEPARAMS.h"  #include "EEPARAMS.h"
298    
299  C     !INPUT/OUTPUT PARAMETERS:  C     !INPUT/OUTPUT PARAMETERS:
300  C     == Routine arguments ==  C     == Routine arguments ==
301  C     fld    ::  Data to be printed  C     fld     :: Data to be printed
302  C     lFld   ::  Number of elements to be printed  C     iFirst  :: First element to print
303  C     index_type :: Flag indicating which type of index to print  C     iLast   :: Last element to print
304  C                   INDEX_K    => /* K = nnn */  C  index_type :: Flag indicating which type of index to print
305  C                   INDEX_I    => /* I = nnn */  C                  INDEX_K    => /* K = nnn */
306  C                   INDEX_J    => /* J = nnn */  C                  INDEX_I    => /* I = nnn */
307  C                   INDEX_NONE =>  C                  INDEX_J    => /* J = nnn */
308  C     compact ::  Flag to control use of repeat symbol for same valued  C                  INDEX_NONE =>
309  C                 fields.  C     markEnd :: Flag to control whether there is a separator after the
310  C     markEnd ::  Flag to control whether there is a separator after the  C                last element
311  C                 last element  C     compact :: Flag to control use of repeat symbol for same valued
312  C     ioUnit ::   Unit number for IO.  C                fields.
313        INTEGER lFld  C     ioUnit  :: Unit number for IO.
314          INTEGER iFirst, iLast
315          INTEGER fld(iFirst:iLast)
316        INTEGER index_type        INTEGER index_type
       INTEGER fld(lFld)  
317        LOGICAL markEnd        LOGICAL markEnd
318        LOGICAL compact        LOGICAL compact
319        INTEGER ioUnit        INTEGER ioUnit
# Line 187  C     K    - Loop counter Line 336  C     K    - Loop counter
336        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
337        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
338        CHARACTER*3 index_lab        CHARACTER*3 index_lab
339          CHARACTER*25 fmt1, fmt2
340        INTEGER K        INTEGER K
341  CEOP  CEOP
342    
# Line 199  CEOP Line 349  CEOP
349        ELSE        ELSE
350         index_lab = '?='         index_lab = '?='
351        ENDIF        ENDIF
352    C-    fortran format to write 1 or 2 indices:
353          fmt1='(A,1X,A,I3,1X,A)'
354          fmt2='(A,1X,A,I3,A,I3,1X,A)'
355          IF ( iLast.GE.1000 ) THEN
356            K = 1+INT(LOG10(FLOAT(iLast)))
357            WRITE(fmt1,'(A,I1,A)')      '(A,1X,A,I',K,',1X,A)'
358            WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)'
359          ENDIF
360        commOpen  = '/*'        commOpen  = '/*'
361        commClose = '*/'        commClose = '*/'
362        iLo = 1        iLo = iFirst
363        iHi = 1        iHi = iFirst
364        punc = ','        punc = ','
365        xOld = fld(1)        xOld = fld(iFirst)
366        DO K=2,lFld        DO K = iFirst+1,iLast
367         xNew = fld(K  )         xNew = fld(K  )
368         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
369          nDup = iHi-iLo+1          nDup = iHi-iLo+1
370          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
371           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
372           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
373       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt1)
374       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
375          ELSE          ELSE
376           WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc
377           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
378       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt2)
379       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
380          ENDIF          ENDIF
381          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
# Line 233  CEOP Line 391  CEOP
391        nDup = iHi-iLo+1        nDup = iHi-iLo+1
392        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
393         WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
394         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
395       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
396       &  commOpen,index_lab,iLo,commClose       &  commOpen,index_lab,iLo,commClose
397        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
398         WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc
399         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
400       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
401       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
402        ENDIF        ENDIF
403        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
# Line 247  CEOP Line 405  CEOP
405        RETURN        RETURN
406        END        END
407    
408    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
409  CBOP  CBOP
410  C     !ROUTINE: PRINT_LIST_L  C     !ROUTINE: PRINT_LIST_L
   
411  C     !INTERFACE:  C     !INTERFACE:
412        SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd,        SUBROUTINE PRINT_LIST_L( fld, iFirst, iLast, index_type,
413       &                         compact, ioUnit )       &                         markEnd, compact, ioUnit )
414        IMPLICIT NONE  
415  C     !DESCRIPTION:  C     !DESCRIPTION:
416  C     *==========================================================*  C     *==========================================================*
417  C     | o SUBROUTINE PRINT_LIST_L                                  C     | o SUBROUTINE PRINT\_LIST\_L
418  C     *==========================================================*  C     *==========================================================*
419  C     | Routine for producing list of values for a field with      C     | Routine for producing list of values for a field with
420  C     | duplicate values collected into                            C     | duplicate values collected into
421  C     |    n @ value                                                C     |    n \@ value
422  C     | record.                                                    C     | record.
423  C     *==========================================================*  C     *==========================================================*
424    
425  C     !USES:  C     !USES:
426  C     == Global data ==          IMPLICIT NONE
427    
428    C     == Global data ==
429  #include "SIZE.h"  #include "SIZE.h"
430  #include "EEPARAMS.h"  #include "EEPARAMS.h"
431    
432  C     !INPUT/OUTPUT PARAMETERS:  C     !INPUT/OUTPUT PARAMETERS:
433  C     == Routine arguments ==  C     == Routine arguments ==
434  C     fld    -  Data to be printed  C     fld     :: Data to be printed
435  C     lFld   -  Number of elements to be printed  C     iFirst  :: First element to print
436  C     index_type - Flag indicating which type of index to print  C     iLast   :: Last element to print
437    C  index_type :: Flag indicating which type of index to print
438  C                  INDEX_K    => /* K = nnn */  C                  INDEX_K    => /* K = nnn */
439  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
440  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
441  C                  INDEX_NONE =>  C                  INDEX_NONE =>
442  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  
443  C                last element  C                last element
444  C     ioUnit -  Unit number for IO.  C     compact :: Flag to control use of repeat symbol for same valued
445        INTEGER lFld  C                fields.
446    C     ioUnit  :: Unit number for IO.
447          INTEGER iFirst, iLast
448          LOGICAL fld(iFirst:iLast)
449        INTEGER index_type        INTEGER index_type
       LOGICAL fld(lFld)  
450        LOGICAL markEnd        LOGICAL markEnd
451        LOGICAL compact        LOGICAL compact
452        INTEGER ioUnit        INTEGER ioUnit
# Line 308  C     K    - Loop counter Line 469  C     K    - Loop counter
469        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
470        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
471        CHARACTER*3 index_lab        CHARACTER*3 index_lab
472          CHARACTER*25 fmt1, fmt2
473        INTEGER K        INTEGER K
474  CEOP  CEOP
475    
# Line 320  CEOP Line 482  CEOP
482        ELSE        ELSE
483         index_lab = '?='         index_lab = '?='
484        ENDIF        ENDIF
485    C-    fortran format to write 1 or 2 indices:
486          fmt1='(A,1X,A,I3,1X,A)'
487          fmt2='(A,1X,A,I3,A,I3,1X,A)'
488          IF ( iLast.GE.1000 ) THEN
489            K = 1+INT(LOG10(FLOAT(iLast)))
490            WRITE(fmt1,'(A,I1,A)')      '(A,1X,A,I',K,',1X,A)'
491            WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)'
492          ENDIF
493        commOpen  = '/*'        commOpen  = '/*'
494        commClose = '*/'        commClose = '*/'
495        iLo = 1        iLo = iFirst
496        iHi = 1        iHi = iFirst
497        punc = ','        punc = ','
498        xOld = fld(1)        xOld = fld(iFirst)
499        DO K=2,lFld        DO K = iFirst+1,iLast
500         xNew = fld(K  )         xNew = fld(K  )
501         IF ( .NOT. compact .OR. (xNew .NEQV. xOld) ) THEN         IF ( .NOT. compact .OR. (xNew .NEQV. xOld) ) THEN
502          nDup = iHi-iLo+1          nDup = iHi-iLo+1
503          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
504           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
505           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
506       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt1)
507       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
508          ELSE          ELSE
509           WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc
510           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
511       &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt2)
512       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
513          ENDIF          ENDIF
514          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
# Line 354  CEOP Line 524  CEOP
524        nDup = iHi-iLo+1        nDup = iHi-iLo+1
525        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
526         WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
527         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
528       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
529       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
530        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
531         WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc
532         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
533       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
534       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
535        ENDIF        ENDIF
536        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
# Line 368  CEOP Line 538  CEOP
538        RETURN        RETURN
539        END        END
540    
541    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
542  CBOP  CBOP
543  C     !ROUTINE: PRINT_LIST_R8  C     !ROUTINE: PRINT_LIST_RL
544  C     !INTERFACE:  C     !INTERFACE:
545        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type,        SUBROUTINE PRINT_LIST_RL( fld, iFirst, iLast, index_type,
546       &    markEnd, compact, ioUnit )       &                          markEnd, compact, ioUnit )
547        IMPLICIT NONE  
548  C     !DESCRIPTION:  C     !DESCRIPTION:
549  C     *==========================================================*  C     *==========================================================*
550  C     | o SUBROUTINE PRINT_LIST_R8                                  C     | o SUBROUTINE PRINT\_LIST\_RL
551  C     *==========================================================*  C     *==========================================================*
552  C     | Routine for producing list of values for a field with      C     | Routine for producing list of values for a field with
553  C     | duplicate values collected into                            C     | duplicate values collected into
554  C     |    n @ value                                                C     |    n \@ value
555  C     | record.                                                    C     | record.
556  C     *==========================================================*  C     *==========================================================*
557    
558  C     !USES:  C     !USES:
559          IMPLICIT NONE
560    
561  C     == Global data ==  C     == Global data ==
562  #include "SIZE.h"  #include "SIZE.h"
563  #include "EEPARAMS.h"  #include "EEPARAMS.h"
564    
565  C     !INPUT/OUTPUT PARAMETERS:  C     !INPUT/OUTPUT PARAMETERS:
566  C     == Routine arguments ==  C     == Routine arguments ==
567  C     fld    -  Data to be printed  C     fld     :: Data to be printed
568  C     lFld   -  Number of elements to be printed  C     iFirst  :: First element to print
569  C     index_type - Flag indicating which type of index to print  C     iLast   :: Last element to print
570    C  index_type :: Flag indicating which type of index to print
571  C                  INDEX_K    => /* K = nnn */  C                  INDEX_K    => /* K = nnn */
572  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
573  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
574  C                  INDEX_NONE =>  C                  INDEX_NONE =>
575  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  
576  C                last element  C                last element
577  C     ioUnit -  Unit number for IO.  C     compact :: Flag to control use of repeat symbol for same valued
578        INTEGER lFld  C                fields.
579    C     ioUnit  :: Unit number for IO.
580          INTEGER iFirst, iLast
581          _RL     fld(iFirst:iLast)
582        INTEGER index_type        INTEGER index_type
       Real*8  fld(lFld)  
583        LOGICAL markEnd        LOGICAL markEnd
584        LOGICAL compact        LOGICAL compact
585        INTEGER ioUnit        INTEGER ioUnit
# Line 423  C     K    - Loop counter Line 597  C     K    - Loop counter
597        INTEGER iLo        INTEGER iLo
598        INTEGER iHi        INTEGER iHi
599        INTEGER nDup        INTEGER nDup
600        Real*8 xNew, xOld        _RL     xNew, xOld
601        CHARACTER punc        CHARACTER punc
602        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
603        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
604        CHARACTER*3 index_lab        CHARACTER*3 index_lab
605          CHARACTER*25 fmt1, fmt2
606        INTEGER K        INTEGER K
607  CEOP  CEOP
608    
# Line 440  CEOP Line 615  CEOP
615        ELSE        ELSE
616         index_lab = '?='         index_lab = '?='
617        ENDIF        ENDIF
618    C-    fortran format to write 1 or 2 indices:
619          fmt1='(A,1X,A,I3,1X,A)'
620          fmt2='(A,1X,A,I3,A,I3,1X,A)'
621          IF ( iLast.GE.1000 ) THEN
622            K = 1+INT(LOG10(FLOAT(iLast)))
623            WRITE(fmt1,'(A,I1,A)')      '(A,1X,A,I',K,',1X,A)'
624            WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)'
625          ENDIF
626        commOpen  = '/*'        commOpen  = '/*'
627        commClose = '*/'        commClose = '*/'
628        iLo = 1        iLo = iFirst
629        iHi = 1        iHi = iFirst
630        punc = ','        punc = ','
631        xOld = fld(1)        xOld = fld(iFirst)
632        DO K=2,lFld        DO K = iFirst+1,iLast
633         xNew = fld(K  )         xNew = fld(K  )
634         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
635          nDup = iHi-iLo+1          nDup = iHi-iLo+1
636          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
637           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
638           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
639       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt1)
640       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
641          ELSE          ELSE
642           WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
643           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
644       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt2)
645       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
646          ENDIF          ENDIF
647          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
      &    SQUEEZE_RIGHT , 1)  
648          iLo  = K          iLo  = K
649          iHi  = K          iHi  = K
650          xOld = xNew          xOld = xNew
# Line 475  CEOP Line 657  CEOP
657        nDup = iHi-iLo+1        nDup = iHi-iLo+1
658        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
659         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
660         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
661       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')       &  WRITE(msgBuf(45:),fmt1)
662       &    commOpen,index_lab,iLo,commClose       &    commOpen,index_lab,iLo,commClose
663        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
664         WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
665         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
666       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),fmt2)
667       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
668        ENDIF        ENDIF
669        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
      &    SQUEEZE_RIGHT , 1)  
670    
671        RETURN        RETURN
672        END        END
673    
674    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
675  CBOP  CBOP
676  C     !ROUTINE: PRINT_MAPRS  C     !ROUTINE: PRINT_MAPRS
677  C     !INTERFACE:  C     !INTERFACE:
# Line 500  C     !INTERFACE: Line 682  C     !INTERFACE:
682       I       kMin, kMax,   kStr,       I       kMin, kMax,   kStr,
683       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
684       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
685        IMPLICIT NONE  
686  C     !DESCRIPTION:  C     !DESCRIPTION:
687  C     *==========================================================*  C     *==========================================================*
688  C     | SUBROUTINE PRINT_MAPR4                                      C     | SUBROUTINE PRINT\_MAPRS
689  C     | o Does textual mapping printing of a field.                C     | o Does textual mapping printing of a field.
690  C     *==========================================================*  C     *==========================================================*
691  C     | This routine does the actual formatting of the data        C     | This routine does the actual formatting of the data
692  C     | and printing to a file. It assumes an array using the      C     | and printing to a file. It assumes an array using the
693  C     | MITgcm UV indexing scheme and base index variables.        C     | MITgcm UV indexing scheme and base index variables.
694  C     | User code should call an interface routine like            C     | User code should call an interface routine like
695  C     | PLOT_FIELD_XYR4( ... ) rather than this code directly.      C     | PLOT\_FIELD\_XYRS( ... ) rather than this code directly.
696  C     | Text plots can be oriented XY, YZ, XZ. An orientation      C     | Text plots can be oriented XY, YZ, XZ. An orientation
697  C     | is specficied through the "plotMode" argument. All the      C     | is specficied through the "plotMode" argument. All the
698  C     | plots made by a single call to this routine will use the    C     | plots made by a single call to this routine will use the
699  C     | same contour interval. The plot range (iMin,...,byStr)      C     | same contour interval. The plot range (iMin,...,byStr)
700  C     | can be three-dimensional. A separate plot is made for      C     | can be three-dimensional. A separate plot is made for
701  C     | each point in the plot range normal to the orientation.    C     | each point in the plot range normal to the orientation.
702  C     | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY).    C     | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY).
703  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY
704  C     |      plots - one for K=1, one for K=3 and one for K=5.      C     |      plots - one for K=1, one for K=3 and one for K=5.
705  C     |      Each plot would have extents iMin:iMax step iStr      C     |      Each plot would have extents iMin:iMax step iStr
706  C     |      and jMin:jMax step jStr.                              C     |      and jMin:jMax step jStr.
707  C     *==========================================================*  C     *==========================================================*
708    
709  C     !USES:  C     !USES:
710          IMPLICIT NONE
711    
712  C     == Global variables ==  C     == Global variables ==
713  #include "SIZE.h"  #include "SIZE.h"
714  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "EESUPPORT.h"  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
715    
716  C     !INPUT/OUTPUT PARAMETERS:  C     !INPUT/OUTPUT PARAMETERS:
717  C     == Routine arguments ==  C     == Routine arguments ==
# Line 545  C     jLo, jHi     be five-dimensional. Line 724  C     jLo, jHi     be five-dimensional.
724  C     kLo, kHi  C     kLo, kHi
725  C     nBx, nBy  C     nBx, nBy
726  C     iMin, iMax - Indexing for points to plot. Points from  C     iMin, iMax - Indexing for points to plot. Points from
727  C     iStr         iMin -> iMax in steps of iStr are plotted  C     iStr         iMin -> iMax in steps of iStr are plotted
728  C     jMin. jMax   and similarly for jMin, jMax, jStr and  C     jMin. jMax   and similarly for jMin, jMax, jStr and
729  C     jStr         kMin, kMax, kStr and bxMin, bxMax, bxStr  C     jStr         kMin, kMax, kStr and bxMin, bxMax, bxStr
730  C     kMin, kMax   byMin, byMax, byStr.  C     kMin, kMax   byMin, byMax, byStr.
# Line 563  C     kStr Line 742  C     kStr
742        INTEGER bxMin, bxMax, bxStr        INTEGER bxMin, bxMax, bxStr
743        INTEGER byMin, byMax, byStr        INTEGER byMin, byMax, byStr
744    
745    C     !FUNCTIONS:
746          INTEGER  IFNBLNK
747          EXTERNAL IFNBLNK
748          INTEGER  ILNBLNK
749          EXTERNAL ILNBLNK
750    
751  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
752  C     == Local variables ==  C     == Local variables ==
753  C     plotBuf - Buffer for building plot record  C     plotBuf - Buffer for building plot record
# Line 587  C               Min  - Start index withi Line 772  C               Min  - Start index withi
772  C               Max  - End index within block  C               Max  - End index within block
773  C               Str  - stride within block  C               Str  - stride within block
774        INTEGER MAX_LEN_PLOTBUF        INTEGER MAX_LEN_PLOTBUF
775        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 )        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-20 )
776        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf
777        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
778        INTEGER lChList        INTEGER lChList
# Line 627  C--   Calculate field range Line 812  C--   Calculate field range
812           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
813            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
814             IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN             IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN
815              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
816       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
817              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
818       &       fMax = fld(I,J,K,bi,bj)       &       fMax = fld(I,J,K,bi,bj)
819             ENDIF             ENDIF
820            ENDDO            ENDDO
# Line 638  C--   Calculate field range Line 823  C--   Calculate field range
823         ENDDO         ENDDO
824        ENDDO        ENDDO
825        fRange = fMax-fMin        fRange = fMax-fMin
826        IF ( fRange .GT. small .AND.        IF ( fRange .GT. small ) validRange = .TRUE.
      &     (MAX_LEN_PLOTBUF-35) .GT. sNx*nSx .AND.  
      &     (MAX_LEN_PLOTBUF-35) .GT. sNy*nSy ) validRange = .TRUE.  
827    
828  C--   Write field title and statistics  C--   Write field title and statistics
829        msgBuf =        msgBuf =
830       & '// ======================================================='       & '// ======================================================='
831        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
832       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
# Line 702  C--   Write field title and statistics Line 885  C--   Write field title and statistics
885       &  ':',kStr,')'       &  ':',kStr,')'
886        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
887       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
888        msgBuf =        msgBuf =
889       & '// ======================================================='       & '// ======================================================='
890        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
891       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
892    
893    c     if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
894    c      msgBuf =
895    c    &  'Model domain too big to print to terminal - skipping I/O'
896    c      CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
897    c    &                   SQUEEZE_RIGHT, 1)
898    c      RETURN
899    c     endif
900    
901  C--   Write field  C--   Write field
902  C     Figure out slice type and set plotting parameters appropriately  C     Figure out slice type and set plotting parameters appropriately
903  C     acc = accross the page  C     acc = accross the page
# Line 799  C      X across, Z down slice Line 990  C      X across, Z down slice
990         pltStep = sNy         pltStep = sNy
991         pltLab  = 'J ='         pltLab  = 'J ='
992        ENDIF        ENDIF
993    C-    check if it fits into buffer (-10 should be enough but -12 is safer):
994          IF ( (accMax-accMin+1)*(accBhi-accBlo+1).GT.MAX_LEN_PLOTBUF-12
995         &     .AND. validRange ) THEN
996           msgBuf =
997         &  'Model domain too big to print to terminal - skipping I/O'
998           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
999         &                   SQUEEZE_RIGHT, 1)
1000           validRange = .FALSE.
1001          ENDIF
1002        IF ( validRange ) THEN        IF ( validRange ) THEN
1003  C      Header  C      Header
1004  C      Data  C      Data
# Line 809  C      Data Line 1009  C      Data
1009           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1010       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
1011           plotBuf = ' '           plotBuf = ' '
1012           iBuf = 6           iBuf = 6
1013           DO bi=accBlo, accBhi, accBstr           DO bi=accBlo, accBhi, accBstr
1014            DO I=accMin, accMax, accStr            DO I=accMin, accMax, accStr
1015             iDx = accBase-1+(bi-1)*accStep+I             iDx = accBase-1+(bi-1)*accStep+I
# Line 831  C      Data Line 1031  C      Data
1031           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1032       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
1033           plotBuf = dwnLab           plotBuf = dwnLab
1034           iBuf = 7           iBuf = 7
1035           DO bi=accBlo, accBhi, accBstr           DO bi=accBlo, accBhi, accBstr
1036            DO I=accMin, accMax, accStr            DO I=accMin, accMax, accStr
1037             iDx = accBase-1+(bi-1)*accStep+I             iDx = accBase-1+(bi-1)*accStep+I
# Line 839  C      Data Line 1039  C      Data
1039             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
1040              WRITE(plotBuf(iBuf:),'(A)')  '|'              WRITE(plotBuf(iBuf:),'(A)')  '|'
1041             ELSE             ELSE
1042              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10)
1043             ENDIF             ENDIF
1044            ENDDO            ENDDO
1045           ENDDO           ENDDO
# Line 848  C      Data Line 1048  C      Data
1048       &                    SQUEEZE_RIGHT, 1)       &                    SQUEEZE_RIGHT, 1)
1049           DO bj=dwnBlo, dwnBhi, dwnBStr           DO bj=dwnBlo, dwnBhi, dwnBStr
1050            DO J=dwnMin, dwnMax, dwnStr            DO J=dwnMin, dwnMax, dwnStr
1051             WRITE(plotBuf,'(1X,I5,1X)')             WRITE(plotBuf,'(1X,I5,1X)')
1052       &      dwnBase-1+(bj-1)*dwnStep+J       &      dwnBase-1+(bj-1)*dwnStep+J
1053             iBuf = 7             iBuf = 7
1054             DO bi=accBlo,accBhi,accBstr             DO bi=accBlo,accBhi,accBstr
# Line 862  C      Data Line 1062  C      Data
1062                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
1063               ENDIF               ENDIF
1064               IF ( validRange .AND. val .NE. 0. ) THEN               IF ( validRange .AND. val .NE. 0. ) THEN
1065                IDX = NINT(                IDX = NINT(
1066       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1067       &             )+1       &             )+1
1068               ELSE               ELSE
1069                IDX = 1                IDX = 1
1070               ENDIF               ENDIF
1071               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1072       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1073               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
1074                IF ( iBuf .LE. MAX_LEN_PLOTBUF )                IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1075       &         plotBuf(iBuf:iBuf) = '.'       &         plotBuf(iBuf:iBuf) = '.'
1076               ENDIF               ENDIF
1077              ENDDO              ENDDO
# Line 885  C      Data Line 1085  C      Data
1085         ENDDO         ENDDO
1086        ENDIF        ENDIF
1087  C--   Write delimiter  C--   Write delimiter
1088        msgBuf =        msgBuf =
1089       & '// ======================================================='       & '// ======================================================='
1090        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1091       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1092        msgBuf =        msgBuf =
1093       & '// END OF FIELD                                          ='       & '// END OF FIELD                                          ='
1094        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1095       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1096        msgBuf =        msgBuf =
1097       & '// ======================================================='       & '// ======================================================='
1098        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1099       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
# Line 904  C--   Write delimiter Line 1104  C--   Write delimiter
1104        RETURN        RETURN
1105        END        END
1106    
1107    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
1108  CBOP  CBOP
1109  C     !ROUTINE: PRINT_MAPRL  C     !ROUTINE: PRINT_MAPRL
   
1110  C     !INTERFACE:  C     !INTERFACE:
1111        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
1112       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
# Line 915  C     !INTERFACE: Line 1115  C     !INTERFACE:
1115       I       kMin, kMax,   kStr,       I       kMin, kMax,   kStr,
1116       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
1117       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
       IMPLICIT NONE  
1118    
1119  C     !DESCRIPTION:  C     !DESCRIPTION:
1120  C     *==========================================================*  C     *==========================================================*
1121  C     | SUBROUTINE PRINT_MAPRL                                      C     | SUBROUTINE PRINT\_MAPRL
1122  C     | o Does textual mapping printing of a field.                C     | o Does textual mapping printing of a field.
1123  C     *==========================================================*  C     *==========================================================*
1124  C     | This routine does the actual formatting of the data        C     | This routine does the actual formatting of the data
1125  C     | and printing to a file. It assumes an array using the      C     | and printing to a file. It assumes an array using the
1126  C     | MITgcm UV indexing scheme and base index variables.        C     | MITgcm UV indexing scheme and base index variables.
1127  C     | User code should call an interface routine like            C     | User code should call an interface routine like
1128  C     | PLOT_FIELD_XYR8( ... ) rather than this code directly.      C     | PLOT\_FIELD\_XYRL( ... ) rather than this code directly.
1129  C     | Text plots can be oriented XY, YZ, XZ. An orientation      C     | Text plots can be oriented XY, YZ, XZ. An orientation
1130  C     | is specficied through the "plotMode" argument. All the      C     | is specficied through the "plotMode" argument. All the
1131  C     | plots made by a single call to this routine will use the    C     | plots made by a single call to this routine will use the
1132  C     | same contour interval. The plot range (iMin,...,byStr)      C     | same contour interval. The plot range (iMin,...,byStr)
1133  C     | can be three-dimensional. A separate plot is made for      C     | can be three-dimensional. A separate plot is made for
1134  C     | each point in the plot range normal to the orientation.    C     | each point in the plot range normal to the orientation.
1135  C     | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY).    C     | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY).
1136  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY
1137  C     |      plots - one for K=1, one for K=3 and one for K=5.      C     |      plots - one for K=1, one for K=3 and one for K=5.
1138  C     |      Each plot would have extents iMin:iMax step iStr      C     |      Each plot would have extents iMin:iMax step iStr
1139  C     |      and jMin:jMax step jStr.                              C     |      and jMin:jMax step jStr.
1140  C     *==========================================================*  C     *==========================================================*
1141    
1142  C     !USES:  C     !USES:
1143          IMPLICIT NONE
1144    
1145  C     == Global variables ==  C     == Global variables ==
1146  #include "SIZE.h"  #include "SIZE.h"
1147  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "EESUPPORT.h"  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
1148    
1149  C     !INPUT/OUTPUT PARAMETERS:  C     !INPUT/OUTPUT PARAMETERS:
1150  C     == Routine arguments ==  C     == Routine arguments ==
# Line 961  C     jLo, jHi     be five-dimensional. Line 1157  C     jLo, jHi     be five-dimensional.
1157  C     kLo, kHi  C     kLo, kHi
1158  C     nBx, nBy  C     nBx, nBy
1159  C     iMin, iMax - Indexing for points to plot. Points from  C     iMin, iMax - Indexing for points to plot. Points from
1160  C     iStr         iMin -> iMax in steps of iStr are plotted  C     iStr         iMin -> iMax in steps of iStr are plotted
1161  C     jMin. jMax   and similarly for jMin, jMax, jStr and  C     jMin. jMax   and similarly for jMin, jMax, jStr and
1162  C     jStr         kMin, kMax, kStr and bxMin, bxMax, bxStr  C     jStr         kMin, kMax, kStr and bxMin, bxMax, bxStr
1163  C     kMin, kMax   byMin, byMax, byStr.  C     kMin, kMax   byMin, byMax, byStr.
# Line 979  C     kStr Line 1175  C     kStr
1175        INTEGER bxMin, bxMax, bxStr        INTEGER bxMin, bxMax, bxStr
1176        INTEGER byMin, byMax, byStr        INTEGER byMin, byMax, byStr
1177    
1178    C     !FUNCTIONS:
1179          INTEGER  IFNBLNK
1180          EXTERNAL IFNBLNK
1181          INTEGER  ILNBLNK
1182          EXTERNAL ILNBLNK
1183    
1184  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
1185  C     == Local variables ==  C     == Local variables ==
1186  C     plotBuf - Buffer for building plot record  C     plotBuf - Buffer for building plot record
# Line 1003  C               Min  - Start index withi Line 1205  C               Min  - Start index withi
1205  C               Max  - End index within block  C               Max  - End index within block
1206  C               Str  - stride within block  C               Str  - stride within block
1207        INTEGER MAX_LEN_PLOTBUF        INTEGER MAX_LEN_PLOTBUF
1208        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 )        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-20 )
1209        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf
1210        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
1211        INTEGER lChList        INTEGER lChList
# Line 1042  C--   Calculate field range Line 1244  C--   Calculate field range
1244          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
1245           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
1246            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
1247             IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )             IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )
1248       &     THEN       &     THEN
1249              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
1250       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
1251              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
1252       &       fMax = fld(I,J,K,bi,bj)       &       fMax = fld(I,J,K,bi,bj)
1253             ENDIF             ENDIF
1254            ENDDO            ENDDO
# Line 1055  C--   Calculate field range Line 1257  C--   Calculate field range
1257         ENDDO         ENDDO
1258        ENDDO        ENDDO
1259        fRange = fMax-fMin        fRange = fMax-fMin
1260        IF ( fRange .GT. small .AND.        IF ( fRange .GT. small ) validRange = .TRUE.
      &     (MAX_LEN_PLOTBUF-35) .GT. sNx*nSx .AND.  
      &     (MAX_LEN_PLOTBUF-35) .GT. sNy*nSy ) validRange = .TRUE.  
1261    
1262  C--   Write field title and statistics  C--   Write field title and statistics
1263        msgBuf =        msgBuf =
1264       & '// ======================================================='       & '// ======================================================='
1265        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1266       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
# Line 1119  C--   Write field title and statistics Line 1319  C--   Write field title and statistics
1319       &  ':',kStr,')'       &  ':',kStr,')'
1320        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1321       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1322        msgBuf =        msgBuf =
1323       & '// ======================================================='       & '// ======================================================='
1324        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1325       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1326    
1327    c     if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
1328    c      msgBuf =
1329    c    &  'Model domain too big to print to terminal - skipping I/O'
1330    c      CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1331    c    &                   SQUEEZE_RIGHT, 1)
1332    c      RETURN
1333    c     endif
1334    
1335  C--   Write field  C--   Write field
1336  C     Figure out slice type and set plotting parameters appropriately  C     Figure out slice type and set plotting parameters appropriately
1337  C     acc = accross the page  C     acc = accross the page
# Line 1216  C      X across, Z down slice Line 1424  C      X across, Z down slice
1424         pltStep = sNy         pltStep = sNy
1425         pltLab  = 'J ='         pltLab  = 'J ='
1426        ENDIF        ENDIF
1427    C-    check if it fits into buffer (-10 should be enough but -12 is safer):
1428          IF ( (accMax-accMin+1)*(accBhi-accBlo+1).GT.MAX_LEN_PLOTBUF-12
1429         &     .AND. validRange ) THEN
1430           msgBuf =
1431         &  'Model domain too big to print to terminal - skipping I/O'
1432           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1433         &                   SQUEEZE_RIGHT, 1)
1434           validRange = .FALSE.
1435          ENDIF
1436        IF ( validRange ) THEN        IF ( validRange ) THEN
1437  C      Header  C      Header
1438  C      Data  C      Data
# Line 1226  C      Data Line 1443  C      Data
1443           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1444       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
1445           plotBuf = ' '           plotBuf = ' '
1446           iBuf = 6           iBuf = 6
1447           DO bi=accBlo, accBhi, accBstr           DO bi=accBlo, accBhi, accBstr
1448            DO I=accMin, accMax, accStr            DO I=accMin, accMax, accStr
1449             iDx = accBase-1+(bi-1)*accStep+I             iDx = accBase-1+(bi-1)*accStep+I
# Line 1247  C      Data Line 1464  C      Data
1464           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1465       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
1466           plotBuf = dwnLab           plotBuf = dwnLab
1467           iBuf = 7           iBuf = 7
1468           DO bi=accBlo, accBhi, accBstr           DO bi=accBlo, accBhi, accBstr
1469            DO I=accMin, accMax, accStr            DO I=accMin, accMax, accStr
1470             iDx = accBase-1+(bi-1)*accStep+I             iDx = accBase-1+(bi-1)*accStep+I
# Line 1255  C      Data Line 1472  C      Data
1472             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
1473              WRITE(plotBuf(iBuf:),'(A)')  '|'              WRITE(plotBuf(iBuf:),'(A)')  '|'
1474             ELSE             ELSE
1475              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10)
1476             ENDIF             ENDIF
1477            ENDDO            ENDDO
1478           ENDDO           ENDDO
# Line 1263  C      Data Line 1480  C      Data
1480       &                    SQUEEZE_RIGHT, 1)       &                    SQUEEZE_RIGHT, 1)
1481           DO bj=dwnBlo, dwnBhi, dwnBStr           DO bj=dwnBlo, dwnBhi, dwnBStr
1482            DO J=dwnMin, dwnMax, dwnStr            DO J=dwnMin, dwnMax, dwnStr
1483             WRITE(plotBuf,'(1X,I5,1X)')             WRITE(plotBuf,'(1X,I5,1X)')
1484       &      dwnBase-1+(bj-1)*dwnStep+J       &      dwnBase-1+(bj-1)*dwnStep+J
1485             iBuf = 7             iBuf = 7
1486             DO bi=accBlo,accBhi,accBstr             DO bi=accBlo,accBhi,accBstr
# Line 1277  C      Data Line 1494  C      Data
1494                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
1495               ENDIF               ENDIF
1496               IF ( validRange .AND. val .NE. 0. ) THEN               IF ( validRange .AND. val .NE. 0. ) THEN
1497                IDX = NINT(                IDX = NINT(
1498       &               FLOAT( lChList-1 )*( val-fMin ) / (fRange)       &               FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1499       &              )+1       &              )+1
1500               ELSE               ELSE
1501                IDX = 1                IDX = 1
1502               ENDIF               ENDIF
1503               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1504       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1505               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
1506                IF ( iBuf .LE. MAX_LEN_PLOTBUF )                IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1507       &         plotBuf(iBuf:iBuf) = '.'       &         plotBuf(iBuf:iBuf) = '.'
1508               ENDIF               ENDIF
1509              ENDDO              ENDDO
# Line 1299  C      Data Line 1516  C      Data
1516         ENDDO         ENDDO
1517        ENDIF        ENDIF
1518  C--   Write delimiter  C--   Write delimiter
1519        msgBuf =        msgBuf =
1520       & '// ======================================================='       & '// ======================================================='
1521        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1522       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1523        msgBuf =        msgBuf =
1524       & '// END OF FIELD                                          ='       & '// END OF FIELD                                          ='
1525        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1526       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1527        msgBuf =        msgBuf =
1528       & '// ======================================================='       & '// ======================================================='
1529        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1530       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
# Line 1317  C--   Write delimiter Line 1534  C--   Write delimiter
1534    
1535        RETURN        RETURN
1536        END        END
   
 CBOP  
 C     !ROUTINE: PRINT_MESSAGE  
   
 C     !INTERFACE:  
       SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )  
       IMPLICIT NONE  
 C     !DESCRIPTION:  
 C     *============================================================*  
 C     | SUBROUTINE PRINT_MESSAGE                                      
 C     | o Write out informational message using "standard" format.    
 C     *============================================================*  
 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     *============================================================*  
   
 C     !USES:  
 C     == Global data ==  
 #include "SIZE.h"  
 #include "EEPARAMS.h"  
 #include "EESUPPORT.h"  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
   
 C     !INPUT/OUTPUT PARAMETERS:  
 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  
   
 C     !LOCAL VARIABLES:  
 C     == Local variables ==  
 C     iStart, iEnd :: String indexing variables  
 C     idString     :: Temp. for building prefix.  
       INTEGER iStart  
       INTEGER iEnd  
       CHARACTER*9 idString  
 CEOP  
   
 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.20  
changed lines
  Added in v.1.31
  ViewVC Help
Powered by ViewVC 1.1.22