/[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.9 by adcroft, Mon Jun 22 16:24:51 1998 UTC revision 1.28 by jmc, Wed Jul 25 21:05:37 2007 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2    C $Name$
3    
4  #include "CPP_EEOPTIONS.h"  #include "CPP_EEOPTIONS.h"
5    
# Line 12  C--    o print_list_l   Prints one-deime Line 13  C--    o print_list_l   Prints one-deime
13  C--                     variables.  C--                     variables.
14  C--    o print_list_r8  Prints one-deimensional list of Real*8  C--    o print_list_r8  Prints one-deimensional list of Real*8
15  C--                     numbers.  C--                     numbers.
16  C--    o print_mapr4    Formats ABCD... contour map of a Real*4 field  C--    o print_maprs    Formats ABCD... contour map of a Real(_RS) field
17  C--                     Uses print_message for writing  C--                     Uses print_message for writing
18  C--    o print_mapr8    Formats ABCD... contour map of a Real*8 field  C--    o print_maprl    Formats ABCD... contour map of a Real(_RL) field
19  C--                     Uses print_message for writing  C--                     Uses print_message for writing
20  C--    o print_message  Does IO with unhighlighted header  C--    o print_message  Does IO with unhighlighted header
21    
22  CStartOfInterface  CBOP              
23    
24    C     !ROUTINE: PRINT_ERROR
25    
26    C     !INTERFACE:
27        SUBROUTINE PRINT_ERROR( message , myThid )        SUBROUTINE PRINT_ERROR( message , myThid )
28  C     /============================================================\        IMPLICIT NONE
29  C     | SUBROUTINE PRINT_ERROR                                     |  
30  C     | o Write out error message using "standard" format.         |  C     !DESCRIPTION:
31  C     | Notes                                                      |  C     *============================================================*
32  C     | =====                                                      |  C     | SUBROUTINE PRINT\_ERROR                                      
33  C     | o Some system's I/O is not "thread-safe". For this reason  |  C     | o Write out error message using "standard" format.          
34  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |  C     *============================================================*
35  C     |   critical region is defined around the write here. In some|  C     | Notes                                                      
36  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |  C     | =====                                                      
37  C     |   for thread number 1 - writes for other threads are       |  C     | o Some system   I/O is not "thread-safe". For this reason  
38  C     |   ignored!                                                 |  C     |   without the FMTFTN\_IO\_THREAD\_SAFE directive set a        
39  C     | o In a non-parallel form these routines can still be used. |  C     |   critical region is defined around the write here. In some
40  C     |   to produce pretty printed output!                        |  C     |   cases  BEGIN\_CRIT() is approximated by only doing writes  
41  C     \============================================================/  C     |   for thread number 1 - writes for other threads are        
42    C     |   ignored!                                                  
43    C     | o In a non-parallel form these routines are still used  
44    C     |   to produce pretty printed output. The process and thread
45    C     |   id prefix is omitted in this case.
46    C     *============================================================*
47    
48    C     !USES:
49  C     == Global data ==  C     == Global data ==
50  #include "SIZE.h"  #include "SIZE.h"
51  #include "EEPARAMS.h"  #include "EEPARAMS.h"
52  #include "EESUPPORT.h"  #include "EESUPPORT.h"
 C     == Routine arguments ==  
       CHARACTER*(*) message  
       INTEGER       myThid  
 CEndOfInterface  
53        INTEGER  IFNBLNK        INTEGER  IFNBLNK
54        EXTERNAL IFNBLNK        EXTERNAL IFNBLNK
55        INTEGER  ILNBLNK        INTEGER  ILNBLNK
56        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
57    
58    C     !INPUT/OUTPUT PARAMETERS:
59    C     == Routine arguments ==
60    C     message :: Text string to print
61    C     myThid  :: Thread number of this instance
62          CHARACTER*(*) message
63          INTEGER       myThid
64    
65    C     !LOCAL VARIABLES:
66  C     == Local variables ==  C     == Local variables ==
67    C     iStart, iEnd :: Temps. for string indexing
68    C     idString     :: Temp. for building message prefix
69        INTEGER iStart        INTEGER iStart
70        INTEGER iEnd        INTEGER iEnd
71        CHARACTER*9 idString        CHARACTER*9 idString
72    CEOP
73    
74  C--   Find beginning and end of message  C--   Find beginning and end of message
75        iStart = IFNBLNK( message )        iStart = IFNBLNK( message )
76        iEnd   = ILNBLNK( message )        iEnd   = ILNBLNK( message )
# Line 60  C--    Write single process format Line 81  C--    Write single process format
81         IF ( message .EQ. ' ' ) THEN         IF ( message .EQ. ' ' ) THEN
82          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '
83         ELSE         ELSE
84          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, message(iStart:iEnd)          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER,
85         &   message(iStart:iEnd)
86         ENDIF         ENDIF
87        ELSEIF ( pidIO .EQ. myProcId ) THEN        ELSE
 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  
88  C       PRINT_ERROR can be called by several threads simulataneously.  C       PRINT_ERROR can be called by several threads simulataneously.
89  C       The write statement may need to be marked as a critical section.  C       The write statement may need to be marked as a critical section.
90  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
91          _BEGIN_CRIT(myThid)  # ifdef USE_OMP_THREADING
92  #endif  C$OMP CRITICAL
93          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)  # else
94       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',         _BEGIN_CRIT(myThid)
95       &  ' '  # endif
 #ifndef FMTFTN_IO_THREAD_SAFE  
         _END_CRIT(myThid)  
