/[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.9 by adcroft, Mon Jun 22 16:24:51 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 73  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 83  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 92  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        RETURN
101    
102      999 CONTINUE
103           ioErrorCount(myThid) = ioErrorCount(myThid)+1
104          GOTO 1000
105        END        END
106    
107  CStartofinterface  CStartofinterface
108        SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, ioUnit )        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  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,I5,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,I5,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,I5,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,I5,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     /==========================================================\  C     /==========================================================\
330  C     | o SUBROUTINE PRINT_LIST_R8                               |  C     | o SUBROUTINE PRINT_LIST_R8                               |
331  C     |==========================================================|  C     |==========================================================|
# Line 119  C                  INDEX_K    => /* K = Line 347  C                  INDEX_K    => /* K =
347  C                  INDEX_I    => /* I = nnn */  C                  INDEX_I    => /* I = nnn */
348  C                  INDEX_J    => /* J = nnn */  C                  INDEX_J    => /* J = nnn */
349  C                  INDEX_NONE =>  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.  C     ioUnit -  Unit number for IO.
355        INTEGER lFld        INTEGER lFld
356        INTEGER index_type        INTEGER index_type
357        Real*8  fld(lFld)        Real*8  fld(lFld)
358          LOGICAL markEnd
359          LOGICAL compact
360        INTEGER ioUnit        INTEGER ioUnit
361    CEndifinterface
362    
363  C     == Local variables ==  C     == Local variables ==
364  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 374  C     K    - Loop counter
374        INTEGER nDup        INTEGER nDup
375        Real*8 xNew, xOld        Real*8 xNew, xOld
376        CHARACTER punc        CHARACTER punc
377        CHARACTER(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
378        CHARACTER*2 commOpen,commClose        CHARACTER*2 commOpen,commClose
379        CHARACTER*3 index_lab        CHARACTER*3 index_lab
380        INTEGER K        INTEGER K
# Line 161  C     K    - Loop counter Line 396  C     K    - Loop counter
396        xOld = fld(1)        xOld = fld(1)
397        DO K=2,lFld        DO K=2,lFld
398         xNew = fld(K  )         xNew = fld(K  )
399         IF ( xNew .NE. xOld ) THEN         IF ( .NOT. compact .OR. xNew .NE. xOld ) THEN
400          nDup = iHi-iLo+1          nDup = iHi-iLo+1
401          IF ( nDup .EQ. 1 ) THEN          IF ( nDup .EQ. 1 ) THEN
402           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc           WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
# Line 182  C     K    - Loop counter Line 417  C     K    - Loop counter
417         ENDIF         ENDIF
418        ENDDO        ENDDO
419        punc = ' '        punc = ' '
420          IF ( markEnd ) punc = ','
421        nDup = iHi-iLo+1        nDup = iHi-iLo+1
422        IF    ( nDup .EQ. 1 ) THEN        IF    ( nDup .EQ. 1 ) THEN
423         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc         WRITE(msgBuf,'(A,1PE23.15,A)') '              ',xOld,punc
# Line 199  C     K    - Loop counter Line 435  C     K    - Loop counter
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 254  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 593  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 601  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 648  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 1057  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 1066  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 1075  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      999 CONTINUE
1317           ioErrorCount(myThid) = ioErrorCount(myThid)+1
1318          GOTO 1000
1319    
1320        END        END
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.9
  ViewVC Help
Powered by ViewVC 1.1.22