/[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.12 by cnh, Wed Oct 28 03:11:35 1998 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 56  C--    Write single process format Line 60  C--    Write single process format
60         IF ( message .EQ. ' ' ) THEN         IF ( message .EQ. ' ' ) THEN
61          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' '
62         ELSE         ELSE
63          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, message(iStart:iEnd)          WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER,
64         &   message(iStart:iEnd)
65         ENDIF         ENDIF
66        ELSEIF ( pidIO .EQ. myProcId ) THEN        ELSEIF ( pidIO .EQ. myProcId ) THEN
67  C--    Write multi-process format  C--    Write multi-process format
# Line 73  C       The write statement may need to Line 78  C       The write statement may need to
78  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
79          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
80  #endif  #endif
81          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
82       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
83       &  ' '       &  ' '
84  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 83  C       The write statement may need to Line 88  C       The write statement may need to
88  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
89          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
90  #endif  #endif
91          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
92       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
93       &  message(iStart:iEnd)       &  message(iStart:iEnd)
94  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 92  C       The write statement may need to Line 97  C       The write statement may need to
97         ENDIF         ENDIF
98        ENDIF        ENDIF
99  C  C
100     1000 CONTINUE
101        RETURN        RETURN
102    
103      999 CONTINUE
104           ioErrorCount(myThid) = ioErrorCount(myThid)+1
105          GOTO 1000
106        END        END
107    
108  CStartofinterface  CStartofinterface
109        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, ioUnit )        SUBROUTINE PRINT_LIST_I( fld, lFld, index_type,
110         &                         markEnd, compact, ioUnit )
111    C     /==========================================================\
112    C     | o SUBROUTINE PRINT_LIST_I                                |
113    C     |==========================================================|
114    C     | Routine for producing list of values for a field with    |
115    C     | duplicate values collected into                          |
116    C     |    n @ value                                             |
117    C     | record.                                                  |
118    C     \==========================================================/
119    
120    C     == Global data ==  
121    #include "SIZE.h"
122    #include "EEPARAMS.h"
123    
124    C     == Routine arguments ==
125    C     fld    -  Data to be printed
126    C     lFld   -  Number of elements to be printed
127    C     index_type - Flag indicating which type of index to print
128    C                  INDEX_K    => /* K = nnn */
129    C                  INDEX_I    => /* I = nnn */
130    C                  INDEX_J    => /* J = nnn */
131    C                  INDEX_NONE =>
132    C     compact -  Flag to control use of repeat symbol for same valued
133    C                fields.
134    C     markEnd -  Flag to control whether there is a separator after the
135    C                last element
136    C     ioUnit -  Unit number for IO.
137          INTEGER lFld
138          INTEGER index_type
139          INTEGER fld(lFld)
140          LOGICAL markEnd
141          LOGICAL compact
142          INTEGER ioUnit
143    CEndifinterface
144    
145    C     == Local variables ==
146    C     iLo  - Range index holders for selecting elements with
147    C     iHi    with the same value
148    C     nDup - Number of duplicates
149    C     xNew, xOld - Hold current and previous values of field
150    C     punc - Field separator
151    C     msgBuf - IO buffer
152    C     index_lab - Index for labelling elements
153    C     K    - Loop counter
154          INTEGER iLo
155          INTEGER iHi
156          INTEGER nDup
157          INTEGER xNew, xOld
158          CHARACTER punc
159          CHARACTER*(MAX_LEN_MBUF) msgBuf
160          CHARACTER*2 commOpen,commClose
161          CHARACTER*3 index_lab
162          INTEGER K
163    
164          IF     ( index_type .EQ. INDEX_I ) THEN
165           index_lab = 'I ='
166          ELSEIF ( index_type .EQ. INDEX_J ) THEN
167           index_lab = 'J ='
168          ELSEIF ( index_type .EQ. INDEX_K ) THEN
169           index_lab = 'K ='
170          ELSE
171           index_lab = '?='
172          ENDIF
173          commOpen  = '/*'
174          commClose = '*/'
175          iLo = 1
176          iHi = 1
177          punc = ','
178          xOld = fld(1)
179          DO K=2,lFld
180           xNew = fld(K  )
181           IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
182            nDup = iHi-iLo+1
183            IF ( nDup .EQ. 1 ) THEN
184             WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
185             IF ( index_type .NE. INDEX_NONE )
186         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
187         &    commOpen,index_lab,iLo,commClose
188            ELSE
189             WRITE(msgBuf,'(I,'' '',A,I9,A)') nDup,'@',xOld,punc
190             IF ( index_type .NE. INDEX_NONE )
191         &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
192         &    commOpen,index_lab,iLo,':',iHi,commClose
193            ENDIF
194            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
195            iLo  = K
196            iHi  = K
197            xOld = xNew
198           ELSE
199            iHi = K
200           ENDIF
201          ENDDO
202          punc = ' '
203          IF ( markEnd ) punc = ','
204          nDup = iHi-iLo+1
205          IF    ( nDup .EQ. 1 ) THEN
206           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
207           IF ( index_type .NE. INDEX_NONE )
208         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
209         &  commOpen,index_lab,iLo,commClose
210          ELSEIF( nDup .GT. 1 ) THEN
211           WRITE(msgBuf,'(I,'' '',A,I9,A)') nDup,'@',xOld,punc
212           IF ( index_type .NE. INDEX_NONE )
213         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
214         &  commOpen,index_lab,iLo,':',iHi,commClose
215          ENDIF
216          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
217    
218          RETURN
219          END
220    
221    CStartofinterface
222          SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd,
223         &                         compact, ioUnit )
224    C     /==========================================================\
225    C     | o SUBROUTINE PRINT_LIST_L                                |
226    C     |==========================================================|
227    C     | Routine for producing list of values for a field with    |
228    C     | duplicate values collected into                          |
229    C     |    n @ value                                             |
230    C     | record.                                                  |
231    C     \==========================================================/
232    
233    C     == Global data ==  
234    #include "SIZE.h"
235    #include "EEPARAMS.h"
236    
237    C     == Routine arguments ==
238    C     fld    -  Data to be printed
239    C     lFld   -  Number of elements to be printed
240    C     index_type - Flag indicating which type of index to print
241    C                  INDEX_K    => /* K = nnn */
242    C                  INDEX_I    => /* I = nnn */
243    C                  INDEX_J    => /* J = nnn */
244    C                  INDEX_NONE =>
245    C     compact -  Flag to control use of repeat symbol for same valued
246    C                fields.
247    C     markEnd -  Flag to control whether there is a separator after the
248    C                last element
249    C     ioUnit -  Unit number for IO.
250          INTEGER lFld
251          INTEGER index_type
252          LOGICAL fld(lFld)
253          LOGICAL markEnd
254          LOGICAL compact
255          INTEGER ioUnit
256  CEndifinterface  CEndifinterface
257    
258    C     == Local variables ==
259    C     iLo  - Range index holders for selecting elements with
260    C     iHi    with the same value
261    C     nDup - Number of duplicates
262    C     xNew, xOld - Hold current and previous values of field
263    C     punc - Field separator
264    C     msgBuf - IO buffer
265    C     index_lab - Index for labelling elements
266    C     K    - Loop counter
267          INTEGER iLo
268          INTEGER iHi
269          INTEGER nDup
270          LOGICAL xNew, xOld
271          CHARACTER punc
272          CHARACTER*(MAX_LEN_MBUF) msgBuf
273          CHARACTER*2 commOpen,commClose
274          CHARACTER*3 index_lab
275          INTEGER K
276    
277          IF     ( index_type .EQ. INDEX_I ) THEN
278           index_lab = 'I ='
279          ELSEIF ( index_type .EQ. INDEX_J ) THEN
280           index_lab = 'J ='
281          ELSEIF ( index_type .EQ. INDEX_K ) THEN
282           index_lab = 'K ='
283          ELSE
284           index_lab = '?='
285          ENDIF
286          commOpen  = '/*'
287          commClose = '*/'
288          iLo = 1
289          iHi = 1
290          punc = ','
291          xOld = fld(1)
292          DO K=2,lFld
293           xNew = fld(K  )
294           IF ( .NOT. compact .OR. xNew .NEQV. xOld ) THEN
295            nDup = iHi-iLo+1
296            IF ( nDup .EQ. 1 ) THEN
297             WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
298             IF ( index_type .NE. INDEX_NONE )
299         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
300         &    commOpen,index_lab,iLo,commClose
301            ELSE
302             WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
303             IF ( index_type .NE. INDEX_NONE )
304         &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')
305         &    commOpen,index_lab,iLo,':',iHi,commClose
306            ENDIF
307            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
308            iLo  = K
309            iHi  = K
310            xOld = xNew
311           ELSE
312            iHi = K
313           ENDIF
314          ENDDO
315          punc = ' '
316          IF ( markEnd ) punc = ','
317          nDup = iHi-iLo+1
318          IF    ( nDup .EQ. 1 ) THEN
319           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
320           IF ( index_type .NE. INDEX_NONE )
321         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
322         &    commOpen,index_lab,iLo,commClose
323          ELSEIF( nDup .GT. 1 ) THEN
324           WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
325           IF ( index_type .NE. INDEX_NONE )
326         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
327         &  commOpen,index_lab,iLo,':',iHi,commClose
328          ENDIF
329          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
330    
331          RETURN
332          END
333    
334    CStartofinterface
335          SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type,
336         &    markEnd, compact, ioUnit )
337  C     /==========================================================\  C     /==========================================================\
338  C     | o SUBROUTINE PRINT_LIST_R8                               |  C     | o SUBROUTINE PRINT_LIST_R8                               |
339  C     |==========================================================|  C     |==========================================================|
# Line 119  C                  INDEX_K    => /* K = Line 355  C                  INDEX_K    => /* K =
355  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
356  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
357  C                  INDEX_NONE =>  C                  INDEX_NONE =>
358    C     compact -  Flag to control use of repeat symbol for same valued
359    C                fields.
360    C     markEnd -  Flag to control whether there is a separator after the
361    C                last element
362  C     ioUnit -  Unit number for IO.  C     ioUnit -  Unit number for IO.
363        INTEGER lFld        INTEGER lFld
364        INTEGER index_type        INTEGER index_type
365        Real*8  fld(lFld)        Real*8  fld(lFld)
366          LOGICAL markEnd
367          LOGICAL compact
368        INTEGER ioUnit        INTEGER ioUnit
369    CEndifinterface
370    
371  C     == Local variables ==  C     == Local variables ==
372  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 382  C     K    - Loop counter
382        INTEGER nDup        INTEGER nDup
383        Real*8 xNew, xOld        Real*8 xNew, xOld
384        CHARACTER punc        CHARACTER punc
385        CHARACTER(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
386        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
387        CHARACTER*3 index_lab        CHARACTER*3 index_lab
388        INTEGER K        INTEGER K
# Line 161  C     K    - Loop counter Line 404  C     K    - Loop counter
404        xOld = fld(1)        xOld = fld(1)
405        DO K=2,lFld        DO K=2,lFld
406         xNew = fld(K  )         xNew = fld(K  )
407         IF ( xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
408          nDup = iHi-iLo+1          nDup = iHi-iLo+1
409          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
410           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
411           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
412       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
413         &    commOpen,index_lab,iLo,commClose
414          ELSE          ELSE
415           WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
416           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
417       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
418       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
419          ENDIF          ENDIF
420          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
421         &    SQUEEZE_RIGHT , 1)
422          iLo  = K          iLo  = K
423          iHi  = K          iHi  = K
424          xOld = xNew          xOld = xNew
# Line 182  C     K    - Loop counter Line 427  C     K    - Loop counter
427         ENDIF         ENDIF
428        ENDDO        ENDDO
429        punc = ' '        punc = ' '
430          IF ( markEnd ) punc = ','
431        nDup = iHi-iLo+1        nDup = iHi-iLo+1
432        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
433         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
434         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
435       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
436         &    commOpen,index_lab,iLo,commClose
437        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
438         WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
439         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
440       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
441       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
442        ENDIF        ENDIF
443        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
444         &    SQUEEZE_RIGHT , 1)
445    
446        RETURN        RETURN
447        END        END
448    
449  CStartOfInterface  CStartOfInterface
450        SUBROUTINE PRINT_MAPR4 ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,
451       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
452       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
453       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
# Line 254  C     kStr Line 502  C     kStr
502        INTEGER jLo, jHi        INTEGER jLo, jHi
503        INTEGER kLo, kHi        INTEGER kLo, kHi
504        INTEGER nBx, nBy        INTEGER nBx, nBy
505        Real*4 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RS fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
506        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
507        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
508        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
# Line 328  C--   Calculate field range Line 576  C--   Calculate field range
576          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
577           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
578            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
579             IF ( fld(I,J,K,bi,bj) .NE. 0. ) THEN             IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN
580              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
581       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
582              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 593  C--   Calculate field range
593        ENDIF        ENDIF
594    
595  C--   Write field title and statistics  C--   Write field title and statistics
596        msgBuf = '// ======================================================='        msgBuf =
597         & '// ======================================================='
598        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
599       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
600        iStrngLo = IFNBLNK(fldTitle)        iStrngLo = IFNBLNK(fldTitle)
# Line 365  C--   Write field title and statistics Line 614  C--   Write field title and statistics
614       & '// CMAX = ', fMax       & '// CMAX = ', fMax
615        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
616       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
617        WRITE(msgBuf,'(A,1PE30.15)')        IF ( validRange ) THEN
618       & '// CINT = ', fRange/FLOAT(lChlist-1)         WRITE(msgBuf,'(A,1PE30.15)')
619         &  '// CINT = ', fRange/FLOAT(lChlist-1)
620          ELSE
621           WRITE(msgBuf,'(A,1PE30.15)')
622         &  '// CINT = ', 0.
623          ENDIF
624        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
625       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
626        WRITE(msgBuf,'(A,1024A1)')        WRITE(msgBuf,'(A,1024A1)')
# Line 398  C--   Write field title and statistics Line 652  C--   Write field title and statistics
652       &  ':',kStr,')'       &  ':',kStr,')'
653        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
654       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
655        msgBuf = '// ======================================================='        msgBuf =
656         & '// ======================================================='
657        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
658       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
659    
# Line 494  C      X across, Z down slice Line 749  C      X across, Z down slice
749         pltStep = sNy         pltStep = sNy
750         pltLab  = 'J ='         pltLab  = 'J ='
751        ENDIF        ENDIF
752        IF ( validRange ) THEN  C     IF ( validRange ) THEN
753  C      Header  C      Header
754  C      Data  C      Data
755         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
756          DO K=pltMin,pltMax,pltStr          DO K=pltMin,pltMax,pltStr
757           WRITE(plotBuf,'(A,I,I,I,I)') pltLab,           WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
758       &   pltBase-1+(bk-1)*pltStep+K       &   pltBase-1+(bk-1)*pltStep+K
759           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
760       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
# Line 556  C      Data Line 811  C      Data
811               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
812                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
813               ENDIF               ENDIF
814               IDX = NINT(               IF ( validRange ) THEN
815                  IDX = NINT(
816       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)
817       &             )+1       &             )+1
818                 ELSE
819                  IDX = 1
820                 ENDIF
821               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
822       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
823               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
# Line 574  C      Data Line 833  C      Data
833           ENDDO           ENDDO
834          ENDDO          ENDDO
835         ENDDO         ENDDO
836        ENDIF  C     ENDIF
837  C--   Write delimiter  C--   Write delimiter
838        msgBuf = '// ======================================================='        msgBuf =
839         & '// ======================================================='
840        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
841       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
842        msgBuf = '// END OF FIELD                                          ='        msgBuf =
843         & '// END OF FIELD                                          ='
844        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
845       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
846        msgBuf = '// ======================================================='        msgBuf =
847         & '// ======================================================='
848        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
849       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
850        msgBuf = ' '        msgBuf = ' '
# Line 593  C--   Write delimiter Line 855  C--   Write delimiter
855        END        END
856    
857  CStartOfInterface  CStartOfInterface
858        SUBROUTINE PRINT_MAPR8 ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
859       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
860       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
861       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
# Line 601  CStartOfInterface Line 863  CStartOfInterface
863       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
864       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
865  C     /==========================================================\  C     /==========================================================\
866  C     | SUBROUTINE PRINT_MAPR8                                   |  C     | SUBROUTINE PRINT_MAPRL                                   |
867  C     | o Does textual mapping printing of a field.              |  C     | o Does textual mapping printing of a field.              |
868  C     |==========================================================|  C     |==========================================================|
869  C     | This routine does the actual formatting of the data      |  C     | This routine does the actual formatting of the data      |
# Line 648  C     kStr Line 910  C     kStr
910        INTEGER jLo, jHi        INTEGER jLo, jHi
911        INTEGER kLo, kHi        INTEGER kLo, kHi
912        INTEGER nBx, nBy        INTEGER nBx, nBy
913        Real*8 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RL fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
914        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
915        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
916        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
# Line 722  C--   Calculate field range Line 984  C--   Calculate field range
984          DO K=kMin, kMax, kStr          DO K=kMin, kMax, kStr
985           DO J=jMin, jMax, jStr           DO J=jMin, jMax, jStr
986            DO I=iMin, iMax, iStr            DO I=iMin, iMax, iStr
987  C          IF ( fld(I,J,K,bi,bj) .NE. 0. ) THEN             IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. )
988         &     THEN
989              IF ( fld(I,J,K,bi,bj) .LT. fMin )              IF ( fld(I,J,K,bi,bj) .LT. fMin )
990       &       fMin = fld(I,J,K,bi,bj)       &       fMin = fld(I,J,K,bi,bj)
991              IF ( fld(I,J,K,bi,bj) .GT. fMax )              IF ( fld(I,J,K,bi,bj) .GT. fMax )
992       &       fMax = fld(I,J,K,bi,bj)       &       fMax = fld(I,J,K,bi,bj)
993  C          ENDIF             ENDIF
994            ENDDO            ENDDO
995           ENDDO           ENDDO
996          ENDDO          ENDDO
# Line 739  C          ENDIF Line 1002  C          ENDIF
1002        ENDIF        ENDIF
1003    
1004  C--   Write field title and statistics  C--   Write field title and statistics
1005        msgBuf = '// ======================================================='        msgBuf =
1006         & '// ======================================================='
1007        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1008       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1009        iStrngLo = IFNBLNK(fldTitle)        iStrngLo = IFNBLNK(fldTitle)
# Line 759  C--   Write field title and statistics Line 1023  C--   Write field title and statistics
1023       & '// CMAX = ', fMax       & '// CMAX = ', fMax
1024        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1025       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1026        WRITE(msgBuf,'(A,1PE30.15)')        IF ( validRange ) THEN
1027           WRITE(msgBuf,'(A,1PE30.15)')
1028       & '// CINT = ', fRange/FLOAT(lChlist-1)       & '// CINT = ', fRange/FLOAT(lChlist-1)
1029          ELSE
1030           WRITE(msgBuf,'(A,1PE30.15)')
1031         & '// CINT = ', 0.
1032          ENDIF
1033        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1034       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1035        WRITE(msgBuf,'(A,1024A1)')        WRITE(msgBuf,'(A,1024A1)')
# Line 792  C--   Write field title and statistics Line 1061  C--   Write field title and statistics
1061       &  ':',kStr,')'       &  ':',kStr,')'
1062        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1063       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1064        msgBuf = '// ======================================================='        msgBuf =
1065         & '// ======================================================='
1066        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1067       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1068    
# Line 888  C      X across, Z down slice Line 1158  C      X across, Z down slice
1158         pltStep = sNy         pltStep = sNy
1159         pltLab  = 'J ='         pltLab  = 'J ='
1160        ENDIF        ENDIF
1161        IF ( validRange ) THEN  C     IF ( validRange ) THEN
1162  C      Header  C      Header
1163  C      Data  C      Data
1164         DO bk=pltBlo, pltBhi, pltBstr         DO bk=pltBlo, pltBhi, pltBstr
1165          DO K=pltMin,pltMax,pltStr          DO K=pltMin,pltMax,pltStr
1166           WRITE(plotBuf,'(A,I,I,I,I)') pltLab,           WRITE(plotBuf,'(A,I4,I4,I4,I4)') pltLab,
1167       &   pltBase-1+(bk-1)*pltStep+K       &   pltBase-1+(bk-1)*pltStep+K
1168           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,           CALL PRINT_MESSAGE(plotBuf, standardMessageUnit,
1169       &                      SQUEEZE_RIGHT, 1)       &                      SQUEEZE_RIGHT, 1)
# Line 948  C      Data Line 1218  C      Data
1218               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN               ELSEIF ( plotMode .EQ. PRINT_MAP_YZ ) THEN
1219                val = fld(K,I,J,bk,bi)                val = fld(K,I,J,bk,bi)
1220               ENDIF               ENDIF
1221               IDX = NINT(               IF ( validRange ) THEN
1222       &              FLOAT( lChList-1 )*( val-fMin ) / (fRange)                IDX = NINT(
1223       &             )+1       &               FLOAT( lChList-1 )*( val-fMin ) / (fRange)
1224         &              )+1
1225                 ELSE
1226                  IDX = 1
1227                 ENDIF
1228               IF ( iBuf .LE. MAX_LEN_PLOTBUF )               IF ( iBuf .LE. MAX_LEN_PLOTBUF )
1229       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)       &        plotBuf(iBuf:iBuf) = chList(IDX:IDX)
1230               IF ( val .EQ. 0. ) THEN               IF ( val .EQ. 0. ) THEN
# Line 965  C      Data Line 1239  C      Data
1239           ENDDO           ENDDO
1240          ENDDO          ENDDO
1241         ENDDO         ENDDO
1242        ENDIF  C     ENDIF
1243  C--   Write delimiter  C--   Write delimiter
1244        msgBuf = '// ======================================================='        msgBuf =
1245         & '// ======================================================='
1246        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1247       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1248        msgBuf = '// END OF FIELD                                          ='        msgBuf =
1249         & '// END OF FIELD                                          ='
1250        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1251       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1252        msgBuf = '// ======================================================='        msgBuf =
1253         & '// ======================================================='
1254        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,        CALL PRINT_MESSAGE(msgBuf, standardMessageUnit,
1255       &                   SQUEEZE_RIGHT, 1)       &                   SQUEEZE_RIGHT, 1)
1256        msgBuf = ' '        msgBuf = ' '
# Line 990  C     | SUBROUTINE PRINT_MESSAGE Line 1267  C     | SUBROUTINE PRINT_MESSAGE
1267  C     | o Write out informational message using "standard" format. |  C     | o Write out informational message using "standard" format. |
1268  C     | Notes                                                      |  C     | Notes                                                      |
1269  C     | =====                                                      |  C     | =====                                                      |
1270  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  |
1271  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |  C     |   without the FMTFTN_IO_THREAD_SAFE directive set a        |
1272  C     |   critical region is defined around the write here. In some|  C     |   critical region is defined around the write here. In some|
1273  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |  C     |   cases  BEGIN_CRIT() is approximated by only doing writes |
# Line 1057  C       The write statement may need to Line 1334  C       The write statement may need to
1334  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1335          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1336  #endif  #endif
1337           WRITE(unit,'(A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A)',ERR=999)
1338       &   '(',PROCESS_HEADER,' ',idString,')',' '       &   '(',PROCESS_HEADER,' ',idString,')',' '
1339  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1340          _END_CRIT(myThid)          _END_CRIT(myThid)
# Line 1066  C       The write statement may need to Line 1343  C       The write statement may need to
1343  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1344          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1345  #endif  #endif
1346           WRITE(unit,'(A,A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)
1347       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',
1348       &   message(iStart:iEnd)       &   message(iStart:iEnd)
1349  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 1075  C       The write statement may need to Line 1352  C       The write statement may need to
1352         ENDIF         ENDIF
1353        ENDIF        ENDIF
1354  C  C
1355     1000 CONTINUE
1356        RETURN        RETURN
1357      999 CONTINUE
1358           ioErrorCount(myThid) = ioErrorCount(myThid)+1
1359          GOTO 1000
1360    
1361        END        END
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.12
  ViewVC Help
Powered by ViewVC 1.1.22