96  #endif  #endif
97         ELSE         IF ( pidIO .EQ. myProcId ) THEN
98  #ifndef FMTFTN_IO_THREAD_SAFE  C--    Write multi-process format
99          _BEGIN_CRIT(myThid)           WRITE(idString,'(I4.4,A,I4.4)') myProcId,'.',myThid
100    
101             IF ( iEnd.EQ.0 ) THEN
102    c         WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
103              WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')
104         &    '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
105         &    ' '
106             ELSE
107    c         WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
108              WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')
109         &    '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
110         &    message(iStart:iEnd)
111             ENDIF
112           ENDIF
113    
114    #ifndef DISABLE_WRITE_TO_UNIT_ZERO
115    C--    also write directly to unit 0 :
116           IF ( numberOfProcs.EQ.1 .AND. iEnd.NE.0 ) THEN
117            IF ( nThreads.LE.1 ) THEN
118              WRITE(0,'(A)') message(1:iEnd)
119            ELSE
120              WRITE(0,'(A,I4.4,A,A)') '(TID ', myThid, ') ',
121         &                   message(1:iEnd)
122            ENDIF
123           ENDIF
124  #endif  #endif
125          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)  
      &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',  
      &  message(iStart:iEnd)  
126  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
127    # ifdef USE_OMP_THREADING
128    C$OMP END CRITICAL
129    # else
130          _END_CRIT(myThid)          _END_CRIT(myThid)
131    # endif
132  #endif  #endif
        ENDIF  
133        ENDIF        ENDIF
134  C  
135   1000 CONTINUE   1000 CONTINUE
136        RETURN        RETURN
137    
138    999 CONTINUE  c 999 CONTINUE
139         ioErrorCount(myThid) = ioErrorCount(myThid)+1  c      ioErrorCount(myThid) = ioErrorCount(myThid)+1
140        GOTO 1000  c     GOTO 1000
141        END        END
142    
143  CStartofinterface  CBOP
144        SUBROUTINE PRINT_LIST_I( fld, lFld, index_type, markEnd, compact, ioUnit )  C     !ROUTINE: PRINT_LIST_I
 C     /==========================================================\  
 C     | o SUBROUTINE PRINT_LIST_I                                |  
 C     |==========================================================|  
 C     | Routine for producing list of values for a field with    |  
 C     | duplicate values collected into                          |  
 C     |    n @ value                                             |  
 C     | record.                                                  |  
 C     \==========================================================/  
145    
146    C     !INTERFACE:
147          SUBROUTINE PRINT_LIST_I( fld, lFld, index_type,
148         &                         markEnd, compact, ioUnit )
149          IMPLICIT NONE
150    C     !DESCRIPTION:
151    C     *==========================================================*
152    C     | o SUBROUTINE PRINT\_LIST\_I                                
153    C     *==========================================================*
154    C     | Routine for producing list of values for a field with    
155    C     | duplicate values collected into                          
156    C     |    n \@ value                                              
157    C     | record.                                                  
158    C     *==========================================================*
159    
160    C     !USES:
161  C     == Global data ==    C     == Global data ==  
162  #include "SIZE.h"  #include "SIZE.h"
163  #include "EEPARAMS.h"  #include "EEPARAMS.h"
164    
165    C     !INPUT/OUTPUT PARAMETERS:
166  C     == Routine arguments ==  C     == Routine arguments ==
167  C     fld    -  Data to be printed  C     fld    ::  Data to be printed
168  C     lFld   -  Number of elements to be printed  C     lFld   ::  Number of elements to be printed
169  C     index_type - Flag indicating which type of index to print  C     index_type :: Flag indicating which type of index to print
170  C                  INDEX_K    => /* K = nnn */  C                   INDEX_K    => /* K = nnn */
171  C                  INDEX_I    => /* I = nnn */  C                   INDEX_I    => /* I = nnn */
172  C                  INDEX_J    => /* J = nnn */  C                   INDEX_J    => /* J = nnn */
173  C                  INDEX_NONE =>  C                   INDEX_NONE =>
174  C     compact -  Flag to control use of repeat symbol for same valued  C     compact ::  Flag to control use of repeat symbol for same valued
175  C                fields.  C                 fields.
176  C     markEnd -  Flag to control whether there is a separator after the  C     markEnd ::  Flag to control whether there is a separator after the
177  C                last element  C                 last element
178  C     ioUnit -  Unit number for IO.  C     ioUnit ::   Unit number for IO.
179        INTEGER lFld        INTEGER lFld
180        INTEGER index_type        INTEGER index_type
181        INTEGER fld(lFld)        INTEGER fld(lFld)
182        LOGICAL markEnd        LOGICAL markEnd
183        LOGICAL compact        LOGICAL compact
184        INTEGER ioUnit        INTEGER ioUnit
 CEndifinterface  
