*IF DEF,FLUXPROC FPRDDBG1.2
C ******************************COPYRIGHT****************************** FPRDDBG1.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPRDDBG1.4
C FPRDDBG1.5
C Use, duplication or disclosure of this code is subject to the FPRDDBG1.6
C restrictions as set forth in the contract. FPRDDBG1.7
C FPRDDBG1.8
C Meteorological Office FPRDDBG1.9
C London Road FPRDDBG1.10
C BRACKNELL FPRDDBG1.11
C Berkshire UK FPRDDBG1.12
C RG12 2SZ FPRDDBG1.13
C FPRDDBG1.14
C If no contract has been raised with this copy of the code, the use, FPRDDBG1.15
C duplication or disclosure of it is strictly prohibited. Permission FPRDDBG1.16
C to do so must first be obtained in writing from the Head of Numerical FPRDDBG1.17
C Modelling at the above address. FPRDDBG1.18
C ******************************COPYRIGHT****************************** FPRDDBG1.19
C FPRDDBG1.20
C Programming standard: Unified Model Documentation Paper No 3 FPRDDBG1.21
C Version No 1 15/1/90 FPRDDBG1.22
C History: FPRDDBG1.23
C version date change FPRDDBG1.24
C 4.5 03/09/98 New code FPRDDBG1.25
C FPRDDBG1.26
! Author: M. J. Bell FPRDDBG1.27
!---------------------------------------------------------------------- FPRDDBG1.28
! contains routines: read_debug_cntl FPRDDBG1.29
! FPRDDBG1.30
! Purpose: Flux processing routine. FPRDDBG1.31
! Reads files controlling diagnostic "debugging" output FPRDDBG1.32
!---------------------------------------------------------------------- FPRDDBG1.33
subroutine read_debug_cntl ( icode ) 1,1FPRDDBG1.34
FPRDDBG1.35
implicit none FPRDDBG1.36
FPRDDBG1.37
! declaration of argument list FPRDDBG1.38
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPRDDBG1.39
FPRDDBG1.40
! declaration of parameters FPRDDBG1.41
FPRDDBG1.42
! declaration of globals used FPRDDBG1.43
*CALL CUNITNOS 
FPRDDBG1.44
*CALL CMESS FPRDDBG1.45
*CALL CDEBUG FPRDDBG1.46
FPRDDBG1.47
! No local arrays FPRDDBG1.48
FPRDDBG1.49
! declaration of local scalars FPRDDBG1.50
integer i ! loop index FPRDDBG1.51
FPRDDBG1.52
! namelist declaration FPRDDBG1.53
NAMELIST /NmLstDbg/ FPRDDBG1.54
# NoDbgPts, FPRDDBG1.55
# IColDbg, JRowDbg, FPRDDBG1.56
# l_winds_dbg, l_heat_dbg, l_moisture_dbg, FPRDDBG1.57
# l_sea_ice_dbg, l_references_dbg, l_pressure_dbg, FPRDDBG1.58
# l_windspd_dbg FPRDDBG1.59
FPRDDBG1.60
!---------------------------------------------------------------------- FPRDDBG1.61
! 0. Preliminaries FPRDDBG1.62
CSub = 'read_debug_cntl' ! subroutine name for error messages FPRDDBG1.63
FPRDDBG1.64
! 1. set default values for variables in NmLstDbg FPRDDBG1.65
NoDbgPts = 0 FPRDDBG1.66
FPRDDBG1.67
do i = 1, MaxNoDbgPts FPRDDBG1.68
IColDbg(i) = 1 FPRDDBG1.69
JRowDbg(i) = 1 FPRDDBG1.70
end do FPRDDBG1.71
FPRDDBG1.72
l_winds_dbg = .false. FPRDDBG1.73
l_heat_dbg = .false. FPRDDBG1.74
l_moisture_dbg = .false. FPRDDBG1.75
l_sea_ice_dbg = .false. FPRDDBG1.76
l_references_dbg = .false. FPRDDBG1.77
l_pressure_dbg = .false. FPRDDBG1.78
l_windspd_dbg = .false. FPRDDBG1.79
FPRDDBG1.80
! 2. read debug control namelist FPRDDBG1.81
read (UnitDbg, NmLstDbg, iostat = icode) FPRDDBG1.82
FPRDDBG1.83
if ( icode .ne. 0 ) then FPRDDBG1.84
write(UnErr,*)CErr,CSub, FPRDDBG1.85
# ' step 2. unable to read debug control namelist' FPRDDBG1.86
icode = 8 FPRDDBG1.87
go to 9999 FPRDDBG1.88
end if FPRDDBG1.89
FPRDDBG1.90
! 3. open file for debugging output FPRDDBG1.91
call Open_file(OutUnitDbg,'Formatted ','Unknown',icode) FPRDDBG1.92
if (icode .ne. 0) then FPRDDBG1.93
write(UnErr,*)CErr,CSub, FPRDDBG1.94
# ' step 3. unable to open file for debugging output' FPRDDBG1.95
icode = 9 FPRDDBG1.96
go to 9999 FPRDDBG1.97
end if FPRDDBG1.98
FPRDDBG1.99
C 4. read and write out contents of namelist FPRDDBG1.100
write(OutUnitDbg, NmLstDbg) FPRDDBG1.101
FPRDDBG1.102
if ( NoDbgPts .le. 0) then FPRDDBG1.103
write(OutUnitDbg, *) ' no points to output ' FPRDDBG1.104
else FPRDDBG1.105
write(OutUnitDbg, *) ' columns of output: ' FPRDDBG1.106
write(OutUnitDbg, '(11I11)' ) (IColDbg(i), i=1,NoDbgPts) FPRDDBG1.107
write(OutUnitDbg, *) ' rows of output: ' FPRDDBG1.108
write(OutUnitDbg, '(11I11)' ) (JRowDbg(i), i=1,NoDbgPts) FPRDDBG1.109
end if FPRDDBG1.110
FPRDDBG1.111
9999 continue FPRDDBG1.112
return FPRDDBG1.113
end FPRDDBG1.114
!---------------------------------------------------------------------- FPRDDBG1.115
*ENDIF FPRDDBG1.116