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