185    
186    C     !LOCAL VARIABLES:
187  C     == Local variables ==  C     == Local variables ==
188  C     iLo  - Range index holders for selecting elements with  C     iLo  - Range index holders for selecting elements with
189  C     iHi    with the same value  C     iHi    with the same value
# Line 158  C     K    - Loop counter Line 202  C     K    - Loop counter
202        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
203        CHARACTER*3 index_lab        CHARACTER*3 index_lab
204        INTEGER K        INTEGER K
205    CEOP
206    
207        IF     ( index_type .EQ. INDEX_I ) THEN        IF     ( index_type .EQ. INDEX_I ) THEN
208         index_lab = 'I ='         index_lab = 'I ='
# Line 176  C     K    - Loop counter Line 221  C     K    - Loop counter
221        xOld = fld(1)        xOld = fld(1)
222        DO K=2,lFld        DO K=2,lFld
223         xNew = fld(K  )         xNew = fld(K  )
224         IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
225          nDup = iHi-iLo+1          nDup = iHi-iLo+1
226          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
227           WRITE(msgBuf,'(A,I5,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
228           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
229       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
230         &    commOpen,index_lab,iLo,commClose
231          ELSE          ELSE
232           WRITE(msgBuf,'(I,'' '',A,I5,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc
233           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
234       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
235       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
# Line 200  C     K    - Loop counter Line 246  C     K    - Loop counter
246        IF ( markEnd ) punc = ','        IF ( markEnd ) punc = ','
247        nDup = iHi-iLo+1        nDup = iHi-iLo+1
248        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
249         WRITE(msgBuf,'(A,I5,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
250         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
251       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
252         &  commOpen,index_lab,iLo,commClose
253        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
254         WRITE(msgBuf,'(I,'' '',A,I5,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc
255         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
256       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
257       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
# Line 214  C     K    - Loop counter Line 261  C     K    - Loop counter
261        RETURN        RETURN
262        END        END
263    
264  CStartofinterface  CBOP
265        SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd, compact, ioUnit )  C     !ROUTINE: PRINT_LIST_L
266  C     /==========================================================\  
267  C     | o SUBROUTINE PRINT_LIST_L                                |  C     !INTERFACE:
268  C     |==========================================================|        SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd,
269  C     | Routine for producing list of values for a field with    |       &                         compact, ioUnit )
270  C     | duplicate values collected into                          |        IMPLICIT NONE
271  C     |    n @ value                                             |  C     !DESCRIPTION:
272  C     | record.                                                  |  C     *==========================================================*
273  C     \==========================================================/  C     | o SUBROUTINE PRINT\_LIST\_L                                
274    C     *==========================================================*
275    C     | Routine for producing list of values for a field with    
276    C     | duplicate values collected into                          
277    C     |    n \@ value                                              
278    C     | record.                                                  
279    C     *==========================================================*
280    
281    C     !USES:
282  C     == Global data ==    C     == Global data ==  
283  #include "SIZE.h"  #include "SIZE.h"
284  #include "EEPARAMS.h"  #include "EEPARAMS.h"
285    
286    C     !INPUT/OUTPUT PARAMETERS:
287  C     == Routine arguments ==  C     == Routine arguments ==
288  C     fld    -  Data to be printed  C     fld    -  Data to be printed
289  C     lFld   -  Number of elements to be printed  C     lFld   -  Number of elements to be printed
# Line 248  C     ioUnit -  Unit number for IO. Line 303  C     ioUnit -  Unit number for IO.
303        LOGICAL markEnd        LOGICAL markEnd
304        LOGICAL compact        LOGICAL compact
305        INTEGER ioUnit        INTEGER ioUnit
 CEndifinterface  
306    
307    C     !LOCAL VARIABLES:
308  C     == Local variables ==  C     == Local variables ==
309  C     iLo  - Range index holders for selecting elements with  C     iLo  - Range index holders for selecting elements with
310  C     iHi    with the same value  C     iHi    with the same value
# Line 268  C     K    - Loop counter Line 323  C     K    - Loop counter
323        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
324        CHARACTER*3 index_lab        CHARACTER*3 index_lab
325        INTEGER K        INTEGER K
326    CEOP
327    
328        IF     ( index_type .EQ. INDEX_I ) THEN        IF     ( index_type .EQ. INDEX_I ) THEN
329         index_lab = 'I ='         index_lab = 'I ='
# Line 286  C     K    - Loop counter Line 342  C     K    - Loop counter
342        xOld = fld(1)        xOld = fld(1)
343        DO K=2,lFld        DO K=2,lFld
344         xNew = fld(K  )         xNew = fld(K  )
345         IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. (xNew .NEQV. xOld) ) THEN
346          nDup = iHi-iLo+1          nDup = iHi-iLo+1
347          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
348           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
349           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
350       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
351         &    commOpen,index_lab,iLo,commClose
352          ELSE          ELSE
353           WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc
354           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
355       &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')
356       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
# Line 312  C     K    - Loop counter Line 369  C     K    - Loop counter
369        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
370         WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
371         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
372       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
373         &    commOpen,index_lab,iLo,commClose
374        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
375         WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc
376         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
377       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
378       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
# Line 324  C     K    - Loop counter Line 382  C     K    - Loop counter
382        RETURN        RETURN
383        END        END
384    
385  CStartofinterface  CBOP
386        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, markEnd, compact, ioUnit )  C     !ROUTINE: PRINT_LIST_R8
387  C     /==========================================================\  C     !INTERFACE:
388  C     | o SUBROUTINE PRINT_LIST_R8                               |        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type,
389  C     |==========================================================|       &    markEnd, compact, ioUnit )
390  C     | Routine for producing list of values for a field with    |        IMPLICIT NONE
391  C     | duplicate values collected into                          |  C     !DESCRIPTION:
392  C     |    n @ value                                             |  C     *==========================================================*
393  C     | record.                                                  |  C     | o SUBROUTINE PRINT\_LIST\_R8
394  C     \==========================================================/  C     *==========================================================*
395    C     | Routine for producing list of values for a field with    
396    C     | duplicate values collected into                          
397    C     |    n \@ value                                              
398    C     | record.                                                  
399    C     *==========================================================*
400    
401  C     == Global data ==    C     !USES:
402    C     == Global data ==
403  #include "SIZE.h"  #include "SIZE.h"
404  #include "EEPARAMS.h"  #include "EEPARAMS.h"
405    
406    C     !INPUT/OUTPUT PARAMETERS:
407  C     == Routine arguments ==  C     == Routine arguments ==
408  C     fld    -  Data to be printed  C     fld    -  Data to be printed
409  C     lFld   -  Number of elements to be printed  C     lFld   -  Number of elements to be printed
# Line 358  C     ioUnit -  Unit number for IO. Line 423  C     ioUnit -  Unit number for IO.
423        LOGICAL markEnd        LOGICAL markEnd
424        LOGICAL compact        LOGICAL compact
425        INTEGER ioUnit        INTEGER ioUnit
 CEndifinterface  
