Skip to content

Commit

Permalink
1. bound specified when assigning array to another array
Browse files Browse the repository at this point in the history 
2. tailing space removed (most of F90 files)
  • Loading branch information
@nmizukami
nmizukami committed May 3, 2019
2 parents 7c07058 + bef458a commit 9c9ebb1
Show file tree
Hide file tree
Showing 10 changed files with 222 additions and 222 deletions.
4 changes: 2 additions & 2 deletions route/build/src/ascii_util.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -97,7 +97,7 @@ subroutine split_line(inline,words,err,message)
! declare local variables
character(len=256) :: temp ! temporary line of characters
integer(i4b) :: iword ! loop through words
integer(i4b),parameter :: maxWords=100 ! maximum number of words in a line
integer(i4b),parameter :: maxWords=100 ! maximum number of words in a line
integer(i4b) :: i1 ! index at the start of a given word
character(len=256) :: cword ! the current word
integer(i4b) :: nWords ! number of words in the character string
Expand Down Expand Up @@ -174,7 +174,7 @@ subroutine get_vlines(unt,vlines,err,message)
! start procedure here
err=0; message='get_vlines/'
! ***** get the valid lines of data from the file and store in linked lists *****
icount=0 ! initialize the counter for the valid lines
icount=0 ! initialize the counter for the valid lines
do iline=1,maxLines
read(unt,'(a)',iostat=iend)temp; if(iend/=0)exit ! read line of data
if (temp(1:1)=='!')cycle
Expand Down
172 changes: 86 additions & 86 deletions route/build/src/irf_route.f90
View file

Large diffs are not rendered by default.

