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

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

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


Revision 1.19 - (show annotations) (download)
Fri Sep 21 14:31:12 2001 UTC (22 years, 6 months ago) by adcroft
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint51k_post, checkpoint47e_post, checkpoint44e_post, checkpoint46l_post, checkpoint46g_pre, checkpoint47c_post, release1_p13_pre, checkpoint50c_post, checkpoint46f_post, checkpoint52d_pre, checkpoint48e_post, checkpoint50c_pre, checkpoint44f_post, checkpoint46b_post, checkpoint43a-release1mods, checkpoint51o_pre, ecco_c50_e32, ecco_c50_e33, ecco_c50_e30, ecco_c50_e31, release1_p13, checkpoint51l_post, checkpoint48i_post, checkpoint46l_pre, chkpt44d_post, checkpoint51, checkpoint50, checkpoint52, release1_p8, release1_p9, checkpoint50d_post, release1_p1, release1_p2, release1_p3, release1_p4, release1_p5, release1_p6, release1_p7, checkpoint52f_post, checkpoint50b_pre, checkpoint44e_pre, checkpoint51f_post, release1_b1, ecco_c51_e34d, ecco_c51_e34e, ecco_c51_e34f, ecco_c51_e34g, ecco_c51_e34a, ecco_c51_e34b, ecco_c51_e34c, checkpoint48b_post, checkpoint43, checkpoint51d_post, checkpoint48c_pre, checkpoint47d_pre, checkpoint51t_post, checkpoint51n_post, release1_chkpt44d_post, checkpoint51s_post, checkpoint47a_post, checkpoint48d_pre, checkpoint51j_post, checkpoint47i_post, checkpoint52e_pre, release1_p11, checkpoint52e_post, checkpoint51n_pre, checkpoint47d_post, icebear5, icebear4, icebear3, icebear2, checkpoint46d_pre, checkpoint48d_post, release1-branch_tutorials, checkpoint48f_post, checkpoint45d_post, checkpoint52b_pre, checkpoint46j_pre, checkpoint51l_pre, chkpt44a_post, checkpoint44h_pre, checkpoint48h_post, checkpoint51q_post, ecco_c50_e29, checkpoint51b_pre, checkpoint46a_post, checkpoint47g_post, checkpoint52b_post, checkpoint52c_post, checkpoint46j_post, checkpoint51h_pre, checkpoint46k_post, ecco_c50_e28, chkpt44c_pre, checkpoint48a_post, checkpoint45a_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, checkpoint52f_pre, ecco_c44_e19, ecco_c44_e18, ecco_c44_e17, ecco_c44_e16, release1_p12, release1_p10, release1_p16, release1_p17, release1_p14, release1_p15, checkpoint47j_post, ecco_c50_e33a, branch-exfmods-tag, checkpoint44g_post, branchpoint-genmake2, checkpoint46e_pre, checkpoint51r_post, checkpoint48c_post, checkpoint45b_post, checkpoint46b_pre, checkpoint51i_post, release1-branch-end, release1_final_v1, checkpoint51b_post, checkpoint51c_post, checkpoint46c_pre, checkpoint46, checkpoint47b_post, checkpoint44b_post, ecco_c51_e34, checkpoint46h_pre, checkpoint52d_post, checkpoint46m_post, checkpoint46a_pre, checkpoint50g_post, checkpoint45c_post, ecco_ice2, ecco_ice1, checkpoint44h_post, checkpoint46g_post, release1_p12_pre, checkpoint52a_pre, ecco_c44_e22, checkpoint50h_post, checkpoint50e_pre, checkpoint50i_post, ecco_c44_e25, checkpoint51i_pre, checkpoint47f_post, checkpoint50e_post, chkpt44a_pre, checkpoint46i_post, ecco_c44_e23, ecco_c44_e20, ecco_c44_e21, ecco_c44_e26, ecco_c44_e27, ecco_c44_e24, checkpoint46c_post, ecco-branch-mod1, ecco-branch-mod2, ecco-branch-mod3, ecco-branch-mod4, ecco-branch-mod5, branch-netcdf, checkpoint50d_pre, checkpoint46e_post, release1_beta1, checkpoint51e_post, checkpoint44b_pre, checkpoint42, checkpoint41, checkpoint47, checkpoint44, checkpoint45, checkpoint48, checkpoint49, checkpoint46h_post, checkpoint51o_post, checkpoint51f_pre, chkpt44c_post, checkpoint48g_post, checkpoint47h_post, checkpoint52a_post, checkpoint44f_pre, checkpoint51g_post, ecco_c52_e35, checkpoint46d_post, checkpoint50b_post, release1-branch_branchpoint, checkpoint51m_post, checkpoint51a_post, checkpoint51p_post, checkpoint51u_post
Branch point for: c24_e25_ice, branch-exfmods-curt, release1_final, release1-branch, branch-genmake2, release1, branch-nonh, tg2-branch, ecco-branch, release1_50yr, netcdf-sm0, icebear, checkpoint51n_branch, release1_coupled
Changes since 1.18: +1 -2 lines
Deleted second IMPLICIT NONE introduced when commenting.

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

  ViewVC Help
Powered by ViewVC 1.1.22