426    
427    C     !LOCA VARIABLES:
428  C     == Local variables ==  C     == Local variables ==
429  C     iLo  - Range index holders for selecting elements with  C     iLo  - Range index holders for selecting elements with
430  C     iHi    with the same value  C     iHi    with the same value
# Line 377  C     K    - Loop counter Line 442  C     K    - Loop counter
442        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
443        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
444        CHARACTER*3 index_lab        CHARACTER*3 index_lab
445          CHARACTER*25 fmt1, fmt2
446        INTEGER K        INTEGER K
447    CEOP
448    
449        IF     ( index_type .EQ. INDEX_I ) THEN        IF     ( index_type .EQ. INDEX_I ) THEN
450         index_lab = 'I ='         index_lab = 'I ='
# Line 388  C     K    - Loop counter Line 455  C     K    - Loop counter
455        ELSE        ELSE
456         index_lab = '?='         index_lab = '?='
457        ENDIF        ENDIF
458    C-    fortran format to write 1 or 2 indices:
459          fmt1='(A,1X,A,I3,1X,A)'
460          fmt2='(A,1X,A,I3,A,I3,1X,A)'
461          IF ( lFld.GE.1000 ) THEN
462            K = 1+INT(LOG10(FLOAT(lFld)))
463            WRITE(fmt1,'(A,I1,A)') '(A,1X,A,I',K,',1X,A)'
464            WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)'
465          ENDIF
466        commOpen  = '/*'        commOpen  = '/*'
467        commClose = '*/'        commClose = '*/'
468        iLo = 1        iLo = 1
# Line 396  C     K    - Loop counter Line 471  C     K    - Loop counter
471        xOld = fld(1)        xOld = fld(1)
472        DO K=2,lFld        DO K=2,lFld
473         xNew = fld(K  )         xNew = fld(K  )
474         IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
475          nDup = iHi-iLo+1          nDup = iHi-iLo+1
476          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
477           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
478           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
479       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &    WRITE(msgBuf(45:),fmt1)
480         &    commOpen,index_lab,iLo,commClose
481          ELSE          ELSE
482           WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
483           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
484       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),fmt2)
485       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
486          ENDIF          ENDIF
487          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
488         &    SQUEEZE_RIGHT , 1)
489          iLo  = K          iLo  = K
490          iHi  = K          iHi  = K
491          xOld = xNew          xOld = xNew
# Line 421  C     K    - Loop counter Line 498  C     K    - Loop counter
498        nDup = iHi-iLo+1        nDup = iHi-iLo+1
499        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
500         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
501         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
502       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &  WRITE(msgBuf(45:),fmt1)
503         &    commOpen,index_lab,iLo,commClose
504        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
505         WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
506         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
507       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),fmt2)
508       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
509        ENDIF        ENDIF
510        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
511         &    SQUEEZE_RIGHT , 1)
512    
513        RETURN        RETURN
514        END        END
515    
516  CStartOfInterface  CBOP
517    C     !ROUTINE: PRINT_MAPRS
518    C     !INTERFACE:
519        SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,
520       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
521       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
# Line 442  CStartOfInterface Line 523  CStartOfInterface
523       I       kMin, kMax,   kStr,       I       kMin, kMax,   kStr,
524       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
525       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
526  C     /==========================================================\  
527  C     | SUBROUTINE PRINT_MAPR4                                   |  C     !DESCRIPTION:
528  C     | o Does textual mapping printing of a field.              |  C     *==========================================================*
529  C     |==========================================================|  C     | SUBROUTINE PRINT\_MAPRS
530  C     | This routine does the actual formatting of the data      |  C     | o Does textual mapping printing of a field.
531  C     | and printing to a file. It assumes an array using the    |  C     *==========================================================*
532  C     | MITgcm UV indexing scheme and base index variables.      |  C     | This routine does the actual formatting of the data
533  C     | User code should call an interface routine like          |  C     | and printing to a file. It assumes an array using the
534  C     | PLOT_FIELD_XYR4( ... ) rather than this code directly.   |  C     | MITgcm UV indexing scheme and base index variables.
535  C     | Text plots can be oriented XY, YZ, XZ. An orientation    |  C     | User code should call an interface routine like
536  C     | is specficied through the "plotMode" argument. All the   |  C     | PLOT\_FIELD\_XYRS( ... ) rather than this code directly.
537  C     | plots made by a single call to this routine will use the |  C     | Text plots can be oriented XY, YZ, XZ. An orientation
538  C     | same contour interval. The plot range (iMin,...,byStr)   |  C     | is specficied through the "plotMode" argument. All the
539  C     | can be three-dimensional. A separate plot is made for    |  C     | plots made by a single call to this routine will use the
540  C     | each point in the plot range normal to the orientation.  |  C     | same contour interval. The plot range (iMin,...,byStr)
541  C     | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY). |  C     | can be three-dimensional. A separate plot is made for
542  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY|  C     | each point in the plot range normal to the orientation.
543  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).
544  C     |      Each plot would have extents iMin:iMax step iStr    |  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY
545  C     |      and jMin:jMax step jStr.                            |  C     |      plots - one for K=1, one for K=3 and one for K=5.
546  C     \==========================================================/  C     |      Each plot would have extents iMin:iMax step iStr
547    C     |      and jMin:jMax step jStr.
548    C     *==========================================================*
549    
550    C     !USES:
551          IMPLICIT NONE
552    
553  C     == Global variables ==  C     == Global variables ==
554  #include "SIZE.h"  #include "SIZE.h"
555  #include "EEPARAMS.h"  #include "EEPARAMS.h"
556  #include "EESUPPORT.h"  #include "EESUPPORT.h"
557          INTEGER  IFNBLNK
558          EXTERNAL IFNBLNK
559          INTEGER  ILNBLNK
560          EXTERNAL ILNBLNK
561    
562    C     !INPUT/OUTPUT PARAMETERS:
563  C     == Routine arguments ==  C     == Routine arguments ==
564  C     fld        - Real*4 array holding data to be plotted  C     fld        - Real*4 array holding data to be plotted
565  C     fldTitle   - Name of field to be plotted  C     fldTitle   - Name of field to be plotted
# Line 496  C     kStr Line 587  C     kStr
587        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
588        INTEGER bxMin, bxMax, bxStr        INTEGER bxMin, bxMax, bxStr
589        INTEGER byMin, byMax, byStr        INTEGER byMin, byMax, byStr
 CEndOfInterface  
 C     == Local variables ==  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
