/[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.5 by cnh, Mon Apr 27 04:24:22 1998 UTC revision 1.25 by jmc, Sat Sep 2 22:47:10 2006 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 18  C--    o print_mapr8    Formats ABCD... Line 19  C--    o print_mapr8    Formats ABCD...
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)')  # 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)')  
      &  '(',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
136        RETURN        RETURN
137    
138    c 999 CONTINUE
139    c      ioErrorCount(myThid) = ioErrorCount(myThid)+1
140    c     GOTO 1000
141        END        END
142    
143  CStartofinterface  CBOP
144        SUBROUTINE PRINT_LIST_I( fld, lFld, index_type, ioUnit )  C     !ROUTINE: PRINT_LIST_I
145  C     /==========================================================\  
146  C     | o SUBROUTINE PRINT_LIST_I                                |  C     !INTERFACE:
147  C     |==========================================================|        SUBROUTINE PRINT_LIST_I( fld, lFld, index_type,
148  C     | Routine for producing list of values for a field with    |       &                         markEnd, compact, ioUnit )
149  C     | duplicate values collected into                          |        IMPLICIT NONE
150  C     |    n @ value                                             |  C     !DESCRIPTION:
151  C     | record.                                                  |  C     *==========================================================*
152  C     \==========================================================/  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     ioUnit -  Unit number for IO.  C     compact ::  Flag to control use of repeat symbol for same valued
175    C                 fields.
176    C     markEnd ::  Flag to control whether there is a separator after the
177    C                 last element
178    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
183          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 143  C     K    - Loop counter Line 198  C     K    - Loop counter
198        INTEGER nDup        INTEGER nDup
199        INTEGER xNew, xOld        INTEGER xNew, xOld
200        CHARACTER punc        CHARACTER punc
201        CHARACTER(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
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 165  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 ( 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
236          ENDIF          ENDIF
237          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
238          iLo  = K          iLo  = K
239          iHi  = K          iHi  = K
240          xOld = xNew          xOld = xNew
# Line 186  C     K    - Loop counter Line 243  C     K    - Loop counter
243         ENDIF         ENDIF
244        ENDDO        ENDDO
245        punc = ' '        punc = ' '
246          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
258        ENDIF        ENDIF
259        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
260    
261        RETURN        RETURN
262        END        END
263    
264  CStartofinterface  CBOP
265        SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, 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 225  C                  INDEX_K    => /* K = Line 292  C                  INDEX_K    => /* K =
292  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
293  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
294  C                  INDEX_NONE =>  C                  INDEX_NONE =>
295    C     compact -  Flag to control use of repeat symbol for same valued
296    C                fields.
297    C     markEnd -  Flag to control whether there is a separator after the
298    C                last element
299  C     ioUnit -  Unit number for IO.  C     ioUnit -  Unit number for IO.
300        INTEGER lFld        INTEGER lFld
301        INTEGER index_type        INTEGER index_type
302        LOGICAL fld(lFld)        LOGICAL fld(lFld)
303          LOGICAL markEnd
304          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 246  C     K    - Loop counter Line 319  C     K    - Loop counter
319        INTEGER nDup        INTEGER nDup
320        LOGICAL xNew, xOld        LOGICAL xNew, xOld
321        CHARACTER punc        CHARACTER punc
322        CHARACTER(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
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 268  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 ( 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
357          ENDIF          ENDIF
358          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
359          iLo  = K          iLo  = K
360          iHi  = K          iHi  = K
361          xOld = xNew          xOld = xNew
# Line 289  C     K    - Loop counter Line 364  C     K    - Loop counter
364         ENDIF         ENDIF
365        ENDDO        ENDDO
366        punc = ' '        punc = ' '
367          IF ( markEnd ) punc = ','
368        nDup = iHi-iLo+1        nDup = iHi-iLo+1
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
379        ENDIF        ENDIF
380        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
381    
382        RETURN        RETURN
383        END        END
384    
385  CStartofinterface  CBOP
386        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, 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 328  C                  INDEX_K    => /* K = Line 412  C                  INDEX_K    => /* K =
412  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
413  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
414  C                  INDEX_NONE =>  C                  INDEX_NONE =>
415    C     compact -  Flag to control use of repeat symbol for same valued
416    C                fields.
417    C     markEnd -  Flag to control whether there is a separator after the
418    C                last element
419  C     ioUnit -  Unit number for IO.  C     ioUnit -  Unit number for IO.
420        INTEGER lFld        INTEGER lFld
421        INTEGER index_type        INTEGER index_type
422        Real*8  fld(lFld)        Real*8  fld(lFld)
423          LOGICAL markEnd
424          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 349  C     K    - Loop counter Line 439  C     K    - Loop counter
439        INTEGER nDup        INTEGER nDup
440        Real*8 xNew, xOld        Real*8 xNew, xOld
441        CHARACTER punc        CHARACTER punc
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        INTEGER K        INTEGER K
446    CEOP
447    
448        IF     ( index_type .EQ. INDEX_I ) THEN        IF     ( index_type .EQ. INDEX_I ) THEN
449         index_lab = 'I ='         index_lab = 'I ='
# Line 371  C     K    - Loop counter Line 462  C     K    - Loop counter
462        xOld = fld(1)        xOld = fld(1)
463        DO K=2,lFld        DO K=2,lFld
464         xNew = fld(K  )         xNew = fld(K  )
465         IF ( xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
466          nDup = iHi-iLo+1          nDup = iHi-iLo+1
467          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
468           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
469           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
470       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
471         &    commOpen,index_lab,iLo,commClose
472          ELSE          ELSE
473           WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
474           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
475       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
476       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
477          ENDIF          ENDIF
478          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
479         &    SQUEEZE_RIGHT , 1)
480          iLo  = K          iLo  = K
481          iHi  = K          iHi  = K
482          xOld = xNew          xOld = xNew
# Line 392  C     K    - Loop counter Line 485  C     K    - Loop counter
485         ENDIF         ENDIF
486        ENDDO        ENDDO
487        punc = ' '        punc = ' '
488          IF ( markEnd ) punc = ','
489        nDup = iHi-iLo+1        nDup = iHi-iLo+1
490        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
491         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
492         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
493       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
494         &    commOpen,index_lab,iLo,commClose
495        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
496         WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
497         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
498       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
499       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
500        ENDIF        ENDIF
501        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
502         &    SQUEEZE_RIGHT , 1)
503    
504        RETURN        RETURN
505        END        END
506    
507  CStartOfInterface  CBOP
508        SUBROUTINE PRINT_MAPR4 ( fld, fldTitle, plotMode,  C     !ROUTINE: PRINT_MAPRS
509    C     !INTERFACE:
510          SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,
511       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
512       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
513       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
514       I       kMin, kMax,   kStr,       I       kMin, kMax,   kStr,
515       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
516       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
517  C     /==========================================================\        IMPLICIT NONE
518  C     | SUBROUTINE PRINT_MAPR4                                   |  C     !DESCRIPTION:
519  C     | o Does textual mapping printing of a field.              |  C     *==========================================================*
520  C     |==========================================================|  C     | SUBROUTINE PRINT\_MAPR4                                    
521  C     | This routine does the actual formatting of the data      |  C     | o Does textual mapping printing of a field.              
522  C     | and printing to a file. It assumes an array using the    |  C     *==========================================================*
523  C     | MITgcm UV indexing scheme and base index variables.      |  C     | This routine does the actual formatting of the data      
524  C     | User code should call an interface routine like          |  C     | and printing to a file. It assumes an array using the    
525  C     | PLOT_FIELD_XYR4( ... ) rather than this code directly.   |  C     | MITgcm UV indexing scheme and base index variables.      
526  C     | Text plots can be oriented XY, YZ, XZ. An orientation    |  C     | User code should call an interface routine like          
527  C     | is specficied through the "plotMode" argument. All the   |  C     | PLOT\_FIELD\_XYR4( ... ) rather than this code directly.    
528  C     | plots made by a single call to this routine will use the |  C     | Text plots can be oriented XY, YZ, XZ. An orientation    
529  C     | same contour interval. The plot range (iMin,...,byStr)   |  C     | is specficied through the "plotMode" argument. All the    
530  C     | can be three-dimensional. A separate plot is made for    |  C     | plots made by a single call to this routine will use the  
531  C     | each point in the plot range normal to the orientation.  |  C     | same contour interval. The plot range (iMin,...,byStr)    
532  C     | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY). |  C     | can be three-dimensional. A separate plot is made for    
533  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY|  C     | each point in the plot range normal to the orientation.  
534  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).  
535  C     |      Each plot would have extents iMin:iMax step iStr    |  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY
536  C     |      and jMin:jMax step jStr.                            |  C     |      plots - one for K=1, one for K=3 and one for K=5.    
537  C     \==========================================================/  C     |      Each plot would have extents iMin:iMax step iStr    
538    C     |      and jMin:jMax step jStr.                            
539    C     *==========================================================*
540    
541    C     !USES:
542  C     == Global variables ==  C     == Global variables ==
543  #include "SIZE.h"  #include "SIZE.h"
544  #include "EEPARAMS.h"  #include "EEPARAMS.h"
545  #include "EESUPPORT.h"  #include "EESUPPORT.h"
546          INTEGER  IFNBLNK
547          EXTERNAL IFNBLNK
548          INTEGER  ILNBLNK
549          EXTERNAL ILNBLNK
550    
551    C     !INPUT/OUTPUT PARAMETERS:
552  C     == Routine arguments ==  C     == Routine arguments ==
553  C     fld        - Real*4 array holding data to be plotted  C     fld        - Real*4 array holding data to be plotted
554  C     fldTitle   - Name of field to be plotted  C     fldTitle   - Name of field to be plotted
# Line 464  C     kStr Line 570  C     kStr
570        INTEGER jLo, jHi        INTEGER jLo, jHi
571        INTEGER kLo, kHi        INTEGER kLo, kHi
572        INTEGER nBx, nBy        INTEGER nBx, nBy
573        Real*4 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RS fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
574        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
575        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
576        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
577        INTEGER bxMin, bxMax, bxStr        INTEGER bxMin, bxMax, bxStr
578        INTEGER byMin, byMax, byStr        INTEGER byMin, byMax, byStr
 CEndOfInterface  
 C     == Local variables ==  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
579    
580    C     !LOCAL VARIABLES:
581  C     == Local variables ==  C     == Local variables ==
582  C     plotBuf - Buffer for building plot record  C     plotBuf - Buffer for building plot record
583  C     chList  - Character string used for plot  C     chList  - Character string used for plot
# Line 506  C               Str  - stride within blo Line 607  C               Str  - stride within blo
607        INTEGER lChList        INTEGER lChList
608        PARAMETER ( lChList = 28 )        PARAMETER ( lChList = 28 )
609        CHARACTER*(lChList) chList        CHARACTER*(lChList) chList
610        REAL fMin        _RL  fMin
611        REAL fMax        _RL  fMax
612        REAL fRange        _RL  fRange
613        REAL val        _RL  val
614        REAL small        _RL  small
615        CHARACTER*2  accLab        CHARACTER*2  accLab
616        CHARACTER*7  dwnLab        CHARACTER*7  dwnLab
617        CHARACTER*3  pltLab        CHARACTER*3  pltLab
# Line 525  C               Str  - stride within blo Line 626  C               Str  - stride within blo
626        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx
627        INTEGER bi, bj, bk        INTEGER bi, bj, bk
628        LOGICAL validRange        LOGICAL validRange
629    CEOP
630    
631        chList = '-abcdefghijklmnopqrstuvwxyz+'        chList = '-abcdefghijklmnopqrstuvwxyz+'
632        small  = 1. _d -15        small  =  1. _d -15
633        fMin   =  1. _d 32        fMin   =  1. _d  32
634        fMax   = -1. _d 32        fMax   = -1. _d  32
635        validRange = .FALSE.        validRange = .FALSE.
636    
637  C--   Calculate field range  C--   Calculate field range
# Line 538  C--   Calculate field range Line 640  C--   Calculate field range
640          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
641           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
642            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
643             IF ( fld(I,J,K,bi,bj) .NE. 0. ) THEN             IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN
644              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
645       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
646              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
# Line 550  C--   Calculate field range Line 652  C--   Calculate field range
652         ENDDO         ENDDO
653        ENDDO        ENDDO
654        fRange = fMax-fMin        fRange = fMax-fMin
655        IF ( fRange .GT. small ) THEN        IF ( fRange .GT. small .AND.
656         validRange = .TRUE.       &     (MAX_LEN_PLOTBUF-35) .GT. sNx*nSx .AND.
657        ENDIF       &     (MAX_LEN_PLOTBUF-35) .GT. sNy*nSy ) validRange = .TRUE.
658    
659  C--   Write field title and statistics  C--   Write field title and statistics
660        msgBuf = '// ======================================================='        msgBuf =
661         & '// ======================================================='
662        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
663       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
664        iStrngLo = IFNBLNK(fldTitle)        iStrngLo = IFNBLNK(fldTitle)
# Line 575  C--   Write field title and statistics Line 678  C--   Write field title and statistics
678       & '// CMAX = ', fMax       & '// CMAX = ', fMax
679        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
680       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
681        WRITE(msgBuf,'(A,1PE30.15)')        IF ( validRange ) THEN
682       & '// CINT = ', fRange/FLOAT(lChlist-1)         WRITE(msgBuf,'(A,1PE30.15)')
683         &  '// CINT = ', fRange/FLOAT(lChlist-1)
684          ELSE
685           WRITE(msgBuf,'(A,1PE30.15)')
686         &  '// CINT = ', 0.
687          ENDIF
688        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
689       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
690        WRITE(msgBuf,'(A,1024A1)')        WRITE(msgBuf,'(A,1024A1)')
# Line 608  C--   Write field title and statistics Line 716  C--   Write field title and statistics
716       &  ':',kStr,')'       &  ':',kStr,')'
717        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
718       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
719        msgBuf = '// ======================================================='        msgBuf =
720         & '// ======================================================='
721        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
722       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
723    
724          if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
725           msgBuf =
726         &  'Model domain too big to print to terminal - skipping I/O'
727           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
728         &                   SQUEEZE_RIGHT, 1)
729           RETURN
730          endif
731    
732  C--   Write field  C--   Write field
733  C     Figure out slice type and set plotting parameters appropriately  C     Figure out slice type and set plotting parameters appropriately
734  C     acc = accross the page  C     acc = accross the page
# Line 709  C      Header Line 826  C      Header
826  C      Data  C      Data
827         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
828          DO K=pltMin,pltMax,pltStr          DO K=pltMin,pltMax,pltStr
829           WRITE(plotBuf,'(A,I,I,I,I)') pltLab,           WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
830       &   pltBase-1+(bk-1)*pltStep+K       &   pltBase-1+(bk-1)*pltStep+K
831           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
832       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
# Line 744  C      Data Line 861  C      Data
861             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN             IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
862              WRITE(plotBuf(iBuf:),'(A)')  '|'              WRITE(plotBuf(iBuf:),'(A)')  '|'
863             ELSE             ELSE
864              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)              WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10)
865             ENDIF             ENDIF
866            ENDDO            ENDDO
867           ENDDO           ENDDO
# Line 766  C      Data Line 883  C      Data
883               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
884                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
885               ENDIF               ENDIF
886               IDX = NINT(               IF ( validRange .AND. val .NE. 0. ) THEN
887                  IDX = NINT(
888       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)
889       &             )+1       &             )+1
890                 ELSE
891                  IDX = 1
892                 ENDIF
893               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
894       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
895               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
# Line 786  C      Data Line 907  C      Data
907         ENDDO         ENDDO
908        ENDIF        ENDIF
909  C--   Write delimiter  C--   Write delimiter
910        msgBuf = '// ======================================================='        msgBuf =
911         & '// ======================================================='
912        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
913       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
914        msgBuf = '// END OF FIELD                                          ='        msgBuf =
915         & '// END OF FIELD                                          ='
916        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
917       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
918        msgBuf = '// ======================================================='        msgBuf =
919         & '// ======================================================='
920        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
921       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
922        msgBuf = ' '        msgBuf = ' '
# Line 802  C--   Write delimiter Line 926  C--   Write delimiter
926        RETURN        RETURN
927        END        END
928    
929  CStartOfInterface  CBOP
930        SUBROUTINE PRINT_MAPR8 ( fld, fldTitle, plotMode,  C     !ROUTINE: PRINT_MAPRL
931    
932    C     !INTERFACE:
933          SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
934       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
935       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
936       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
937       I       kMin, kMax,   kStr,       I       kMin, kMax,   kStr,
938       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
939       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
940  C     /==========================================================\        IMPLICIT NONE
941  C     | SUBROUTINE PRINT_MAPR8                                   |  
942  C     | o Does textual mapping printing of a field.              |  C     !DESCRIPTION:
943  C     |==========================================================|  C     *==========================================================*
944  C     | This routine does the actual formatting of the data      |  C     | SUBROUTINE PRINT\_MAPRL                                    
945  C     | and printing to a file. It assumes an array using the    |  C     | o Does textual mapping printing of a field.              
946  C     | MITgcm UV indexing scheme and base index variables.      |  C     *==========================================================*
947  C     | User code should call an interface routine like          |  C     | This routine does the actual formatting of the data      
948  C     | PLOT_FIELD_XYR8( ... ) rather than this code directly.   |  C     | and printing to a file. It assumes an array using the    
949  C     | Text plots can be oriented XY, YZ, XZ. An orientation    |  C     | MITgcm UV indexing scheme and base index variables.      
950  C     | is specficied through the "plotMode" argument. All the   |  C     | User code should call an interface routine like          
951  C     | plots made by a single call to this routine will use the |  C     | PLOT\_FIELD\_XYR8( ... ) rather than this code directly.    
952  C     | same contour interval. The plot range (iMin,...,byStr)   |  C     | Text plots can be oriented XY, YZ, XZ. An orientation    
953  C     | can be three-dimensional. A separate plot is made for    |  C     | is specficied through the "plotMode" argument. All the    
954  C     | each point in the plot range normal to the orientation.  |  C     | plots made by a single call to this routine will use the  
955  C     | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY). |  C     | same contour interval. The plot range (iMin,...,byStr)    
956  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY|  C     | can be three-dimensional. A separate plot is made for    
957  C     |      plots - one for K=1, one for K=3 and one for K=5.   |  C     | each point in the plot range normal to the orientation.  
958  C     |      Each plot would have extents iMin:iMax step iStr    |  C     | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY).  
959  C     |      and jMin:jMax step jStr.                            |  C     |      kMin =1, kMax = 5 and kStr = 2 will produce three XY
960  C     \==========================================================/  C     |      plots - one for K=1, one for K=3 and one for K=5.    
961    C     |      Each plot would have extents iMin:iMax step iStr    
962    C     |      and jMin:jMax step jStr.                            
963    C     *==========================================================*
964    
965    C     !USES:
966  C     == Global variables ==  C     == Global variables ==
967  #include "SIZE.h"  #include "SIZE.h"
968  #include "EEPARAMS.h"  #include "EEPARAMS.h"
969  #include "EESUPPORT.h"  #include "EESUPPORT.h"
970          INTEGER  IFNBLNK
971          EXTERNAL IFNBLNK
972          INTEGER  ILNBLNK
973          EXTERNAL ILNBLNK
974    
975    C     !INPUT/OUTPUT PARAMETERS:
976  C     == Routine arguments ==  C     == Routine arguments ==
977  C     fld        - Real*8 array holding data to be plotted  C     fld        - Real*8 array holding data to be plotted
978  C     fldTitle   - Name of field to be plotted  C     fldTitle   - Name of field to be plotted
# Line 858  C     kStr Line 994  C     kStr
994        INTEGER jLo, jHi        INTEGER jLo, jHi
995        INTEGER kLo, kHi        INTEGER kLo, kHi
996        INTEGER nBx, nBy        INTEGER nBx, nBy
997        Real*8 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RL fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
998        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
999        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
1000        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
1001        INTEGER bxMin, bxMax, bxStr        INTEGER bxMin, bxMax, bxStr
1002        INTEGER byMin, byMax, byStr        INTEGER byMin, byMax, byStr
 CEndOfInterface  
 C     == Local variables ==  
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
1003    
1004    C     !LOCAL VARIABLES:
1005  C     == Local variables ==  C     == Local variables ==
1006  C     plotBuf - Buffer for building plot record  C     plotBuf - Buffer for building plot record
1007  C     chList  - Character string used for plot  C     chList  - Character string used for plot
# Line 900  C               Str  - stride within blo Line 1031  C               Str  - stride within blo
1031        INTEGER lChList        INTEGER lChList
1032        PARAMETER ( lChList = 28 )        PARAMETER ( lChList = 28 )
1033        CHARACTER*(lChList) chList        CHARACTER*(lChList) chList
1034        REAL fMin        _RL  fMin
1035        REAL fMax        _RL  fMax
1036        REAL fRange        _RL  fRange
1037        REAL val        _RL  val
1038        REAL small        _RL  small
1039        CHARACTER*2  accLab        CHARACTER*2  accLab
1040        CHARACTER*7  dwnLab        CHARACTER*7  dwnLab
1041        CHARACTER*3  pltLab        CHARACTER*3  pltLab
# Line 919  C               Str  - stride within blo Line 1050  C               Str  - stride within blo
1050        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx        INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx
1051        INTEGER bi, bj, bk        INTEGER bi, bj, bk
1052        LOGICAL validRange        LOGICAL validRange
1053    CEOP
1054    
1055        chList = '-abcdefghijklmnopqrstuvwxyz+'        chList = '-abcdefghijklmnopqrstuvwxyz+'
1056        small  = 1. _d -15        small  = 1. _d -15
# Line 932  C--   Calculate field range Line 1064  C--   Calculate field range
1064          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
1065           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
1066            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
1067  C          IF ( fld(I,J,K,bi,bj) .NE. 0. ) THEN             IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )
1068         &     THEN
1069              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
1070       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
1071              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
1072       &       fMax = fld(I,J,K,bi,bj)       &       fMax = fld(I,J,K,bi,bj)
1073  C          ENDIF             ENDIF
1074            ENDDO            ENDDO
1075           ENDDO           ENDDO
1076          ENDDO          ENDDO
1077         ENDDO         ENDDO
1078        ENDDO        ENDDO
1079        fRange = fMax-fMin        fRange = fMax-fMin
1080        IF ( fRange .GT. small ) THEN        IF ( fRange .GT. small .AND.
1081         validRange = .TRUE.       &     (MAX_LEN_PLOTBUF-35) .GT. sNx*nSx .AND.
1082        ENDIF       &     (MAX_LEN_PLOTBUF-35) .GT. sNy*nSy ) validRange = .TRUE.
1083    
1084  C--   Write field title and statistics  C--   Write field title and statistics
1085        msgBuf = '// ======================================================='        msgBuf =
1086         & '// ======================================================='
1087        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1088       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1089        iStrngLo = IFNBLNK(fldTitle)        iStrngLo = IFNBLNK(fldTitle)
# Line 969  C--   Write field title and statistics Line 1103  C--   Write field title and statistics
1103       & '// CMAX = ', fMax       & '// CMAX = ', fMax
1104        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1105       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1106        WRITE(msgBuf,'(A,1PE30.15)')        IF ( validRange ) THEN
1107           WRITE(msgBuf,'(A,1PE30.15)')
1108       & '// CINT = ', fRange/FLOAT(lChlist-1)       & '// CINT = ', fRange/FLOAT(lChlist-1)
1109          ELSE
1110           WRITE(msgBuf,'(A,1PE30.15)')
1111         & '// CINT = ', 0.
1112          ENDIF
1113        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1114       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1115        WRITE(msgBuf,'(A,1024A1)')        WRITE(msgBuf,'(A,1024A1)')
# Line 1002  C--   Write field title and statistics Line 1141  C--   Write field title and statistics
1141       &  ':',kStr,')'       &  ':',kStr,')'
1142        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1143       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1144        msgBuf = '// ======================================================='        msgBuf =
1145         & '// ======================================================='
1146        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1147       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1148    
1149          if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
1150           msgBuf =
1151         &  'Model domain too big to print to terminal - skipping I/O'
1152           CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1153         &                   SQUEEZE_RIGHT, 1)
1154           RETURN
1155          endif
1156    
1157  C--   Write field  C--   Write field
1158  C     Figure out slice type and set plotting parameters appropriately  C     Figure out slice type and set plotting parameters appropriately
1159  C     acc = accross the page  C     acc = accross the page
# Line 1103  C      Header Line 1251  C      Header
1251  C      Data  C      Data
1252         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
1253          DO K=pltMin,pltMax,pltStr          DO K=pltMin,pltMax,pltStr
1254           WRITE(plotBuf,'(A,I,I,I,I)') pltLab,           WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
1255       &   pltBase-1+(bk-1)*pltStep+K       &   pltBase-1+(bk-1)*pltStep+K
1256           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1257       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
# Line 1158  C      Data Line 1306  C      Data
1306               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
1307                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
1308               ENDIF               ENDIF
1309               IDX = NINT(               IF ( validRange .AND. val .NE. 0. ) THEN
1310       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)                IDX = NINT(
1311       &             )+1       &               FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1312         &              )+1
1313                 ELSE
1314                  IDX = 1
1315                 ENDIF
1316               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1317       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1318               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
# Line 1177  C      Data Line 1329  C      Data
1329         ENDDO         ENDDO
1330        ENDIF        ENDIF
1331  C--   Write delimiter  C--   Write delimiter
1332        msgBuf = '// ======================================================='        msgBuf =
1333         & '// ======================================================='
1334        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1335       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1336        msgBuf = '// END OF FIELD                                          ='        msgBuf =
1337         & '// END OF FIELD                                          ='
1338        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1339       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1340        msgBuf = '// ======================================================='        msgBuf =
1341         & '// ======================================================='
1342        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1343       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1344        msgBuf = ' '        msgBuf = ' '
# Line 1193  C--   Write delimiter Line 1348  C--   Write delimiter
1348        RETURN        RETURN
1349        END        END
1350    
1351  CStartOfInterface  CBOP
1352    C     !ROUTINE: PRINT_MESSAGE
1353    
1354    C     !INTERFACE:
1355        SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )        SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )
1356  C     /============================================================\        IMPLICIT NONE
1357  C     | SUBROUTINE PRINT_MESSAGE                                   |  C     !DESCRIPTION:
1358  C     | o Write out informational message using "standard" format. |  C     *============================================================*
1359  C     | Notes                                                      |  C     | SUBROUTINE PRINT\_MESSAGE                                    
1360  C     | =====                                                      |  C     | o Write out informational message using "standard" format.  
1361  C     | o Some system's I/O is not "thread-safe". For this reason  |  C     *============================================================*
1362  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |  C     | Notes                                                      
1363  C     |   critical region is defined around the write here. In some|  C     | =====                                                      
1364  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |  C     | o Some system   I/O is not "thread-safe". For this reason  
1365  C     |   for thread number 1 - writes for other threads are       |  C     |   without the FMTFTN\_IO\_THREAD\_SAFE directive set a        
1366  C     |   ignored!                                                 |  C     |   critical region is defined around the write here. In some
1367  C     | o In a non-parallel form these routines can still be used. |  C     |   cases  BEGIN\_CRIT() is approximated by only doing writes  
1368  C     |   to produce pretty printed output!                        |  C     |   for thread number 1 - writes for other threads are        
1369  C     \============================================================/  C     |   ignored!                                                  
1370    C     | o In a non-parallel form these routines can still be used.  
1371    C     |   to produce pretty printed output!                        
1372    C     *============================================================*
1373    
1374    C     !USES:
1375  C     == Global data ==  C     == Global data ==
1376  #include "SIZE.h"  #include "SIZE.h"
1377  #include "EEPARAMS.h"  #include "EEPARAMS.h"
1378  #include "EESUPPORT.h"  #include "EESUPPORT.h"
1379          INTEGER  IFNBLNK
1380          EXTERNAL IFNBLNK
1381          INTEGER  ILNBLNK
1382          EXTERNAL ILNBLNK
1383    
1384    C     !INPUT/OUTPUT PARAMETERS:
1385  C     == Routine arguments ==  C     == Routine arguments ==
1386  C     message - Message to write  C     message :: Message to write
1387  C     unit    - Unit number to write to  C     unit    :: Unit number to write to
1388  C     sq      - Justification option  C     sq      :: Justification option
1389        CHARACTER*(*) message        CHARACTER*(*) message
1390        INTEGER       unit        INTEGER       unit
1391        CHARACTER*(*) sq        CHARACTER*(*) sq
1392        INTEGER  myThid        INTEGER  myThid
1393  CEndOfInterface  
1394        INTEGER  IFNBLNK  C     !LOCAL VARIABLES:
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
1395  C     == Local variables ==  C     == Local variables ==
1396    C     iStart, iEnd :: String indexing variables
1397    C     idString     :: Temp. for building prefix.
1398        INTEGER iStart        INTEGER iStart
1399        INTEGER iEnd        INTEGER iEnd
1400        CHARACTER*9 idString        CHARACTER*9 idString
1401    CEOP
1402    
1403  C--   Find beginning and end of message  C--   Find beginning and end of message
1404        IF ( sq .EQ. SQUEEZE_BOTH .OR.        IF ( sq .EQ. SQUEEZE_BOTH .OR.
1405       &     sq .EQ. SQUEEZE_LEFT ) THEN       &     sq .EQ. SQUEEZE_LEFT ) THEN
# Line 1267  C       The write statement may need to Line 1437  C       The write statement may need to
1437  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1438          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1439  #endif  #endif
1440           WRITE(unit,'(A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A)',ERR=999)
1441       &   '(',PROCESS_HEADER,' ',idString,')',' '       &   '(',PROCESS_HEADER,' ',idString,')',' '
1442  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1443          _END_CRIT(myThid)          _END_CRIT(myThid)
# Line 1276  C       The write statement may need to Line 1446  C       The write statement may need to
1446  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1447          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1448  #endif  #endif
1449           WRITE(unit,'(A,A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)
1450       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',
1451       &   message(iStart:iEnd)       &   message(iStart:iEnd)
1452  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 1284  C       The write statement may need to Line 1454  C       The write statement may need to
1454  #endif  #endif
1455         ENDIF         ENDIF
1456        ENDIF        ENDIF
1457    
1458    #ifndef DISABLE_WRITE_TO_UNIT_ZERO
1459    C--   if error message, also write directly to unit 0 :
1460          IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1
1461         &     .AND. unit.EQ.errorMessageUnit ) THEN
1462            iEnd   = ILNBLNK( message )
1463            IF (iEnd.NE.0) WRITE(0,'(A)') message(1:iEnd)
1464          ENDIF
1465    #endif
1466  C  C
1467     1000 CONTINUE
1468        RETURN        RETURN
1469      999 CONTINUE
1470           ioErrorCount(myThid) = ioErrorCount(myThid)+1
1471          GOTO 1000
1472    
1473        END        END
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.25
  ViewVC Help
Powered by ViewVC 1.1.22