*IF DEF,C80_1A,OR,DEF,RECON,OR,DEF,UTILIO,OR,DEF,FLDIO,OR,DEF,UTILHIST GKR1F405.18
C ******************************COPYRIGHT****************************** PR_F_C1A.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. PR_F_C1A.4
C PR_F_C1A.5
C Use, duplication or disclosure of this code is subject to the PR_F_C1A.6
C restrictions as set forth in the contract. PR_F_C1A.7
C PR_F_C1A.8
C Meteorological Office PR_F_C1A.9
C London Road PR_F_C1A.10
C BRACKNELL PR_F_C1A.11
C Berkshire UK PR_F_C1A.12
C RG12 2SZ PR_F_C1A.13
C PR_F_C1A.14
C If no contract has been raised with this copy of the code, the use, PR_F_C1A.15
C duplication or disclosure of it is strictly prohibited. Permission PR_F_C1A.16
C to do so must first be obtained in writing from the Head of Numerical PR_F_C1A.17
C Modelling at the above address. PR_F_C1A.18
C ******************************COPYRIGHT****************************** PR_F_C1A.19
C PR_F_C1A.20
CLL Routine: PR_F_C1A ------------------------------------------------ PR_F_C1A.21
CLL PR_F_C1A.22
CLL Purpose: To print messages generated by the I/O routines in C PR_F_C1A.23
CLL PR_F_C1A.24
CLL Author: Bob Carruthers, Cray Research. Date: 31 June 1997 PR_F_C1A.25
CLL GKR1F405.14
CLL Version Date Modification history GKR1F405.15
CLL 4.5 09/10/98 Added def UTILHIST to top def line to allow GKR1F405.16
CLL history executables to be built. K Rogers GKR1F405.17
CLL PR_F_C1A.26
CLL ------------------------------------------------------------------- PR_F_C1A.27
C*L Interface and arguments: ------------------------------------------ PR_F_C1A.28
subroutine print_from_c(unit, message) ,1PR_F_C1A.29
implicit none PR_F_C1A.30
c PR_F_C1A.31
integer unit ! the nuit number that the message PR_F_C1A.32
! applies to, or -1 if there is no PR_F_C1A.33
! unit number. PR_F_C1A.34
c PR_F_C1A.35
character*(*) message ! the text of the message PR_F_C1A.36
c PR_F_C1A.37
character*256 old_message ! the text of the last message PR_F_C1A.38
c PR_F_C1A.39
integer PR_F_C1A.40
2 old_unit ! the unit number for the last message PR_F_C1A.41
3 ,i ! loop index PR_F_C1A.42
4 ,message_count ! count of the number of times the last PR_F_C1A.43
! message appeared, after the first time PR_F_C1A.44
5 ,get_char_len ! function to find the length of a PR_F_C1A.45
! character variable, ignoring trailing PR_F_C1A.46
! blanks. PR_F_C1A.47
6 ,l ! length of the message from PR_F_C1A.48
! get_char_len PR_F_C1A.49
7 ,old_l ! length of the old message PR_F_C1A.50
c PR_F_C1A.51
save old_unit, old_message, message_count PR_F_C1A.52
data old_unit/-2/, message_count/0/, old_l/1/, PR_F_C1A.53
2 old_message/'?????????'/ PR_F_C1A.54
c PR_F_C1A.55
l=get_char_len
(message) PR_F_C1A.56
if(old_unit.eq.unit .and. old_message(1:l).eq.message(1:l)) then PR_F_C1A.57
message_count=message_count+1 PR_F_C1A.58
else PR_F_C1A.59
if(message_count.gt.0) then PR_F_C1A.60
write(6,'(a,'' - Repeated '',i3, PR_F_C1A.61
2 '' Time(s)'')') old_message(1:old_l), message_count PR_F_C1A.62
endif PR_F_C1A.63
*IF DEF,T3E,AND,DEF,DIAG92 PR_F_C1A.64
if(unit.eq.17) then PR_F_C1A.65
do i=1, n$pes PR_F_C1A.66
if(my_pe().eq.i-1) then PR_F_C1A.67
if(unit.ne.old_unit .and. i.eq.1) write(0,'('' '')') PR_F_C1A.68
write(0,'(a)') message(1:l) PR_F_C1A.69
if(unit.ne.old_unit .and. i.eq.1) write(6,'('' '')') PR_F_C1A.70
write(6,'(a)') message(1:l) PR_F_C1A.71
endif PR_F_C1A.72
call barrier() PR_F_C1A.73
end do PR_F_C1A.74
else PR_F_C1A.75
if(unit.ne.old_unit) write(0,'('' '')') PR_F_C1A.76
write(0,'(a)') message(1:l) PR_F_C1A.77
if(unit.ne.old_unit) write(6,'('' '')') PR_F_C1A.78
write(6,'(a)') message(1:l) PR_F_C1A.79
endif PR_F_C1A.80
*ELSE PR_F_C1A.81
if(unit.ne.old_unit) write(6,'('' '')') PR_F_C1A.82
write(6,'(a)') message(1:l) PR_F_C1A.83
*ENDIF PR_F_C1A.84
message_count=0 PR_F_C1A.85
old_message=message PR_F_C1A.86
old_l=l PR_F_C1A.87
old_unit=unit PR_F_C1A.88
endif PR_F_C1A.89
return PR_F_C1A.90
end PR_F_C1A.91
*ENDIF PR_F_C1A.92