590    
591    C     !LOCAL VARIABLES:
592  C     == Local variables ==  C     == Local variables ==
593  C     plotBuf - Buffer for building plot record  C     plotBuf - Buffer for building plot record
594  C     chList  - Character string used for plot  C     chList  - Character string used for plot
# Line 526  C               Min  - Start index withi Line 612  C               Min  - Start index withi
612  C               Max  - End index within block  C               Max  - End index within block
613  C               Str  - stride within block  C               Str  - stride within block
614        INTEGER MAX_LEN_PLOTBUF        INTEGER MAX_LEN_PLOTBUF
615        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 )        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-20 )
616        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf
617        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
618        INTEGER lChList        INTEGER lChList
619        PARAMETER ( lChList = 28 )        PARAMETER ( lChList = 28 )
620        CHARACTER*(lChList) chList        CHARACTER*(lChList) chList
621        REAL fMin        _RL  fMin
622        REAL fMax        _RL  fMax
623        REAL fRange        _RL  fRange
624        REAL val        _RL  val
625        REAL small        _RL  small
626        CHARACTER*2  accLab        CHARACTER*2  accLab
627        CHARACTER*7  dwnLab        CHARACTER*7  dwnLab
628        CHARACTER*3  pltLab        CHARACTER*3  pltLab
# Line 551  C               Str  - stride within blo Line 637  C               Str  - stride within blo
637        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx
638        INTEGER bi, bj, bk        INTEGER bi, bj, bk
639        LOGICAL validRange        LOGICAL validRange
640    CEOP
641    
642        chList = '-abcdefghijklmnopqrstuvwxyz+'        chList = '-abcdefghijklmnopqrstuvwxyz+'
643        small  = 1. _d -15        small  =  1. _d -15
644        fMin   =  1. _d 32        fMin   =  1. _d  32
645        fMax   = -1. _d 32        fMax   = -1. _d  32
646        validRange = .FALSE.        validRange = .FALSE.
647    
648  C--   Calculate field range  C--   Calculate field range
# Line 564  C--   Calculate field range Line 651  C--   Calculate field range
651          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
652           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
653            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
654             IF ( fld(I,J,K,bi,bj) .NE. 0. ) THEN             IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN
655              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
656       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
657              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
# Line 576  C--   Calculate field range Line 663  C--   Calculate field range
663         ENDDO         ENDDO
664        ENDDO        ENDDO
665        fRange = fMax-fMin        fRange = fMax-fMin
666        IF ( fRange .GT. small ) THEN        IF ( fRange .GT. small ) validRange = .TRUE.
        validRange = .TRUE.  
       ENDIF  
