diff --git a/src/Makefile b/src/Makefile index 88c44dd..1aca7d3 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,5 +1,5 @@ ######################################################################## -### rout.f makefile #################################################### +### rout.f makefile #################################################### ######################################################################## # # Routing algorithm written D. Lohmann @@ -7,8 +7,6 @@ # This is a slightly modified code (main algotrithms unchanged -IO and # array dimensions simplified). # Maintained by G. O'Donnell (tempgd@hydro.washington.edu) and Andy Wood -# -# $Id: Makefile,v 1.1 2005/04/07 05:07:28 vicadmin Exp $ # #This program uses the non-standard Fortran argument GETARG @@ -22,7 +20,7 @@ FFLAGS = -O -C -ffixed-line-length-none #for debugging #FFLAGS = -C -g -lm -ffixed-line-length-none -FC=g77 +FC=gfortran HFILES= parameter.h diff --git a/src/init_routines.f b/src/init_routines.f index d00620f..da341f8 100644 --- a/src/init_routines.f +++ b/src/init_routines.f @@ -10,10 +10,6 @@ SUBROUTINE INIT_ARRAY( A, NROW, NCOL, VALUE ) IMPLICIT NONE -c RCS ID STRING - CHARACTER*50 RCSID - DATA RCSID/"$Id: init_routines.f,v 1.1 2005/04/07 05:07:28 vicadmin Exp $"/ - INTEGER NCOL, NROW INTEGER I, J REAL A(NCOL,NROW) @@ -65,7 +61,7 @@ SUBROUTINE CREATE_VIC_NAMES( JLOC, ILOC, EXTEN, CLEN, DPREC ) END DO CLEN=CLEN-1 - + RETURN END @@ -95,27 +91,27 @@ SUBROUTINE SEARCH_CATCHMENT II = I JJ = J 300 CONTINUE - IF ((II .GT. ICOL) .OR. (II .LT.1) .OR. + IF ((II .GT. ICOL) .OR. (II .LT.1) .OR. & (JJ .GT. IROW) .OR. (JJ .LT.1)) THEN GOTO 310 END IF - IF ((II .EQ. PI) .AND. (JJ .EQ. PJ)) THEN + IF ((II .EQ. PI) .AND. (JJ .EQ. PJ)) THEN NO_OF_BOX = NO_OF_BOX + 1 CATCHIJ(NO_OF_BOX,1) = I CATCHIJ(NO_OF_BOX,2) = J GOTO 310 - ELSE - IF ((DIREC(II,JJ,1).NE.0) .AND. !check if the current + ELSE + IF ((DIREC(II,JJ,1).NE.0) .AND. !check if the current & (DIREC(II,JJ,2) .NE.0)) THEN !ii,jj cell routes down III = DIREC(II,JJ,1) !to the subbasin outlet - JJJ = DIREC(II,JJ,2) !point, following the + JJJ = DIREC(II,JJ,2) !point, following the II = III !direction of direc(,) JJ = JJJ !from each cell GOTO 300 - END IF !if you get there, + END IF !if you get there, END IF !no_of_box increments 310 CONTINUE !and you try another - END DO !cell. + END DO !cell. END DO WRITE(*,*) 'Number of grid cells upstream of present station', diff --git a/src/make_convolution.f b/src/make_convolution.f index 1024ea4..8fa15f6 100644 --- a/src/make_convolution.f +++ b/src/make_convolution.f @@ -1,22 +1,18 @@ SUBROUTINE MAKE_CONVOLUTION - & (NCOL, NROW, NOB, PMAX, DAYS, CATCHIJ, + & (NCOL, NROW, NOB, PMAX, DAYS, CATCHIJ, & BASE, RUNO, FLOW, KE, UH_DAY, UH_S, FRACTION, FACTOR_SUM, & XC, YC, SIZE, DPREC, INPATH,ICOL,NDAY,IDAY,IMONTH,IYEAR, & MO, YR, NYR) IMPLICIT NONE -c RCS ID STRING - CHARACTER*50 RCSID - DATA RCSID/"$Id: make_convolution.f,v 1.1 2005/04/07 05:07:28 vicadmin Exp $"/ - INTEGER N, I, J, DAYS, NDAY, II, JJ INTEGER NCOL,NROW,ICOL,NOB,PMAX,KE,UH_DAY INTEGER CATCHIJ(PMAX,2) INTEGER NYR REAL UH_S(PMAX,KE+UH_DAY-1) - REAL BASE(DAYS), RUNO(DAYS), FLOW(DAYS) + REAL BASE(DAYS), RUNO(DAYS), FLOW(DAYS) REAL FRACTION(NCOL,NROW) REAL PI, RERD, FACTOR, FACTOR_SUM @@ -36,7 +32,7 @@ SUBROUTINE MAKE_CONVOLUTION REAL STORAGE, K_CONST REAL DUM1,DUM2 - + INTEGER IDAY(DAYS), IMONTH(DAYS), IYEAR(DAYS) INTEGER MO(12*NYR),YR(12*NYR) INTEGER MISS_NUM @@ -44,9 +40,9 @@ SUBROUTINE MAKE_CONVOLUTION MISS_NUM=0 -C *** 0 <= K_CONST = 1.0 +C *** 0 <= K_CONST = 1.0 C *** K_CONST smaller 1.0 makes it a simple linear storage - + K_CONST = 1.0 PI = ATAN(1.0) * 4.0 @@ -66,18 +62,18 @@ SUBROUTINE MAKE_CONVOLUTION END DO II = CATCHIJ(N,1) JJ = CATCHIJ(N,2) - + c the grid has been flipped left to right c find the revised cooordinates ILOC=XC + (ICOL-II)*SIZE + SIZE/2.0 JLOC=YC + JJ*SIZE - SIZE/2.0 - AREA = RERD**2*ABS(SIZE)*PI/180* !give area of box in + AREA = RERD**2*ABS(SIZE)*PI/180* !give area of box in & ABS(SIN((JLOC-SIZE/2.0)*PI/180)- !square meters $ SIN((JLOC+SIZE/2.0)*PI/180)) - + AREA_SUM = AREA_SUM + AREA c WRITE(*,*) N, ILOC, JLOC @@ -87,7 +83,7 @@ SUBROUTINE MAKE_CONVOLUTION FACTOR_SUM = FACTOR_SUM + FACTOR - + call create_vic_names(jloc,iloc,loc,clen,dprec) c print*, INPATH(1:INDEX(INPATH,' ')-1)//LOC(1:CLEN) diff --git a/src/read_routines.f b/src/read_routines.f index 0c16049..3b4b7d4 100644 --- a/src/read_routines.f +++ b/src/read_routines.f @@ -1,4 +1,4 @@ -c SUBROUTINES RELATED TO READING +c SUBROUTINES RELATED TO READING c read_diff() c read_fraction() c read_grid_uh() @@ -10,10 +10,6 @@ SUBROUTINE READ_DIFF(DIFF,NCOL,NROW,FILENAME, $ IROW, ICOL) -c RCS ID STRING - CHARACTER*50 RCSID - DATA RCSID/"$Id: read_routines.f,v 1.1 2005/04/07 05:07:28 vicadmin Exp $"/ - INTEGER NCOL,NROW,IROW,ICOL,I,J REAL DIFF(NCOL,NROW) CHARACTER*72 FILENAME @@ -26,8 +22,8 @@ SUBROUTINE READ_DIFF(DIFF,NCOL,NROW,FILENAME, END DO DO J = IROW,1,-1 - READ(10,*) (DIFF(I,J), I=ICOL,1,-1) - END DO + READ(10,*) (DIFF(I,J), I=ICOL,1,-1) + END DO CLOSE(10) @@ -54,8 +50,8 @@ SUBROUTINE READ_FRACTION(FRACTION,NCOL,NROW,FILENAME, END DO DO J = IROW,1,-1 - READ(22,*) (FRACTION(I,J), I=ICOL,1,-1) - END DO + READ(22,*) (FRACTION(I,J), I=ICOL,1,-1) + END DO CLOSE(22) @@ -69,7 +65,7 @@ SUBROUTINE READ_FRACTION(FRACTION,NCOL,NROW,FILENAME, SUBROUTINE READ_GRID_UH & (UH_BOX, KE, PMAX, NOB, CATCHIJ,FILENAME) - + IMPLICIT NONE INTEGER KE, PMAX, NOB @@ -105,8 +101,8 @@ SUBROUTINE READ_VELO(VELO,NCOL,NROW,FILENAME, END DO DO J = IROW,1,-1 - READ(10,*) (VELO(I,J), I=ICOL,1,-1) - END DO + READ(10,*) (VELO(I,J), I=ICOL,1,-1) + END DO CLOSE(10) @@ -133,8 +129,8 @@ SUBROUTINE READ_XMASK(XMASK,NCOL,NROW,FILENAME, END DO DO J = IROW,1,-1 - READ(10,*, END=20) (XMASK(I,J), I=ICOL,1,-1) - END DO + READ(10,*, END=20) (XMASK(I,J), I=ICOL,1,-1) + END DO CLOSE(10) RETURN @@ -153,11 +149,11 @@ SUBROUTINE READ_DIREC(DIREC,NCOL,NROW,H,XC,YC,SIZE IMPLICIT NONE INTEGER NCOL,NROW,I,J,IROW,ICOL,IMISS - INTEGER DIREC(NCOL,NROW,2) + INTEGER DIREC(NCOL,NROW,2) INTEGER H(NCOL,NROW) REAL XC, YC, SIZE CHARACTER*72 FILENAME - CHARACTER*14 CDUM + CHARACTER*14 CDUM OPEN(10, FILE = FILENAME, FORM = 'FORMATTED', $ STATUS='OLD',ERR=9001) @@ -174,10 +170,10 @@ SUBROUTINE READ_DIREC(DIREC,NCOL,NROW,H,XC,YC,SIZE $ irow, icol STOP ENDIF - + DO J = IROW,1,-1 - READ(10,*) (H(I,J), I=ICOL,1,-1) - END DO + READ(10,*) (H(I,J), I=ICOL,1,-1) + END DO CLOSE(10) DO I = 1, ICOL @@ -194,7 +190,7 @@ SUBROUTINE READ_DIREC(DIREC,NCOL,NROW,H,XC,YC,SIZE ELSE IF (H(I,J) .EQ. 3) THEN DIREC(I,J,1) = I-1 DIREC(I,J,2) = J - ELSE IF (H(I,J) .EQ. 4) THEN + ELSE IF (H(I,J) .EQ. 4) THEN DIREC(I,J,1) = I-1 DIREC(I,J,2) = J-1 ELSE IF (H(I,J) .EQ. 5) THEN @@ -217,4 +213,3 @@ SUBROUTINE READ_DIREC(DIREC,NCOL,NROW,H,XC,YC,SIZE $ FILENAME STOP END - diff --git a/src/rout.f b/src/rout.f index 1047ecd..840d3f2 100644 --- a/src/rout.f +++ b/src/rout.f @@ -9,22 +9,18 @@ PROGRAM rout c See WA Hydrology Homepage for operational details. c Modified 5/99 to read in the uh_s array if it has already -c been generated in a previous run. +c been generated in a previous run. c Modified 2/2001 by edm to include month and year in output c and also check dates in VIC output files and calculate NDAYS c IMPLICIT NONE -c RCS ID STRING - CHARACTER*50 RCSID - DATA RCSID/"$Id: rout.f,v 1.1 2005/04/07 05:07:29 vicadmin Exp $"/ - integer IARGC integer isaleap external isaleap - + c change dimensions here c nrow and ncol should be larger than the grid c nyr should equal run length yrs+1 @@ -42,9 +38,9 @@ PROGRAM rout PARAMETER (UH_DAY = 96 ) PARAMETER (TMAX = UH_DAY*24) PARAMETER (PMAX = 10000 ) - + INTEGER DIREC(NCOL,NROW,2) - REAL VELO(NCOL,NROW), DIFF(NCOL,NROW) + REAL VELO(NCOL,NROW), DIFF(NCOL,NROW) REAL XMASK(NCOL,NROW), FRACTION(NCOL,NROW) REAL UH_BOX(PMAX,KE), UHM(NCOL,NROW,LE) REAL UH_S(PMAX,KE+UH_DAY-1) @@ -55,11 +51,11 @@ PROGRAM rout INTEGER NO_OF_BOX INTEGER CATCHIJ(PMAX,2) INTEGER H(NCOL,NROW) - + INTEGER PI, PJ REAL UH_DAILY(PMAX,UH_DAY) REAL FR(TMAX,2) - + INTEGER NR INTEGER IROW, ICOL INTEGER LP,M,Y @@ -174,7 +170,7 @@ PROGRAM rout DO J=START_MO,12*(STOP_YEAR-START_YEAR)+STOP_MO IF(M.EQ.2) THEN LP=isaleap(Y) - ELSE + ELSE LP=0 ENDIF NDAY = NDAY+DAYS_IN_MONTH(M)+LP @@ -205,11 +201,11 @@ PROGRAM rout C Loop over required stations 100 CONTINUE - READ(10,*,END=110) + READ(10,*,END=110) & NR, NAME, PI, PJ, AREA READ(10,'(A80)',END=110) UH_STRING !new, AW: uh_string IF (NR .EQ. 1) THEN - WRITE(*,'(I2,2X,A,I4,I4,G12.6)') + WRITE(*,'(I2,2X,A,I4,I4,G12.6)') & NR, NAME, PI, PJ PRINT*, 'Routing station: ', NAME c note, the arrays are flipped left to right @@ -220,7 +216,7 @@ PROGRAM rout CALL SEARCH_CATCHMENT & (PI,PJ,DIREC,NCOL,NROW, & NO_OF_BOX,CATCHIJ,PMAX,IROW,ICOL) - + print*, 'reading grid_UH...' CALL READ_GRID_UH & (UH_BOX, KE, PMAX, NO_OF_BOX, CATCHIJ,FILENAME) @@ -237,25 +233,25 @@ PROGRAM rout & CATCHIJ, BASE, RUNO, FLOW, KE, UH_DAY, UH_S, FRACTION, & FACTOR_SUM,XC,YC,SIZE,DPREC,INPATH,ICOL,NDAY, & IDAY,IMONTH,IYEAR, MO, YR, NYR) - + print*, 'writing data...' CALL WRITE_DATA - & (FLOW, NDAY, NAME5, FACTOR_SUM, OUTPATH,IDAY,IMONTH,IYEAR) + & (FLOW, NDAY, NAME5, FACTOR_SUM, OUTPATH,IDAY,IMONTH,IYEAR) CALL WRITE_MONTH - & (DAYS_IN_MONTH,START_YEAR, STOP_YEAR, FIRST_YEAR, - & LAST_YEAR, START_MO, STOP_MO, FIRST_MO, + & (DAYS_IN_MONTH,START_YEAR, STOP_YEAR, FIRST_YEAR, + & LAST_YEAR, START_MO, STOP_MO, FIRST_MO, & LAST_MO, - & NAME5, DAYS, FLOW, FACTOR_SUM, MONTHLY, MONTHLY_mm, + & NAME5, DAYS, FLOW, FACTOR_SUM, MONTHLY, MONTHLY_mm, & YEARLY,YEARLY_mm,OUTPATH,NDAY,IMONTH,IYEAR,MO,YR,NMONTHS,NYR) END IF GOTO 100 110 CONTINUE - + STOP - 9001 WRITE(*,*) 'CANNOT OPEN: ', FILE_INPUT + 9001 WRITE(*,*) 'CANNOT OPEN: ', FILE_INPUT END c *********************************************** c FUNCTION ISALEAP diff --git a/src/unit_hyd_routines.f b/src/unit_hyd_routines.f index 73610a3..96a7c3a 100644 --- a/src/unit_hyd_routines.f +++ b/src/unit_hyd_routines.f @@ -8,10 +8,6 @@ SUBROUTINE MAKE_UHM(UH,VELO,DIFF,XMASK,NCOL,NROW,LE,DT, $ IROW,ICOL) -c RCS ID STRING - CHARACTER*50 RCSID - DATA RCSID/"$Id: unit_hyd_routines.f,v 1.1 2005/04/07 05:07:29 vicadmin Exp $"/ - REAL UH(NCOL,NROW,LE), INTE INTEGER I, J, K, LE REAL T, DT, POT, VELO(NCOL,NROW), DIFF(NCOL,NROW) @@ -25,16 +21,11 @@ SUBROUTINE MAKE_UHM(UH,VELO,DIFF,XMASK,NCOL,NROW,LE,DT, DO K = 1,LE T = T + DT IF (VELO(I,J) .GT. 0.0) THEN - POT = ((VELO(I,J)*T-XMASK(I,J))**2.0)/ - & (4.0*DIFF(I,J)*T) - IF (POT .GT. 69.0) THEN - H = 0.0 - ELSE - H = 1.0/(2.0*SQRT(PI*DIFF(I,J))) * + POT = ((VELO(I,J)*T-XMASK(I,J))**2.0)/(4.0*DIFF(I,J)*T) + H = 1.0/(2.0*SQRT(PI*DIFF(I,J))) * & XMASK(I,J)/(T**1.5) * EXP(-POT) - END IF - ELSE - H = 0.0 + ELSE + H = 0.0 END IF UH(I,J,K) = H END DO @@ -54,14 +45,14 @@ SUBROUTINE MAKE_UHM(UH,VELO,DIFF,XMASK,NCOL,NROW,LE,DT, END IF END DO END DO - + RETURN END -c Solve for +c Solve for SUBROUTINE MAKE_GRID_UH & (DIREC, NOB, UH_DAY, TMAX, PI, PJ, LE, UH_DAILY, KE, - & CATCHIJ, UHM, FR, PMAX, NCOL, NROW, UH_BOX, + & CATCHIJ, UHM, FR, PMAX, NCOL, NROW, UH_BOX, & UH_S, UH_STRING, NAME5) IMPLICIT NONE @@ -80,13 +71,13 @@ SUBROUTINE MAKE_GRID_UH CHARACTER*80 UH_STRING !new, AW CHARACTER*5 NAME5 - + IF (UH_STRING(1:4) .ne. 'NONE') THEN ! read UH_S grid, not make it print*, 'reading UH_S grid from file' - open(98, file=UH_STRING, status='old') + open(98, file=UH_STRING, status='old') DO N = 1,NOB READ(98, *) (UH_S(N,K), K = 1,KE+UH_DAY-1) - END DO + END DO ELSE ! make UH_S grid, and save it print*, 'making UH_S grid...it takes a while...' @@ -96,7 +87,7 @@ SUBROUTINE MAKE_GRID_UH print*, ' save this file and specify it in your station' print*, ' location file to avoid this step in the future' - open(98, file = NAME5//'.uh_s', status='new') + open(98, file = NAME5//'.uh_s', status='new') DO N = 1, NOB print*, 'grid cell', N,' out of', NOB @@ -119,8 +110,8 @@ SUBROUTINE MAKE_GRID_UH IF ((I .NE. PI) .OR. (J .NE. PJ)) THEN DO T = 1, TMAX DO L = 1, LE - IF ((T-L) .GT. 0) THEN - FR(T,2) = FR(T,2) + FR(T-L,1)*UHM(I,J,L) + IF ((T-L) .GE. 0) THEN + FR(T,2) = FR(T,2) + FR(T-L+1,1)*UHM(I,J,L) END IF END DO END DO @@ -152,7 +143,7 @@ SUBROUTINE MAKE_GRID_UH DO N = 1,NOB DO K = 1,KE DO U =1,UH_DAY - UH_S(N,K+U-1) = UH_S(N,K+U-1) + + UH_S(N,K+U-1) = UH_S(N,K+U-1) + & UH_BOX(N,K) * UH_DAILY(N,U) END DO END DO @@ -170,14 +161,10 @@ SUBROUTINE MAKE_GRID_UH DO N = 1,NOB WRITE(98, *) (UH_S(N,K), K = 1,KE+UH_DAY-1) - END DO + END DO - END IF + END IF close(98) RETURN END - - - - diff --git a/src/write_routines.f b/src/write_routines.f index 55abfbe..1f6114b 100644 --- a/src/write_routines.f +++ b/src/write_routines.f @@ -8,10 +8,6 @@ SUBROUTINE WRITE_DATA IMPLICIT NONE -c RCS ID STRING - CHARACTER*50 RCSID - DATA RCSID/"$Id: write_routines.f,v 1.1 2005/04/07 05:07:29 vicadmin Exp $"/ - INTEGER DAYS REAL FLOW(DAYS) INTEGER IDAY(DAYS), IMONTH(DAYS), IYEAR(DAYS) @@ -19,7 +15,7 @@ SUBROUTINE WRITE_DATA CHARACTER*5 NAME5 REAL FACTOR_SUM CHARACTER*72 OUTPATH - + CLEN = INDEX(OUTPATH,' ')-1 OPEN(30, FILE = OUTPATH(1:CLEN)//NAME5//'.day') @@ -34,17 +30,17 @@ SUBROUTINE WRITE_DATA END SUBROUTINE WRITE_MONTH - & (DAYS_IN_MONTH,START_YEAR, STOP_YEAR, FIRST_YEAR, LAST_YEAR, + & (DAYS_IN_MONTH,START_YEAR, STOP_YEAR, FIRST_YEAR, LAST_YEAR, & START_MO, STOP_MO, FIRST_MO, LAST_MO, - & NAME5, DAYS, FLOW, FACTOR_SUM, MONTHLY, MONTHLY_mm, + & NAME5, DAYS, FLOW, FACTOR_SUM, MONTHLY, MONTHLY_mm, & YEARLY, YEARLY_mm,OUTPATH,NDAY,IMONTH,IYEAR,MO,YR,NMONTHS,NYR) IMPLICIT NONE INTEGER DAYS_IN_MONTH(12) INTEGER NYR - INTEGER START_YEAR, STOP_YEAR, FIRST_YEAR, LAST_YEAR - INTEGER START_MO, STOP_MO, FIRST_MO, LAST_MO !AWW-092700 + INTEGER START_YEAR, STOP_YEAR, FIRST_YEAR, LAST_YEAR + INTEGER START_MO, STOP_MO, FIRST_MO, LAST_MO !AWW-092700 INTEGER DAYS,NDAY,NMONTHS INTEGER IMONTH(DAYS),IYEAR(DAYS) INTEGER SKIPTO, STOPAT @@ -79,7 +75,7 @@ SUBROUTINE WRITE_MONTH MONTHLY(I) = 0.0 MONTHLY_mm(I) = 0.0 END DO - + c Average flows for each month in simulation M=1 OLDMO=MO(1) @@ -107,7 +103,7 @@ SUBROUTINE WRITE_MONTH WRITE(40,*) YR(I),MO(I), MONTHLY(I) WRITE(41,*) YR(I),MO(I), MONTHLY_mm(I) YEARLY(MOD(I-1,12)+1) = YEARLY(MOD(I-1,12)+1) + MONTHLY(I) - YEARLY_mm(MOD(I-1,12)+1) = + YEARLY_mm(MOD(I-1,12)+1) = & YEARLY_mm(MOD(I-1,12)+1) + MONTHLY_mm(I) MCOUNT(MO(I)) = MCOUNT(MO(I))+1 END DO