--- MITgcm/eesupp/src/print.F 2004/01/27 15:59:23 1.21 +++ MITgcm/eesupp/src/print.F 2009/06/19 03:05:13 1.31 @@ -1,88 +1,101 @@ -C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/eesupp/src/print.F,v 1.21 2004/01/27 15:59:23 jmc Exp $ +C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/eesupp/src/print.F,v 1.31 2009/06/19 03:05:13 jmc Exp $ C $Name: $ #include "CPP_EEOPTIONS.h" -C-- File printf.F: Routines for performing formatted textual I/O -C-- in the MITgcm UV implementation environment. -C-- Contents -C-- o print_error Does IO with **ERROR** highlighted header -C-- o print_list_i Prints one-deimensional list of INTEGER -C-- numbers. -C-- o print_list_l Prints one-deimensional list of LOGICAL -C-- variables. -C-- o print_list_r8 Prints one-deimensional list of Real*8 -C-- numbers. -C-- o print_mapr4 Formats ABCD... contour map of a Real*4 field -C-- Uses print_message for writing -C-- o print_mapr8 Formats ABCD... contour map of a Real*8 field -C-- Uses print_message for writing -C-- o print_message Does IO with unhighlighted header - -CBOP - -C !ROUTINE: PRINT_ERROR +C-- File printf.F: Routines for performing formatted textual I/O +C-- in the MITgcm UV implementation environment. +C-- Contents +C-- o PRINT_MESSAGE Does IO with unhighlighted header +C-- o PRINT_ERROR Does IO with **ERROR** highlighted header +C-- o PRINT_LIST_I Prints one-dimensional list of INTEGER +C-- numbers. +C-- o PRINT_LIST_L Prints one-dimensional list of LOGICAL +C-- variables. +C-- o PRINT_LIST_RL Prints one-dimensional list of Real(_RL) +C-- numbers. +C-- o PRINT_MAPRS Formats ABCD... contour map of a Real(_RS) field +C-- Uses print_message for writing +C-- o PRINT_MAPRL Formats ABCD... contour map of a Real(_RL) field +C-- Uses print_message for writing +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +C !ROUTINE: PRINT_MESSAGE C !INTERFACE: - SUBROUTINE PRINT_ERROR( message , myThid ) - IMPLICIT NONE + SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid ) C !DESCRIPTION: C *============================================================* -C | SUBROUTINE PRINT_ERROR -C | o Write out error message using "standard" format. +C | SUBROUTINE PRINT\_MESSAGE +C | o Write out informational message using "standard" format. C *============================================================* -C | Notes -C | ===== -C | o Some system I/O is not "thread-safe". For this reason -C | without the FMTFTN_IO_THREAD_SAFE directive set a -C | critical region is defined around the write here. In some -C | cases BEGIN_CRIT() is approximated by only doing writes -C | for thread number 1 - writes for other threads are -C | ignored! -C | o In a non-parallel form these routines are still used -C | to produce pretty printed output. The process and thread -C | id prefix is omitted in this case. +C | Notes +C | ===== +C | o Some system I/O is not "thread-safe". For this reason +C | without the FMTFTN\_IO\_THREAD\_SAFE directive set a +C | critical region is defined around the write here. In some +C | cases BEGIN\_CRIT() is approximated by only doing writes +C | for thread number 1 - writes for other threads are +C | ignored! +C | o In a non-parallel form these routines can still be used. +C | to produce pretty printed output! C *============================================================* C !USES: + IMPLICIT NONE + C == Global data == #include "SIZE.h" #include "EEPARAMS.h" #include "EESUPPORT.h" - INTEGER IFNBLNK - EXTERNAL IFNBLNK - INTEGER ILNBLNK - EXTERNAL ILNBLNK C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == -C message :: Text string to print -C myThid :: Thread number of this instance +C message :: Message to write +C unit :: Unit number to write to +C sq :: Justification option CHARACTER*(*) message - INTEGER myThid + INTEGER unit + CHARACTER*(*) sq + INTEGER myThid + +C !FUNCTIONS: + INTEGER IFNBLNK + EXTERNAL IFNBLNK + INTEGER ILNBLNK + EXTERNAL ILNBLNK C !LOCAL VARIABLES: C == Local variables == -C iStart, iEnd :: Temps. for string indexing -C idString :: Temp. for building message prefix +C iStart, iEnd :: String indexing variables +C idString :: Temp. for building prefix. INTEGER iStart INTEGER iEnd CHARACTER*9 idString CEOP C-- Find beginning and end of message - iStart = IFNBLNK( message ) - iEnd = ILNBLNK( message ) + IF ( sq .EQ. SQUEEZE_BOTH .OR. + & sq .EQ. SQUEEZE_LEFT ) THEN + iStart = IFNBLNK( message ) + ELSE + iStart = 1 + ENDIF + IF ( sq .EQ. SQUEEZE_BOTH .OR. + & sq .EQ. SQUEEZE_RIGHT ) THEN + iEnd = ILNBLNK( message ) + ELSE + iEnd = LEN(message) + ENDIF C-- Test to see if in multi-process ( or multi-threaded ) mode. C If so include process or thread identifier. IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN C-- Write single process format IF ( message .EQ. ' ' ) THEN - WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' ' + WRITE(unit,'(A)') ' ' ELSE - WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, - & message(iStart:iEnd) + WRITE(unit,'(A)') message(iStart:iEnd) ENDIF ELSEIF ( pidIO .EQ. myProcId ) THEN C-- Write multi-process format @@ -94,14 +107,13 @@ _END_CRIT(myThid) #endif IF ( message .EQ. ' ' ) THEN -C PRINT_ERROR can be called by several threads simulataneously. -C The write statement may need to be marked as a critical section. +C PRINT can be called by several threads simultaneously. +C The write statement may need to ne marked as a critical section. #ifndef FMTFTN_IO_THREAD_SAFE _BEGIN_CRIT(myThid) #endif - WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999) - & '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ', - & ' ' + WRITE(unit,'(A,A,A,A,A,A)',ERR=999) + & '(',PROCESS_HEADER,' ',idString,')',' ' #ifndef FMTFTN_IO_THREAD_SAFE _END_CRIT(myThid) #endif @@ -109,9 +121,9 @@ #ifndef FMTFTN_IO_THREAD_SAFE _BEGIN_CRIT(myThid) #endif - WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999) - & '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ', - & message(iStart:iEnd) + WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999) + & '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ', + & message(iStart:iEnd) #ifndef FMTFTN_IO_THREAD_SAFE _END_CRIT(myThid) #endif @@ -119,59 +131,189 @@ ENDIF #ifndef DISABLE_WRITE_TO_UNIT_ZERO -C-- also write directly to unit 0 : - IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1 ) THEN +C-- if error message, also write directly to unit 0 : + IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1 + & .AND. unit.EQ.errorMessageUnit ) THEN + iEnd = ILNBLNK( message ) IF (iEnd.NE.0) WRITE(0,'(A)') message(1:iEnd) ENDIF #endif - +C 1000 CONTINUE RETURN - 999 CONTINUE ioErrorCount(myThid) = ioErrorCount(myThid)+1 GOTO 1000 + END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP -C !ROUTINE: PRINT_LIST_I +C !ROUTINE: PRINT_ERROR +C !INTERFACE: + SUBROUTINE PRINT_ERROR( message , myThid ) + +C !DESCRIPTION: +C *============================================================* +C | SUBROUTINE PRINT\_ERROR +C | o Write out error message using "standard" format. +C *============================================================* +C | Notes +C | ===== +C | o Some system I/O is not "thread-safe". For this reason +C | without the FMTFTN\_IO\_THREAD\_SAFE directive set a +C | critical region is defined around the write here. In some +C | cases BEGIN\_CRIT() is approximated by only doing writes +C | for thread number 1 - writes for other threads are +C | ignored! +C | o In a non-parallel form these routines are still used +C | to produce pretty printed output. The process and thread +C | id prefix is omitted in this case. +C *============================================================* + +C !USES: + IMPLICIT NONE +C == Global data == +#include "SIZE.h" +#include "EEPARAMS.h" +#include "EESUPPORT.h" + +C !INPUT/OUTPUT PARAMETERS: +C == Routine arguments == +C message :: Text string to print +C myThid :: Thread number of this instance + CHARACTER*(*) message + INTEGER myThid + +C !FUNCTIONS: +c INTEGER IFNBLNK +c EXTERNAL IFNBLNK + INTEGER ILNBLNK + EXTERNAL ILNBLNK + +C !LOCAL VARIABLES: +C == Local variables == +C iStart, iEnd :: Temps. for string indexing +C idString :: Temp. for building message prefix +c INTEGER iStart + INTEGER iEnd + CHARACTER*9 idString +CEOP + +C-- Find beginning and end of message +c iStart = IFNBLNK( message ) + iEnd = ILNBLNK( message ) +C-- Test to see if in multi-process ( or multi-threaded ) mode. +C If so include process or thread identifier. + IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN +C-- Write single process format + IF ( iEnd.EQ.0 ) THEN + WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, ' ' + ELSE + WRITE(errorMessageUnit,'(A,1X,A)') ERROR_HEADER, + & message(1:iEnd) +c & message(iStart:iEnd) + ENDIF + ELSE +C PRINT_ERROR can be called by several threads simulataneously. +C The write statement may need to be marked as a critical section. +#ifndef FMTFTN_IO_THREAD_SAFE +# ifdef USE_OMP_THREADING +C$OMP CRITICAL +# else + _BEGIN_CRIT(myThid) +# endif +#endif + IF ( pidIO .EQ. myProcId ) THEN +C-- Write multi-process format + WRITE(idString,'(I4.4,A,I4.4)') myProcId,'.',myThid + + IF ( iEnd.EQ.0 ) THEN +c WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999) + WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)') + & '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ', + & ' ' + ELSE +c WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)',ERR=999) + WRITE(errorMessageUnit,'(A,A,1X,A,A,A,A,A)') + & '(',PROCESS_HEADER,idString,')',ERROR_HEADER,' ', + & message(1:iEnd) +c & message(iStart:iEnd) + ENDIF + ENDIF + +#ifndef DISABLE_WRITE_TO_UNIT_ZERO +C-- also write directly to unit 0 : + IF ( numberOfProcs.EQ.1 .AND. iEnd.NE.0 ) THEN + IF ( nThreads.LE.1 ) THEN + WRITE(0,'(A)') message(1:iEnd) + ELSE + WRITE(0,'(A,I4.4,A,A)') '(TID ', myThid, ') ', + & message(1:iEnd) + ENDIF + ENDIF +#endif + +#ifndef FMTFTN_IO_THREAD_SAFE +# ifdef USE_OMP_THREADING +C$OMP END CRITICAL +# else + _END_CRIT(myThid) +# endif +#endif + ENDIF + + 1000 CONTINUE + RETURN + +c 999 CONTINUE +c ioErrorCount(myThid) = ioErrorCount(myThid)+1 +c GOTO 1000 + END + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +CBOP +C !ROUTINE: PRINT_LIST_I C !INTERFACE: - SUBROUTINE PRINT_LIST_I( fld, lFld, index_type, + SUBROUTINE PRINT_LIST_I( fld, iFirst, iLast, index_type, & markEnd, compact, ioUnit ) - IMPLICIT NONE + C !DESCRIPTION: C *==========================================================* -C | o SUBROUTINE PRINT_LIST_I +C | o SUBROUTINE PRINT\_LIST\_I C *==========================================================* -C | Routine for producing list of values for a field with -C | duplicate values collected into -C | n @ value -C | record. +C | Routine for producing list of values for a field with +C | duplicate values collected into +C | n \@ value +C | record. C *==========================================================* C !USES: -C == Global data == + IMPLICIT NONE + +C == Global data == #include "SIZE.h" #include "EEPARAMS.h" C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == -C fld :: Data to be printed -C lFld :: Number of elements to be printed -C index_type :: Flag indicating which type of index to print -C INDEX_K => /* K = nnn */ -C INDEX_I => /* I = nnn */ -C INDEX_J => /* J = nnn */ -C INDEX_NONE => -C compact :: Flag to control use of repeat symbol for same valued -C fields. -C markEnd :: Flag to control whether there is a separator after the -C last element -C ioUnit :: Unit number for IO. - INTEGER lFld +C fld :: Data to be printed +C iFirst :: First element to print +C iLast :: Last element to print +C index_type :: Flag indicating which type of index to print +C INDEX_K => /* K = nnn */ +C INDEX_I => /* I = nnn */ +C INDEX_J => /* J = nnn */ +C INDEX_NONE => +C markEnd :: Flag to control whether there is a separator after the +C last element +C compact :: Flag to control use of repeat symbol for same valued +C fields. +C ioUnit :: Unit number for IO. + INTEGER iFirst, iLast + INTEGER fld(iFirst:iLast) INTEGER index_type - INTEGER fld(lFld) LOGICAL markEnd LOGICAL compact INTEGER ioUnit @@ -194,6 +336,7 @@ CHARACTER*(MAX_LEN_MBUF) msgBuf CHARACTER*2 commOpen,commClose CHARACTER*3 index_lab + CHARACTER*25 fmt1, fmt2 INTEGER K CEOP @@ -206,25 +349,33 @@ ELSE index_lab = '?=' ENDIF +C- fortran format to write 1 or 2 indices: + fmt1='(A,1X,A,I3,1X,A)' + fmt2='(A,1X,A,I3,A,I3,1X,A)' + IF ( iLast.GE.1000 ) THEN + K = 1+INT(LOG10(FLOAT(iLast))) + WRITE(fmt1,'(A,I1,A)') '(A,1X,A,I',K,',1X,A)' + WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)' + ENDIF commOpen = '/*' commClose = '*/' - iLo = 1 - iHi = 1 + iLo = iFirst + iHi = iFirst punc = ',' - xOld = fld(1) - DO K=2,lFld + xOld = fld(iFirst) + DO K = iFirst+1,iLast xNew = fld(K ) IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN nDup = iHi-iLo+1 IF ( nDup .EQ. 1 ) THEN WRITE(msgBuf,'(A,I9,A)') ' ',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),fmt1) & commOpen,index_lab,iLo,commClose ELSE WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),fmt2) & commOpen,index_lab,iLo,':',iHi,commClose ENDIF CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1) @@ -240,13 +391,13 @@ nDup = iHi-iLo+1 IF ( nDup .EQ. 1 ) THEN WRITE(msgBuf,'(A,I9,A)') ' ',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') & commOpen,index_lab,iLo,commClose ELSEIF( nDup .GT. 1 ) THEN WRITE(msgBuf,'(I5,'' '',A,I9,A)') nDup,'@',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)') & commOpen,index_lab,iLo,':',iHi,commClose ENDIF CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1) @@ -254,45 +405,48 @@ RETURN END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP C !ROUTINE: PRINT_LIST_L - C !INTERFACE: - SUBROUTINE PRINT_LIST_L( fld, lFld, index_type, markEnd, - & compact, ioUnit ) - IMPLICIT NONE + SUBROUTINE PRINT_LIST_L( fld, iFirst, iLast, index_type, + & markEnd, compact, ioUnit ) + C !DESCRIPTION: C *==========================================================* -C | o SUBROUTINE PRINT_LIST_L +C | o SUBROUTINE PRINT\_LIST\_L C *==========================================================* -C | Routine for producing list of values for a field with -C | duplicate values collected into -C | n @ value -C | record. +C | Routine for producing list of values for a field with +C | duplicate values collected into +C | n \@ value +C | record. C *==========================================================* C !USES: -C == Global data == + IMPLICIT NONE + +C == Global data == #include "SIZE.h" #include "EEPARAMS.h" C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == -C fld - Data to be printed -C lFld - Number of elements to be printed -C index_type - Flag indicating which type of index to print +C fld :: Data to be printed +C iFirst :: First element to print +C iLast :: Last element to print +C index_type :: Flag indicating which type of index to print C INDEX_K => /* K = nnn */ C INDEX_I => /* I = nnn */ C INDEX_J => /* J = nnn */ C INDEX_NONE => -C compact - Flag to control use of repeat symbol for same valued -C fields. -C markEnd - Flag to control whether there is a separator after the +C markEnd :: Flag to control whether there is a separator after the C last element -C ioUnit - Unit number for IO. - INTEGER lFld +C compact :: Flag to control use of repeat symbol for same valued +C fields. +C ioUnit :: Unit number for IO. + INTEGER iFirst, iLast + LOGICAL fld(iFirst:iLast) INTEGER index_type - LOGICAL fld(lFld) LOGICAL markEnd LOGICAL compact INTEGER ioUnit @@ -315,6 +469,7 @@ CHARACTER*(MAX_LEN_MBUF) msgBuf CHARACTER*2 commOpen,commClose CHARACTER*3 index_lab + CHARACTER*25 fmt1, fmt2 INTEGER K CEOP @@ -327,25 +482,33 @@ ELSE index_lab = '?=' ENDIF +C- fortran format to write 1 or 2 indices: + fmt1='(A,1X,A,I3,1X,A)' + fmt2='(A,1X,A,I3,A,I3,1X,A)' + IF ( iLast.GE.1000 ) THEN + K = 1+INT(LOG10(FLOAT(iLast))) + WRITE(fmt1,'(A,I1,A)') '(A,1X,A,I',K,',1X,A)' + WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)' + ENDIF commOpen = '/*' commClose = '*/' - iLo = 1 - iHi = 1 + iLo = iFirst + iHi = iFirst punc = ',' - xOld = fld(1) - DO K=2,lFld + xOld = fld(iFirst) + DO K = iFirst+1,iLast xNew = fld(K ) IF ( .NOT. compact .OR. (xNew .NEQV. xOld) ) THEN nDup = iHi-iLo+1 IF ( nDup .EQ. 1 ) THEN WRITE(msgBuf,'(A,L5,A)') ' ',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),fmt1) & commOpen,index_lab,iLo,commClose ELSE WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,L3,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),fmt2) & commOpen,index_lab,iLo,':',iHi,commClose ENDIF CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1) @@ -361,13 +524,13 @@ nDup = iHi-iLo+1 IF ( nDup .EQ. 1 ) THEN WRITE(msgBuf,'(A,L5,A)') ' ',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') & commOpen,index_lab,iLo,commClose ELSEIF( nDup .GT. 1 ) THEN WRITE(msgBuf,'(I5,'' '',A,L5,A)') nDup,'@',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)') & commOpen,index_lab,iLo,':',iHi,commClose ENDIF CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1) @@ -375,44 +538,48 @@ RETURN END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP -C !ROUTINE: PRINT_LIST_R8 +C !ROUTINE: PRINT_LIST_RL C !INTERFACE: - SUBROUTINE PRINT_LIST_R8( fld, lFld, index_type, - & markEnd, compact, ioUnit ) - IMPLICIT NONE + SUBROUTINE PRINT_LIST_RL( fld, iFirst, iLast, index_type, + & markEnd, compact, ioUnit ) + C !DESCRIPTION: C *==========================================================* -C | o SUBROUTINE PRINT_LIST_R8 +C | o SUBROUTINE PRINT\_LIST\_RL C *==========================================================* -C | Routine for producing list of values for a field with -C | duplicate values collected into -C | n @ value -C | record. +C | Routine for producing list of values for a field with +C | duplicate values collected into +C | n \@ value +C | record. C *==========================================================* C !USES: + IMPLICIT NONE + C == Global data == #include "SIZE.h" #include "EEPARAMS.h" C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == -C fld - Data to be printed -C lFld - Number of elements to be printed -C index_type - Flag indicating which type of index to print +C fld :: Data to be printed +C iFirst :: First element to print +C iLast :: Last element to print +C index_type :: Flag indicating which type of index to print C INDEX_K => /* K = nnn */ C INDEX_I => /* I = nnn */ C INDEX_J => /* J = nnn */ C INDEX_NONE => -C compact - Flag to control use of repeat symbol for same valued -C fields. -C markEnd - Flag to control whether there is a separator after the +C markEnd :: Flag to control whether there is a separator after the C last element -C ioUnit - Unit number for IO. - INTEGER lFld +C compact :: Flag to control use of repeat symbol for same valued +C fields. +C ioUnit :: Unit number for IO. + INTEGER iFirst, iLast + _RL fld(iFirst:iLast) INTEGER index_type - Real*8 fld(lFld) LOGICAL markEnd LOGICAL compact INTEGER ioUnit @@ -430,11 +597,12 @@ INTEGER iLo INTEGER iHi INTEGER nDup - Real*8 xNew, xOld + _RL xNew, xOld CHARACTER punc CHARACTER*(MAX_LEN_MBUF) msgBuf CHARACTER*2 commOpen,commClose CHARACTER*3 index_lab + CHARACTER*25 fmt1, fmt2 INTEGER K CEOP @@ -447,29 +615,36 @@ ELSE index_lab = '?=' ENDIF +C- fortran format to write 1 or 2 indices: + fmt1='(A,1X,A,I3,1X,A)' + fmt2='(A,1X,A,I3,A,I3,1X,A)' + IF ( iLast.GE.1000 ) THEN + K = 1+INT(LOG10(FLOAT(iLast))) + WRITE(fmt1,'(A,I1,A)') '(A,1X,A,I',K,',1X,A)' + WRITE(fmt2,'(A,I1,A,I1,A)') '(A,1X,A,I',K,',A,I',K,',1X,A)' + ENDIF commOpen = '/*' commClose = '*/' - iLo = 1 - iHi = 1 + iLo = iFirst + iHi = iFirst punc = ',' - xOld = fld(1) - DO K=2,lFld + xOld = fld(iFirst) + DO K = iFirst+1,iLast xNew = fld(K ) IF ( .NOT. compact .OR. (xNew .NE. xOld) ) THEN nDup = iHi-iLo+1 IF ( nDup .EQ. 1 ) THEN WRITE(msgBuf,'(A,1PE23.15,A)') ' ',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),fmt1) & commOpen,index_lab,iLo,commClose ELSE WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),fmt2) & commOpen,index_lab,iLo,':',iHi,commClose ENDIF - CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, - & SQUEEZE_RIGHT , 1) + CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1) iLo = K iHi = K xOld = xNew @@ -482,21 +657,21 @@ nDup = iHi-iLo+1 IF ( nDup .EQ. 1 ) THEN WRITE(msgBuf,'(A,1PE23.15,A)') ' ',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),fmt1) & commOpen,index_lab,iLo,commClose ELSEIF( nDup .GT. 1 ) THEN WRITE(msgBuf,'(I5,'' '',A,1PE23.15,A)') nDup,'@',xOld,punc - IF ( index_type .NE. INDEX_NONE ) - & WRITE(msgBuf(45:),'(A,1X,A,I3,A,I3,1X,A)') + IF ( index_type .NE. INDEX_NONE ) + & WRITE(msgBuf(45:),fmt2) & commOpen,index_lab,iLo,':',iHi,commClose ENDIF - CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, - & SQUEEZE_RIGHT , 1) + CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1) RETURN END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP C !ROUTINE: PRINT_MAPRS C !INTERFACE: @@ -507,39 +682,36 @@ I kMin, kMax, kStr, I bxMin, bxMax, bxStr, I byMin, byMax, byStr ) - IMPLICIT NONE + C !DESCRIPTION: C *==========================================================* -C | SUBROUTINE PRINT_MAPR4 -C | o Does textual mapping printing of a field. +C | SUBROUTINE PRINT\_MAPRS +C | o Does textual mapping printing of a field. C *==========================================================* -C | This routine does the actual formatting of the data -C | and printing to a file. It assumes an array using the -C | MITgcm UV indexing scheme and base index variables. -C | User code should call an interface routine like -C | PLOT_FIELD_XYR4( ... ) rather than this code directly. -C | Text plots can be oriented XY, YZ, XZ. An orientation -C | is specficied through the "plotMode" argument. All the -C | plots made by a single call to this routine will use the -C | same contour interval. The plot range (iMin,...,byStr) -C | can be three-dimensional. A separate plot is made for -C | each point in the plot range normal to the orientation. -C | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY). -C | kMin =1, kMax = 5 and kStr = 2 will produce three XY -C | plots - one for K=1, one for K=3 and one for K=5. -C | Each plot would have extents iMin:iMax step iStr -C | and jMin:jMax step jStr. +C | This routine does the actual formatting of the data +C | and printing to a file. It assumes an array using the +C | MITgcm UV indexing scheme and base index variables. +C | User code should call an interface routine like +C | PLOT\_FIELD\_XYRS( ... ) rather than this code directly. +C | Text plots can be oriented XY, YZ, XZ. An orientation +C | is specficied through the "plotMode" argument. All the +C | plots made by a single call to this routine will use the +C | same contour interval. The plot range (iMin,...,byStr) +C | can be three-dimensional. A separate plot is made for +C | each point in the plot range normal to the orientation. +C | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY). +C | kMin =1, kMax = 5 and kStr = 2 will produce three XY +C | plots - one for K=1, one for K=3 and one for K=5. +C | Each plot would have extents iMin:iMax step iStr +C | and jMin:jMax step jStr. C *==========================================================* C !USES: + IMPLICIT NONE + C == Global variables == #include "SIZE.h" #include "EEPARAMS.h" -#include "EESUPPORT.h" - INTEGER IFNBLNK - EXTERNAL IFNBLNK - INTEGER ILNBLNK - EXTERNAL ILNBLNK C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == @@ -552,7 +724,7 @@ C kLo, kHi C nBx, nBy C iMin, iMax - Indexing for points to plot. Points from -C iStr iMin -> iMax in steps of iStr are plotted +C iStr iMin -> iMax in steps of iStr are plotted C jMin. jMax and similarly for jMin, jMax, jStr and C jStr kMin, kMax, kStr and bxMin, bxMax, bxStr C kMin, kMax byMin, byMax, byStr. @@ -570,6 +742,12 @@ INTEGER bxMin, bxMax, bxStr INTEGER byMin, byMax, byStr +C !FUNCTIONS: + INTEGER IFNBLNK + EXTERNAL IFNBLNK + INTEGER ILNBLNK + EXTERNAL ILNBLNK + C !LOCAL VARIABLES: C == Local variables == C plotBuf - Buffer for building plot record @@ -594,7 +772,7 @@ C Max - End index within block C Str - stride within block INTEGER MAX_LEN_PLOTBUF - PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 ) + PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-20 ) CHARACTER*(MAX_LEN_PLOTBUF) plotBuf CHARACTER*(MAX_LEN_MBUF) msgBuf INTEGER lChList @@ -634,9 +812,9 @@ DO J=jMin, jMax, jStr DO I=iMin, iMax, iStr IF (printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0.) THEN - IF ( fld(I,J,K,bi,bj) .LT. fMin ) + IF ( fld(I,J,K,bi,bj) .LT. fMin ) & fMin = fld(I,J,K,bi,bj) - IF ( fld(I,J,K,bi,bj) .GT. fMax ) + IF ( fld(I,J,K,bi,bj) .GT. fMax ) & fMax = fld(I,J,K,bi,bj) ENDIF ENDDO @@ -645,12 +823,10 @@ ENDDO ENDDO fRange = fMax-fMin - IF ( fRange .GT. small .AND. - & (MAX_LEN_PLOTBUF-35) .GT. sNx*nSx .AND. - & (MAX_LEN_PLOTBUF-35) .GT. sNy*nSy ) validRange = .TRUE. + IF ( fRange .GT. small ) validRange = .TRUE. C-- Write field title and statistics - msgBuf = + msgBuf = & '// =======================================================' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) @@ -709,11 +885,19 @@ & ':',kStr,')' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) - msgBuf = + msgBuf = & '// =======================================================' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) +c if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN +c msgBuf = +c & 'Model domain too big to print to terminal - skipping I/O' +c CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, +c & SQUEEZE_RIGHT, 1) +c RETURN +c endif + C-- Write field C Figure out slice type and set plotting parameters appropriately C acc = accross the page @@ -806,6 +990,15 @@ pltStep = sNy pltLab = 'J =' ENDIF +C- check if it fits into buffer (-10 should be enough but -12 is safer): + IF ( (accMax-accMin+1)*(accBhi-accBlo+1).GT.MAX_LEN_PLOTBUF-12 + & .AND. validRange ) THEN + msgBuf = + & 'Model domain too big to print to terminal - skipping I/O' + CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, + & SQUEEZE_RIGHT, 1) + validRange = .FALSE. + ENDIF IF ( validRange ) THEN C Header C Data @@ -816,7 +1009,7 @@ CALL PRINT_MESSAGE(plotBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) plotBuf = ' ' - iBuf = 6 + iBuf = 6 DO bi=accBlo, accBhi, accBstr DO I=accMin, accMax, accStr iDx = accBase-1+(bi-1)*accStep+I @@ -838,7 +1031,7 @@ CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) plotBuf = dwnLab - iBuf = 7 + iBuf = 7 DO bi=accBlo, accBhi, accBstr DO I=accMin, accMax, accStr iDx = accBase-1+(bi-1)*accStep+I @@ -846,7 +1039,7 @@ IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN WRITE(plotBuf(iBuf:),'(A)') '|' ELSE - WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10) + WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10) ENDIF ENDDO ENDDO @@ -855,7 +1048,7 @@ & SQUEEZE_RIGHT, 1) DO bj=dwnBlo, dwnBhi, dwnBStr DO J=dwnMin, dwnMax, dwnStr - WRITE(plotBuf,'(1X,I5,1X)') + WRITE(plotBuf,'(1X,I5,1X)') & dwnBase-1+(bj-1)*dwnStep+J iBuf = 7 DO bi=accBlo,accBhi,accBstr @@ -869,16 +1062,16 @@ val = fld(K,I,J,bk,bi) ENDIF IF ( validRange .AND. val .NE. 0. ) THEN - IDX = NINT( - & FLOAT( lChList-1 )*( val-fMin ) / (fRange) + IDX = NINT( + & FLOAT( lChList-1 )*( val-fMin ) / (fRange) & )+1 ELSE IDX = 1 ENDIF - IF ( iBuf .LE. MAX_LEN_PLOTBUF ) + IF ( iBuf .LE. MAX_LEN_PLOTBUF ) & plotBuf(iBuf:iBuf) = chList(IDX:IDX) IF ( val .EQ. 0. ) THEN - IF ( iBuf .LE. MAX_LEN_PLOTBUF ) + IF ( iBuf .LE. MAX_LEN_PLOTBUF ) & plotBuf(iBuf:iBuf) = '.' ENDIF ENDDO @@ -892,15 +1085,15 @@ ENDDO ENDIF C-- Write delimiter - msgBuf = + msgBuf = & '// =======================================================' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) - msgBuf = + msgBuf = & '// END OF FIELD =' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) - msgBuf = + msgBuf = & '// =======================================================' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) @@ -911,9 +1104,9 @@ RETURN END +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP C !ROUTINE: PRINT_MAPRL - C !INTERFACE: SUBROUTINE PRINT_MAPRL ( fld, fldTitle, plotMode, I iLo, iHi, jLo, jHi, kLo, kHi, nBx, nBy, @@ -922,40 +1115,36 @@ I kMin, kMax, kStr, I bxMin, bxMax, bxStr, I byMin, byMax, byStr ) - IMPLICIT NONE C !DESCRIPTION: C *==========================================================* -C | SUBROUTINE PRINT_MAPRL -C | o Does textual mapping printing of a field. +C | SUBROUTINE PRINT\_MAPRL +C | o Does textual mapping printing of a field. C *==========================================================* -C | This routine does the actual formatting of the data -C | and printing to a file. It assumes an array using the -C | MITgcm UV indexing scheme and base index variables. -C | User code should call an interface routine like -C | PLOT_FIELD_XYR8( ... ) rather than this code directly. -C | Text plots can be oriented XY, YZ, XZ. An orientation -C | is specficied through the "plotMode" argument. All the -C | plots made by a single call to this routine will use the -C | same contour interval. The plot range (iMin,...,byStr) -C | can be three-dimensional. A separate plot is made for -C | each point in the plot range normal to the orientation. -C | e.g. if the orientation is XY (plotMode = PRINT_MAP_XY). -C | kMin =1, kMax = 5 and kStr = 2 will produce three XY -C | plots - one for K=1, one for K=3 and one for K=5. -C | Each plot would have extents iMin:iMax step iStr -C | and jMin:jMax step jStr. +C | This routine does the actual formatting of the data +C | and printing to a file. It assumes an array using the +C | MITgcm UV indexing scheme and base index variables. +C | User code should call an interface routine like +C | PLOT\_FIELD\_XYRL( ... ) rather than this code directly. +C | Text plots can be oriented XY, YZ, XZ. An orientation +C | is specficied through the "plotMode" argument. All the +C | plots made by a single call to this routine will use the +C | same contour interval. The plot range (iMin,...,byStr) +C | can be three-dimensional. A separate plot is made for +C | each point in the plot range normal to the orientation. +C | e.g. if the orientation is XY (plotMode = PRINT\_MAP\_XY). +C | kMin =1, kMax = 5 and kStr = 2 will produce three XY +C | plots - one for K=1, one for K=3 and one for K=5. +C | Each plot would have extents iMin:iMax step iStr +C | and jMin:jMax step jStr. C *==========================================================* C !USES: + IMPLICIT NONE + C == Global variables == #include "SIZE.h" #include "EEPARAMS.h" -#include "EESUPPORT.h" - INTEGER IFNBLNK - EXTERNAL IFNBLNK - INTEGER ILNBLNK - EXTERNAL ILNBLNK C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == @@ -968,7 +1157,7 @@ C kLo, kHi C nBx, nBy C iMin, iMax - Indexing for points to plot. Points from -C iStr iMin -> iMax in steps of iStr are plotted +C iStr iMin -> iMax in steps of iStr are plotted C jMin. jMax and similarly for jMin, jMax, jStr and C jStr kMin, kMax, kStr and bxMin, bxMax, bxStr C kMin, kMax byMin, byMax, byStr. @@ -986,6 +1175,12 @@ INTEGER bxMin, bxMax, bxStr INTEGER byMin, byMax, byStr +C !FUNCTIONS: + INTEGER IFNBLNK + EXTERNAL IFNBLNK + INTEGER ILNBLNK + EXTERNAL ILNBLNK + C !LOCAL VARIABLES: C == Local variables == C plotBuf - Buffer for building plot record @@ -1010,7 +1205,7 @@ C Max - End index within block C Str - stride within block INTEGER MAX_LEN_PLOTBUF - PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-4 ) + PARAMETER ( MAX_LEN_PLOTBUF = MAX_LEN_MBUF-20 ) CHARACTER*(MAX_LEN_PLOTBUF) plotBuf CHARACTER*(MAX_LEN_MBUF) msgBuf INTEGER lChList @@ -1049,11 +1244,11 @@ DO K=kMin, kMax, kStr DO J=jMin, jMax, jStr DO I=iMin, iMax, iStr - IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. ) + IF ( printMapIncludesZeros .OR. fld(I,J,K,bi,bj) .NE. 0. ) & THEN - IF ( fld(I,J,K,bi,bj) .LT. fMin ) + IF ( fld(I,J,K,bi,bj) .LT. fMin ) & fMin = fld(I,J,K,bi,bj) - IF ( fld(I,J,K,bi,bj) .GT. fMax ) + IF ( fld(I,J,K,bi,bj) .GT. fMax ) & fMax = fld(I,J,K,bi,bj) ENDIF ENDDO @@ -1062,12 +1257,10 @@ ENDDO ENDDO fRange = fMax-fMin - IF ( fRange .GT. small .AND. - & (MAX_LEN_PLOTBUF-35) .GT. sNx*nSx .AND. - & (MAX_LEN_PLOTBUF-35) .GT. sNy*nSy ) validRange = .TRUE. + IF ( fRange .GT. small ) validRange = .TRUE. C-- Write field title and statistics - msgBuf = + msgBuf = & '// =======================================================' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) @@ -1126,11 +1319,19 @@ & ':',kStr,')' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) - msgBuf = + msgBuf = & '// =======================================================' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) +c if (Nx.gt.MAX_LEN_PLOTBUF-20) THEN +c msgBuf = +c & 'Model domain too big to print to terminal - skipping I/O' +c CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, +c & SQUEEZE_RIGHT, 1) +c RETURN +c endif + C-- Write field C Figure out slice type and set plotting parameters appropriately C acc = accross the page @@ -1223,6 +1424,15 @@ pltStep = sNy pltLab = 'J =' ENDIF +C- check if it fits into buffer (-10 should be enough but -12 is safer): + IF ( (accMax-accMin+1)*(accBhi-accBlo+1).GT.MAX_LEN_PLOTBUF-12 + & .AND. validRange ) THEN + msgBuf = + & 'Model domain too big to print to terminal - skipping I/O' + CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, + & SQUEEZE_RIGHT, 1) + validRange = .FALSE. + ENDIF IF ( validRange ) THEN C Header C Data @@ -1233,7 +1443,7 @@ CALL PRINT_MESSAGE(plotBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) plotBuf = ' ' - iBuf = 6 + iBuf = 6 DO bi=accBlo, accBhi, accBstr DO I=accMin, accMax, accStr iDx = accBase-1+(bi-1)*accStep+I @@ -1254,7 +1464,7 @@ CALL PRINT_MESSAGE(plotBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) plotBuf = dwnLab - iBuf = 7 + iBuf = 7 DO bi=accBlo, accBhi, accBstr DO I=accMin, accMax, accStr iDx = accBase-1+(bi-1)*accStep+I @@ -1262,7 +1472,7 @@ IF ( 10*((iBuf-7)/10) .EQ. iBuf-7 ) THEN WRITE(plotBuf(iBuf:),'(A)') '|' ELSE - WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(iDx,10) + WRITE(plotBuf(iBuf:iBuf),'(I1)') MOD(ABS(iDx),10) ENDIF ENDDO ENDDO @@ -1270,7 +1480,7 @@ & SQUEEZE_RIGHT, 1) DO bj=dwnBlo, dwnBhi, dwnBStr DO J=dwnMin, dwnMax, dwnStr - WRITE(plotBuf,'(1X,I5,1X)') + WRITE(plotBuf,'(1X,I5,1X)') & dwnBase-1+(bj-1)*dwnStep+J iBuf = 7 DO bi=accBlo,accBhi,accBstr @@ -1284,16 +1494,16 @@ val = fld(K,I,J,bk,bi) ENDIF IF ( validRange .AND. val .NE. 0. ) THEN - IDX = NINT( - & FLOAT( lChList-1 )*( val-fMin ) / (fRange) + IDX = NINT( + & FLOAT( lChList-1 )*( val-fMin ) / (fRange) & )+1 ELSE IDX = 1 ENDIF - IF ( iBuf .LE. MAX_LEN_PLOTBUF ) + IF ( iBuf .LE. MAX_LEN_PLOTBUF ) & plotBuf(iBuf:iBuf) = chList(IDX:IDX) IF ( val .EQ. 0. ) THEN - IF ( iBuf .LE. MAX_LEN_PLOTBUF ) + IF ( iBuf .LE. MAX_LEN_PLOTBUF ) & plotBuf(iBuf:iBuf) = '.' ENDIF ENDDO @@ -1306,15 +1516,15 @@ ENDDO ENDIF C-- Write delimiter - msgBuf = + msgBuf = & '// =======================================================' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) - msgBuf = + msgBuf = & '// END OF FIELD =' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) - msgBuf = + msgBuf = & '// =======================================================' CALL PRINT_MESSAGE(msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, 1) @@ -1324,127 +1534,3 @@ RETURN END - -CBOP -C !ROUTINE: PRINT_MESSAGE - -C !INTERFACE: - SUBROUTINE PRINT_MESSAGE( message, unit, sq , myThid ) - IMPLICIT NONE -C !DESCRIPTION: -C *============================================================* -C | SUBROUTINE PRINT_MESSAGE -C | o Write out informational message using "standard" format. -C *============================================================* -C | Notes -C | ===== -C | o Some system I/O is not "thread-safe". For this reason -C | without the FMTFTN_IO_THREAD_SAFE directive set a -C | critical region is defined around the write here. In some -C | cases BEGIN_CRIT() is approximated by only doing writes -C | for thread number 1 - writes for other threads are -C | ignored! -C | o In a non-parallel form these routines can still be used. -C | to produce pretty printed output! -C *============================================================* - -C !USES: -C == Global data == -#include "SIZE.h" -#include "EEPARAMS.h" -#include "EESUPPORT.h" - INTEGER IFNBLNK - EXTERNAL IFNBLNK - INTEGER ILNBLNK - EXTERNAL ILNBLNK - -C !INPUT/OUTPUT PARAMETERS: -C == Routine arguments == -C message :: Message to write -C unit :: Unit number to write to -C sq :: Justification option - CHARACTER*(*) message - INTEGER unit - CHARACTER*(*) sq - INTEGER myThid - -C !LOCAL VARIABLES: -C == Local variables == -C iStart, iEnd :: String indexing variables -C idString :: Temp. for building prefix. - INTEGER iStart - INTEGER iEnd - CHARACTER*9 idString -CEOP - -C-- Find beginning and end of message - IF ( sq .EQ. SQUEEZE_BOTH .OR. - & sq .EQ. SQUEEZE_LEFT ) THEN - iStart = IFNBLNK( message ) - ELSE - iStart = 1 - ENDIF - IF ( sq .EQ. SQUEEZE_BOTH .OR. - & sq .EQ. SQUEEZE_RIGHT ) THEN - iEnd = ILNBLNK( message ) - ELSE - iEnd = LEN(message) - ENDIF -C-- Test to see if in multi-process ( or multi-threaded ) mode. -C If so include process or thread identifier. - IF ( numberOfProcs .EQ. 0 .AND. nThreads .EQ. 1 ) THEN -C-- Write single process format - IF ( message .EQ. ' ' ) THEN - WRITE(unit,'(A)') ' ' - ELSE - WRITE(unit,'(A)') message(iStart:iEnd) - ENDIF - ELSEIF ( pidIO .EQ. myProcId ) THEN -C-- Write multi-process format -#ifndef FMTFTN_IO_THREAD_SAFE - _BEGIN_CRIT(myThid) -#endif - WRITE(idString,'(I4.4,A,I4.4)') myProcId,'.',myThid -#ifndef FMTFTN_IO_THREAD_SAFE - _END_CRIT(myThid) -#endif - IF ( message .EQ. ' ' ) THEN -C PRINT can be called by several threads simultaneously. -C The write statement may need to ne marked as a critical section. -#ifndef FMTFTN_IO_THREAD_SAFE - _BEGIN_CRIT(myThid) -#endif - WRITE(unit,'(A,A,A,A,A,A)',ERR=999) - & '(',PROCESS_HEADER,' ',idString,')',' ' -#ifndef FMTFTN_IO_THREAD_SAFE - _END_CRIT(myThid) -#endif - ELSE -#ifndef FMTFTN_IO_THREAD_SAFE - _BEGIN_CRIT(myThid) -#endif - WRITE(unit,'(A,A,A,A,A,A,A)',ERR=999) - & '(',PROCESS_HEADER,' ',idString(1:ILNBLNK(idString)),')',' ', - & message(iStart:iEnd) -#ifndef FMTFTN_IO_THREAD_SAFE - _END_CRIT(myThid) -#endif - ENDIF - ENDIF - -#ifndef DISABLE_WRITE_TO_UNIT_ZERO -C-- if error message, also write directly to unit 0 : - IF ( numberOfProcs .EQ. 1 .AND. nThreads .EQ. 1 - & .AND. unit.EQ.errorMessageUnit ) THEN - iEnd = ILNBLNK( message ) - IF (iEnd.NE.0) WRITE(0,'(A)') message(1:iEnd) - ENDIF -#endif -C - 1000 CONTINUE - RETURN - 999 CONTINUE - ioErrorCount(myThid) = ioErrorCount(myThid)+1 - GOTO 1000 - - END