667    
668  C--   Write field title and statistics  C--   Write field title and statistics
669        msgBuf = '// ======================================================='        msgBuf =
670         & '// ======================================================='
671        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
672       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
673        iStrngLo = IFNBLNK(fldTitle)        iStrngLo = IFNBLNK(fldTitle)
# Line 601  C--   Write field title and statistics Line 687  C--   Write field title and statistics
687       & '// CMAX = ', fMax       & '// CMAX = ', fMax
688        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
689       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
690        WRITE(msgBuf,'(A,1PE30.15)')        IF ( validRange ) THEN
691       & '// CINT = ', fRange/FLOAT(lChlist-1)         WRITE(msgBuf,'(A,1PE30.15)')
692         &  '// CINT = ', fRange/FLOAT(lChlist-1)
693          ELSE
694           WRITE(msgBuf,'(A,1PE30.15)')
695         &  '// CINT = ', 0.
696          ENDIF
697        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
698       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
699        WRITE(msgBuf,'(A,1024A1)')        WRITE(msgBuf,'(A,1024A1)')
# Line 634  C--   Write field title and statistics Line 725  C--   Write field title and statistics
725       &  ':',kStr,')'       &  ':',kStr,')'
726        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
727       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
728        msgBuf = '// ======================================================='        msgBuf =
729         & '// ======================================================='
730        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
731       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
732    
733    c     if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
734    c      msgBuf =
735    c    &  'Model domain too big to print to terminal - skipping I/O'
736    c      CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
737    c    &                   SQUEEZE_RIGHT, 1)
738    c      RETURN
739    c     endif
740    
741  C--   Write field  C--   Write field
742  C     Figure out slice type and set plotting parameters appropriately  C     Figure out slice type and set plotting parameters appropriately
743  C     acc = accross the page  C     acc = accross the page
# Line 730  C      X across, Z down slice Line 830  C      X across, Z down slice
830         pltStep = sNy         pltStep = sNy
831         pltLab  = 'J ='         pltLab  = 'J ='
832        ENDIF        ENDIF
833    C-    check if it fits into buffer (-10 should be enough but -12 is safer):
834          IF ( (accMax-accMin+1)*(accBhi-accBlo+1).GT.MAX_LEN_PLOTBUF-12
835         &     .AND. validRange ) THEN
836           msgBuf =
837         &  'Model domain too big to print to terminal - skipping I/O'
838           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
839         &                   SQUEEZE_RIGHT, 1)
840           validRange = .FALSE.
841          ENDIF
842        IF ( validRange ) THEN        IF ( validRange ) THEN
843  C      Header  C      Header
844  C      Data  C      Data
845         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
846          DO K=pltMin,pltMax,pltStr          DO K=pltMin,pltMax,pltStr
847           WRITE(plotBuf,'(A,I,I,I,I)') pltLab,           WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
848       &   pltBase-1+(bk-1)*pltStep+K       &   pltBase-1+(bk-1)*pltStep+K
849           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
850       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
# Line 770  C      Data Line 879  C      Data
879             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
880              WRITE(plotBuf(iBuf:),'(A)')  '|'              WRITE(plotBuf(iBuf:),'(A)')  '|'
881             ELSE             ELSE
882              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10)
883             ENDIF             ENDIF
884            ENDDO            ENDDO
885           ENDDO           ENDDO
# Line 792  C      Data Line 901  C      Data
901               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
902                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
903               ENDIF               ENDIF
904               IDX = NINT(               IF ( validRange .AND. val .NE. 0. ) THEN
905                  IDX = NINT(
906       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)
907       &             )+1       &             )+1
908                 ELSE
909                  IDX = 1
910                 ENDIF
911               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
912       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
913               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
# Line 812  C      Data Line 925  C      Data
925         ENDDO         ENDDO
926        ENDIF        ENDIF
927  C--   Write delimiter  C--   Write delimiter
928        msgBuf = '// ======================================================='        msgBuf =
929         & '// ======================================================='
930        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
931       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
932        msgBuf = '// END OF FIELD                                          ='        msgBuf =
933         & '// END OF FIELD                                          ='
934        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
935       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
936        msgBuf = '// ======================================================='        msgBuf =
937         & '// ======================================================='
938        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
939       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
940        msgBuf = ' '        msgBuf = ' '
# Line 828  C--   Write delimiter Line 944  C--   Write delimiter
944        RETURN        RETURN
945        END        END
946    
947  CStartOfInterface  CBOP
948    C     !ROUTINE: PRINT_MAPRL
949    
950    C     !INTERFACE:
951        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
952       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
953       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
# Line 836  CStartOfInterface Line 955  CStartOfInterface
955       I       kMin, kMax,   kStr,       I       kMin, kMax,   kStr,
956       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
957       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
958  C     /==========================================================\  
959  C     | SUBROUTINE PRINT_MAPRL                                   |  C     !DESCRIPTION:
960  C     | o Does textual mapping printing of a field.              |  C     *==========================================================*
961  C     |==========================================================|  C     | SUBROUTINE PRINT\_MAPRL
962  C     | This routine does the actual formatting of the data      |  C     | o Does textual mapping printing of a field.
963  C     | and printing to a file. It assumes an array using the    |  C     *==========================================================*
964  C     | MITgcm UV indexing scheme and base index variables.      |  C     | This routine does the actual formatting of the data
965  C     | User code should call an interface routine like          |  C     | and printing to a file. It assumes an array using the
966  C     | PLOT_FIELD_XYR8( ... ) rather than this code directly.   |  C     | MITgcm UV indexing scheme and base index variables.
967  C     | Text plots can be oriented XY, YZ, XZ. An orientation    |  C     | User code should call an interface routine like
968  C     | is specficied through the "plotMode" argument. All the   |  C     | PLOT\_FIELD\_XYRL( ... ) rather than this code directly.
969  C     | plots made by a single call to this routine will use the |  C     | Text plots can be oriented XY, YZ, XZ. An orientation
970  C     | same contour interval. The plot range (iMin,...,byStr)   |  C     | is specficied through the "plotMode" argument. All the
971  C     | can be three-dimensional. A separate plot is made for    |  C     | plots made by a single call to this routine will use the
972  C     | each point in the plot range normal to the orientation.  |  C     | same contour interval. The plot range (iMin,...,byStr)
973  C     | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY). |  C     | can be three-dimensional. A separate plot is made for
974  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY|  C     | each point in the plot range normal to the orientation.
975  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).
976  C     |      Each plot would have extents iMin:iMax step iStr    |  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY
977  C     |      and jMin:jMax step jStr.                            |  C     |      plots - one for K=1, one for K=3 and one for K=5.
978  C     \==========================================================/  C     |      Each plot would have extents iMin:iMax step iStr
979    C     |      and jMin:jMax step jStr.
980    C     *==========================================================*
981    
982    C     !USES:
983          IMPLICIT NONE
984    
985  C     == Global variables ==  C     == Global variables ==
986  #include "SIZE.h"  #include "SIZE.h"
987  #include "EEPARAMS.h"  #include "EEPARAMS.h"
988  #include "EESUPPORT.h"  #include "EESUPPORT.h"
989          INTEGER  IFNBLNK
990          EXTERNAL IFNBLNK
991          INTEGER  ILNBLNK
992          EXTERNAL ILNBLNK
993    
994    C     !INPUT/OUTPUT PARAMETERS:
995  C     == Routine arguments ==  C     == Routine arguments ==
996  C     fld        - Real*8 array holding data to be plotted  C     fld        - Real*8 array holding data to be plotted
997  C     fldTitle   - Name of field to be plotted  C     fldTitle   - Name of field to be plotted
# Line 890  C     kStr Line 1019  C     kStr
1019        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
1020        INTEGER bxMin, bxMax, bxStr        INTEGER bxMin, bxMax, bxStr
1021        INTEGER byMin, byMax, byStr        INTEGER byMin, byMax, byStr
 CEndOfInterface  
 C     == Local variables ==  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
