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

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

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

Revision 1.23 - (hide annotations) (download)
Sat Mar 27 03:51:51 2004 UTC (20 years, 2 months ago) by edhill
Branch: MAIN
CVS Tags: checkpoint57m_post, checkpoint57g_pre, checkpoint57s_post, checkpoint58b_post, checkpoint57b_post, checkpoint57g_post, checkpoint56b_post, checkpoint57y_post, checkpoint54d_post, checkpoint54e_post, checkpoint57r_post, checkpoint57d_post, checkpoint57i_post, checkpoint58, checkpoint55, checkpoint54, checkpoint57, checkpoint56, checkpoint53, checkpoint58f_post, checkpoint57n_post, checkpoint58d_post, checkpoint58a_post, checkpoint57z_post, checkpoint54f_post, checkpoint55i_post, checkpoint58m_post, checkpoint57l_post, checkpoint57t_post, checkpoint55c_post, checkpoint57v_post, checkpoint57f_post, checkpoint53d_post, checkpoint57a_post, checkpoint57h_pre, checkpoint54b_post, checkpoint57h_post, checkpoint52m_post, checkpoint57y_pre, checkpoint55g_post, checkpoint57c_post, checkpoint55d_post, checkpoint58e_post, checkpoint54a_pre, checkpoint53c_post, checkpoint55d_pre, checkpoint57c_pre, checkpoint55j_post, checkpoint54a_post, checkpoint55h_post, checkpoint57e_post, checkpoint55b_post, checkpoint53a_post, checkpoint55f_post, checkpoint53g_post, checkpoint57p_post, checkpint57u_post, checkpoint57q_post, eckpoint57e_pre, checkpoint58k_post, checkpoint56a_post, checkpoint58l_post, checkpoint53f_post, checkpoint57h_done, checkpoint57j_post, checkpoint57f_pre, checkpoint58g_post, checkpoint52n_post, checkpoint53b_pre, checkpoint58h_post, checkpoint56c_post, checkpoint58j_post, checkpoint57a_pre, checkpoint55a_post, checkpoint57o_post, checkpoint57k_post, checkpoint53b_post, checkpoint57w_post, checkpoint58i_post, checkpoint57x_post, checkpoint58c_post, checkpoint53d_pre, checkpoint55e_post, checkpoint54c_post
Changes since 1.22: +19 -19 lines 
 o cleanup comments (NO CODE CHANGES) in eesupp for protex
 o the "api reference" framework now builds documentation for:
     eesupp, pkg/generic_advdiff, and pkg/gmredi
 o remove mnc from the default gfd in pkg_groups pending
     further testing on systems where NetCDF is not installed
