Skip to content

Commit ee66188

Browse files
author
Joe Hamman
authored
Merge pull request #1 from jhamman/fix/uh_convolution
Fix/uh_convolution
2 parents 8ad59be + f80f9eb commit ee66188

File tree

7 files changed

+75
-111
lines changed

7 files changed

+75
-111
lines changed

‎src/Makefile‎

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,12 @@
11
########################################################################
2-
### rout.f makefile ####################################################
2+
### rout.f makefile ####################################################
33
########################################################################
44
#
55
# Routing algorithm written D. Lohmann
66
#
77
# This is a slightly modified code (main algotrithms unchanged -IO and
88
# array dimensions simplified).
99
# Maintained by G. O'Donnell ([email protected]) and Andy Wood
10-
#
11-
# $Id: Makefile,v 1.1 2005/04/07 05:07:28 vicadmin Exp $
1210
#
1311

1412
#This program uses the non-standard Fortran argument GETARG
@@ -22,7 +20,7 @@ FFLAGS = -O -C -ffixed-line-length-none
2220
#for debugging
2321
#FFLAGS = -C -g -lm -ffixed-line-length-none
2422

25-
FC=g77
23+
FC=gfortran
2624

2725
HFILES= parameter.h
2826

‎src/init_routines.f‎

Lines changed: 8 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -10,10 +10,6 @@ SUBROUTINE INIT_ARRAY( A, NROW, NCOL, VALUE )
1010

1111
IMPLICIT NONE
1212

13-
c RCS ID STRING
14-
CHARACTER*50 RCSID
15-
DATA RCSID/"$Id: init_routines.f,v 1.1 2005/04/07 05:07:28 vicadmin Exp $"/
16-
1713
INTEGER NCOL, NROW
1814
INTEGER I, J
1915
REAL A(NCOL,NROW)
@@ -65,7 +61,7 @@ SUBROUTINE CREATE_VIC_NAMES( JLOC, ILOC, EXTEN, CLEN, DPREC )
6561
END DO
6662

6763
CLEN=CLEN-1
68-
64+
6965
RETURN
7066
END
7167