1022    
1023    C     !LOCAL VARIABLES:
1024  C     == Local variables ==  C     == Local variables ==
1025  C     plotBuf - Buffer for building plot record  C     plotBuf - Buffer for building plot record
1026  C     chList  - Character string used for plot  C     chList  - Character string used for plot
# Line 920  C               Min  - Start index withi Line 1044  C               Min  - Start index withi
1044  C               Max  - End index within block  C               Max  - End index within block
1045  C               Str  - stride within block  C               Str  - stride within block
1046        INTEGER MAX_LEN_PLOTBUF        INTEGER MAX_LEN_PLOTBUF
1047        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 )        PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-20 )
1048        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf        CHARACTER*(MAX_LEN_PLOTBUF) plotBuf
1049        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
1050        INTEGER lChList        INTEGER lChList
1051        PARAMETER ( lChList = 28 )        PARAMETER ( lChList = 28 )
1052        CHARACTER*(lChList) chList        CHARACTER*(lChList) chList
1053        REAL fMin        _RL  fMin
1054        REAL fMax        _RL  fMax
1055        REAL fRange        _RL  fRange
1056        REAL val        _RL  val
1057        REAL small        _RL  small
1058        CHARACTER*2  accLab        CHARACTER*2  accLab
1059        CHARACTER*7  dwnLab        CHARACTER*7  dwnLab
1060        CHARACTER*3  pltLab        CHARACTER*3  pltLab
# Line 945  C               Str  - stride within blo Line 1069  C               Str  - stride within blo
1069        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx
1070        INTEGER bi, bj, bk        INTEGER bi, bj, bk
1071        LOGICAL validRange        LOGICAL validRange
1072    CEOP
1073    
1074        chList = '-abcdefghijklmnopqrstuvwxyz+'        chList = '-abcdefghijklmnopqrstuvwxyz+'
1075        small  = 1. _d -15        small  = 1. _d -15
# Line 958  C--   Calculate field range Line 1083  C--   Calculate field range
1083          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
1084           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
1085            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
1086  C          IF ( fld(I,J,K,bi,bj) .NE. 0. ) THEN             IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )
1087         &     THEN
1088              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
1089       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
1090              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
1091       &       fMax = fld(I,J,K,bi,bj)       &       fMax = fld(I,J,K,bi,bj)
1092  C          ENDIF             ENDIF
1093            ENDDO            ENDDO
1094           ENDDO           ENDDO
1095          ENDDO          ENDDO
1096         ENDDO         ENDDO
1097        ENDDO        ENDDO
1098        fRange = fMax-fMin        fRange = fMax-fMin
1099        IF ( fRange .GT. small ) THEN        IF ( fRange .GT. small ) validRange = .TRUE.
        validRange = .TRUE.  
       ENDIF  
