/[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.5 by cnh, Mon Apr 27 04:24:22 1998 UTC revision 1.14 by adcroft, Mon May 24 15:15:11 1999 UTC
# Line 25  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 34  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 60  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 77  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 87  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 96  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_I( fld, lFld, index_type, ioUnit )        SUBROUTINE PRINT_LIST_I( fld, lFld, index_type,
111         &                         markEnd, compact, ioUnit )
112  C     /==========================================================\  C     /==========================================================\
113  C     | o SUBROUTINE PRINT_LIST_I                                |  C     | o SUBROUTINE PRINT_LIST_I                                |
114  C     |==========================================================|  C     |==========================================================|
# Line 109  C     | duplicate values collected into Line 117  C     | duplicate values collected into
117  C     |    n @ value                                             |  C     |    n @ value                                             |
118  C     | record.                                                  |  C     | record.                                                  |
119  C     \==========================================================/  C     \==========================================================/
120          IMPLICIT NONE
121    
122  C     == Global data ==    C     == Global data ==  
123  #include "SIZE.h"  #include "SIZE.h"
# Line 122  C                  INDEX_K    => /* K = Line 131  C                  INDEX_K    => /* K =
131  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
132  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
133  C                  INDEX_NONE =>  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.  C     ioUnit -  Unit number for IO.
139        INTEGER lFld        INTEGER lFld
140        INTEGER index_type        INTEGER index_type
141        INTEGER fld(lFld)        INTEGER fld(lFld)
142          LOGICAL markEnd
143          LOGICAL compact
144        INTEGER ioUnit        INTEGER ioUnit
145  CEndifinterface  CEndifinterface
146    
# Line 143  C     K    - Loop counter Line 158  C     K    - Loop counter
158        INTEGER nDup        INTEGER nDup
159        INTEGER xNew, xOld        INTEGER xNew, xOld
160        CHARACTER punc        CHARACTER punc
161        CHARACTER(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
162        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
163        CHARACTER*3 index_lab        CHARACTER*3 index_lab
164        INTEGER K        INTEGER K
# Line 165  C     K    - Loop counter Line 180  C     K    - Loop counter
180        xOld = fld(1)        xOld = fld(1)
181        DO K=2,lFld        DO K=2,lFld
182         xNew = fld(K  )         xNew = fld(K  )
183         IF ( xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
184          nDup = iHi-iLo+1          nDup = iHi-iLo+1
185          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
186           WRITE(msgBuf,'(A,I5,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
187           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
188       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
189         &    commOpen,index_lab,iLo,commClose
190          ELSE          ELSE
191           WRITE(msgBuf,'(I,'' '',A,I5,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I,'' '',A,I9,A)') nDup,'@',xOld,punc
192           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
193       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
194       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
195          ENDIF          ENDIF
196          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
197          iLo  = K          iLo  = K
198          iHi  = K          iHi  = K
199          xOld = xNew          xOld = xNew
# Line 186  C     K    - Loop counter Line 202  C     K    - Loop counter
202         ENDIF         ENDIF
203        ENDDO        ENDDO
204        punc = ' '        punc = ' '
205          IF ( markEnd ) punc = ','
206        nDup = iHi-iLo+1        nDup = iHi-iLo+1
207        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
208         WRITE(msgBuf,'(A,I5,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
209         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
210       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
211         &  commOpen,index_lab,iLo,commClose
212        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
213         WRITE(msgBuf,'(I,'' '',A,I5,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I,'' '',A,I9,A)') nDup,'@',xOld,punc
214         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
215       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
216       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
217        ENDIF        ENDIF
218        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
219    
220        RETURN        RETURN
221        END        END
222    
223  CStartofinterface  CStartofinterface
224        SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, ioUnit )        SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd,
225         &                         compact, ioUnit )
226  C     /==========================================================\  C     /==========================================================\
227  C     | o SUBROUTINE PRINT_LIST_L                                |  C     | o SUBROUTINE PRINT_LIST_L                                |
228  C     |==========================================================|  C     |==========================================================|
# Line 212  C     | duplicate values collected into Line 231  C     | duplicate values collected into
231  C     |    n @ value                                             |  C     |    n @ value                                             |
232  C     | record.                                                  |  C     | record.                                                  |
233  C     \==========================================================/  C     \==========================================================/
234          IMPLICIT NONE
235    
236  C     == Global data ==    C     == Global data ==  
237  #include "SIZE.h"  #include "SIZE.h"
# Line 225  C                  INDEX_K    => /* K = Line 245  C                  INDEX_K    => /* K =
245  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
246  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
247  C                  INDEX_NONE =>  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.  C     ioUnit -  Unit number for IO.
253        INTEGER lFld        INTEGER lFld
254        INTEGER index_type        INTEGER index_type
255        LOGICAL fld(lFld)        LOGICAL fld(lFld)
256          LOGICAL markEnd
257          LOGICAL compact
258        INTEGER ioUnit        INTEGER ioUnit
259  CEndifinterface  CEndifinterface
260    
# Line 246  C     K    - Loop counter Line 272  C     K    - Loop counter
272        INTEGER nDup        INTEGER nDup
273        LOGICAL xNew, xOld        LOGICAL xNew, xOld
274        CHARACTER punc        CHARACTER punc
275        CHARACTER(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
276        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
277        CHARACTER*3 index_lab        CHARACTER*3 index_lab
278        INTEGER K        INTEGER K
# Line 268  C     K    - Loop counter Line 294  C     K    - Loop counter
294        xOld = fld(1)        xOld = fld(1)
295        DO K=2,lFld        DO K=2,lFld
296         xNew = fld(K  )         xNew = fld(K  )
297         IF ( xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. xNew .NEQV. xOld ) THEN
298          nDup = iHi-iLo+1          nDup = iHi-iLo+1
299          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
300           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
301           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
302       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
303         &    commOpen,index_lab,iLo,commClose
304          ELSE          ELSE
305           WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc           WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
306           IF ( index_type .NE. INDEX_NONE )           IF ( index_type .NE. INDEX_NONE )
307       &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')       &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')
308       &    commOpen,index_lab,iLo,':',iHi,commClose       &    commOpen,index_lab,iLo,':',iHi,commClose
309          ENDIF          ENDIF
310          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
311          iLo  = K          iLo  = K
312          iHi  = K          iHi  = K
313          xOld = xNew          xOld = xNew
# Line 289  C     K    - Loop counter Line 316  C     K    - Loop counter
316         ENDIF         ENDIF
317        ENDDO        ENDDO
318        punc = ' '        punc = ' '
319          IF ( markEnd ) punc = ','
320        nDup = iHi-iLo+1        nDup = iHi-iLo+1
321        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
322         WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
323         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
324       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose       &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)')
325         &    commOpen,index_lab,iLo,commClose
326        ELSEIF( nDup .GT. 1 ) THEN        ELSEIF( nDup .GT. 1 ) THEN
327         WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc         WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
328         IF ( index_type .NE. INDEX_NONE )         IF ( index_type .NE. INDEX_NONE )
329       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')       &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
330       &  commOpen,index_lab,iLo,':',iHi,commClose       &  commOpen,index_lab,iLo,':',iHi,commClose
331        ENDIF        ENDIF
332        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
333    
334        RETURN        RETURN
335        END        END
336    
337  CStartofinterface  CStartofinterface
338        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, ioUnit )        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 315  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 328  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  CEndifinterface
374    
# Line 349  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 371  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 392  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 437  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 464  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 506  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 527  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 538  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 555  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 575  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 608  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 704  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 766  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 784  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 803  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 811  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 831  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 858  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 900  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 932  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 949  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 969  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 1002  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 1098  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 1158  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 1175  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 1200  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 1209  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 1267  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 1276  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 1285  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.5  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22