/[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.8 by cnh, Mon Jun 15 05:13:55 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, 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     ioUnit -  Unit number for IO.
131          INTEGER lFld
132          INTEGER index_type
133          INTEGER fld(lFld)
134          INTEGER ioUnit
135    CEndifinterface
136    
137    C     == Local variables ==
138    C     iLo  - Range index holders for selecting elements with
139    C     iHi    with the same value
140    C     nDup - Number of duplicates
141    C     xNew, xOld - Hold current and previous values of field
142    C     punc - Field separator
143    C     msgBuf - IO buffer
144    C     index_lab - Index for labelling elements
145    C     K    - Loop counter
146          INTEGER iLo
147          INTEGER iHi
148          INTEGER nDup
149          INTEGER xNew, xOld
150          CHARACTER punc
151          CHARACTER*(MAX_LEN_MBUF) msgBuf
152          CHARACTER*2 commOpen,commClose
153          CHARACTER*3 index_lab
154          INTEGER K
155    
156          IF     ( index_type .EQ. INDEX_I ) THEN
157           index_lab = 'I ='
158          ELSEIF ( index_type .EQ. INDEX_J ) THEN
159           index_lab = 'J ='
160          ELSEIF ( index_type .EQ. INDEX_K ) THEN
161           index_lab = 'K ='
162          ELSE
163           index_lab = '?='
164          ENDIF
165          commOpen  = '/*'
166          commClose = '*/'
167          iLo = 1
168          iHi = 1
169          punc = ','
170          xOld = fld(1)
171          DO K=2,lFld
172           xNew = fld(K  )
173           IF ( xNew .NE. xOld ) THEN
174            nDup = iHi-iLo+1
175            IF ( nDup .EQ. 1 ) THEN
176             WRITE(msgBuf,'(A,I5,A)') '              ',xOld,punc
177             IF ( index_type .NE. INDEX_NONE )
178         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
179            ELSE
180             WRITE(msgBuf,'(I,'' '',A,I5,A)') nDup,'@',xOld,punc
181             IF ( index_type .NE. INDEX_NONE )
182         &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
183         &    commOpen,index_lab,iLo,':',iHi,commClose
184            ENDIF
185            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
186            iLo  = K
187            iHi  = K
188            xOld = xNew
189           ELSE
190            iHi = K
191           ENDIF
192          ENDDO
193          punc = ' '
194          nDup = iHi-iLo+1
195          IF    ( nDup .EQ. 1 ) THEN
196           WRITE(msgBuf,'(A,I5,A)') '              ',xOld,punc
197           IF ( index_type .NE. INDEX_NONE )
198         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
199          ELSEIF( nDup .GT. 1 ) THEN
200           WRITE(msgBuf,'(I,'' '',A,I5,A)') nDup,'@',xOld,punc
201           IF ( index_type .NE. INDEX_NONE )
202         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
203         &  commOpen,index_lab,iLo,':',iHi,commClose
204          ENDIF
205          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
206    
207          RETURN
208          END
209    
210    CStartofinterface
211          SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, ioUnit )
212    C     /==========================================================\
213    C     | o SUBROUTINE PRINT_LIST_L                                |
214    C     |==========================================================|
215    C     | Routine for producing list of values for a field with    |
216    C     | duplicate values collected into                          |
217    C     |    n @ value                                             |
218    C     | record.                                                  |
219    C     \==========================================================/
220    
221    C     == Global data ==  
222    #include "SIZE.h"
223    #include "EEPARAMS.h"
224    
225    C     == Routine arguments ==
226    C     fld    -  Data to be printed
227    C     lFld   -  Number of elements to be printed
228    C     index_type - Flag indicating which type of index to print
229    C                  INDEX_K    => /* K = nnn */
230    C                  INDEX_I    => /* I = nnn */
231    C                  INDEX_J    => /* J = nnn */
232    C                  INDEX_NONE =>
233    C     ioUnit -  Unit number for IO.
234          INTEGER lFld
235          INTEGER index_type
236          LOGICAL fld(lFld)
237          INTEGER ioUnit
238    CEndifinterface
239    
240    C     == Local variables ==
241    C     iLo  - Range index holders for selecting elements with
242    C     iHi    with the same value
243    C     nDup - Number of duplicates
244    C     xNew, xOld - Hold current and previous values of field
245    C     punc - Field separator
246    C     msgBuf - IO buffer
247    C     index_lab - Index for labelling elements
248    C     K    - Loop counter
249          INTEGER iLo
250          INTEGER iHi
251          INTEGER nDup
252          LOGICAL xNew, xOld
253          CHARACTER punc
254          CHARACTER*(MAX_LEN_MBUF) msgBuf
255          CHARACTER*2 commOpen,commClose
256          CHARACTER*3 index_lab
257          INTEGER K
258    
259          IF     ( index_type .EQ. INDEX_I ) THEN
260           index_lab = 'I ='
261          ELSEIF ( index_type .EQ. INDEX_J ) THEN
262           index_lab = 'J ='
263          ELSEIF ( index_type .EQ. INDEX_K ) THEN
264           index_lab = 'K ='
265          ELSE
266           index_lab = '?='
267          ENDIF
268          commOpen  = '/*'
269          commClose = '*/'
270          iLo = 1
271          iHi = 1
272          punc = ','
273          xOld = fld(1)
274          DO K=2,lFld
275           xNew = fld(K  )
276           IF ( xNew .NE. xOld ) THEN
277            nDup = iHi-iLo+1
278            IF ( nDup .EQ. 1 ) THEN
279             WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
280             IF ( index_type .NE. INDEX_NONE )
281         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
282            ELSE
283             WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
284             IF ( index_type .NE. INDEX_NONE )
285         &    WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)')
286         &    commOpen,index_lab,iLo,':',iHi,commClose
287            ENDIF
288            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
289            iLo  = K
290            iHi  = K
291            xOld = xNew
292           ELSE
293            iHi = K
294           ENDIF
295          ENDDO
296          punc = ' '
297          nDup = iHi-iLo+1
298          IF    ( nDup .EQ. 1 ) THEN
299           WRITE(msgBuf,'(A,L5,A)') '              ',xOld,punc
300           IF ( index_type .NE. INDEX_NONE )
301         &  WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
302          ELSEIF( nDup .GT. 1 ) THEN
303           WRITE(msgBuf,'(I,'' '',A,L5,A)') nDup,'@',xOld,punc
304           IF ( index_type .NE. INDEX_NONE )
305         &  WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
306         &  commOpen,index_lab,iLo,':',iHi,commClose
307          ENDIF
308          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
309    
310          RETURN
311          END
312    
313    CStartofinterface
314          SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, ioUnit )
315    C     /==========================================================\
316    C     | o SUBROUTINE PRINT_LIST_R8                               |
317    C     |==========================================================|
318    C     | Routine for producing list of values for a field with    |
319    C     | duplicate values collected into                          |
320    C     |    n @ value                                             |
321    C     | record.                                                  |
322    C     \==========================================================/
323    
324    C     == Global data ==  
325    #include "SIZE.h"
326    #include "EEPARAMS.h"
327    
328    C     == Routine arguments ==
329    C     fld    -  Data to be printed
330    C     lFld   -  Number of elements to be printed
331    C     index_type - Flag indicating which type of index to print
332    C                  INDEX_K    => /* K = nnn */
333    C                  INDEX_I    => /* I = nnn */
334    C                  INDEX_J    => /* J = nnn */
335    C                  INDEX_NONE =>
336    C     ioUnit -  Unit number for IO.
337          INTEGER lFld
338          INTEGER index_type
339          Real*8  fld(lFld)
340          INTEGER ioUnit
341    CEndifinterface
342    
343    C     == Local variables ==
344    C     iLo  - Range index holders for selecting elements with
345    C     iHi    with the same value
346    C     nDup - Number of duplicates
347    C     xNew, xOld - Hold current and previous values of field
348    C     punc - Field separator
349    C     msgBuf - IO buffer
350    C     index_lab - Index for labelling elements
351    C     K    - Loop counter
352          INTEGER iLo
353          INTEGER iHi
354          INTEGER nDup
355          Real*8 xNew, xOld
356          CHARACTER punc
357          CHARACTER*(MAX_LEN_MBUF) msgBuf
358          CHARACTER*2 commOpen,commClose
359          CHARACTER*3 index_lab
360          INTEGER K
361    
362          IF     ( index_type .EQ. INDEX_I ) THEN
363           index_lab = 'I ='
364          ELSEIF ( index_type .EQ. INDEX_J ) THEN
365           index_lab = 'J ='
366          ELSEIF ( index_type .EQ. INDEX_K ) THEN
367           index_lab = 'K ='
368          ELSE
369           index_lab = '?='
370          ENDIF
371          commOpen  = '/*'
372          commClose = '*/'
373          iLo = 1
374          iHi = 1
375          punc = ','
376          xOld = fld(1)
377          DO K=2,lFld
378           xNew = fld(K  )
379           IF ( xNew .NE. xOld ) THEN
380            nDup = iHi-iLo+1
381            IF ( nDup .EQ. 1 ) THEN
382             WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
383             IF ( index_type .NE. INDEX_NONE )
384         &    WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') commOpen,index_lab,iLo,commClose
385            ELSE
386             WRITE(msgBuf,'(I,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc
387             IF ( index_type .NE. INDEX_NONE )
388         &    WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)')
389         &    commOpen,index_lab,iLo,':',iHi,commClose
390            ENDIF
391            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)
392            iLo  = K
393            iHi  = K
394            xOld = xNew
395           ELSE
396            iHi = K
397           ENDIF
398          ENDDO
399          punc = ' '
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          ELSEIF( nDup .GT. 1 ) THEN
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    
413        RETURN        RETURN
414        END        END
415    
416  CStartOfInterface  CStartOfInterface
417        SUBROUTINE PRINT_MAPR4 ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRS ( fld, fldTitle, plotMode,
418       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
419       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
420       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
# Line 147  C     kStr Line 469  C     kStr
469        INTEGER jLo, jHi        INTEGER jLo, jHi
470        INTEGER kLo, kHi        INTEGER kLo, kHi
471        INTEGER nBx, nBy        INTEGER nBx, nBy
472        Real*4 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RS fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
473        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
474        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
475        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
# Line 486  C--   Write delimiter Line 808  C--   Write delimiter
808        END        END
809    
810  CStartOfInterface  CStartOfInterface
811        SUBROUTINE PRINT_MAPR8 ( fld, fldTitle, plotMode,        SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode,
812       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,       I        iLo,   iHi,   jLo,   jHi,  kLo,  kHi, nBx, nBy,
813       I       iMin,  iMax,  iStr,       I       iMin,  iMax,  iStr,
814       I       jMin,  jMax,  jStr,       I       jMin,  jMax,  jStr,
# Line 494  CStartOfInterface Line 816  CStartOfInterface
816       I      bxMin, bxMax,  bxStr,       I      bxMin, bxMax,  bxStr,
817       I      byMin, byMax,  byStr )       I      byMin, byMax,  byStr )
818  C     /==========================================================\  C     /==========================================================\
819  C     | SUBROUTINE PRINT_MAPR8                                   |  C     | SUBROUTINE PRINT_MAPRL                                   |
820  C     | o Does textual mapping printing of a field.              |  C     | o Does textual mapping printing of a field.              |
821  C     |==========================================================|  C     |==========================================================|
822  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 863  C     kStr
863        INTEGER jLo, jHi        INTEGER jLo, jHi
864        INTEGER kLo, kHi        INTEGER kLo, kHi
865        INTEGER nBx, nBy        INTEGER nBx, nBy
866        Real*8 fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)        _RL fld(iLo:iHi,jLo:jHi,kLo:kHi,nBx,nBy)
867        INTEGER iMin, iMax, iStr        INTEGER iMin, iMax, iStr
868        INTEGER jMin, jMax, jStr        INTEGER jMin, jMax, jStr
869        INTEGER kMin, kMax, kStr        INTEGER kMin, kMax, kStr
# Line 950  C       The write statement may need to Line 1272  C       The write statement may need to
1272  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1273          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1274  #endif  #endif
1275           WRITE(unit,'(A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A)',ERR=999)
1276       &   '(',PROCESS_HEADER,' ',idString,')',' '       &   '(',PROCESS_HEADER,' ',idString,')',' '
1277  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1278          _END_CRIT(myThid)          _END_CRIT(myThid)
# Line 959  C       The write statement may need to Line 1281  C       The write statement may need to
1281  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
1282          _BEGIN_CRIT(myThid)          _BEGIN_CRIT(myThid)
1283  #endif  #endif
1284           WRITE(unit,'(A,A,A,A,A,A,A)')           WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999)
1285       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',       &   '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ',
1286       &   message(iStart:iEnd)       &   message(iStart:iEnd)
1287  #ifndef FMTFTN_IO_THREAD_SAFE  #ifndef FMTFTN_IO_THREAD_SAFE
# Line 968  C       The write statement may need to Line 1290  C       The write statement may need to
1290         ENDIF         ENDIF
1291        ENDIF        ENDIF
1292  C  C
1293     1000 CONTINUE
1294        RETURN        RETURN
1295        END    999 CONTINUE
1296           ioErrorCount(myThid) = ioErrorCount(myThid)+1
1297          GOTO 1000
1298    
1299  C $Id$        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.8
  ViewVC Help
Powered by ViewVC 1.1.22