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

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

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

revision 1.4 by cnh, Sun Apr 26 23:41:54 1998 UTC revision 1.14 by adcroft, Mon May 24 15:15:11 1999 UTC
# Line 6  C--   File printf.F: Routines for perfor Line 6  C--   File printf.F: Routines for perfor
6  C--                  in the MITgcm UV implementation environment.  C--                  in the MITgcm UV implementation environment.
7  C--    Contents  C--    Contents
8  C--    o print_error    Does IO with **ERROR** highlighted header  C--    o print_error    Does IO with **ERROR** highlighted header
9    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  C--    o print_list_r8  Prints one-deimensional list of Real*8  C--    o print_list_r8  Prints one-deimensional list of Real*8
14  C--                     numbers.  C--                     numbers.
15  C--    o print_mapr4    Formats ABCD... contour map of a Real*4 field  C--    o print_mapr4    Formats ABCD... contour map of a Real*4 field
# Line 21  C     | SUBROUTINE PRINT_ERROR Line 25  C     | SUBROUTINE PRINT_ERROR
25  C     | o Write out error message using "standard" format.         |  C     | o Write out error message using "standard" format.         |
26  C     | Notes                                                      |  C     | Notes                                                      |
27  C     | =====                                                      |  C     | =====                                                      |
28  C     | o Some system's I/O is not "thread-safe". For this reason  |  C     | o Some system   I/O is not "thread-safe". For this reason  |
29  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |
30  C     |   critical region is defined around the write here. In some|  C     |   critical region is defined around the write here. In some|
31  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |
# Line 30  C     |   ignored! Line 34  C     |   ignored!
34  C     | o In a non-parallel form these routines can still be used. |  C     | o In a non-parallel form these routines can still be used. |
35  C     |   to produce pretty printed output!                        |  C     |   to produce pretty printed output!                        |
36  C     \============================================================/  C     \============================================================/
37          IMPLICIT NONE
38  C     == Global data ==  C     == Global data ==
39  #include "SIZE.h"  #include "SIZE.h"
40  #include "EEPARAMS.h"  #include "EEPARAMS.h"
# Line 56  C--    Write single process format Line 61  C--    Write single process format
61         IF ( message .EQ. ' ' ) THEN         IF ( message .EQ. ' ' ) THEN
62          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '
63         ELSE         ELSE
64          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, message(iStart:iEnd)          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER,
65         &   message(iStart:iEnd)
66         ENDIF         ENDIF
67        ELSEIF ( pidIO .EQ. myProcId ) THEN        ELSEIF ( pidIO .EQ. myProcId ) THEN
68  C--    Write multi-process format  C--    Write multi-process format
# Line 73  C       The write statement may need to Line 79  C       The write statement may need to
79  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
80          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
81  #endif  #endif
82          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
83       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
84       &  ' '       &  ' '
85  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 83  C       The write statement may need to Line 89  C       The write statement may need to
89  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
90          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
91  #endif  #endif
92          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
93       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
94       &  message(iStart:iEnd)       &  message(iStart:iEnd)
95  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 92  C       The write statement may need to Line 98  C       The write statement may need to
98         ENDIF         ENDIF
99        ENDIF        ENDIF
100  C  C
101     1000 CONTINUE
102        RETURN        RETURN
103    
104      999 CONTINUE
105           ioErrorCount(myThid) = ioErrorCount(myThid)+1
106          GOTO 1000
107        END        END
108    
109  CStartofinterface  CStartofinterface
110        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, ioUnit )        SUBROUTINE PRINT_LIST_I( fld, lFld, index_type,
111         &                         markEnd, compact, ioUnit )
112    C     /==========================================================\
113    C     | o SUBROUTINE PRINT_LIST_I                                |
114    C     |==========================================================|
115    C     | Routine for producing list of values for a field with    |
116    C     | duplicate values collected into                          |
117    C     |    n @ value                                             |
118    C     | record.                                                  |
119    C     \==========================================================/
120          IMPLICIT NONE
121    
122    C     == Global data ==  
123    #include "SIZE.h"
124    #include "EEPARAMS.h"
125    
126    C     == Routine arguments ==
127    C     fld    -  Data to be printed
128    C     lFld   -  Number of elements to be printed
129    C     index_type - Flag indicating which type of index to print
130    C                  INDEX_K    => /* K = nnn */
131    C                  INDEX_I    => /* I = nnn */
132    C                  INDEX_J    => /* J = nnn */
133    C                  INDEX_NONE =>
134    C     compact -  Flag to control use of repeat symbol for same valued
135    C                fields.
136    C     markEnd -  Flag to control whether there is a separator after the
137    C                last element
138    C     ioUnit -  Unit number for IO.
139          INTEGER lFld
140          INTEGER index_type
141          INTEGER fld(lFld)
142          LOGICAL markEnd
143          LOGICAL compact
144          INTEGER ioUnit
145  CEndifinterface  CEndifinterface
146    
147    C     == Local variables ==
148    C     iLo  - Range index holders for selecting elements with
149    C     iHi    with the same value
150    C     nDup - Number of duplicates
151    C     xNew, xOld - Hold current and previous values of field
152    C     punc - Field separator
153    C     msgBuf - IO buffer
154    C     index_lab - Index for labelling elements
155    C     K    - Loop counter
156          INTEGER iLo
157          INTEGER iHi
158          INTEGER nDup
159          INTEGER xNew, xOld
160          CHARACTER punc
161          CHARACTER*(MAX_LEN_MBUF) msgBuf
162          CHARACTER*2 commOpen,commClose
163          CHARACTER*3 index_lab
164          INTEGER K
165    
166          IF     ( index_type .EQ. INDEX_I ) THEN
167           index_lab = 'I ='
168          ELSEIF ( index_type .EQ. INDEX_J ) THEN
169           index_lab = 'J ='
170          ELSEIF ( index_type .EQ. INDEX_K ) THEN
171           index_lab = 'K ='
172          ELSE
173           index_lab = '?='
174          ENDIF
175          commOpen  = '/*'
176          commClose = '*/'
177          iLo = 1
178          iHi = 1
179          punc = ','
180          xOld = fld(1)
181          DO K=2,lFld
182           xNew = fld(K  )
183           IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
184            nDup = iHi-iLo+1
185            IF ( nDup .EQ. 1 ) THEN
186             WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
187             IF ( index_type .NE. INDEX_NONE )
188         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
189         &    commOpen,index_lab,iLo,commClose
190            ELSE
191             WRITE(msgBuf,'(I,'' '',A,I9,A)') nDup,'@',xOld,punc
192             IF ( index_type .NE. INDEX_NONE )
193         &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
194         &    commOpen,index_lab,iLo,':',iHi,commClose
195            ENDIF
196            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
197            iLo  = K
198            iHi  = K
199            xOld = xNew
200           ELSE
201            iHi = K
202           ENDIF
203          ENDDO
204          punc = ' '
205          IF ( markEnd ) punc = ','
206          nDup = iHi-iLo+1
207          IF    ( nDup .EQ. 1 ) THEN
208           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
209           IF ( index_type .NE. INDEX_NONE )
210         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
211         &  commOpen,index_lab,iLo,commClose
212          ELSEIF( nDup .GT. 1 ) THEN
213           WRITE(msgBuf,'(I,'' '',A,I9,A)') nDup,'@',xOld,punc
214           IF ( index_type .NE. INDEX_NONE )
215         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
216         &  commOpen,index_lab,iLo,':',iHi,commClose
217          ENDIF
218          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
219    
220          RETURN
221          END
222    
223    CStartofinterface
224          SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd,
225         &                         compact, ioUnit )
226    C     /==========================================================\
227    C     | o SUBROUTINE PRINT_LIST_L                                |
228    C     |==========================================================|
229    C     | Routine for producing list of values for a field with    |
230    C     | duplicate values collected into                          |
231    C     |    n @ value                                             |
232    C     | record.                                                  |
233    C     \==========================================================/
234          IMPLICIT NONE
235    
236    C     == Global data ==  
237    #include "SIZE.h"
238    #include "EEPARAMS.h"
239    
240    C     == Routine arguments ==
241    C     fld    -  Data to be printed
242    C     lFld   -  Number of elements to be printed
243    C     index_type - Flag indicating which type of index to print
244    C                  INDEX_K    => /* K = nnn */
245    C                  INDEX_I    => /* I = nnn */
246    C                  INDEX_J    => /* J = nnn */
247    C                  INDEX_NONE =>
248    C     compact -  Flag to control use of repeat symbol for same valued
249    C                fields.
250    C     markEnd -  Flag to control whether there is a separator after the
251    C                last element
252    C     ioUnit -  Unit number for IO.
253          INTEGER lFld
254          INTEGER index_type
255          LOGICAL fld(lFld)
256          LOGICAL markEnd
257          LOGICAL compact
258          INTEGER ioUnit
259    CEndifinterface
260    
261    C     == Local variables ==
262    C     iLo  - Range index holders for selecting elements with
263    C     iHi    with the same value
264    C     nDup - Number of duplicates
265    C     xNew, xOld - Hold current and previous values of field
266    C     punc - Field separator
267    C     msgBuf - IO buffer
268    C     index_lab - Index for labelling elements
269    C     K    - Loop counter
270          INTEGER iLo
271          INTEGER iHi
272          INTEGER nDup
273          LOGICAL xNew, xOld
274          CHARACTER punc
275          CHARACTER*(MAX_LEN_MBUF) msgBuf
276          CHARACTER*2 commOpen,commClose
277          CHARACTER*3 index_lab
278          INTEGER K
279    
280          IF     ( index_type .EQ. INDEX_I ) THEN
281           index_lab = 'I ='
282          ELSEIF ( index_type .EQ. INDEX_J ) THEN
283           index_lab = 'J ='
284          ELSEIF ( index_type .EQ. INDEX_K ) THEN
285           index_lab = 'K ='
286          ELSE
287           index_lab = '?='
288          ENDIF
289          commOpen  = '/*'
290          commClose = '*/'
291          iLo = 1
292          iHi = 1
293          punc = ','
294          xOld = fld(1)
295          DO K=2,lFld
296           xNew = fld(K  )
297           IF ( .NOT. compact .OR. xNew .NEQV. xOld ) THEN
298            nDup = iHi-iLo+1
299            IF ( nDup .EQ. 1 ) THEN
300             WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
301             IF ( index_type .NE. INDEX_NONE )
302         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
303         &    commOpen,index_lab,iLo,commClose
304            ELSE
305             WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
306             IF ( index_type .NE. INDEX_NONE )
307         &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')
308         &    commOpen,index_lab,iLo,':',iHi,commClose
309            ENDIF
310            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
311            iLo  = K
312            iHi  = K
313            xOld = xNew
314           ELSE
315            iHi = K
316           ENDIF
317          ENDDO
318          punc = ' '
319          IF ( markEnd ) punc = ','
320          nDup = iHi-iLo+1
321          IF    ( nDup .EQ. 1 ) THEN
322           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
323           IF ( index_type .NE. INDEX_NONE )
324         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
325         &    commOpen,index_lab,iLo,commClose
326          ELSEIF( nDup .GT. 1 ) THEN
327           WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
328           IF ( index_type .NE. INDEX_NONE )
329         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
330         &  commOpen,index_lab,iLo,':',iHi,commClose
331          ENDIF
332          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
333    
334          RETURN
335          END
336    
337    CStartofinterface
338          SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type,
339         &    markEnd, compact, ioUnit )
340  C     /==========================================================\  C     /==========================================================\
341  C     | o SUBROUTINE PRINT_LIST_R8                               |  C     | o SUBROUTINE PRINT_LIST_R8                               |
342  C     |==========================================================|  C     |==========================================================|
# Line 106  C     | duplicate values collected into Line 345  C     | duplicate values collected into
345  C     |    n @ value                                             |  C     |    n @ value                                             |
346  C     | record.                                                  |  C     | record.                                                  |
347  C     \==========================================================/  C     \==========================================================/
348          IMPLICIT NONE
349    
350  C     == Global data ==    C     == Global data ==  
351  #include "SIZE.h"  #include "SIZE.h"
# Line 119  C                  INDEX_K    => /* K = Line 359  C                  INDEX_K    => /* K =
359  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
360  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
361  C                  INDEX_NONE =>  C                  INDEX_NONE =>
362    C     compact -  Flag to control use of repeat symbol for same valued
363    C                fields.
364    C     markEnd -  Flag to control whether there is a separator after the
365    C                last element
366  C     ioUnit -  Unit number for IO.  C     ioUnit -  Unit number for IO.
367        INTEGER lFld        INTEGER lFld
368        INTEGER index_type        INTEGER index_type
369        Real*8  fld(lFld)        Real*8  fld(lFld)
370          LOGICAL markEnd
371          LOGICAL compact
372        INTEGER ioUnit        INTEGER ioUnit
373    CEndifinterface
374    
375  C     == Local variables ==  C     == Local variables ==
376  C     iLo  - Range index holders for selecting elements with  C     iLo  - Range index holders for selecting elements with
# Line 139  C     K    - Loop counter Line 386  C     K    - Loop counter
386        INTEGER nDup        INTEGER nDup
387        Real*8 xNew, xOld        Real*8 xNew, xOld
388        CHARACTER punc        CHARACTER punc
389        CHARACTER(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
390        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
391        CHARACTER*3 index_lab        CHARACTER*3 index_lab
392        INTEGER K        INTEGER K
# Line 161  C     K    - Loop counter Line 408  C     K    - Loop counter
408        xOld = fld(1)        xOld = fld(1)
409        DO K=2,lFld        DO K=2,lFld
410         xNew = fld(K  )         xNew = fld(K  )
411         IF ( xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
412          nDup = iHi-iLo+1          nDup = iHi-iLo+1
413          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
414           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
415           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
416       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
417         &    commOpen,index_lab,iLo,commClose
418          ELSE          ELSE
419           WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
420           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
421       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
422       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
423          ENDIF          ENDIF
424          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
425         &    SQUEEZE_RIGHT , 1)
426          iLo  = K          iLo  = K
427          iHi  = K          iHi  = K
428          xOld = xNew          xOld = xNew
# Line 182  C     K    - Loop counter Line 431  C     K    - Loop counter
431         ENDIF         ENDIF
432        ENDDO        ENDDO
433        punc = ' '        punc = ' '
434          IF ( markEnd ) punc = ','
435        nDup = iHi-iLo+1        nDup = iHi-iLo+1
436        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
437         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
438         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
439       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
440         &    commOpen,index_lab,iLo,commClose
441        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
442         WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
443         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
444       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
445       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
446        ENDIF        ENDIF
447        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
448         &    SQUEEZE_RIGHT , 1)
449    
450        RETURN        RETURN
451        END        END
452    
453  CStartOfInterface  CStartOfInterface
454        SUBROUTINE PRINT_MAPR4 ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,
455       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
456       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
457       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
# Line 227  C     |      plots - one for K=1, one fo Line 479  C     |      plots - one for K=1, one fo
479  C     |      Each plot would have extents iMin:iMax step iStr    |  C     |      Each plot would have extents iMin:iMax step iStr    |
480  C     |      and jMin:jMax step jStr.                            |  C     |      and jMin:jMax step jStr.                            |
481  C     \==========================================================/  C     \==========================================================/
482          IMPLICIT NONE
483    
484  C     == Global variables ==  C     == Global variables ==
485  #include "SIZE.h"  #include "SIZE.h"
# Line 254  C     kStr Line 507  C     kStr
507        INTEGER jLo, jHi        INTEGER jLo, jHi
508        INTEGER kLo, kHi        INTEGER kLo, kHi
509        INTEGER nBx, nBy        INTEGER nBx, nBy
510        Real*4 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RS fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
511        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
512        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
513        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
# Line 296  C               Str  - stride within blo Line 549  C               Str  - stride within blo
549        INTEGER lChList        INTEGER lChList
550        PARAMETER ( lChList = 28 )        PARAMETER ( lChList = 28 )
551        CHARACTER*(lChList) chList        CHARACTER*(lChList) chList
552        REAL fMin        _RL  fMin
553        REAL fMax        _RL  fMax
554        REAL fRange        _RL  fRange
555        REAL val        _RL  val
556        REAL small        _RL  small
557        CHARACTER*2  accLab        CHARACTER*2  accLab
558        CHARACTER*7  dwnLab        CHARACTER*7  dwnLab
559        CHARACTER*3  pltLab        CHARACTER*3  pltLab
# Line 317  C               Str  - stride within blo Line 570  C               Str  - stride within blo
570        LOGICAL validRange        LOGICAL validRange
571    
572        chList = '-abcdefghijklmnopqrstuvwxyz+'        chList = '-abcdefghijklmnopqrstuvwxyz+'
573        small  = 1. _d -15        small  =  1. _d -15
574        fMin   =  1. _d 32        fMin   =  1. _d  32
575        fMax   = -1. _d 32        fMax   = -1. _d  32
576        validRange = .FALSE.        validRange = .FALSE.
577    
578  C--   Calculate field range  C--   Calculate field range
# Line 328  C--   Calculate field range Line 581  C--   Calculate field range
581          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
582           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
583            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
584             IF ( fld(I,J,K,bi,bj) .NE. 0. ) THEN             IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN
585              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
586       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
587              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
# Line 345  C--   Calculate field range Line 598  C--   Calculate field range
598        ENDIF        ENDIF
599    
600  C--   Write field title and statistics  C--   Write field title and statistics
601        msgBuf = '// ======================================================='        msgBuf =
602         & '// ======================================================='
603        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
604       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
605        iStrngLo = IFNBLNK(fldTitle)        iStrngLo = IFNBLNK(fldTitle)
# Line 365  C--   Write field title and statistics Line 619  C--   Write field title and statistics
619       & '// CMAX = ', fMax       & '// CMAX = ', fMax
620        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
621       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
622        WRITE(msgBuf,'(A,1PE30.15)')        IF ( validRange ) THEN
623       & '// CINT = ', fRange/FLOAT(lChlist-1)         WRITE(msgBuf,'(A,1PE30.15)')
624         &  '// CINT = ', fRange/FLOAT(lChlist-1)
625          ELSE
626           WRITE(msgBuf,'(A,1PE30.15)')
627         &  '// CINT = ', 0.
628          ENDIF
629        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
630       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
631        WRITE(msgBuf,'(A,1024A1)')        WRITE(msgBuf,'(A,1024A1)')
# Line 398  C--   Write field title and statistics Line 657  C--   Write field title and statistics
657       &  ':',kStr,')'       &  ':',kStr,')'
658        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
659       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
660        msgBuf = '// ======================================================='        msgBuf =
661         & '// ======================================================='
662        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
663       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
664    
# Line 494  C      X across, Z down slice Line 754  C      X across, Z down slice
754         pltStep = sNy         pltStep = sNy
755         pltLab  = 'J ='         pltLab  = 'J ='
756        ENDIF        ENDIF
757        IF ( validRange ) THEN  C     IF ( validRange ) THEN
758  C      Header  C      Header
759  C      Data  C      Data
760         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
761          DO K=pltMin,pltMax,pltStr          DO K=pltMin,pltMax,pltStr
762           WRITE(plotBuf,'(A,I,I,I,I)') pltLab,           WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
763       &   pltBase-1+(bk-1)*pltStep+K       &   pltBase-1+(bk-1)*pltStep+K
764           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
765       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
# Line 556  C      Data Line 816  C      Data
816               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
817                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
818               ENDIF               ENDIF
819               IDX = NINT(               IF ( validRange .AND. val .NE. 0. ) THEN
820                  IDX = NINT(
821       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)
822       &             )+1       &             )+1
823                 ELSE
824                  IDX = 1
825                 ENDIF
826               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
827       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
828               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
# Line 574  C      Data Line 838  C      Data
838           ENDDO           ENDDO
839          ENDDO          ENDDO
840         ENDDO         ENDDO
841        ENDIF  C     ENDIF
842  C--   Write delimiter  C--   Write delimiter
843        msgBuf = '// ======================================================='        msgBuf =
844         & '// ======================================================='
845        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
846       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
847        msgBuf = '// END OF FIELD                                          ='        msgBuf =
848         & '// END OF FIELD                                          ='
849        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
850       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
851        msgBuf = '// ======================================================='        msgBuf =
852         & '// ======================================================='
853        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
854       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
855        msgBuf = ' '        msgBuf = ' '
# Line 593  C--   Write delimiter Line 860  C--   Write delimiter
860        END        END
861    
862  CStartOfInterface  CStartOfInterface
863        SUBROUTINE PRINT_MAPR8 ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
864       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
865       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
866       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
# Line 601  CStartOfInterface Line 868  CStartOfInterface
868       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
869       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
870  C     /==========================================================\  C     /==========================================================\
871  C     | SUBROUTINE PRINT_MAPR8                                   |  C     | SUBROUTINE PRINT_MAPRL                                   |
872  C     | o Does textual mapping printing of a field.              |  C     | o Does textual mapping printing of a field.              |
873  C     |==========================================================|  C     |==========================================================|
874  C     | This routine does the actual formatting of the data      |  C     | This routine does the actual formatting of the data      |
# Line 621  C     |      plots - one for K=1, one fo Line 888  C     |      plots - one for K=1, one fo
888  C     |      Each plot would have extents iMin:iMax step iStr    |  C     |      Each plot would have extents iMin:iMax step iStr    |
889  C     |      and jMin:jMax step jStr.                            |  C     |      and jMin:jMax step jStr.                            |
890  C     \==========================================================/  C     \==========================================================/
891          IMPLICIT NONE
892    
893  C     == Global variables ==  C     == Global variables ==
894  #include "SIZE.h"  #include "SIZE.h"
# Line 648  C     kStr Line 916  C     kStr
916        INTEGER jLo, jHi        INTEGER jLo, jHi
917        INTEGER kLo, kHi        INTEGER kLo, kHi
918        INTEGER nBx, nBy        INTEGER nBx, nBy
919        Real*8 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RL fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
920        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
921        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
922        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
# Line 690  C               Str  - stride within blo Line 958  C               Str  - stride within blo
958        INTEGER lChList        INTEGER lChList
959        PARAMETER ( lChList = 28 )        PARAMETER ( lChList = 28 )
960        CHARACTER*(lChList) chList        CHARACTER*(lChList) chList
961        REAL fMin        _RL  fMin
962        REAL fMax        _RL  fMax
963        REAL fRange        _RL  fRange
964        REAL val        _RL  val
965        REAL small        _RL  small
966        CHARACTER*2  accLab        CHARACTER*2  accLab
967        CHARACTER*7  dwnLab        CHARACTER*7  dwnLab
968        CHARACTER*3  pltLab        CHARACTER*3  pltLab
# Line 722  C--   Calculate field range Line 990  C--   Calculate field range
990          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
991           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
992            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
993  C          IF ( fld(I,J,K,bi,bj) .NE. 0. ) THEN             IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )
994         &     THEN
995              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
996       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
997              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
998       &       fMax = fld(I,J,K,bi,bj)       &       fMax = fld(I,J,K,bi,bj)
999  C          ENDIF             ENDIF
1000            ENDDO            ENDDO
1001           ENDDO           ENDDO
1002          ENDDO          ENDDO
# Line 739  C          ENDIF Line 1008  C          ENDIF
1008        ENDIF        ENDIF
1009    
1010  C--   Write field title and statistics  C--   Write field title and statistics
1011        msgBuf = '// ======================================================='        msgBuf =
1012         & '// ======================================================='
1013        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1014       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1015        iStrngLo = IFNBLNK(fldTitle)        iStrngLo = IFNBLNK(fldTitle)
# Line 759  C--   Write field title and statistics Line 1029  C--   Write field title and statistics
1029       & '// CMAX = ', fMax       & '// CMAX = ', fMax
1030        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1031       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1032        WRITE(msgBuf,'(A,1PE30.15)')        IF ( validRange ) THEN
1033           WRITE(msgBuf,'(A,1PE30.15)')
1034       & '// CINT = ', fRange/FLOAT(lChlist-1)       & '// CINT = ', fRange/FLOAT(lChlist-1)
1035          ELSE
1036           WRITE(msgBuf,'(A,1PE30.15)')
1037         & '// CINT = ', 0.
1038          ENDIF
1039        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1040       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1041        WRITE(msgBuf,'(A,1024A1)')        WRITE(msgBuf,'(A,1024A1)')
# Line 792  C--   Write field title and statistics Line 1067  C--   Write field title and statistics
1067       &  ':',kStr,')'       &  ':',kStr,')'
1068        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1069       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1070        msgBuf = '// ======================================================='        msgBuf =
1071         & '// ======================================================='
1072        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1073       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1074    
# Line 888  C      X across, Z down slice Line 1164  C      X across, Z down slice
1164         pltStep = sNy         pltStep = sNy
1165         pltLab  = 'J ='         pltLab  = 'J ='
1166        ENDIF        ENDIF
1167        IF ( validRange ) THEN  C     IF ( validRange ) THEN
1168  C      Header  C      Header
1169  C      Data  C      Data
1170         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
1171          DO K=pltMin,pltMax,pltStr          DO K=pltMin,pltMax,pltStr
1172           WRITE(plotBuf,'(A,I,I,I,I)') pltLab,           WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
1173       &   pltBase-1+(bk-1)*pltStep+K       &   pltBase-1+(bk-1)*pltStep+K
1174           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1175       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
# Line 948  C      Data Line 1224  C      Data
1224               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
1225                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
1226               ENDIF               ENDIF
1227               IDX = NINT(               IF ( validRange .AND. val .NE. 0. ) THEN
1228       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)                IDX = NINT(
1229       &             )+1       &               FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1230         &              )+1
1231                 ELSE
1232                  IDX = 1
1233                 ENDIF
1234               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1235       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1236               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
# Line 965  C      Data Line 1245  C      Data
1245           ENDDO           ENDDO
1246          ENDDO          ENDDO
1247         ENDDO         ENDDO
1248        ENDIF  C     ENDIF
1249  C--   Write delimiter  C--   Write delimiter
1250        msgBuf = '// ======================================================='        msgBuf =
1251         & '// ======================================================='
1252        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1253       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1254        msgBuf = '// END OF FIELD                                          ='        msgBuf =
1255         & '// END OF FIELD                                          ='
1256        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1257       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1258        msgBuf = '// ======================================================='        msgBuf =
1259         & '// ======================================================='
1260        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1261       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1262        msgBuf = ' '        msgBuf = ' '
# Line 990  C     | SUBROUTINE PRINT_MESSAGE Line 1273  C     | SUBROUTINE PRINT_MESSAGE
1273  C     | o Write out informational message using "standard" format. |  C     | o Write out informational message using "standard" format. |
1274  C     | Notes                                                      |  C     | Notes                                                      |
1275  C     | =====                                                      |  C     | =====                                                      |
1276  C     | o Some system's I/O is not "thread-safe". For this reason  |  C     | o Some system   I/O is not "thread-safe". For this reason  |
1277  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |
1278  C     |   critical region is defined around the write here. In some|  C     |   critical region is defined around the write here. In some|
1279  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |
# Line 999  C     |   ignored! Line 1282  C     |   ignored!
1282  C     | o In a non-parallel form these routines can still be used. |  C     | o In a non-parallel form these routines can still be used. |
1283  C     |   to produce pretty printed output!                        |  C     |   to produce pretty printed output!                        |
1284  C     \============================================================/  C     \============================================================/
1285          IMPLICIT NONE
1286  C     == Global data ==  C     == Global data ==
1287  #include "SIZE.h"  #include "SIZE.h"
1288  #include "EEPARAMS.h"  #include "EEPARAMS.h"
# Line 1057  C       The write statement may need to Line 1341  C       The write statement may need to
1341  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1342          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1343  #endif  #endif
1344           WRITE(unit,'(A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A)',ERR=999)
1345       &   '(',PROCESS_HEADER,' ',idString,')',' '       &   '(',PROCESS_HEADER,' ',idString,')',' '
1346  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1347          _END_CRIT(myThid)          _END_CRIT(myThid)
# Line 1066  C       The write statement may need to Line 1350  C       The write statement may need to
1350  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1351          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1352  #endif  #endif
1353           WRITE(unit,'(A,A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)
1354       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',
1355       &   message(iStart:iEnd)       &   message(iStart:iEnd)
1356  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 1075  C       The write statement may need to Line 1359  C       The write statement may need to
1359         ENDIF         ENDIF
1360        ENDIF        ENDIF
1361  C  C
1362     1000 CONTINUE
1363        RETURN        RETURN
1364      999 CONTINUE
1365           ioErrorCount(myThid) = ioErrorCount(myThid)+1
1366          GOTO 1000
1367    
1368        END        END
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22