1100    
1101  C--   Write field title and statistics  C--   Write field title and statistics
1102        msgBuf = '// ======================================================='        msgBuf =
1103         & '// ======================================================='
1104        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1105       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1106        iStrngLo = IFNBLNK(fldTitle)        iStrngLo = IFNBLNK(fldTitle)
# Line 995  C--   Write field title and statistics Line 1120  C--   Write field title and statistics
1120       & '// CMAX = ', fMax       & '// CMAX = ', fMax
1121        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1122       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1123        WRITE(msgBuf,'(A,1PE30.15)')        IF ( validRange ) THEN
1124           WRITE(msgBuf,'(A,1PE30.15)')
1125       & '// CINT = ', fRange/FLOAT(lChlist-1)       & '// CINT = ', fRange/FLOAT(lChlist-1)
1126          ELSE
1127           WRITE(msgBuf,'(A,1PE30.15)')
1128         & '// CINT = ', 0.
1129          ENDIF
1130        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1131       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1132        WRITE(msgBuf,'(A,1024A1)')        WRITE(msgBuf,'(A,1024A1)')
# Line 1028  C--   Write field title and statistics Line 1158  C--   Write field title and statistics
1158       &  ':',kStr,')'       &  ':',kStr,')'
1159        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1160       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1161        msgBuf = '// ======================================================='        msgBuf =
1162         & '// ======================================================='
1163        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1164       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1165    
1166    c     if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
1167    c      msgBuf =
1168    c    &  'Model domain too big to print to terminal - skipping I/O'
1169    c      CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1170    c    &                   SQUEEZE_RIGHT, 1)
1171    c      RETURN
1172    c     endif
1173    
1174  C--   Write field  C--   Write field
1175  C     Figure out slice type and set plotting parameters appropriately  C     Figure out slice type and set plotting parameters appropriately
1176  C     acc = accross the page  C     acc = accross the page
# Line 1124  C      X across, Z down slice Line 1263  C      X across, Z down slice
1263         pltStep = sNy         pltStep = sNy
1264         pltLab  = 'J ='         pltLab  = 'J ='
1265        ENDIF        ENDIF
1266    C-    check if it fits into buffer (-10 should be enough but -12 is safer):
1267          IF ( (accMax-accMin+1)*(accBhi-accBlo+1).GT.MAX_LEN_PLOTBUF-12
1268         &     .AND. validRange ) THEN
1269           msgBuf =
1270         &  'Model domain too big to print to terminal - skipping I/O'
1271           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1272         &                   SQUEEZE_RIGHT, 1)
1273           validRange = .FALSE.
1274          ENDIF
1275        IF ( validRange ) THEN        IF ( validRange ) THEN
1276  C      Header  C      Header
1277  C      Data  C      Data
1278         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
1279          DO K=pltMin,pltMax,pltStr          DO K=pltMin,pltMax,pltStr
1280           WRITE(plotBuf,'(A,I,I,I,I)') pltLab,           WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
1281       &   pltBase-1+(bk-1)*pltStep+K       &   pltBase-1+(bk-1)*pltStep+K
1282           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1283       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
# Line 1163  C      Data Line 1311  C      Data
1311             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
1312              WRITE(plotBuf(iBuf:),'(A)')  '|'              WRITE(plotBuf(iBuf:),'(A)')  '|'
1313             ELSE             ELSE
1314              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10)
1315             ENDIF             ENDIF
1316            ENDDO            ENDDO
1317           ENDDO           ENDDO
# Line 1184  C      Data Line 1332  C      Data
1332               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
1333                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
1334               ENDIF               ENDIF
1335               IDX = NINT(               IF ( validRange .AND. val .NE. 0. ) THEN
1336       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)                IDX = NINT(
1337       &             )+1       &               FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1338         &              )+1
1339                 ELSE
1340                  IDX = 1
1341                 ENDIF
1342               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1343       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1344               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
# Line 1203  C      Data Line 1355  C      Data
1355         ENDDO         ENDDO
1356        ENDIF        ENDIF
1357  C--   Write delimiter  C--   Write delimiter
1358        msgBuf = '// ======================================================='        msgBuf =
1359         & '// ======================================================='
1360        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1361       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1362        msgBuf = '// END OF FIELD                                          ='        msgBuf =
1363         & '// END OF FIELD                                          ='
1364        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1365       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1366        msgBuf = '// ======================================================='        msgBuf =
1367         & '// ======================================================='
1368        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1369       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1370        msgBuf = ' '        msgBuf = ' '
# Line 1219  C--   Write delimiter Line 1374  C--   Write delimiter
1374        RETURN        RETURN
1375        END        END
1376    
1377  CStartOfInterface  CBOP
1378    C     !ROUTINE: PRINT_MESSAGE
1379    
1380    C     !INTERFACE:
1381        SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )        SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )
1382  C     /============================================================\        IMPLICIT NONE
1383  C     | SUBROUTINE PRINT_MESSAGE                                   |  C     !DESCRIPTION:
1384  C     | o Write out informational message using "standard" format. |  C     *============================================================*
1385  C     | Notes                                                      |  C     | SUBROUTINE PRINT\_MESSAGE                                    
1386  C     | =====                                                      |  C     | o Write out informational message using "standard" format.  
1387  C     | o Some system's I/O is not "thread-safe". For this reason  |  C     *============================================================*
1388  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |  C     | Notes                                                      
1389  C     |   critical region is defined around the write here. In some|  C     | =====                                                      
1390  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |  C     | o Some system   I/O is not "thread-safe". For this reason  
1391  C     |   for thread number 1 - writes for other threads are       |  C     |   without the FMTFTN\_IO\_THREAD\_SAFE directive set a        
1392  C     |   ignored!                                                 |  C     |   critical region is defined around the write here. In some
1393  C     | o In a non-parallel form these routines can still be used. |  C     |   cases  BEGIN\_CRIT() is approximated by only doing writes  
1394  C     |   to produce pretty printed output!                        |  C     |   for thread number 1 - writes for other threads are        
1395  C     \============================================================/  C     |   ignored!                                                  
1396    C     | o In a non-parallel form these routines can still be used.  
1397    C     |   to produce pretty printed output!                        
1398    C     *============================================================*
1399    
1400    C     !USES:
1401  C     == Global data ==  C     == Global data ==
1402  #include "SIZE.h"  #include "SIZE.h"
1403  #include "EEPARAMS.h"  #include "EEPARAMS.h"
1404  #include "EESUPPORT.h"  #include "EESUPPORT.h"
1405          INTEGER  IFNBLNK
1406          EXTERNAL IFNBLNK
1407          INTEGER  ILNBLNK
1408          EXTERNAL ILNBLNK
1409    
1410    C     !INPUT/OUTPUT PARAMETERS:
1411  C     == Routine arguments ==  C     == Routine arguments ==
1412  C     message - Message to write  C     message :: Message to write
1413  C     unit    - Unit number to write to  C     unit    :: Unit number to write to
1414  C     sq      - Justification option  C     sq      :: Justification option
1415        CHARACTER*(*) message        CHARACTER*(*) message
1416        INTEGER       unit        INTEGER       unit
1417        CHARACTER*(*) sq        CHARACTER*(*) sq
1418        INTEGER  myThid        INTEGER  myThid
1419  CEndOfInterface  
1420        INTEGER  IFNBLNK  C     !LOCAL VARIABLES:
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
1421  C     == Local variables ==  C     == Local variables ==
1422    C     iStart, iEnd :: String indexing variables
1423    C     idString     :: Temp. for building prefix.
1424        INTEGER iStart        INTEGER iStart
1425        INTEGER iEnd        INTEGER iEnd
1426        CHARACTER*9 idString        CHARACTER*9 idString
1427    CEOP
1428    
1429  C--   Find beginning and end of message  C--   Find beginning and end of message
1430        IF ( sq .EQ. SQUEEZE_BOTH .OR.        IF ( sq .EQ. SQUEEZE_BOTH .OR.
1431       &     sq .EQ. SQUEEZE_LEFT ) THEN       &     sq .EQ. SQUEEZE_LEFT ) THEN
# Line 1310  C       The write statement may need to Line 1480  C       The write statement may need to
1480  #endif  #endif
1481         ENDIF         ENDIF
1482        ENDIF        ENDIF
1483    
1484    #ifndef DISABLE_WRITE_TO_UNIT_ZERO
1485    C--   if error message, also write directly to unit 0 :
1486          IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1
1487         &     .AND. unit.EQ.errorMessageUnit ) THEN
1488            iEnd   = ILNBLNK( message )
1489            IF (iEnd.NE.0) WRITE(0,'(A)') message(1:iEnd)
1490          ENDIF
1491    #endif
1492  C  C
1493   1000 CONTINUE   1000 CONTINUE
1494        RETURN        RETURN
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.28
  ViewVC Help
Powered by ViewVC 1.1.22