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