/[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.2 by cnh, Thu Apr 23 20:37:31 1998 UTC revision 1.10 by adcroft, Wed Jul 15 22:16:10 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
14    C--                     numbers.
15    C--    o print_mapr4    Formats ABCD... contour map of a Real*4 field
16    C--                     Uses print_message for writing
17  C--    o print_mapr8    Formats ABCD... contour map of a Real*8 field  C--    o print_mapr8    Formats ABCD... contour map of a Real*8 field
18  C--                     Uses print_message for writing  C--                     Uses print_message for writing
19  C--    o print_message  Does IO with unhighlighted header  C--    o print_message  Does IO with unhighlighted header
# Line 69  C       The write statement may need to Line 77  C       The write statement may need to
77  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
78          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
79  #endif  #endif
80          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
81       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
82       &  ' '       &  ' '
83  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 79  C       The write statement may need to Line 87  C       The write statement may need to
87  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
88          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
89  #endif  #endif
90          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)')          WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999)
91       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',       &  '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ',
92       &  message(iStart:iEnd)       &  message(iStart:iEnd)
93  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 88  C       The write statement may need to Line 96  C       The write statement may need to
96         ENDIF         ENDIF
97        ENDIF        ENDIF
98  C  C
99     1000 CONTINUE
100          RETURN
101    
102      999 CONTINUE
103           ioErrorCount(myThid) = ioErrorCount(myThid)+1
104          GOTO 1000
105          END
106    
107    CStartofinterface
108          SUBROUTINE PRINT_LIST_I( fld, lFld, index_type, markEnd, compact, ioUnit )
109    C     /==========================================================\
110    C     | o SUBROUTINE PRINT_LIST_I                                |
111    C     |==========================================================|
112    C     | Routine for producing list of values for a field with    |
113    C     | duplicate values collected into                          |
114    C     |    n @ value                                             |
115    C     | record.                                                  |
116    C     \==========================================================/
117    
118    C     == Global data ==  
119    #include "SIZE.h"
120    #include "EEPARAMS.h"
121    
122    C     == Routine arguments ==
123    C     fld    -  Data to be printed
124    C     lFld   -  Number of elements to be printed
125    C     index_type - Flag indicating which type of index to print
126    C                  INDEX_K    => /* K = nnn */
127    C                  INDEX_I    => /* I = nnn */
128    C                  INDEX_J    => /* J = nnn */
129    C                  INDEX_NONE =>
130    C     compact -  Flag to control use of repeat symbol for same valued
131    C                fields.
132    C     markEnd -  Flag to control whether there is a separator after the
133    C                last element
134    C     ioUnit -  Unit number for IO.
135          INTEGER lFld
136          INTEGER index_type
137          INTEGER fld(lFld)
138          LOGICAL markEnd
139          LOGICAL compact
140          INTEGER ioUnit
141    CEndifinterface
142    
143    C     == Local variables ==
144    C     iLo  - Range index holders for selecting elements with
145    C     iHi    with the same value
146    C     nDup - Number of duplicates
147    C     xNew, xOld - Hold current and previous values of field
148    C     punc - Field separator
149    C     msgBuf - IO buffer
150    C     index_lab - Index for labelling elements
151    C     K    - Loop counter
152          INTEGER iLo
153          INTEGER iHi
154          INTEGER nDup
155          INTEGER xNew, xOld
156          CHARACTER punc
157          CHARACTER*(MAX_LEN_MBUF) msgBuf
158          CHARACTER*2 commOpen,commClose
159          CHARACTER*3 index_lab
160          INTEGER K
161    
162          IF     ( index_type .EQ. INDEX_I ) THEN
163           index_lab = 'I ='
164          ELSEIF ( index_type .EQ. INDEX_J ) THEN
165           index_lab = 'J ='
166          ELSEIF ( index_type .EQ. INDEX_K ) THEN
167           index_lab = 'K ='
168          ELSE
169           index_lab = '?='
170          ENDIF
171          commOpen  = '/*'
172          commClose = '*/'
173          iLo = 1
174          iHi = 1
175          punc = ','
176          xOld = fld(1)
177          DO K=2,lFld
178           xNew = fld(K  )
179           IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
180            nDup = iHi-iLo+1
181            IF ( nDup .EQ. 1 ) THEN
182             WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
183             IF ( index_type .NE. INDEX_NONE )
184         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
185            ELSE
186             WRITE(msgBuf,'(I,'' '',A,I9,A)') nDup,'@',xOld,punc
187             IF ( index_type .NE. INDEX_NONE )
188         &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
189         &    commOpen,index_lab,iLo,':',iHi,commClose
190            ENDIF
191            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
192            iLo  = K
193            iHi  = K
194            xOld = xNew
195           ELSE
196            iHi = K
197           ENDIF
198          ENDDO
199          punc = ' '
200          IF ( markEnd ) punc = ','
201          nDup = iHi-iLo+1
202          IF    ( nDup .EQ. 1 ) THEN
203           WRITE(msgBuf,'(A,I9,A)') '              ',xOld,punc
204           IF ( index_type .NE. INDEX_NONE )
205         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
206          ELSEIF( nDup .GT. 1 ) THEN
207           WRITE(msgBuf,'(I,'' '',A,I9,A)') nDup,'@',xOld,punc
208           IF ( index_type .NE. INDEX_NONE )
209         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
210         &  commOpen,index_lab,iLo,':',iHi,commClose
211          ENDIF
212          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
213    
214          RETURN
215          END
216    
217    CStartofinterface
218          SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd, compact, ioUnit )
219    C     /==========================================================\
220    C     | o SUBROUTINE PRINT_LIST_L                                |
221    C     |==========================================================|
222    C     | Routine for producing list of values for a field with    |
223    C     | duplicate values collected into                          |
224    C     |    n @ value                                             |
225    C     | record.                                                  |
226    C     \==========================================================/
227    
228    C     == Global data ==  
229    #include "SIZE.h"
230    #include "EEPARAMS.h"
231    
232    C     == Routine arguments ==
233    C     fld    -  Data to be printed
234    C     lFld   -  Number of elements to be printed
235    C     index_type - Flag indicating which type of index to print
236    C                  INDEX_K    => /* K = nnn */
237    C                  INDEX_I    => /* I = nnn */
238    C                  INDEX_J    => /* J = nnn */
239    C                  INDEX_NONE =>
240    C     compact -  Flag to control use of repeat symbol for same valued
241    C                fields.
242    C     markEnd -  Flag to control whether there is a separator after the
243    C                last element
244    C     ioUnit -  Unit number for IO.
245          INTEGER lFld
246          INTEGER index_type
247          LOGICAL fld(lFld)
248          LOGICAL markEnd
249          LOGICAL compact
250          INTEGER ioUnit
251    CEndifinterface
252    
253    C     == Local variables ==
254    C     iLo  - Range index holders for selecting elements with
255    C     iHi    with the same value
256    C     nDup - Number of duplicates
257    C     xNew, xOld - Hold current and previous values of field
258    C     punc - Field separator
259    C     msgBuf - IO buffer
260    C     index_lab - Index for labelling elements
261    C     K    - Loop counter
262          INTEGER iLo
263          INTEGER iHi
264          INTEGER nDup
265          LOGICAL xNew, xOld
266          CHARACTER punc
267          CHARACTER*(MAX_LEN_MBUF) msgBuf
268          CHARACTER*2 commOpen,commClose
269          CHARACTER*3 index_lab
270          INTEGER K
271    
272          IF     ( index_type .EQ. INDEX_I ) THEN
273           index_lab = 'I ='
274          ELSEIF ( index_type .EQ. INDEX_J ) THEN
275           index_lab = 'J ='
276          ELSEIF ( index_type .EQ. INDEX_K ) THEN
277           index_lab = 'K ='
278          ELSE
279           index_lab = '?='
280          ENDIF
281          commOpen  = '/*'
282          commClose = '*/'
283          iLo = 1
284          iHi = 1
285          punc = ','
286          xOld = fld(1)
287          DO K=2,lFld
288           xNew = fld(K  )
289           IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
290            nDup = iHi-iLo+1
291            IF ( nDup .EQ. 1 ) THEN
292             WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
293             IF ( index_type .NE. INDEX_NONE )
294         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
295            ELSE
296             WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
297             IF ( index_type .NE. INDEX_NONE )
298         &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')
299         &    commOpen,index_lab,iLo,':',iHi,commClose
300            ENDIF
301            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
302            iLo  = K
303            iHi  = K
304            xOld = xNew
305           ELSE
306            iHi = K
307           ENDIF
308          ENDDO
309          punc = ' '
310          IF ( markEnd ) punc = ','
311          nDup = iHi-iLo+1
312          IF    ( nDup .EQ. 1 ) THEN
313           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
314           IF ( index_type .NE. INDEX_NONE )
315         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
316          ELSEIF( nDup .GT. 1 ) THEN
317           WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
318           IF ( index_type .NE. INDEX_NONE )
319         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
320         &  commOpen,index_lab,iLo,':',iHi,commClose
321          ENDIF
322          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
323    
324          RETURN
325          END
326    
327    CStartofinterface
328          SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, markEnd, compact, ioUnit )
329    C     /==========================================================\
330    C     | o SUBROUTINE PRINT_LIST_R8                               |
331    C     |==========================================================|
332    C     | Routine for producing list of values for a field with    |
333    C     | duplicate values collected into                          |
334    C     |    n @ value                                             |
335    C     | record.                                                  |
336    C     \==========================================================/
337    
338    C     == Global data ==  
339    #include "SIZE.h"
340    #include "EEPARAMS.h"
341    
342    C     == Routine arguments ==
343    C     fld    -  Data to be printed
344    C     lFld   -  Number of elements to be printed
345    C     index_type - Flag indicating which type of index to print
346    C                  INDEX_K    => /* K = nnn */
347    C                  INDEX_I    => /* I = nnn */
348    C                  INDEX_J    => /* J = nnn */
349    C                  INDEX_NONE =>
350    C     compact -  Flag to control use of repeat symbol for same valued
351    C                fields.
352    C     markEnd -  Flag to control whether there is a separator after the
353    C                last element
354    C     ioUnit -  Unit number for IO.
355          INTEGER lFld
356          INTEGER index_type
357          Real*8  fld(lFld)
358          LOGICAL markEnd
359          LOGICAL compact
360          INTEGER ioUnit
361    CEndifinterface
362    
363    C     == Local variables ==
364    C     iLo  - Range index holders for selecting elements with
365    C     iHi    with the same value
366    C     nDup - Number of duplicates
367    C     xNew, xOld - Hold current and previous values of field
368    C     punc - Field separator
369    C     msgBuf - IO buffer
370    C     index_lab - Index for labelling elements
371    C     K    - Loop counter
372          INTEGER iLo
373          INTEGER iHi
374          INTEGER nDup
375          Real*8 xNew, xOld
376          CHARACTER punc
377          CHARACTER*(MAX_LEN_MBUF) msgBuf
378          CHARACTER*2 commOpen,commClose
379          CHARACTER*3 index_lab
380          INTEGER K
381    
382          IF     ( index_type .EQ. INDEX_I ) THEN
383           index_lab = 'I ='
384          ELSEIF ( index_type .EQ. INDEX_J ) THEN
385           index_lab = 'J ='
386          ELSEIF ( index_type .EQ. INDEX_K ) THEN
387           index_lab = 'K ='
388          ELSE
389           index_lab = '?='
390          ENDIF
391          commOpen  = '/*'
392          commClose = '*/'
393          iLo = 1
394          iHi = 1
395          punc = ','
396          xOld = fld(1)
397          DO K=2,lFld
398           xNew = fld(K  )
399           IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
400            nDup = iHi-iLo+1
401            IF ( nDup .EQ. 1 ) THEN
402             WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
403             IF ( index_type .NE. INDEX_NONE )
404         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
405            ELSE
406             WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
407             IF ( index_type .NE. INDEX_NONE )
408         &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
409         &    commOpen,index_lab,iLo,':',iHi,commClose
410            ENDIF
411            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)
412            iLo  = K
413            iHi  = K
414            xOld = xNew
415           ELSE
416            iHi = K
417           ENDIF
418          ENDDO
419          punc = ' '
420          IF ( markEnd ) punc = ','
421          nDup = iHi-iLo+1
422          IF    ( nDup .EQ. 1 ) THEN
423           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
424           IF ( index_type .NE. INDEX_NONE )
425         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
426          ELSEIF( nDup .GT. 1 ) THEN
427           WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
428           IF ( index_type .NE. INDEX_NONE )
429         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
430         &  commOpen,index_lab,iLo,':',iHi,commClose
431          ENDIF
432          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)
433    
434        RETURN        RETURN
435        END        END
436    
437  CStartOfInterface  CStartOfInterface
438        SUBROUTINE PRINT_MAPR4 ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,
439       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
440       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
441       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
# Line 147  C     kStr Line 490  C     kStr
490        INTEGER jLo, jHi        INTEGER jLo, jHi
491        INTEGER kLo, kHi        INTEGER kLo, kHi
492        INTEGER nBx, nBy        INTEGER nBx, nBy
493        Real*4 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RS fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
494        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
495        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
496        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
# Line 486  C--   Write delimiter Line 829  C--   Write delimiter
829        END        END
830    
831  CStartOfInterface  CStartOfInterface
832        SUBROUTINE PRINT_MAPR8 ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
833       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
834       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
835       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
# Line 494  CStartOfInterface Line 837  CStartOfInterface
837       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
838       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
839  C     /==========================================================\  C     /==========================================================\
840  C     | SUBROUTINE PRINT_MAPR8                                   |  C     | SUBROUTINE PRINT_MAPRL                                   |
841  C     | o Does textual mapping printing of a field.              |  C     | o Does textual mapping printing of a field.              |
842  C     |==========================================================|  C     |==========================================================|
843  C     | This routine does the actual formatting of the data      |  C     | This routine does the actual formatting of the data      |
# Line 541  C     kStr Line 884  C     kStr
884        INTEGER jLo, jHi        INTEGER jLo, jHi
885        INTEGER kLo, kHi        INTEGER kLo, kHi
886        INTEGER nBx, nBy        INTEGER nBx, nBy
887        Real*8 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RL fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
888        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
889        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
890        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
# Line 950  C       The write statement may need to Line 1293  C       The write statement may need to
1293  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1294          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1295  #endif  #endif
1296           WRITE(unit,'(A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A)',ERR=999)
1297       &   '(',PROCESS_HEADER,' ',idString,')',' '       &   '(',PROCESS_HEADER,' ',idString,')',' '
1298  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1299          _END_CRIT(myThid)          _END_CRIT(myThid)
# Line 959  C       The write statement may need to Line 1302  C       The write statement may need to
1302  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1303          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1304  #endif  #endif
1305           WRITE(unit,'(A,A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)
1306       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',
1307       &   message(iStart:iEnd)       &   message(iStart:iEnd)
1308  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 968  C       The write statement may need to Line 1311  C       The write statement may need to
1311         ENDIF         ENDIF
1312        ENDIF        ENDIF
1313  C  C
1314     1000 CONTINUE
1315        RETURN        RETURN
1316        END    999 CONTINUE
1317           ioErrorCount(myThid) = ioErrorCount(myThid)+1
1318          GOTO 1000
1319    
1320  C $Id$        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.10
  ViewVC Help
Powered by ViewVC 1.1.22