1 edhill 1.23 C $Header: /u/gcmpack/MITgcm/eesupp/src/print.F,v 1.22 2004/02/23 20:04:27 adcroft Exp $
2 cnh 1.18 C $Name: $
3 cnh 1.1
4     #include "CPP_EEOPTIONS.h"
5    
6     C-- File printf.F: Routines for performing formatted textual I/O
7     C-- in the MITgcm UV implementation environment.
8     C-- Contents
9     C-- o print_error Does IO with **ERROR** highlighted header
10 cnh 1.5 C-- o print_list_i Prints one-deimensional list of INTEGER
11     C-- numbers.
12     C-- o print_list_l Prints one-deimensional list of LOGICAL
13     C-- variables.
14 cnh 1.4 C-- o print_list_r8 Prints one-deimensional list of Real*8
15     C-- numbers.
16     C-- o print_mapr4 Formats ABCD... contour map of a Real*4 field
17     C-- Uses print_message for writing
18 cnh 1.1 C-- o print_mapr8 Formats ABCD... contour map of a Real*8 field
19     C-- Uses print_message for writing
20     C-- o print_message Does IO with unhighlighted header
21    
22 cnh 1.18 CBOP
23    
24     C !ROUTINE: PRINT_ERROR
25    
26     C !INTERFACE:
27 cnh 1.1 SUBROUTINE PRINT_ERROR( message , myThid )
28 adcroft 1.14 IMPLICIT NONE
29 cnh 1.18
30     C !DESCRIPTION:
31     C *============================================================*
32 edhill 1.23 C | SUBROUTINE PRINT\_ERROR
33 cnh 1.18 C | o Write out error message using "standard" format.
34     C *============================================================*
35     C | Notes
36     C | =====
37     C | o Some system I/O is not "thread-safe". For this reason
38 edhill 1.23 C | without the FMTFTN\_IO\_THREAD\_SAFE directive set a
39 cnh 1.18 C | critical region is defined around the write here. In some
40 edhill 1.23 C | cases BEGIN\_CRIT() is approximated by only doing writes
41 cnh 1.18 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 cnh 1.1 C == Global data ==
50     #include "SIZE.h"
51     #include "EEPARAMS.h"
52     #include "EESUPPORT.h"
53     INTEGER IFNBLNK
54     EXTERNAL IFNBLNK
55     INTEGER ILNBLNK
56     EXTERNAL ILNBLNK
57 cnh 1.18
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 cnh 1.1 C == Local variables ==
67 cnh 1.18 C iStart, iEnd :: Temps. for string indexing
68     C idString :: Temp. for building message prefix
69 cnh 1.1 INTEGER iStart
70     INTEGER iEnd
71     CHARACTER*9 idString
72 cnh 1.18 CEOP
73    
74 cnh 1.1 C-- Find beginning and end of message
75     iStart = IFNBLNK( message )
76     iEnd = ILNBLNK( message )
77     C-- Test to see if in multi-process ( or multi-threaded ) mode.
78     C If so include process or thread identifier.
79     IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN
80     C-- Write single process format
81     IF ( message .EQ. ' ' ) THEN
82     WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '
83     ELSE
84 cnh 1.12 WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER,
85     & message(iStart:iEnd)
86 cnh 1.1 ENDIF
87     ELSEIF ( pidIO .EQ. myProcId ) THEN
88     C-- Write multi-process format
89     #ifndef FMTFTN_IO_THREAD_SAFE
90     _BEGIN_CRIT(myThid)
91     #endif
92     WRITE(idString,'(I4.4,A,I4.4)') myProcId,'.',myThid
93     #ifndef FMTFTN_IO_THREAD_SAFE
94     _END_CRIT(myThid)
95     #endif
96     IF ( message .EQ. ' ' ) THEN
97     C PRINT_ERROR can be called by several threads simulataneously.
98     C The write statement may need to be marked as a critical section.
99     #ifndef FMTFTN_IO_THREAD_SAFE
100     _BEGIN_CRIT(myThid)
101     #endif
102 cnh 1.6 WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
103 cnh 1.1 & '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
104     & ' '
105     #ifndef FMTFTN_IO_THREAD_SAFE
106     _END_CRIT(myThid)
107     #endif
108     ELSE
109     #ifndef FMTFTN_IO_THREAD_SAFE
110     _BEGIN_CRIT(myThid)
111     #endif
112 cnh 1.6 WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
113 cnh 1.1 & '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
114     & message(iStart:iEnd)
115     #ifndef FMTFTN_IO_THREAD_SAFE
116     _END_CRIT(myThid)
117     #endif
118     ENDIF
119     ENDIF
120 jmc 1.21
121     #ifndef DISABLE_WRITE_TO_UNIT_ZERO
122     C-- also write directly to unit 0 :
123     IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1 ) THEN
124     IF (iEnd.NE.0) WRITE(0,'(A)') message(1:iEnd)
125     ENDIF
126     #endif
127    
128 cnh 1.6 1000 CONTINUE
129 cnh 1.4 RETURN
130 cnh 1.6
131     999 CONTINUE
132     ioErrorCount(myThid) = ioErrorCount(myThid)+1
133     GOTO 1000
134 cnh 1.4 END
135    
136 cnh 1.18 CBOP
137     C !ROUTINE: PRINT_LIST_I
138    
139     C !INTERFACE:
140 cnh 1.12 SUBROUTINE PRINT_LIST_I( fld, lFld, index_type,
141     & markEnd, compact, ioUnit )
142 adcroft 1.14 IMPLICIT NONE
143 cnh 1.18 C !DESCRIPTION:
144     C *==========================================================*
145 edhill 1.23 C | o SUBROUTINE PRINT\_LIST\_I
146 cnh 1.18 C *==========================================================*
147     C | Routine for producing list of values for a field with
148     C | duplicate values collected into
149 edhill 1.23 C | n \@ value
150 cnh 1.18 C | record.
151     C *==========================================================*
152 cnh 1.5
153 cnh 1.18 C !USES:
154 cnh 1.5 C == Global data ==
155     #include "SIZE.h"
156     #include "EEPARAMS.h"
157    
158 cnh 1.18 C !INPUT/OUTPUT PARAMETERS:
159 cnh 1.5 C == Routine arguments ==
160 cnh 1.18 C fld :: Data to be printed
161     C lFld :: Number of elements to be printed
162     C index_type :: Flag indicating which type of index to print
163     C INDEX_K => /* K = nnn */
164     C INDEX_I => /* I = nnn */
165     C INDEX_J => /* J = nnn */
166     C INDEX_NONE =>
167     C compact :: Flag to control use of repeat symbol for same valued
168     C fields.
169     C markEnd :: Flag to control whether there is a separator after the
170     C last element
171     C ioUnit :: Unit number for IO.
172 cnh 1.5 INTEGER lFld
173     INTEGER index_type
174     INTEGER fld(lFld)
175 adcroft 1.9 LOGICAL markEnd
176     LOGICAL compact
177 cnh 1.5 INTEGER ioUnit
178    
179 cnh 1.18 C !LOCAL VARIABLES:
180 cnh 1.5 C == Local variables ==
181     C iLo - Range index holders for selecting elements with
182     C iHi with the same value
183     C nDup - Number of duplicates
184     C xNew, xOld - Hold current and previous values of field
185     C punc - Field separator
186     C msgBuf - IO buffer
187     C index_lab - Index for labelling elements
188     C K - Loop counter
189     INTEGER iLo
190     INTEGER iHi
191     INTEGER nDup
192     INTEGER xNew, xOld
193     CHARACTER punc
194 cnh 1.7 CHARACTER*(MAX_LEN_MBUF) msgBuf
195 cnh 1.5 CHARACTER*2 commOpen,commClose
196     CHARACTER*3 index_lab
197     INTEGER K
198 cnh 1.18 CEOP
199 cnh 1.5
200     IF ( index_type .EQ. INDEX_I ) THEN
201     index_lab = 'I ='
202     ELSEIF ( index_type .EQ. INDEX_J ) THEN
203     index_lab = 'J ='
204     ELSEIF ( index_type .EQ. INDEX_K ) THEN
205     index_lab = 'K ='
206     ELSE
207     index_lab = '?='
208     ENDIF
209     commOpen = '/*'
210     commClose = '*/'
211     iLo = 1
212     iHi = 1
213     punc = ','
214     xOld = fld(1)
215     DO K=2,lFld
216     xNew = fld(K )
217 adcroft 1.16 IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
218 cnh 1.5 nDup = iHi-iLo+1
219     IF ( nDup .EQ. 1 ) THEN
220 adcroft 1.10 WRITE(msgBuf,'(A,I9,A)') ' ',xOld,punc
221 cnh 1.5 IF ( index_type .NE. INDEX_NONE )
222 cnh 1.12 & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
223     & commOpen,index_lab,iLo,commClose
224 cnh 1.5 ELSE
225 adcroft 1.15 WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc
226 cnh 1.5 IF ( index_type .NE. INDEX_NONE )
227     & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
228     & commOpen,index_lab,iLo,':',iHi,commClose
229     ENDIF
230 cnh 1.6 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
231 cnh 1.5 iLo = K
232     iHi = K
233     xOld = xNew
234     ELSE
235     iHi = K
236     ENDIF
237     ENDDO
238     punc = ' '
239 adcroft 1.9 IF ( markEnd ) punc = ','
240 cnh 1.5 nDup = iHi-iLo+1
241     IF ( nDup .EQ. 1 ) THEN
242 adcroft 1.10 WRITE(msgBuf,'(A,I9,A)') ' ',xOld,punc
243 cnh 1.5 IF ( index_type .NE. INDEX_NONE )
244 cnh 1.12 & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
245     & commOpen,index_lab,iLo,commClose
246 cnh 1.5 ELSEIF( nDup .GT. 1 ) THEN
247 adcroft 1.15 WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc
248 cnh 1.5 IF ( index_type .NE. INDEX_NONE )
249     & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
250     & commOpen,index_lab,iLo,':',iHi,commClose
251     ENDIF
252 cnh 1.6 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
253 cnh 1.5
254     RETURN
255     END
256    
257 cnh 1.18 CBOP
258     C !ROUTINE: PRINT_LIST_L
259    
260     C !INTERFACE:
261 cnh 1.12 SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd,
262     & compact, ioUnit )
263 adcroft 1.14 IMPLICIT NONE
264 cnh 1.18 C !DESCRIPTION:
265     C *==========================================================*
266 edhill 1.23 C | o SUBROUTINE PRINT\_LIST\_L
267 cnh 1.18 C *==========================================================*
268     C | Routine for producing list of values for a field with
269     C | duplicate values collected into
270 edhill 1.23 C | n \@ value
271 cnh 1.18 C | record.
272     C *==========================================================*
273 cnh 1.5
274 cnh 1.18 C !USES:
275 cnh 1.5 C == Global data ==
276     #include "SIZE.h"
277     #include "EEPARAMS.h"
278    
279 cnh 1.18 C !INPUT/OUTPUT PARAMETERS:
280 cnh 1.5 C == Routine arguments ==
281     C fld - Data to be printed
282     C lFld - Number of elements to be printed
283     C index_type - Flag indicating which type of index to print
284     C INDEX_K => /* K = nnn */
285     C INDEX_I => /* I = nnn */
286     C INDEX_J => /* J = nnn */
287     C INDEX_NONE =>
288 adcroft 1.9 C compact - Flag to control use of repeat symbol for same valued
289     C fields.
290     C markEnd - Flag to control whether there is a separator after the
291     C last element
292 cnh 1.5 C ioUnit - Unit number for IO.
293     INTEGER lFld
294     INTEGER index_type
295     LOGICAL fld(lFld)
296 adcroft 1.9 LOGICAL markEnd
297     LOGICAL compact
298 cnh 1.5 INTEGER ioUnit
299    
300 cnh 1.18 C !LOCAL VARIABLES:
301 cnh 1.5 C == Local variables ==
302     C iLo - Range index holders for selecting elements with
303     C iHi with the same value
304     C nDup - Number of duplicates
305     C xNew, xOld - Hold current and previous values of field
306     C punc - Field separator
307     C msgBuf - IO buffer
308     C index_lab - Index for labelling elements
309     C K - Loop counter
310     INTEGER iLo
311     INTEGER iHi
312     INTEGER nDup
313     LOGICAL xNew, xOld
314     CHARACTER punc
315 cnh 1.7 CHARACTER*(MAX_LEN_MBUF) msgBuf
316 cnh 1.5 CHARACTER*2 commOpen,commClose
317     CHARACTER*3 index_lab
318     INTEGER K
319 cnh 1.18 CEOP
320 cnh 1.5
321     IF ( index_type .EQ. INDEX_I ) THEN
322     index_lab = 'I ='
323     ELSEIF ( index_type .EQ. INDEX_J ) THEN
324     index_lab = 'J ='
325     ELSEIF ( index_type .EQ. INDEX_K ) THEN
326     index_lab = 'K ='
327     ELSE
328     index_lab = '?='
329     ENDIF
330     commOpen = '/*'
331     commClose = '*/'
332     iLo = 1
333     iHi = 1
334     punc = ','
335     xOld = fld(1)
336     DO K=2,lFld
337     xNew = fld(K )
338 adcroft 1.16 IF ( .NOT. compact .OR. (xNew .NEQV. xOld) ) THEN
339 cnh 1.5 nDup = iHi-iLo+1
340     IF ( nDup .EQ. 1 ) THEN
341     WRITE(msgBuf,'(A,L5,A)') ' ',xOld,punc
342     IF ( index_type .NE. INDEX_NONE )
343 cnh 1.12 & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
344     & commOpen,index_lab,iLo,commClose
345 cnh 1.5 ELSE
346 adcroft 1.15 WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc
347 cnh 1.5 IF ( index_type .NE. INDEX_NONE )
348     & WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')
349     & commOpen,index_lab,iLo,':',iHi,commClose
350     ENDIF
351 cnh 1.6 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
352 cnh 1.5 iLo = K
353     iHi = K
354     xOld = xNew
355     ELSE
356     iHi = K
357     ENDIF
358     ENDDO
359     punc = ' '
360 adcroft 1.9 IF ( markEnd ) punc = ','
361 cnh 1.5 nDup = iHi-iLo+1
362     IF ( nDup .EQ. 1 ) THEN
363     WRITE(msgBuf,'(A,L5,A)') ' ',xOld,punc
364     IF ( index_type .NE. INDEX_NONE )
365 cnh 1.12 & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
366     & commOpen,index_lab,iLo,commClose
367 cnh 1.5 ELSEIF( nDup .GT. 1 ) THEN
368 adcroft 1.15 WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc
369 cnh 1.5 IF ( index_type .NE. INDEX_NONE )
370     & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
371     & commOpen,index_lab,iLo,':',iHi,commClose
372     ENDIF
373 cnh 1.6 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
374 cnh 1.5
375     RETURN
376     END
377    
378 cnh 1.18 CBOP
379     C !ROUTINE: PRINT_LIST_R8
380     C !INTERFACE:
381 cnh 1.12 SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type,
382     & markEnd, compact, ioUnit )
383 adcroft 1.14 IMPLICIT NONE
384 cnh 1.18 C !DESCRIPTION:
385     C *==========================================================*
386 edhill 1.23 C | o SUBROUTINE PRINT\_LIST\_R8
387 cnh 1.18 C *==========================================================*
388     C | Routine for producing list of values for a field with
389     C | duplicate values collected into
390 edhill 1.23 C | n \@ value
391 cnh 1.18 C | record.
392     C *==========================================================*
393 cnh 1.4
394 cnh 1.18 C !USES:
395     C == Global data ==
396 cnh 1.4 #include "SIZE.h"
397     #include "EEPARAMS.h"
398    
399 cnh 1.18 C !INPUT/OUTPUT PARAMETERS:
400 cnh 1.4 C == Routine arguments ==
401     C fld - Data to be printed
402     C lFld - Number of elements to be printed
403     C index_type - Flag indicating which type of index to print
404     C INDEX_K => /* K = nnn */
405     C INDEX_I => /* I = nnn */
406     C INDEX_J => /* J = nnn */
407     C INDEX_NONE =>
408 adcroft 1.9 C compact - Flag to control use of repeat symbol for same valued
409     C fields.
410     C markEnd - Flag to control whether there is a separator after the
411     C last element
412 cnh 1.4 C ioUnit - Unit number for IO.
413     INTEGER lFld
414     INTEGER index_type
415     Real*8 fld(lFld)
416 adcroft 1.9 LOGICAL markEnd
417     LOGICAL compact
418 cnh 1.4 INTEGER ioUnit
419    
420 cnh 1.18 C !LOCA VARIABLES:
421 cnh 1.4 C == Local variables ==
422     C iLo - Range index holders for selecting elements with
423     C iHi with the same value
424     C nDup - Number of duplicates
425     C xNew, xOld - Hold current and previous values of field
426     C punc - Field separator
427     C msgBuf - IO buffer
428     C index_lab - Index for labelling elements
429     C K - Loop counter
430     INTEGER iLo
431     INTEGER iHi
432     INTEGER nDup
433     Real*8 xNew, xOld
434     CHARACTER punc
435 cnh 1.7 CHARACTER*(MAX_LEN_MBUF) msgBuf
436 cnh 1.4 CHARACTER*2 commOpen,commClose
437     CHARACTER*3 index_lab
438     INTEGER K
439 cnh 1.18 CEOP
440 cnh 1.4
441     IF ( index_type .EQ. INDEX_I ) THEN
442     index_lab = 'I ='
443     ELSEIF ( index_type .EQ. INDEX_J ) THEN
444     index_lab = 'J ='
445     ELSEIF ( index_type .EQ. INDEX_K ) THEN
446     index_lab = 'K ='
447     ELSE
448     index_lab = '?='
449     ENDIF
450     commOpen = '/*'
451     commClose = '*/'
452     iLo = 1
453     iHi = 1
454     punc = ','
455     xOld = fld(1)
456     DO K=2,lFld
457     xNew = fld(K )
458 adcroft 1.16 IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN
459 cnh 1.4 nDup = iHi-iLo+1
460     IF ( nDup .EQ. 1 ) THEN
461     WRITE(msgBuf,'(A,1PE23.15,A)') ' ',xOld,punc
462     IF ( index_type .NE. INDEX_NONE )
463 cnh 1.12 & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
464     & commOpen,index_lab,iLo,commClose
465 cnh 1.4 ELSE
466 cnh 1.12 WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
467 cnh 1.4 IF ( index_type .NE. INDEX_NONE )
468     & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
469     & commOpen,index_lab,iLo,':',iHi,commClose
470     ENDIF
471 cnh 1.12 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
472     & SQUEEZE_RIGHT , 1)
473 cnh 1.4 iLo = K
474     iHi = K
475     xOld = xNew
476     ELSE
477     iHi = K
478     ENDIF
479     ENDDO
480     punc = ' '
481 adcroft 1.9 IF ( markEnd ) punc = ','
482 cnh 1.4 nDup = iHi-iLo+1
483     IF ( nDup .EQ. 1 ) THEN
484     WRITE(msgBuf,'(A,1PE23.15,A)') ' ',xOld,punc
485     IF ( index_type .NE. INDEX_NONE )
486 cnh 1.12 & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
487     & commOpen,index_lab,iLo,commClose
488 cnh 1.4 ELSEIF( nDup .GT. 1 ) THEN
489 cnh 1.12 WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
490 cnh 1.4 IF ( index_type .NE. INDEX_NONE )
491     & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
492     & commOpen,index_lab,iLo,':',iHi,commClose
493     ENDIF
494 cnh 1.12 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
495     & SQUEEZE_RIGHT , 1)
496 cnh 1.4
497 cnh 1.1 RETURN
498     END
499    
500 cnh 1.18 CBOP
501     C !ROUTINE: PRINT_MAPRS
502     C !INTERFACE:
503 cnh 1.8 SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,
504 cnh 1.1 I iLo, iHi, jLo, jHi, kLo, kHi, nBx, nBy,
505     I iMin, iMax, iStr,
506     I jMin, jMax, jStr,
507     I kMin, kMax, kStr,
508     I bxMin, bxMax, bxStr,
509     I byMin, byMax, byStr )
510 adcroft 1.14 IMPLICIT NONE
511 cnh 1.18 C !DESCRIPTION:
512     C *==========================================================*
513 edhill 1.23 C | SUBROUTINE PRINT\_MAPR4
514 cnh 1.18 C | o Does textual mapping printing of a field.
515     C *==========================================================*
516     C | This routine does the actual formatting of the data
517     C | and printing to a file. It assumes an array using the
518     C | MITgcm UV indexing scheme and base index variables.
519     C | User code should call an interface routine like
520 edhill 1.23 C | PLOT\_FIELD\_XYR4( ... ) rather than this code directly.
521 cnh 1.18 C | Text plots can be oriented XY, YZ, XZ. An orientation
522     C | is specficied through the "plotMode" argument. All the
523     C | plots made by a single call to this routine will use the
524     C | same contour interval. The plot range (iMin,...,byStr)
525     C | can be three-dimensional. A separate plot is made for
526     C | each point in the plot range normal to the orientation.
527 edhill 1.23 C | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY).
528 cnh 1.18 C | kMin =1, kMax = 5 and kStr = 2 will produce three XY
529     C | plots - one for K=1, one for K=3 and one for K=5.
530     C | Each plot would have extents iMin:iMax step iStr
531     C | and jMin:jMax step jStr.
532     C *==========================================================*
533 cnh 1.1
534 cnh 1.18 C !USES:
535 cnh 1.1 C == Global variables ==
536     #include "SIZE.h"
537     #include "EEPARAMS.h"
538     #include "EESUPPORT.h"
539 cnh 1.18 INTEGER IFNBLNK
540     EXTERNAL IFNBLNK
541     INTEGER ILNBLNK
542     EXTERNAL ILNBLNK
543 cnh 1.1
544 cnh 1.18 C !INPUT/OUTPUT PARAMETERS:
545 cnh 1.1 C == Routine arguments ==
546     C fld - Real*4 array holding data to be plotted
547     C fldTitle - Name of field to be plotted
548     C plotMode - Text string indicating plot orientation
549     C ( see - EEPARAMS.h for valid values ).
550     C iLo, iHi, - Dimensions of array fld. fld is assumed to
551     C jLo, jHi be five-dimensional.
552     C kLo, kHi
553     C nBx, nBy
554     C iMin, iMax - Indexing for points to plot. Points from
555     C iStr iMin -> iMax in steps of iStr are plotted
556     C jMin. jMax and similarly for jMin, jMax, jStr and
557     C jStr kMin, kMax, kStr and bxMin, bxMax, bxStr
558     C kMin, kMax byMin, byMax, byStr.
559     C kStr
560     CHARACTER*(*) fldTitle
561     CHARACTER*(*) plotMode
562     INTEGER iLo, iHi
563     INTEGER jLo, jHi
564     INTEGER kLo, kHi
565     INTEGER nBx, nBy
566 cnh 1.8 _RS fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
567 cnh 1.1 INTEGER iMin, iMax, iStr
568     INTEGER jMin, jMax, jStr
569     INTEGER kMin, kMax, kStr
570     INTEGER bxMin, bxMax, bxStr
571     INTEGER byMin, byMax, byStr
572    
573 cnh 1.18 C !LOCAL VARIABLES:
574 cnh 1.1 C == Local variables ==
575     C plotBuf - Buffer for building plot record
576     C chList - Character string used for plot
577     C fMin, fMax - Contour min, max and range
578     C fRange
579     C val - Value of element to be "plotted"
580     C small - Lowest range for which contours are plotted
581     C accXXX - Variables used in indexing accross page records.
582     C dwnXXX Variables used in indexing down the page.
583     C pltXXX Variables used in indexing multiple plots ( multiple
584     C plots use same contour range).
585     C Lab - Label
586     C Base - Base number for element indexing
587     C The process bottom, left coordinate in the
588     C global domain.
589     C Step - Block size
590     C Blo - Start block
591     C Bhi - End block
592     C Bstr - Block stride
593     C Min - Start index within block
594     C Max - End index within block
595     C Str - stride within block
596     INTEGER MAX_LEN_PLOTBUF
597     PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 )
598     CHARACTER*(MAX_LEN_PLOTBUF) plotBuf
599     CHARACTER*(MAX_LEN_MBUF) msgBuf
600     INTEGER lChList
601     PARAMETER ( lChList = 28 )
602     CHARACTER*(lChList) chList
603 cnh 1.13 _RL fMin
604     _RL fMax
605     _RL fRange
606     _RL val
607     _RL small
608 cnh 1.1 CHARACTER*2 accLab
609     CHARACTER*7 dwnLab
610     CHARACTER*3 pltLab
611     INTEGER accBase, dwnBase, pltBase
612     INTEGER accStep, dwnStep, pltStep
613     INTEGER accBlo, dwnBlo, pltBlo
614     INTEGER accBhi, dwnBhi, pltBhi
615     INTEGER accBstr, dwnBstr, pltBstr
616     INTEGER accMin, dwnMin, pltMin
617     INTEGER accMax, dwnMax, pltMax
618     INTEGER accStr, dwnStr, pltStr
619     INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx
620     INTEGER bi, bj, bk
621     LOGICAL validRange
622 cnh 1.18 CEOP
623 cnh 1.1
624     chList = '-abcdefghijklmnopqrstuvwxyz+'
625 cnh 1.13 small = 1. _d -15
626     fMin = 1. _d 32
627     fMax = -1. _d 32
628 cnh 1.1 validRange = .FALSE.
629    
630     C-- Calculate field range
631     DO bj=byMin, byMax, byStr
632     DO bi=bxMin, bxMax, bxStr
633     DO K=kMin, kMax, kStr
634     DO J=jMin, jMax, jStr
635     DO I=iMin, iMax, iStr
636 cnh 1.11 IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN
637 cnh 1.1 IF ( fld(I,J,K,bi,bj) .LT. fMin )
638     & fMin = fld(I,J,K,bi,bj)
639     IF ( fld(I,J,K,bi,bj) .GT. fMax )
640     & fMax = fld(I,J,K,bi,bj)
641     ENDIF
642     ENDDO
643     ENDDO
644     ENDDO
645     ENDDO
646     ENDDO
647     fRange = fMax-fMin
648 dimitri 1.20 IF ( fRange .GT. small .AND.
649     & (MAX_LEN_PLOTBUF-35) .GT. sNx*nSx .AND.
650     & (MAX_LEN_PLOTBUF-35) .GT. sNy*nSy ) validRange = .TRUE.
651 cnh 1.1
652     C-- Write field title and statistics
653 cnh 1.12 msgBuf =
654     & '// ======================================================='
655 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
656     & SQUEEZE_RIGHT, 1)
657     iStrngLo = IFNBLNK(fldTitle)
658     iStrngHi = ILNBLNK(fldTitle)
659     IF ( iStrngLo .LE. iStrngHi ) THEN
660     WRITE(msgBuf,'(A)') fldTitle(iStrngLo:iStrngHi)
661     ELSE
662     msgBuf = '// UNKNOWN FIELD'
663     ENDIF
664     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
665     & SQUEEZE_RIGHT, 1)
666     WRITE(msgBuf,'(A,1PE30.15)')
667     & '// CMIN = ', fMin
668     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
669     & SQUEEZE_RIGHT, 1)
670     WRITE(msgBuf,'(A,1PE30.15)')
671     & '// CMAX = ', fMax
672     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
673     & SQUEEZE_RIGHT, 1)
674 cnh 1.11 IF ( validRange ) THEN
675     WRITE(msgBuf,'(A,1PE30.15)')
676     & '// CINT = ', fRange/FLOAT(lChlist-1)
677     ELSE
678     WRITE(msgBuf,'(A,1PE30.15)')
679     & '// CINT = ', 0.
680     ENDIF
681 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
682     & SQUEEZE_RIGHT, 1)
683     WRITE(msgBuf,'(A,1024A1)')
684     & '// SYMBOLS (CMIN->CMAX): ',(chList(I:I),I=1,lChList)
685     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
686     & SQUEEZE_RIGHT, 1)
687     WRITE(msgBuf,'(A,1024A1)')
688     & '// 0.0: ','.'
689     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
690     & SQUEEZE_RIGHT, 1)
691     WRITE(msgBuf,'(A,3(A,I4),A)')
692     & '// RANGE I (Lo:Hi:Step):',
693     & '(',myXGlobalLo-1+(bxMin-1)*sNx+iMin,
694     & ':',myXGlobalLo-1+(bxMax-1)*sNx+iMax,
695     & ':',iStr,')'
696     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
697     & SQUEEZE_RIGHT, 1)
698     WRITE(msgBuf,'(A,3(A,I4),A)')
699     & '// RANGE J (Lo:Hi:Step):',
700     & '(',myYGlobalLo-1+(byMin-1)*sNy+jMin,
701     & ':',myYGlobalLo-1+(byMax-1)*sNy+jMax,
702     & ':',jStr,')'
703     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
704     & SQUEEZE_RIGHT, 1)
705     WRITE(msgBuf,'(A,3(A,I4),A)')
706     & '// RANGE K (Lo:Hi:Step):',
707     & '(',kMin,
708     & ':',kMax,
709     & ':',kStr,')'
710     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
711     & SQUEEZE_RIGHT, 1)
712 cnh 1.12 msgBuf =
713     & '// ======================================================='
714 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
715     & SQUEEZE_RIGHT, 1)
716    
717 adcroft 1.22 if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
718     msgBuf =
719     & 'Model domain too big to print to terminal - skipping I/O'
720     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
721     & SQUEEZE_RIGHT, 1)
722     RETURN
723     endif
724    
725 cnh 1.1 C-- Write field
726     C Figure out slice type and set plotting parameters appropriately
727     C acc = accross the page
728     C dwn = down the page
729     IF ( plotMode .EQ. PRINT_MAP_XY ) THEN
730     C X across, Y down slice
731     accLab = 'I='
732     accBase = myXGlobalLo
733     accStep = sNx
734     accBlo = bxMin
735     accBhi = bxMax
736     accBStr = bxStr
737     accMin = iMin
738     accMax = iMax
739     accStr = iStr
740     dwnLab = '|--J--|'
741     dwnBase = myYGlobalLo
742     dwnStep = sNy
743     dwnBlo = byMin
744     dwnBhi = byMax
745     dwnBStr = byStr
746     dwnMin = jMin
747     dwnMax = jMax
748     dwnStr = jStr
749     pltBlo = 1
750     pltBhi = 1
751     pltBstr = 1
752     pltMin = kMin
753     pltMax = kMax
754     pltStr = kStr
755     pltBase = 1
756     pltStep = 1
757     pltLab = 'K ='
758     ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
759     C Y across, Z down slice
760     accLab = 'J='
761     accBase = myYGlobalLo
762     accStep = sNy
763     accBlo = byMin
764     accBhi = byMax
765     accBStr = byStr
766     accMin = jMin
767     accMax = jMax
768     accStr = jStr
769     dwnLab = '|--K--|'
770     dwnBase = 1
771     dwnStep = 1
772     dwnBlo = 1
773     dwnBhi = 1
774     dwnBStr = 1
775     dwnMin = kMin
776     dwnMax = kMax
777     dwnStr = kStr
778     pltBlo = bxMin
779     pltBhi = bxMax
780     pltBstr = bxStr
781     pltMin = iMin
782     pltMax = iMax
783     pltStr = iStr
784     pltBase = myXGlobalLo
785     pltStep = sNx
786     pltLab = 'I ='
787     ELSEIF ( plotMode .EQ. PRINT_MAP_XZ ) THEN
788     C X across, Z down slice
789     accLab = 'I='
790     accBase = myXGlobalLo
791     accStep = sNx
792     accBlo = bxMin
793     accBhi = bxMax
794     accBStr = bxStr
795     accMin = iMin
796     accMax = iMax
797     accStr = iStr
798     dwnLab = '|--K--|'
799     dwnBase = 1
800     dwnStep = 1
801     dwnBlo = 1
802     dwnBhi = 1
803     dwnBStr = 1
804     dwnMin = kMin
805     dwnMax = kMax
806     dwnStr = kStr
807     pltBlo = byMin
808     pltBhi = byMax
809     pltBstr = byStr
810     pltMin = jMin
811     pltMax = jMax
812     pltStr = jStr
813     pltBase = myYGlobalLo
814     pltStep = sNy
815     pltLab = 'J ='
816     ENDIF
817 dimitri 1.20 IF ( validRange ) THEN
818 cnh 1.1 C Header
819     C Data
820     DO bk=pltBlo, pltBhi, pltBstr
821     DO K=pltMin,pltMax,pltStr
822 cnh 1.12 WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
823 cnh 1.1 & pltBase-1+(bk-1)*pltStep+K
824     CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
825     & SQUEEZE_RIGHT, 1)
826     plotBuf = ' '
827     iBuf = 6
828     DO bi=accBlo, accBhi, accBstr
829     DO I=accMin, accMax, accStr
830     iDx = accBase-1+(bi-1)*accStep+I
831     iBuf = iBuf + 1
832     IF ( 10*((iBuf-6)/10) .EQ. iBuf-6 ) THEN
833     IF ( iDx. LT. 10 ) THEN
834     WRITE(plotBuf(iBuf:),'(A,I1)') accLab,iDx
835     ELSEIF ( iDx. LT. 100 ) THEN
836     WRITE(plotBuf(iBuf:),'(A,I2)') accLab,iDx
837     ELSEIF ( iDx. LT. 1000 ) THEN
838     WRITE(plotBuf(iBuf:),'(A,I3)') accLab,iDx
839     ELSEIF ( iDx. LT. 10000 ) THEN
840     WRITE(plotBuf(iBuf:),'(A,I4)') accLab,iDx
841     ENDIF
842     ENDIF
843     ENDDO
844     ENDDO
845     WRITE(msgBuf,'(A,A)') '// ',plotBuf
846     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
847     & SQUEEZE_RIGHT, 1)
848     plotBuf = dwnLab
849     iBuf = 7
850     DO bi=accBlo, accBhi, accBstr
851     DO I=accMin, accMax, accStr
852     iDx = accBase-1+(bi-1)*accStep+I
853     iBuf = iBuf+1
854     IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
855     WRITE(plotBuf(iBuf:),'(A)') '|'
856     ELSE
857     WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)
858     ENDIF
859     ENDDO
860     ENDDO
861     WRITE(msgBuf,'(A,A)') '// ',plotBuf
862     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
863     & SQUEEZE_RIGHT, 1)
864     DO bj=dwnBlo, dwnBhi, dwnBStr
865     DO J=dwnMin, dwnMax, dwnStr
866     WRITE(plotBuf,'(1X,I5,1X)')
867     & dwnBase-1+(bj-1)*dwnStep+J
868     iBuf = 7
869     DO bi=accBlo,accBhi,accBstr
870     DO I=accMin,accMax,accStr
871     iBuf = iBuf + 1
872     IF ( plotMode .EQ. PRINT_MAP_XY ) THEN
873     val = fld(I,J,K,bi,bj)
874     ELSEIF ( plotMode .EQ. PRINT_MAP_XZ ) THEN
875     val = fld(I,K,J,bi,bk)
876     ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
877     val = fld(K,I,J,bk,bi)
878     ENDIF
879 cnh 1.13 IF ( validRange .AND. val .NE. 0. ) THEN
880 cnh 1.11 IDX = NINT(
881 cnh 1.1 & FLOAT( lChList-1 )*( val-fMin ) / (fRange)
882     & )+1
883 cnh 1.11 ELSE
884     IDX = 1
885     ENDIF
886 cnh 1.1 IF ( iBuf .LE. MAX_LEN_PLOTBUF )
887     & plotBuf(iBuf:iBuf) = chList(IDX:IDX)
888     IF ( val .EQ. 0. ) THEN
889     IF ( iBuf .LE. MAX_LEN_PLOTBUF )
890     & plotBuf(iBuf:iBuf) = '.'
891     ENDIF
892     ENDDO
893     ENDDO
894     WRITE(msgBuf,'(A,A)') '// ',plotBuf
895     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
896     & SQUEEZE_RIGHT, 1)
897     ENDDO
898     ENDDO
899     ENDDO
900     ENDDO
901 dimitri 1.20 ENDIF
902 cnh 1.1 C-- Write delimiter
903 cnh 1.12 msgBuf =
904     & '// ======================================================='
905 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
906     & SQUEEZE_RIGHT, 1)
907 cnh 1.12 msgBuf =
908     & '// END OF FIELD ='
909 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
910     & SQUEEZE_RIGHT, 1)
911 cnh 1.12 msgBuf =
912     & '// ======================================================='
913 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
914     & SQUEEZE_RIGHT, 1)
915     msgBuf = ' '
916     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
917     & SQUEEZE_RIGHT, 1)
918    
919     RETURN
920     END
921    
922 cnh 1.18 CBOP
923     C !ROUTINE: PRINT_MAPRL
924    
925     C !INTERFACE:
926 cnh 1.8 SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
927 cnh 1.1 I iLo, iHi, jLo, jHi, kLo, kHi, nBx, nBy,
928     I iMin, iMax, iStr,
929     I jMin, jMax, jStr,
930     I kMin, kMax, kStr,
931     I bxMin, bxMax, bxStr,
932     I byMin, byMax, byStr )
933 adcroft 1.14 IMPLICIT NONE
934 cnh 1.1
935 cnh 1.18 C !DESCRIPTION:
936     C *==========================================================*
937 edhill 1.23 C | SUBROUTINE PRINT\_MAPRL
938 cnh 1.18 C | o Does textual mapping printing of a field.
939     C *==========================================================*
940     C | This routine does the actual formatting of the data
941     C | and printing to a file. It assumes an array using the
942     C | MITgcm UV indexing scheme and base index variables.
943     C | User code should call an interface routine like
944 edhill 1.23 C | PLOT\_FIELD\_XYR8( ... ) rather than this code directly.
945 cnh 1.18 C | Text plots can be oriented XY, YZ, XZ. An orientation
946     C | is specficied through the "plotMode" argument. All the
947     C | plots made by a single call to this routine will use the
948     C | same contour interval. The plot range (iMin,...,byStr)
949     C | can be three-dimensional. A separate plot is made for
950     C | each point in the plot range normal to the orientation.
951 edhill 1.23 C | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY).
952 cnh 1.18 C | kMin =1, kMax = 5 and kStr = 2 will produce three XY
953     C | plots - one for K=1, one for K=3 and one for K=5.
954     C | Each plot would have extents iMin:iMax step iStr
955     C | and jMin:jMax step jStr.
956     C *==========================================================*
957    
958     C !USES:
959 cnh 1.1 C == Global variables ==
960     #include "SIZE.h"
961     #include "EEPARAMS.h"
962     #include "EESUPPORT.h"
963 cnh 1.18 INTEGER IFNBLNK
964     EXTERNAL IFNBLNK
965     INTEGER ILNBLNK
966     EXTERNAL ILNBLNK
967 cnh 1.1
968 cnh 1.18 C !INPUT/OUTPUT PARAMETERS:
969 cnh 1.1 C == Routine arguments ==
970     C fld - Real*8 array holding data to be plotted
971     C fldTitle - Name of field to be plotted
972     C plotMode - Text string indicating plot orientation
973     C ( see - EEPARAMS.h for valid values ).
974     C iLo, iHi, - Dimensions of array fld. fld is assumed to
975     C jLo, jHi be five-dimensional.
976     C kLo, kHi
977     C nBx, nBy
978     C iMin, iMax - Indexing for points to plot. Points from
979     C iStr iMin -> iMax in steps of iStr are plotted
980     C jMin. jMax and similarly for jMin, jMax, jStr and
981     C jStr kMin, kMax, kStr and bxMin, bxMax, bxStr
982     C kMin, kMax byMin, byMax, byStr.
983     C kStr
984     CHARACTER*(*) fldTitle
985     CHARACTER*(*) plotMode
986     INTEGER iLo, iHi
987     INTEGER jLo, jHi
988     INTEGER kLo, kHi
989     INTEGER nBx, nBy
990 cnh 1.8 _RL fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
991 cnh 1.1 INTEGER iMin, iMax, iStr
992     INTEGER jMin, jMax, jStr
993     INTEGER kMin, kMax, kStr
994     INTEGER bxMin, bxMax, bxStr
995     INTEGER byMin, byMax, byStr
996    
997 cnh 1.18 C !LOCAL VARIABLES:
998 cnh 1.1 C == Local variables ==
999     C plotBuf - Buffer for building plot record
1000     C chList - Character string used for plot
1001     C fMin, fMax - Contour min, max and range
1002     C fRange
1003     C val - Value of element to be "plotted"
1004     C small - Lowest range for which contours are plotted
1005     C accXXX - Variables used in indexing accross page records.
1006     C dwnXXX Variables used in indexing down the page.
1007     C pltXXX Variables used in indexing multiple plots ( multiple
1008     C plots use same contour range).
1009     C Lab - Label
1010     C Base - Base number for element indexing
1011     C The process bottom, left coordinate in the
1012     C global domain.
1013     C Step - Block size
1014     C Blo - Start block
1015     C Bhi - End block
1016     C Bstr - Block stride
1017     C Min - Start index within block
1018     C Max - End index within block
1019     C Str - stride within block
1020     INTEGER MAX_LEN_PLOTBUF
1021     PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 )
1022     CHARACTER*(MAX_LEN_PLOTBUF) plotBuf
1023     CHARACTER*(MAX_LEN_MBUF) msgBuf
1024     INTEGER lChList
1025     PARAMETER ( lChList = 28 )
1026     CHARACTER*(lChList) chList
1027 cnh 1.13 _RL fMin
1028     _RL fMax
1029     _RL fRange
1030     _RL val
1031     _RL small
1032 cnh 1.1 CHARACTER*2 accLab
1033     CHARACTER*7 dwnLab
1034     CHARACTER*3 pltLab
1035     INTEGER accBase, dwnBase, pltBase
1036     INTEGER accStep, dwnStep, pltStep
1037     INTEGER accBlo, dwnBlo, pltBlo
1038     INTEGER accBhi, dwnBhi, pltBhi
1039     INTEGER accBstr, dwnBstr, pltBstr
1040     INTEGER accMin, dwnMin, pltMin
1041     INTEGER accMax, dwnMax, pltMax
1042     INTEGER accStr, dwnStr, pltStr
1043     INTEGER I, J, K, iStrngLo, iStrngHi, iBuf, iDx
1044     INTEGER bi, bj, bk
1045     LOGICAL validRange
1046 cnh 1.18 CEOP
1047 cnh 1.1
1048     chList = '-abcdefghijklmnopqrstuvwxyz+'
1049     small = 1. _d -15
1050     fMin = 1. _d 32
1051     fMax = -1. _d 32
1052     validRange = .FALSE.
1053    
1054     C-- Calculate field range
1055     DO bj=byMin, byMax, byStr
1056     DO bi=bxMin, bxMax, bxStr
1057     DO K=kMin, kMax, kStr
1058     DO J=jMin, jMax, jStr
1059     DO I=iMin, iMax, iStr
1060 cnh 1.12 IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )
1061     & THEN
1062 cnh 1.1 IF ( fld(I,J,K,bi,bj) .LT. fMin )
1063     & fMin = fld(I,J,K,bi,bj)
1064     IF ( fld(I,J,K,bi,bj) .GT. fMax )
1065     & fMax = fld(I,J,K,bi,bj)
1066 cnh 1.11 ENDIF
1067 cnh 1.1 ENDDO
1068     ENDDO
1069     ENDDO
1070     ENDDO
1071     ENDDO
1072     fRange = fMax-fMin
1073 dimitri 1.20 IF ( fRange .GT. small .AND.
1074     & (MAX_LEN_PLOTBUF-35) .GT. sNx*nSx .AND.
1075     & (MAX_LEN_PLOTBUF-35) .GT. sNy*nSy ) validRange = .TRUE.
1076 cnh 1.1
1077     C-- Write field title and statistics
1078 cnh 1.12 msgBuf =
1079     & '// ======================================================='
1080 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1081     & SQUEEZE_RIGHT, 1)
1082     iStrngLo = IFNBLNK(fldTitle)
1083     iStrngHi = ILNBLNK(fldTitle)
1084     IF ( iStrngLo .LE. iStrngHi ) THEN
1085     WRITE(msgBuf,'(A)') fldTitle(iStrngLo:iStrngHi)
1086     ELSE
1087     msgBuf = '// UNKNOWN FIELD'
1088     ENDIF
1089     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1090     & SQUEEZE_RIGHT, 1)
1091     WRITE(msgBuf,'(A,1PE30.15)')
1092     & '// CMIN = ', fMin
1093     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1094     & SQUEEZE_RIGHT, 1)
1095     WRITE(msgBuf,'(A,1PE30.15)')
1096     & '// CMAX = ', fMax
1097     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1098     & SQUEEZE_RIGHT, 1)
1099 cnh 1.11 IF ( validRange ) THEN
1100     WRITE(msgBuf,'(A,1PE30.15)')
1101 cnh 1.1 & '// CINT = ', fRange/FLOAT(lChlist-1)
1102 cnh 1.11 ELSE
1103     WRITE(msgBuf,'(A,1PE30.15)')
1104     & '// CINT = ', 0.
1105     ENDIF
1106 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1107     & SQUEEZE_RIGHT, 1)
1108     WRITE(msgBuf,'(A,1024A1)')
1109     & '// SYMBOLS (CMIN->CMAX): ',(chList(I:I),I=1,lChList)
1110     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1111     & SQUEEZE_RIGHT, 1)
1112     WRITE(msgBuf,'(A,1024A1)')
1113     & '// 0.0: ','.'
1114     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1115     & SQUEEZE_RIGHT, 1)
1116     WRITE(msgBuf,'(A,3(A,I4),A)')
1117     & '// RANGE I (Lo:Hi:Step):',
1118     & '(',myXGlobalLo-1+(bxMin-1)*sNx+iMin,
1119     & ':',myXGlobalLo-1+(bxMax-1)*sNx+iMax,
1120     & ':',iStr,')'
1121     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1122     & SQUEEZE_RIGHT, 1)
1123     WRITE(msgBuf,'(A,3(A,I4),A)')
1124     & '// RANGE J (Lo:Hi:Step):',
1125     & '(',myYGlobalLo-1+(byMin-1)*sNy+jMin,
1126     & ':',myYGlobalLo-1+(byMax-1)*sNy+jMax,
1127     & ':',jStr,')'
1128     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1129     & SQUEEZE_RIGHT, 1)
1130     WRITE(msgBuf,'(A,3(A,I4),A)')
1131     & '// RANGE K (Lo:Hi:Step):',
1132     & '(',kMin,
1133     & ':',kMax,
1134     & ':',kStr,')'
1135     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1136     & SQUEEZE_RIGHT, 1)
1137 cnh 1.12 msgBuf =
1138     & '// ======================================================='
1139 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1140     & SQUEEZE_RIGHT, 1)
1141 adcroft 1.22
1142     if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN
1143     msgBuf =
1144     & 'Model domain too big to print to terminal - skipping I/O'
1145     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1146     & SQUEEZE_RIGHT, 1)
1147     RETURN
1148     endif
1149 cnh 1.1
1150     C-- Write field
1151     C Figure out slice type and set plotting parameters appropriately
1152     C acc = accross the page
1153     C dwn = down the page
1154     IF ( plotMode .EQ. PRINT_MAP_XY ) THEN
1155     C X across, Y down slice
1156     accLab = 'I='
1157     accBase = myXGlobalLo
1158     accStep = sNx
1159     accBlo = bxMin
1160     accBhi = bxMax
1161     accBStr = bxStr
1162     accMin = iMin
1163     accMax = iMax
1164     accStr = iStr
1165     dwnLab = '|--J--|'
1166     dwnBase = myYGlobalLo
1167     dwnStep = sNy
1168     dwnBlo = byMin
1169     dwnBhi = byMax
1170     dwnBStr = byStr
1171     dwnMin = jMin
1172     dwnMax = jMax
1173     dwnStr = jStr
1174     pltBlo = 1
1175     pltBhi = 1
1176     pltBstr = 1
1177     pltMin = kMin
1178     pltMax = kMax
1179     pltStr = kStr
1180     pltBase = 1
1181     pltStep = 1
1182     pltLab = 'K ='
1183     ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
1184     C Y across, Z down slice
1185     accLab = 'J='
1186     accBase = myYGlobalLo
1187     accStep = sNy
1188     accBlo = byMin
1189     accBhi = byMax
1190     accBStr = byStr
1191     accMin = jMin
1192     accMax = jMax
1193     accStr = jStr
1194     dwnLab = '|--K--|'
1195     dwnBase = 1
1196     dwnStep = 1
1197     dwnBlo = 1
1198     dwnBhi = 1
1199     dwnBStr = 1
1200     dwnMin = kMin
1201     dwnMax = kMax
1202     dwnStr = kStr
1203     pltBlo = bxMin
1204     pltBhi = bxMax
1205     pltBstr = bxStr
1206     pltMin = iMin
1207     pltMax = iMax
1208     pltStr = iStr
1209     pltBase = myXGlobalLo
1210     pltStep = sNx
1211     pltLab = 'I ='
1212     ELSEIF ( plotMode .EQ. PRINT_MAP_XZ ) THEN
1213     C X across, Z down slice
1214     accLab = 'I='
1215     accBase = myXGlobalLo
1216     accStep = sNx
1217     accBlo = bxMin
1218     accBhi = bxMax
1219     accBStr = bxStr
1220     accMin = iMin
1221     accMax = iMax
1222     accStr = iStr
1223     dwnLab = '|--K--|'
1224     dwnBase = 1
1225     dwnStep = 1
1226     dwnBlo = 1
1227     dwnBhi = 1
1228     dwnBStr = 1
1229     dwnMin = kMin
1230     dwnMax = kMax
1231     dwnStr = kStr
1232     pltBlo = byMin
1233     pltBhi = byMax
1234     pltBstr = byStr
1235     pltMin = jMin
1236     pltMax = jMax
1237     pltStr = jStr
1238     pltBase = myYGlobalLo
1239     pltStep = sNy
1240     pltLab = 'J ='
1241     ENDIF
1242 dimitri 1.20 IF ( validRange ) THEN
1243 cnh 1.1 C Header
1244     C Data
1245     DO bk=pltBlo, pltBhi, pltBstr
1246     DO K=pltMin,pltMax,pltStr
1247 cnh 1.12 WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
1248 cnh 1.1 & pltBase-1+(bk-1)*pltStep+K
1249     CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1250     & SQUEEZE_RIGHT, 1)
1251     plotBuf = ' '
1252     iBuf = 6
1253     DO bi=accBlo, accBhi, accBstr
1254     DO I=accMin, accMax, accStr
1255     iDx = accBase-1+(bi-1)*accStep+I
1256     iBuf = iBuf + 1
1257     IF ( 10*((iBuf-6)/10) .EQ. iBuf-6 ) THEN
1258     IF ( iDx. LT. 10 ) THEN
1259     WRITE(plotBuf(iBuf:),'(A,I1)') accLab,iDx
1260     ELSEIF ( iDx. LT. 100 ) THEN
1261     WRITE(plotBuf(iBuf:),'(A,I2)') accLab,iDx
1262     ELSEIF ( iDx. LT. 1000 ) THEN
1263     WRITE(plotBuf(iBuf:),'(A,I3)') accLab,iDx
1264     ELSEIF ( iDx. LT. 10000 ) THEN
1265     WRITE(plotBuf(iBuf:),'(A,I4)') accLab,iDx
1266     ENDIF
1267     ENDIF
1268     ENDDO
1269     ENDDO
1270     CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1271     & SQUEEZE_RIGHT, 1)
1272     plotBuf = dwnLab
1273     iBuf = 7
1274     DO bi=accBlo, accBhi, accBstr
1275     DO I=accMin, accMax, accStr
1276     iDx = accBase-1+(bi-1)*accStep+I
1277     iBuf = iBuf+1
1278     IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN
1279     WRITE(plotBuf(iBuf:),'(A)') '|'
1280     ELSE
1281     WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10)
1282     ENDIF
1283     ENDDO
1284     ENDDO
1285     CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1286     & SQUEEZE_RIGHT, 1)
1287     DO bj=dwnBlo, dwnBhi, dwnBStr
1288     DO J=dwnMin, dwnMax, dwnStr
1289     WRITE(plotBuf,'(1X,I5,1X)')
1290     & dwnBase-1+(bj-1)*dwnStep+J
1291     iBuf = 7
1292     DO bi=accBlo,accBhi,accBstr
1293     DO I=accMin,accMax,accStr
1294     iBuf = iBuf + 1
1295     IF ( plotMode .EQ. PRINT_MAP_XY ) THEN
1296     val = fld(I,J,K,bi,bj)
1297     ELSEIF ( plotMode .EQ. PRINT_MAP_XZ ) THEN
1298     val = fld(I,K,J,bi,bk)
1299     ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
1300     val = fld(K,I,J,bk,bi)
1301     ENDIF
1302 cnh 1.13 IF ( validRange .AND. val .NE. 0. ) THEN
1303 cnh 1.11 IDX = NINT(
1304     & FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1305     & )+1
1306     ELSE
1307     IDX = 1
1308     ENDIF
1309 cnh 1.1 IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1310     & plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1311     IF ( val .EQ. 0. ) THEN
1312     IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1313     & plotBuf(iBuf:iBuf) = '.'
1314     ENDIF
1315     ENDDO
1316     ENDDO
1317     CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1318     & SQUEEZE_RIGHT, 1)
1319     ENDDO
1320     ENDDO
1321     ENDDO
1322     ENDDO
1323 dimitri 1.20 ENDIF
1324 cnh 1.1 C-- Write delimiter
1325 cnh 1.12 msgBuf =
1326     & '// ======================================================='
1327 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1328     & SQUEEZE_RIGHT, 1)
1329 cnh 1.12 msgBuf =
1330     & '// END OF FIELD ='
1331 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1332     & SQUEEZE_RIGHT, 1)
1333 cnh 1.12 msgBuf =
1334     & '// ======================================================='
1335 cnh 1.1 CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1336     & SQUEEZE_RIGHT, 1)
1337     msgBuf = ' '
1338     CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1339     & SQUEEZE_RIGHT, 1)
1340    
1341     RETURN
1342     END
1343    
1344 cnh 1.18 CBOP
1345     C !ROUTINE: PRINT_MESSAGE
1346    
1347     C !INTERFACE:
1348 cnh 1.1 SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid )
1349 adcroft 1.14 IMPLICIT NONE
1350 cnh 1.18 C !DESCRIPTION:
1351     C *============================================================*
1352 edhill 1.23 C | SUBROUTINE PRINT\_MESSAGE
1353 cnh 1.18 C | o Write out informational message using "standard" format.
1354     C *============================================================*
1355     C | Notes
1356     C | =====
1357     C | o Some system I/O is not "thread-safe". For this reason
1358 edhill 1.23 C | without the FMTFTN\_IO\_THREAD\_SAFE directive set a
1359 cnh 1.18 C | critical region is defined around the write here. In some
1360 edhill 1.23 C | cases BEGIN\_CRIT() is approximated by only doing writes
1361 cnh 1.18 C | for thread number 1 - writes for other threads are
1362     C | ignored!
1363     C | o In a non-parallel form these routines can still be used.
1364     C | to produce pretty printed output!
1365     C *============================================================*
1366    
1367     C !USES:
1368 cnh 1.1 C == Global data ==
1369     #include "SIZE.h"
1370     #include "EEPARAMS.h"
1371     #include "EESUPPORT.h"
1372 cnh 1.18 INTEGER IFNBLNK
1373     EXTERNAL IFNBLNK
1374     INTEGER ILNBLNK
1375     EXTERNAL ILNBLNK
1376    
1377     C !INPUT/OUTPUT PARAMETERS:
1378 cnh 1.1 C == Routine arguments ==
1379 cnh 1.18 C message :: Message to write
1380     C unit :: Unit number to write to
1381     C sq :: Justification option
1382 cnh 1.1 CHARACTER*(*) message
1383     INTEGER unit
1384     CHARACTER*(*) sq
1385     INTEGER myThid
1386 cnh 1.18
1387     C !LOCAL VARIABLES:
1388 cnh 1.1 C == Local variables ==
1389 cnh 1.18 C iStart, iEnd :: String indexing variables
1390     C idString :: Temp. for building prefix.
1391 cnh 1.1 INTEGER iStart
1392     INTEGER iEnd
1393     CHARACTER*9 idString
1394 cnh 1.18 CEOP
1395    
1396 cnh 1.1 C-- Find beginning and end of message
1397     IF ( sq .EQ. SQUEEZE_BOTH .OR.
1398     & sq .EQ. SQUEEZE_LEFT ) THEN
1399     iStart = IFNBLNK( message )
1400     ELSE
1401     iStart = 1
1402     ENDIF
1403     IF ( sq .EQ. SQUEEZE_BOTH .OR.
1404     & sq .EQ. SQUEEZE_RIGHT ) THEN
1405     iEnd = ILNBLNK( message )
1406     ELSE
1407     iEnd = LEN(message)
1408     ENDIF
1409     C-- Test to see if in multi-process ( or multi-threaded ) mode.
1410     C If so include process or thread identifier.
1411     IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN
1412     C-- Write single process format
1413     IF ( message .EQ. ' ' ) THEN
1414     WRITE(unit,'(A)') ' '
1415     ELSE
1416     WRITE(unit,'(A)') message(iStart:iEnd)
1417     ENDIF
1418     ELSEIF ( pidIO .EQ. myProcId ) THEN
1419     C-- Write multi-process format
1420     #ifndef FMTFTN_IO_THREAD_SAFE
1421     _BEGIN_CRIT(myThid)
1422     #endif
1423     WRITE(idString,'(I4.4,A,I4.4)') myProcId,'.',myThid
1424     #ifndef FMTFTN_IO_THREAD_SAFE
1425     _END_CRIT(myThid)
1426     #endif
1427     IF ( message .EQ. ' ' ) THEN
1428     C PRINT can be called by several threads simultaneously.
1429     C The write statement may need to ne marked as a critical section.
1430     #ifndef FMTFTN_IO_THREAD_SAFE
1431     _BEGIN_CRIT(myThid)
1432     #endif
1433 cnh 1.6 WRITE(unit,'(A,A,A,A,A,A)',ERR=999)
1434 cnh 1.1 & '(',PROCESS_HEADER,' ',idString,')',' '
1435     #ifndef FMTFTN_IO_THREAD_SAFE
1436     _END_CRIT(myThid)
1437     #endif
1438     ELSE
1439     #ifndef FMTFTN_IO_THREAD_SAFE
1440     _BEGIN_CRIT(myThid)
1441     #endif
1442 cnh 1.6 WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)
1443 cnh 1.1 & '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',
1444     & message(iStart:iEnd)
1445     #ifndef FMTFTN_IO_THREAD_SAFE
1446     _END_CRIT(myThid)
1447     #endif
1448     ENDIF
1449     ENDIF
1450 jmc 1.21
1451     #ifndef DISABLE_WRITE_TO_UNIT_ZERO
1452     C-- if error message, also write directly to unit 0 :
1453     IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1
1454     & .AND. unit.EQ.errorMessageUnit ) THEN
1455     iEnd = ILNBLNK( message )
1456     IF (iEnd.NE.0) WRITE(0,'(A)') message(1:iEnd)
1457     ENDIF
1458     #endif
1459 cnh 1.1 C
1460 cnh 1.6 1000 CONTINUE
1461 cnh 1.1 RETURN
1462 cnh 1.6 999 CONTINUE
1463     ioErrorCount(myThid) = ioErrorCount(myThid)+1
1464     GOTO 1000
1465    
1466 cnh 1.1 END
  ViewVC Help
Powered by ViewVC 1.1.22