58 changes: 29 additions & 29 deletions route/build/src/kwt_route.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -83,11 +83,11 @@ SUBROUTINE REACHORDER(NRCH, & ! input
CYCLE
ENDIF
! climb upstream as far as possible
JRCH = IRCH ! the first reach under investigation
JRCH = IRCH ! the first reach under investigation
DO ! do until get to a "most upstream" reach that is not assigned
NUPS = SIZE(NETOPO(JRCH)%UREACHI) ! get number of upstream reaches
IF (NUPS.GE.1) THEN ! (if NUPS = 0, then it is a first-order basin)
KRCH = JRCH ! the reach under investigation
KRCH = JRCH ! the reach under investigation
! loop through upstream reaches
DO IUPS=1,NUPS
UINDEX = NETOPO(JRCH)%UREACHI(IUPS) ! POSITION of the upstream reach
Expand All @@ -104,7 +104,7 @@ SUBROUTINE REACHORDER(NRCH, & ! input
RCHFLAG(JRCH) = .TRUE.
NETOPO(ICOUNT)%RHORDER = JRCH
EXIT
ENDIF
ENDIF
CYCLE ! if jrch changes, keep looping (move upstream)
ELSE ! if the reach is a first-order basin
! assign JRCH
Expand Down Expand Up @@ -199,7 +199,7 @@ SUBROUTINE REACH_LIST(NRCH,NTOTAL,ierr,message)
INTLIST(IRCH)%N_URCH = 0 ! initialize the number of upstream reaches
NULLIFY(INTLIST(IRCH)%HPOINT) ! set pointer to a linked list to NULL
END DO ! (irch)

! build the linked lists for all reaches
DO KRCH=1,NRCH
! ensure take streamflow from surrounding basin (a reach is upstream of itself!)
Expand Down Expand Up @@ -235,14 +235,14 @@ SUBROUTINE REACH_LIST(NRCH,NTOTAL,ierr,message)
if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif
print*, 'jrch, numups, NETOPO(JRCH)%RCHLIST(:) = ', jrch, numups, NETOPO(JRCH)%RCHLIST(:)
END DO ! jrch

! free up memory
DEALLOCATE(INTLIST,STAT=IERR)
if(ierr/=0)then; ierr=20; message=trim(message)//'problem deallocating space for INTLIST'; return; endif
! ----------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------
CONTAINS

! For a down stream reach, add an upstream reach to its list of upstream reaches
SUBROUTINE ADD2LIST(D_RCH,U_RCH,ierr,message)
INTEGER(I4B),INTENT(IN) :: U_RCH ! upstream reach index
Expand Down Expand Up @@ -324,7 +324,7 @@ SUBROUTINE QROUTE_RCH(IENS,JRCH, & ! input: array indices
! JRCH: index of stream segment
! T0: start of the time step (seconds)
! T1: end of the time step (seconds)
! LAKEFLAG: >0 if processing lakes
! LAKEFLAG: >0 if processing lakes
! RSTEP: retrospective time step offset (optional)
!
! Outputs (in addition to update of data structures):
Expand Down Expand Up @@ -388,7 +388,7 @@ SUBROUTINE QROUTE_RCH(IENS,JRCH, & ! input: array indices
!
! Most computations were originally performed within calcts in Topnet ver7, with calls
! to subroutines in kinwav_v7.f
!
!
! ----------------------------------------------------------------------------------------
! Modifications to Source ([email protected]):
!
Expand All @@ -401,7 +401,7 @@ SUBROUTINE QROUTE_RCH(IENS,JRCH, & ! input: array indices
! * use of a new data structure (KROUTE) to hold and update the flow particles
!
! * upgrade to F90 (especially structured variables and dynamic memory allocation)
!
!
! ----------------------------------------------------------------------------------------
! Future revisions:
!
Expand Down Expand Up @@ -475,11 +475,11 @@ SUBROUTINE QROUTE_RCH(IENS,JRCH, & ! input: array indices
! check
if(JRCH==ixPrint)then
print*, 'JRCH, Q_JRCH = ', JRCH, Q_JRCH
endif
endif

ELSE
! set flow in headwater reaches to modelled streamflow from time delay histogram
RCHFLX(IENS,JRCH)%REACH_Q = RCHFLX(IENS,JRCH)%BASIN_QR(1)
RCHFLX(IENS,JRCH)%REACH_Q = RCHFLX(IENS,JRCH)%BASIN_QR(1)
RETURN ! no upstream reaches (routing for sub-basins done using time-delay histogram)
ENDIF
! ----------------------------------------------------------------------------------------
Expand Down Expand Up @@ -515,15 +515,15 @@ SUBROUTINE QROUTE_RCH(IENS,JRCH, & ! input: array indices
print*, 'FROUTE = ', FROUTE
print*, 'TENTRY = ', TENTRY
print*, 'T_EXIT = ', T_EXIT
endif
endif

! ----------------------------------------------------------------------------------------
! (4) COMPUTE TIME-STEP AVERAGES
! ----------------------------------------------------------------------------------------
NR = COUNT(FROUTE)-1 ! -1 because of the zero element (last routed)
NN = NQ2-NR ! number of non-routed points
TNEW = (/T_START,T_END/)
! (zero position last routed; use of NR+1 instead of NR keeps next expected routed point)
! (zero position last routed; use of NR+1 instead of NR keeps next expected routed point)
CALL INTERP_RCH(T_EXIT(0:NR+1),Q_JRCH(0:NR+1),TNEW,QNEW,IERR,CMESSAGE)
if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif
if(JRCH == ixPrint) print*, 'QNEW(1) = ', QNEW(1)
Expand Down Expand Up @@ -695,14 +695,14 @@ SUBROUTINE GETUSQ_RCH(IENS,JRCH,LAKEFLAG,T0,T1,& ! input
ROFFSET = RSTEP
END IF
IF (LAKEFLAG.EQ.1) THEN ! lakes are enabled
! get lake outflow and only lake outflow if reach is a lake outlet reach, else do as normal
! get lake outflow and only lake outflow if reach is a lake outlet reach, else do as normal
ILAK = NETOPO(JRCH)%LAKE_IX ! lake index
IF (ILAK.GT.0) THEN ! part of reach is in lake
IF (NETOPO(JRCH)%REACHIX.EQ.LKTOPO(ILAK)%DREACHI) THEN ! we are in a lake outlet reach
ND = 1
ALLOCATE(QD(1),TD(1),STAT=IERR)
if(ierr/=0)then; message=trim(message)//'problem allocating array for QD and TD'; return; endif
QD(1) = LAKFLX(IENS,ILAK)%LAKE_Q / RPARAM(JRCH)%R_WIDTH ! lake outflow per unit reach width
QD(1) = LAKFLX(IENS,ILAK)%LAKE_Q / RPARAM(JRCH)%R_WIDTH ! lake outflow per unit reach width
TD(1) = T1 - DT*ROFFSET
ELSE
CALL QEXMUL_RCH(IENS,JRCH,T0,T1,ND,QD,TD,ierr,cmessage,RSTEP) ! do as normal for unsubmerged part of inlet reach
Expand Down Expand Up @@ -827,7 +827,7 @@ SUBROUTINE QEXMUL_RCH(IENS,JRCH,T0,T1,& ! input
INTEGER(I4B) :: IR ! index of the upstream reach
INTEGER(I4B) :: NS ! size of the wave
INTEGER(I4B) :: NR ! # routed particles in u/s reach
INTEGER(I4B) :: NQ ! NR+1, if non-routed particle exists
INTEGER(I4B) :: NQ ! NR+1, if non-routed particle exists
TYPE(FPOINT), DIMENSION(:), POINTER, SAVE :: NEW_WAVE ! temporary wave
LOGICAL(LGT),SAVE :: INIT=.TRUE. ! used to initialize pointers
! Local variables to merge flow
Expand Down Expand Up @@ -987,7 +987,7 @@ SUBROUTINE QEXMUL_RCH(IENS,JRCH,T0,T1,& ! input
if(ierr/=0)then; message=trim(message)//'problem deallocating array NEW_WAVE'; return; endif
NULLIFY(NEW_WAVE)
! save the upstream width
UWIDTH(NUPB+IUPR) = RPARAM(IR)%R_WIDTH ! reach, width = parameter
UWIDTH(NUPB+IUPR) = RPARAM(IR)%R_WIDTH ! reach, width = parameter
! save the time for the first particle in each reach
CTIME(NUPB+IUPR) = USFLOW(NUPB+IUPR)%KWAVE(1)%TR ! central time
! keep track of the total number of points that must be routed downstream
Expand All @@ -1001,7 +1001,7 @@ SUBROUTINE QEXMUL_RCH(IENS,JRCH,T0,T1,& ! input
! *other than* x, we need to estimate (interpolate) flow for the *times* associted with
! each of the flow particles in reach x. Then, at a given time, we can sum the flow
! (routed in reach x plus interpolated flow in all other reaches). This needs to be done
! for all upstream reaches.
! for all upstream reaches.
! ----------------------------------------------------------------------------------------
! We accomplish this as follows. We define a vector of indices (ITIM), where each
! element of ITIM points to a particle in a given upstream reach still to be processed.
Expand All @@ -1012,7 +1012,7 @@ SUBROUTINE QEXMUL_RCH(IENS,JRCH,T0,T1,& ! input
! reaches by the width of the downstream reach, and sum the flow over all upstream reaches.
! We then move the index forward in ITIM (for the upstream reach just processed), get a
! new vector CTIME, and process the next earliest particle. We continue until all
! flow particles are processed in all upstream reaches.
! flow particles are processed in all upstream reaches.
! ----------------------------------------------------------------------------------------
IPRT = 0 ! initialize counter for flow particles in the output array
! allocate space for the merged flow at the downstream reach
Expand Down Expand Up @@ -1181,7 +1181,7 @@ SUBROUTINE REMOVE_RCH(MAXQPAR,& ! input
INTEGER(I4B) :: IPRT ! loop through flow particles
REAL(DP), DIMENSION(:), ALLOCATABLE :: Q,T,Z ! copies of Q_JRCH and T_JRCH
LOGICAL(LGT), DIMENSION(:), ALLOCATABLE :: PARFLG ! .FALSE. if particle removed
INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: INDEX0 ! indices of original vectors
INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: INDEX0 ! indices of original vectors
REAL(DP), DIMENSION(:), ALLOCATABLE :: ABSERR ! absolute error btw interp and orig
REAL(DP) :: Q_INTP ! interpolated particle
INTEGER(I4B) :: MPRT ! local number of flow particles
Expand Down Expand Up @@ -1265,8 +1265,8 @@ SUBROUTINE REMOVE_RCH(MAXQPAR,& ! input
! ----------------------------------------------------------------------------------------
CONTAINS
FUNCTION INTERP(T0,Q1,Q2,T1,T2)
REAL(DP),INTENT(IN) :: Q1,Q2 ! flow at neighbouring times
REAL(DP),INTENT(IN) :: T1,T2 ! neighbouring times
REAL(DP),INTENT(IN) :: Q1,Q2 ! flow at neighbouring times
REAL(DP),INTENT(IN) :: T1,T2 ! neighbouring times
REAL(DP),INTENT(IN) :: T0 ! desired time
REAL(DP) :: INTERP ! function name
! dQ/dT dT
Expand Down Expand Up @@ -1315,7 +1315,7 @@ SUBROUTINE KINWAV_RCH(JRCH,T_START,T_END,Q_JRCH,TENTRY,FROUTE,T_EXIT,NQ2,&
! flow either side of a shock -- thus we may have
! fewer elements on output if several particles are
! merged, INTENT(INOUT)
! TENTRY: array of time elements -- neighbouring times are merged if a shock forms,
! TENTRY: array of time elements -- neighbouring times are merged if a shock forms,
! then merged times are dis-aggregated, one second is
! added to the time corresponding to the higer merged
! flow (note also fewer elements), INTENT(INOUT)
Expand Down Expand Up @@ -1351,7 +1351,7 @@ SUBROUTINE KINWAV_RCH(JRCH,T_START,T_END,Q_JRCH,TENTRY,FROUTE,T_EXIT,NQ2,&
!
! ----------------------------------------------------------------------------------------
! Source:
!
!
! This routine is based on the subroutine kinwav, located in kinwav_v7.f
!
! ----------------------------------------------------------------------------------------
Expand Down Expand Up @@ -1408,7 +1408,7 @@ SUBROUTINE KINWAV_RCH(JRCH,T_START,T_END,Q_JRCH,TENTRY,FROUTE,T_EXIT,NQ2,&
REAL(DP) :: XXB ! wave break
INTEGER(I4B) :: IXB,JXB ! define position of wave break
REAL(DP) :: A1,A2 ! stage - different sides of break
REAL(DP) :: CM ! merged celerity
REAL(DP) :: CM ! merged celerity
REAL(DP) :: TEXIT ! expected exit time of "current" particle
REAL(DP) :: TNEXT ! expected exit time of "next" particle
REAL(DP) :: TEXIT2 ! exit time of "bottom" of merged element
Expand All @@ -1417,7 +1417,7 @@ SUBROUTINE KINWAV_RCH(JRCH,T_START,T_END,Q_JRCH,TENTRY,FROUTE,T_EXIT,NQ2,&
INTEGER(I4B) :: ICOUNT ! used to account for merged pts
character(len=256) :: cmessage ! error message of downwind routine
! ----------------------------------------------------------------------------------------
! NOTE: If merged particles DO NOT exit the reach in the current time step, they are
! NOTE: If merged particles DO NOT exit the reach in the current time step, they are
! disaggregated into the original particles; if the merged particles DO exit the
! reach, then we save only the "slowest" and "fastest" particle.
! ----------------------------------------------------------------------------------------
Expand Down Expand Up @@ -1456,7 +1456,7 @@ SUBROUTINE KINWAV_RCH(JRCH,T_START,T_END,Q_JRCH,TENTRY,FROUTE,T_EXIT,NQ2,&
WC(1:NN) = ALFA*K**(1./ALFA)*Q1(1:NN)**((ALFA-1.)/ALFA)
GT_ONE: IF(NN.GT.1) THEN ! no breaking if just one point
X = 0. ! altered later to describe "closest" shock
GOTALL: DO ! keep going until all shocks are merged
GOTALL: DO ! keep going until all shocks are merged
XB = XMX ! initialized to length of the stream segment
! --------------------------------------------------------------------------------------
! check for breaking
Expand Down Expand Up @@ -1496,7 +1496,7 @@ SUBROUTINE KINWAV_RCH(JRCH,T_START,T_END,Q_JRCH,TENTRY,FROUTE,T_EXIT,NQ2,&
IX(IXB:NN) = IX(IXB+1:NN+1) ! index (minimum index value of each merged particle)
T1(IXB:NN) = T1(IXB+1:NN+1) ! entry time
WC(IXB:NN) = WC(IXB+1:NN+1) ! wave celerity
Q1(IXB:NN) = Q1(IXB+1:NN+1) ! unmodified flows
Q1(IXB:NN) = Q1(IXB+1:NN+1) ! unmodified flows
Q2(IXB:NN) = Q2(IXB+1:NN+1) ! unmodified flows
! update X - already got the "closest shock to start", see if there are any other shocks
X = XB
Expand Down Expand Up @@ -1536,7 +1536,7 @@ SUBROUTINE KINWAV_RCH(JRCH,T_START,T_END,Q_JRCH,TENTRY,FROUTE,T_EXIT,NQ2,&
if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif
ELSE ! merged elements have not exited
! when a merged element does not exit, need to disaggregate into original particles
DO JROUTE=1,NI ! loop thru # original inputs
DO JROUTE=1,NI ! loop thru # original inputs
IF(MF(JROUTE).EQ.IROUTE) &
CALL RUPDATE(Q0(JROUTE),T0(JROUTE),TEXIT,ierr,cmessage) ! fill arrays w/ Q0, T0, + run checks
if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif
Expand Down
2 changes: 1 addition & 1 deletion route/build/src/lake_param.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,7 +15,7 @@ MODULE lake_param
REAL(DP) :: DSCHECO ! discharge at "ecological" height
REAL(DP) :: DSCHSPL ! discharge at spillway height
REAL(DP) :: RATECVA ! discharge rating curve parameter
REAL(DP) :: RATECVB ! discharge rating curve parameter
REAL(DP) :: RATECVB ! discharge rating curve parameter
ENDTYPE LAKPRP
TYPE(LAKPRP), DIMENSION(:), POINTER :: LPARAM ! Reach Parameters
! Lake topology
Expand Down
2 changes: 1 addition & 1 deletion route/build/src/qtimedelay.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ SUBROUTINE QTIMEDELAY(dt, fshape, tscale, IERR, MESSAGE)
! input
REAL(DP), INTENT(IN) :: dt ! model time step
REAL(SP), INTENT(IN) :: fshape ! shapef parameter in gamma distribution
REAL(DP), INTENT(IN) :: tscale ! time scale parameter
REAL(DP), INTENT(IN) :: tscale ! time scale parameter
! output
INTEGER(I4B), INTENT(OUT) :: IERR ! error code
CHARACTER(*), INTENT(OUT) :: MESSAGE ! error message
Expand Down
8 changes: 4 additions & 4 deletions route/build/src/read_ntopo.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,11 +13,11 @@ module read_ntopo
contains

! *********************************************************************
! subroutine: get vector dimension from netCDF
! subroutine: get vector dimension from netCDF
! *********************************************************************
subroutine get_vec_dim(fname, & ! input: filename
dname, & ! input: variable name
nDim, & ! output: Size of dimension
nDim, & ! output: Size of dimension
ierr, message) ! output: error control
implicit none
! input variables
Expand Down Expand Up @@ -81,7 +81,7 @@ subroutine get_vec_ivar(fname, & ! input: filename
ierr = nf90_open(trim(fname),nf90_nowrite,ncid)
if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif

! allocate space for the output
! allocate space for the output
!allocate(iVec(iCount),stat=ierr)
!if(ierr/=0)then; message=trim(message)//'problem allocating space for iVec'; return; endif

Expand Down Expand Up @@ -222,7 +222,7 @@ subroutine get_vec_dvar(fname, & ! input: filename
ierr = nf90_open(trim(fname),nf90_nowrite,ncid)
if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif

! allocate space for the output
! allocate space for the output
! allocate(dVec(iCount),stat=ierr)
! if(ierr/=0)then; message=trim(message)//'problem allocating space for dVec'; return; endif

Expand Down
2 changes: 1 addition & 1 deletion route/build/src/read_simoutput.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,7 @@ subroutine get_qDims(fname, & ! input: filename
! get the ID of the time variable
ierr = nf90_inq_varid(ncid, trim(vname_time), ivarID)
if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif

! get the time units
ierr = nf90_get_att(ncid, ivarID, 'units', units_time)
if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif
Expand Down
Loading

0 comments on commit 9c9ebb1

Please sign in to comment.