@@ -95,27 +91,27 @@ SUBROUTINE SEARCH_CATCHMENT
9591
II = I
9692
JJ = J
9793
300 CONTINUE
98-
IF ((II .GT. ICOL) .OR. (II .LT.1) .OR.
94+
IF ((II .GT. ICOL) .OR. (II .LT.1) .OR.
9995
& (JJ .GT. IROW) .OR. (JJ .LT.1)) THEN
10096
GOTO 310
10197
END IF
102-
IF ((II .EQ. PI) .AND. (JJ .EQ. PJ)) THEN
98+
IF ((II .EQ. PI) .AND. (JJ .EQ. PJ)) THEN
10399
NO_OF_BOX = NO_OF_BOX + 1
104100
CATCHIJ(NO_OF_BOX,1) = I
105101
CATCHIJ(NO_OF_BOX,2) = J
106102
GOTO 310
107-
ELSE
108-
IF ((DIREC(II,JJ,1).NE.0) .AND. !check if the current
103+
ELSE
104+
IF ((DIREC(II,JJ,1).NE.0) .AND. !check if the current
109105
& (DIREC(II,JJ,2) .NE.0)) THEN !ii,jj cell routes down
110106
III = DIREC(II,JJ,1) !to the subbasin outlet
111-
JJJ = DIREC(II,JJ,2) !point, following the
107+
JJJ = DIREC(II,JJ,2) !point, following the
112108
II = III !direction of direc(,)
113109
JJ = JJJ !from each cell
114110
GOTO 300
115-
END IF !if you get there,
111+
END IF !if you get there,
116112
END IF !no_of_box increments
117113
310 CONTINUE !and you try another
118-
END DO !cell.
114+
END DO !cell.
119115
END DO
120116

121117
WRITE(*,*) 'Number of grid cells upstream of present station',

‎src/make_convolution.f‎

Lines changed: 9 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,22 +1,18 @@
11

22
SUBROUTINE MAKE_CONVOLUTION
3-
& (NCOL, NROW, NOB, PMAX, DAYS, CATCHIJ,
3+
& (NCOL, NROW, NOB, PMAX, DAYS, CATCHIJ,
44
& BASE, RUNO, FLOW, KE, UH_DAY, UH_S, FRACTION, FACTOR_SUM,
55
& XC, YC, SIZE, DPREC, INPATH,ICOL,NDAY,IDAY,IMONTH,IYEAR,
66
& MO, YR, NYR)
77

88
IMPLICIT NONE
99

10-
c RCS ID STRING
11-
CHARACTER*50 RCSID
12-
DATA RCSID/"$Id: make_convolution.f,v 1.1 2005/04/07 05:07:28 vicadmin Exp $"/
13-
1410
INTEGER N, I, J, DAYS, NDAY, II, JJ
1511
INTEGER NCOL,NROW,ICOL,NOB,PMAX,KE,UH_DAY
1612
INTEGER CATCHIJ(PMAX,2)
1713
INTEGER NYR
1814
REAL UH_S(PMAX,KE+UH_DAY-1)
19-
REAL BASE(DAYS), RUNO(DAYS), FLOW(DAYS)
15+
REAL BASE(DAYS), RUNO(DAYS), FLOW(DAYS)
2016
REAL FRACTION(NCOL,NROW)
2117

2218
REAL PI, RERD, FACTOR, FACTOR_SUM
@@ -36,17 +32,17 @@ SUBROUTINE MAKE_CONVOLUTION
3632

3733
REAL STORAGE, K_CONST
3834
REAL DUM1,DUM2
39-
35+
4036
INTEGER IDAY(DAYS), IMONTH(DAYS), IYEAR(DAYS)
4137
INTEGER MO(12*NYR),YR(12*NYR)
4238
INTEGER MISS_NUM
4339
C MISS_NUM is the number of grid cell output files not found
4440

4541
MISS_NUM=0
4642

47-
C *** 0 <= K_CONST = 1.0
43+
C *** 0 <= K_CONST = 1.0
4844
C *** K_CONST smaller 1.0 makes it a simple linear storage
49-
45+
5046
K_CONST = 1.0
5147

5248
PI = ATAN(1.0) * 4.0
@@ -66,18 +62,18 @@ SUBROUTINE MAKE_CONVOLUTION
6662
END DO
6763
II = CATCHIJ(N,1)
6864
JJ = CATCHIJ(N,2)
69-
65+
7066
c the grid has been flipped left to right
7167
c find the revised cooordinates
7268

7369
ILOC=XC + (ICOL-II)*SIZE + SIZE/2.0
7470
JLOC=YC + JJ*SIZE - SIZE/2.0
7571

76-
AREA = RERD**2*ABS(SIZE)*PI/180* !give area of box in
72+
AREA = RERD**2*ABS(SIZE)*PI/180* !give area of box in
7773
& ABS(SIN((JLOC-SIZE/2.0)*PI/180)- !square meters
7874
$ SIN((JLOC+SIZE/2.0)*PI/180))
7975

80-
76+
8177
AREA_SUM = AREA_SUM + AREA
8278

8379
c WRITE(*,*) N, ILOC, JLOC
@@ -87,7 +83,7 @@ SUBROUTINE MAKE_CONVOLUTION
8783

8884
FACTOR_SUM = FACTOR_SUM + FACTOR
8985

90-
86+
9187
call create_vic_names(jloc,iloc,loc,clen,dprec)
9288

9389
c print*, INPATH(1:INDEX(INPATH,' ')-1)//LOC(1:CLEN)

‎src/read_routines.f‎

Lines changed: 16 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
c SUBROUTINES RELATED TO READING
1+
c SUBROUTINES RELATED TO READING
22
c read_diff()
33
c read_fraction()
44
c read_grid_uh()
@@ -10,10 +10,6 @@
1010
SUBROUTINE READ_DIFF(DIFF,NCOL,NROW,FILENAME,
1111
$ IROW, ICOL)
1212

13-
c RCS ID STRING
14-
CHARACTER*50 RCSID
15-
DATA RCSID/"$Id: read_routines.f,v 1.1 2005/04/07 05:07:28 vicadmin Exp $"/
16-
1713
INTEGER NCOL,NROW,IROW,ICOL,I,J
1814
REAL DIFF(NCOL,NROW)
1915
CHARACTER*72 FILENAME
@@ -26,8 +22,8 @@ SUBROUTINE READ_DIFF(DIFF,NCOL,NROW,FILENAME,
2622
END DO
2723

2824
DO J = IROW,1,-1
29-
READ(10,*) (DIFF(I,J), I=ICOL,1,-1)
30-
END DO
25+
READ(10,*) (DIFF(I,J), I=ICOL,1,-1)
26+
END DO
3127

3228
CLOSE(10)
3329

@@ -54,8 +50,8 @@ SUBROUTINE READ_FRACTION(FRACTION,NCOL,NROW,FILENAME,
5450
END DO
5551

5652
DO J = IROW,1,-1
57-
READ(22,*) (FRACTION(I,J), I=ICOL,1,-1)
58-
END DO
53+
READ(22,*) (FRACTION(I,J), I=ICOL,1,-1)
54+
END DO
5955

6056
CLOSE(22)
6157

@@ -69,7 +65,7 @@ SUBROUTINE READ_FRACTION(FRACTION,NCOL,NROW,FILENAME,
6965
SUBROUTINE READ_GRID_UH
7066
& (UH_BOX, KE, PMAX, NOB, CATCHIJ,FILENAME)
7167

72-
68+
7369
IMPLICIT NONE
7470

7571
INTEGER KE, PMAX, NOB
@@ -105,8 +101,8 @@ SUBROUTINE READ_VELO(VELO,NCOL,NROW,FILENAME,
105101
END DO
106102

107103
DO J = IROW,1,-1
108-
READ(10,*) (VELO(I,J), I=ICOL,1,-1)
109-
END DO
104+
READ(10,*) (VELO(I,J), I=ICOL,1,-1)
105+
END DO
110106

111107
CLOSE(10)
112108

@@ -133,8 +129,8 @@ SUBROUTINE READ_XMASK(XMASK,NCOL,NROW,FILENAME,
133129
END DO
134130

135131
DO J = IROW,1,-1
136-
READ(10,*, END=20) (XMASK(I,J), I=ICOL,1,-1)
137-
END DO
132+
READ(10,*, END=20) (XMASK(I,J), I=ICOL,1,-1)
133+
END DO
138134
CLOSE(10)
139135

140136
RETURN
@@ -153,11 +149,11 @@ SUBROUTINE READ_DIREC(DIREC,NCOL,NROW,H,XC,YC,SIZE
153149
IMPLICIT NONE
154150

155151
INTEGER NCOL,NROW,I,J,IROW,ICOL,IMISS
156-
INTEGER DIREC(NCOL,NROW,2)
152+
INTEGER DIREC(NCOL,NROW,2)
157153
INTEGER H(NCOL,NROW)
158154
REAL XC, YC, SIZE
159155
CHARACTER*72 FILENAME
160-
CHARACTER*14 CDUM
156+
CHARACTER*14 CDUM
161157

162158
OPEN(10, FILE = FILENAME, FORM = 'FORMATTED',
163159
$ STATUS='OLD',ERR=9001)
@@ -174,10 +170,10 @@ SUBROUTINE READ_DIREC(DIREC,NCOL,NROW,H,XC,YC,SIZE
174170
$ irow, icol
175171
STOP
176172
ENDIF
177-
173+
178174
DO J = IROW,1,-1
179-
READ(10,*) (H(I,J), I=ICOL,1,-1)
180-
END DO
175+
READ(10,*) (H(I,J), I=ICOL,1,-1)
176+
END DO
181177
CLOSE(10)
182178

183179
DO I = 1, ICOL
@@ -194,7 +190,7 @@ SUBROUTINE READ_DIREC(DIREC,NCOL,NROW,H,XC,YC,SIZE
194190
ELSE IF (H(I,J) .EQ. 3) THEN
195191
DIREC(I,J,1) = I-1
196192
DIREC(I,J,2) = J
197-
ELSE IF (H(I,J) .EQ. 4) THEN
193+
ELSE IF (H(I,J) .EQ. 4) THEN
198194
DIREC(I,J,1) = I-1
199195
DIREC(I,J,2) = J-1
200196
ELSE IF (H(I,J) .EQ. 5) THEN
@@ -217,4 +213,3 @@ SUBROUTINE READ_DIREC(DIREC,NCOL,NROW,H,XC,YC,SIZE
217213
$ FILENAME
218214
STOP
219215
END
220-

‎src/rout.f‎

Lines changed: 17 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -9,22 +9,18 @@ PROGRAM rout
99
c See WA Hydrology Homepage for operational details.
1010

1111
c Modified 5/99 to read in the uh_s array if it has already
12-
c been generated in a previous run.
12+
c been generated in a previous run.
1313

1414
c Modified 2/2001 by edm to include month and year in output
1515
c and also check dates in VIC output files and calculate NDAYS
1616
c
1717
IMPLICIT NONE
1818

19-
c RCS ID STRING
20-
CHARACTER*50 RCSID
21-
DATA RCSID/"$Id: rout.f,v 1.1 2005/04/07 05:07:29 vicadmin Exp $"/
22-
2319
integer IARGC
2420

2521
integer isaleap
2622
external isaleap
27-
23+
2824
c change dimensions here
2925
c nrow and ncol should be larger than the grid
3026
c nyr should equal run length yrs+1
@@ -42,9 +38,9 @@ PROGRAM rout
4238
PARAMETER (UH_DAY = 96 )
4339
PARAMETER (TMAX = UH_DAY*24)
4440
PARAMETER (PMAX = 10000 )
45-
41+
4642
INTEGER DIREC(NCOL,NROW,2)
47-
REAL VELO(NCOL,NROW), DIFF(NCOL,NROW)
43+
REAL VELO(NCOL,NROW), DIFF(NCOL,NROW)
4844
REAL XMASK(NCOL,NROW), FRACTION(NCOL,NROW)
4945
REAL UH_BOX(PMAX,KE), UHM(NCOL,NROW,LE)
5046
REAL UH_S(PMAX,KE+UH_DAY-1)
@@ -55,11 +51,11 @@ PROGRAM rout
5551
INTEGER NO_OF_BOX
5652
INTEGER CATCHIJ(PMAX,2)
5753
INTEGER H(NCOL,NROW)
58-
54+
5955
INTEGER PI, PJ
6056
REAL UH_DAILY(PMAX,UH_DAY)
6157
REAL FR(TMAX,2)
62-
58+
6359
INTEGER NR
6460
INTEGER IROW, ICOL
6561
INTEGER LP,M,Y
@@ -174,7 +170,7 @@ PROGRAM rout
174170
DO J=START_MO,12*(STOP_YEAR-START_YEAR)+STOP_MO
175171
IF(M.EQ.2) THEN
176172
LP=isaleap(Y)
177-
ELSE
173+
ELSE
178174
LP=0
179175
ENDIF
180176
NDAY = NDAY+DAYS_IN_MONTH(M)+LP
@@ -205,11 +201,11 @@ PROGRAM rout
205201
C Loop over required stations
206202

207203
100 CONTINUE
208-
READ(10,*,END=110)
204+
READ(10,*,END=110)
209205
& NR, NAME, PI, PJ, AREA
210206
READ(10,'(A80)',END=110) UH_STRING !new, AW: uh_string
211207
IF (NR .EQ. 1) THEN
212-
WRITE(*,'(I2,2X,A,I4,I4,G12.6)')
208+
WRITE(*,'(I2,2X,A,I4,I4,G12.6)')
213209
& NR, NAME, PI, PJ
214210
PRINT*, 'Routing station: ', NAME
215211
c note, the arrays are flipped left to right
@@ -220,7 +216,7 @@ PROGRAM rout
220216
CALL SEARCH_CATCHMENT
221217
& (PI,PJ,DIREC,NCOL,NROW,
222218
& NO_OF_BOX,CATCHIJ,PMAX,IROW,ICOL)
223-
219+
224220
print*, 'reading grid_UH...'
225221
CALL READ_GRID_UH
226222
& (UH_BOX, KE, PMAX, NO_OF_BOX, CATCHIJ,FILENAME)
@@ -237,25 +233,25 @@ PROGRAM rout
237233
& CATCHIJ, BASE, RUNO, FLOW, KE, UH_DAY, UH_S, FRACTION,
238234
& FACTOR_SUM,XC,YC,SIZE,DPREC,INPATH,ICOL,NDAY,
239235
& IDAY,IMONTH,IYEAR, MO, YR, NYR)
240-
236+
241237
print*, 'writing data...'
242238
CALL WRITE_DATA
243-
& (FLOW, NDAY, NAME5, FACTOR_SUM, OUTPATH,IDAY,IMONTH,IYEAR)
239+
& (FLOW, NDAY, NAME5, FACTOR_SUM, OUTPATH,IDAY,IMONTH,IYEAR)
244240

245241
CALL WRITE_MONTH
246-
& (DAYS_IN_MONTH,START_YEAR, STOP_YEAR, FIRST_YEAR,
247-
& LAST_YEAR, START_MO, STOP_MO, FIRST_MO,
242+
& (DAYS_IN_MONTH,START_YEAR, STOP_YEAR, FIRST_YEAR,
243+
& LAST_YEAR, START_MO, STOP_MO, FIRST_MO,
248244
& LAST_MO,
249-
& NAME5, DAYS, FLOW, FACTOR_SUM, MONTHLY, MONTHLY_mm,
245+
& NAME5, DAYS, FLOW, FACTOR_SUM, MONTHLY, MONTHLY_mm,
250246
& YEARLY,YEARLY_mm,OUTPATH,NDAY,IMONTH,IYEAR,MO,YR,NMONTHS,NYR)
251247

252248

253249
END IF
254250
GOTO 100
255251
110 CONTINUE
256-
252+
257253
STOP
258-
9001 WRITE(*,*) 'CANNOT OPEN: ', FILE_INPUT
254+
9001 WRITE(*,*) 'CANNOT OPEN: ', FILE_INPUT
259255
END
260256
c ***********************************************
261257
c FUNCTION ISALEAP

0 commit comments

Comments
 (0)