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