!...........................................................................
!
!  basis dimension
!  and information on how to find basis label from proton, neutron labels
!
!  if proton Slater determinant is ip and neutron Slater determinant is in
!  basis = pstart(ip)+nstart(in)
!
!  IMPORTANT:  ip and in must come from "conjugate" sectors
!  also note: neutrons form inner loop
!
module basis
  use precisions

  implicit none
  integer(kind=basis_prec) :: dimbasis 		    ! dimension of combined basis
  integer(kind=basis_prec) :: dimbasis_proc         ! local dimension of combined basis
  integer(kind=basis_prec) :: nXsd(2)         ! dimensions of proton, neutrons SDs
  integer(kind=basis_prec),allocatable,target :: pstart(:),nstart(:)   ! used for finding basi

contains

!----
!===========================================================================
!  BIGSTICK  configuration-interaction shell-model code
!
!===========================================================================
!
!  BBASISLIB1.f
!
!===========================================================================
!  SUBROUTINES
!     basismaster: master routine
!
!  FUNCTIONS
!      w_of_loc:  sums W for array loc (locations of particles in s.p. sections)
!      w_of_occ:  sums W for array occ (# of particles occupying each s.p. section)
!===========================================================================
!   NOTES: Main goal of these routines is to construct templates
!   structure: template(ith)%of_nh(nh)%list(i)%occ(is)
!      ith = species/hand;  nh = # of particles in a haiku
!      i = which template    occ(is) = template (occupation of is'th section)
!   Templates guide construction of haikus
!  Construction of templates is complicated. There are two paths to creating
!  templates:
!  PATH 1: For each nh (# of particles in a haiku) there is a maximum W-cut
!  dictated by the truncation of the basis. These are generated via
!   "temporary templates" which are not occupations but via ordered locations of
!   each particle: the ip'th particle is assigned a location loc(ip)
!   and one enforces loc(ip) >= loc(ip+1), while also enforcing a max summed W
!   and a max occupation in each s.p. section. Up to the max W, all possible
!   templates are generated.
!   PATH 2: Because of the "hop" algorithm we use, we want to make sure that for
!   every haiku, we can destroy one particle and also find that resulting haiku
!   in our list. Towards this end we generate additional templates by
!   deleting particles from template occupation and keeping them even if they
!   violate the W-cut (if they satisfy the W-cut they've already been created)
!
!   The templates are, for each nh,ordered by W, which will help with ordering
!   of haikus later on.
!
!   Finally for each template a "parent" template is identified, by deleting
!   a particle. Later on, in haiku generation, the daughter is created by
!   adding one particle to the parent.  The parent is not necessarily unique,
!   but does not need to be.
!
!   ONCE THE PARENTS ARE IDENTIFIED, one no longer needs the explicit templates!
!
!=====================================================================
!
!  MASTER ROUTINE FOR GENERATING BASIS
!
!  CALLED BY: bigstick_main program
!
!  SUBROUTINES CALLED:
!	master_sections 	: sets up sections in single-particle space (like quantum numbers)
!	writeouthsps 		: (optional)
!       grouper			: organizes hsps by "groups" with similar quantum numbers
!	writeoutgroups		: (optional)
!  	templatemaster		: templates are used when truncating on W
!	template_heritage
!	haiku_master		: creates haikus
!	blockmaster		: organizes haikus into blocks by quantum number
!	printblockhaikus	: (optional)
!  	mastersdlimits		: finds limits on proton, neutron Slater determinants
!	mastercombinedbasis	: combines proton, neutron states into final basis
!
subroutine basismaster
  use verbosity
  use menu_choices
  use nodeinfo
  use templates
  use spsections
  use haikus
  use blocks
  use slaterlimits

  implicit none

!----------- reorder hspsqn------------------------------------
  if(iproc == 0)then
     print*,' '
     print*,' .... Building basis ... '
     print*,' '
     print*,' Information about basis: '
  end if
  call master_sections
  if(print_hsps)call writeouthsps(1)
  if(print_hsps)call writeouthsps(-1)
!-----------set up groups of s.p. states----------------------------
  call grouper
  if(print_groups)call writeoutgroups(1)
  if(print_groups)call writeoutgroups(-1)
!------------------TEMPLATES-----------------------------------------
! templates are used in construction of the basis

  call templatemaster(1)         ! for right protons haikus
  call template_heritage(1)
  call templatemaster(-1)        ! for left protons haiksu
  call template_heritage(-1)
  call templatemaster(2)         ! for right neutron haikus
  call template_heritage(2)
  call templatemaster(-2)        !     left neutron haikus
  call template_heritage(-2)
!---------------- FIND JZ LIMITS OF TEMPLATES ---------------------
!  call master_of_jzsectplates()
!  call assign_jz_to_templates()
!  call reconcile_templates_for_Jz()
!  call reconcile_templates_for_Jz()   ! CALL TWICE TO MAKE SURE

!------------------HAIKUS---------------------------------------------

  call haiku_master(1)           !   right proton haikus
  call haiku_master(-1)          !   left proton haikus
  call haiku_master(2)           !    right neutron haikus
  call haiku_master(-2)          !   left neutron haikus

!------------------HAIKU BLOCKS---------------------------------
  call blockmaster(1)            ! right proton haiku blocks
  call blockmaster(-1)           ! left proton haiku blocks
  call blockmaster(2)           ! right neutron haiku blocks
  call blockmaster(-2)           ! left neutron haiku blocks
  if ( print_haikus ) then
     print*,' Printing out haikus...'
     call printblockhaikus(1)
     call printblockhaikus(-1)
     call printblockhaikus(2)
     call printblockhaikus(-2)
  end if

!------------------COMBINED BASIS-----------------------------
  call mastersdlimits        ! find limits on SD quantum numbers
  call mastercombinedbasis

    if(iproc == 0)then
     print*,' '
     print*,' .... Basis built ... '
     print*,' '
  end if
  return

end subroutine basismaster
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!  BIGSTICK configuration-interaction shell-model code
!
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!
!  bbasislib6.f90
!
!  sixth set of routines to generate the basis:
!  sets up for sectors of SDs
!
!===============================================================

!  In the previous routines we deduced the limits of q#s for quantum numbers
!  for proton/neutron SDs. Next we need to further refine these limits
!  to get the total basis
!

!##############################################################################
! subroutine mastercombinedbasis
!
! SUBROUTINES CALLED:
!   count_create_sectors
!   count_fill_sectors_w_blocks
!   match_conjugate_sectors
!   combine_basis
!
subroutine mastercombinedbasis

  use sectors
  use verbosity
  use blocks
  implicit none
  integer it,is
  do it = 1,2
     call count_create_sectors(it,.false.)
     call count_create_sectors(it,.true.)
     do is = 1,nsectors(it)
        call count_fill_sectors_w_blocks(it,is,.false.)
        call count_fill_sectors_w_blocks(it,is,.true.)
     enddo ! is
  enddo  ! it
  if(verbose_haikus)call countusedhaikus
  do it = 1,2
     do is = 1,nsectors(it)
        call match_conjugate_sectors(it,is,.false.)
        call match_conjugate_sectors(it,is,.true.)
     enddo ! is
  enddo  ! it
  call combinebasis
!call checkbasis
  return
end subroutine mastercombinedbasis

!##############################################################################
! subroutine count_create_sections
!
! note, proton and neutrons sections have opposite order for jz
!
! CALLED BY: mastercombinedbasis
!

subroutine count_create_sectors(it,create)

  use system_parameters
  use sectors
  use slaterlimits
  use nodeinfo
  use bmpi_mod
  use io
  use sporbit
  implicit none

  integer(4) :: ierr
  integer :: it
  logical :: create
  integer :: icount
  integer :: jzx
  integer :: jzstart,jzend,jzstep
  integer :: parstart,parend,parstep,parx
  integer :: iw
  integer :: aerr

  if(it < 1)then  ! ERROR TRAP
     print*,' Doh! variable it must be = 1 or 2 ',it
     stop
  endif

  icount = 0

  if(it== 1)then  ! proton parity + first, then -
     parstart = limxsd(1)%parmin
     parend   = limxsd(1)%parmax
     parstep  = 1
  else
     if(iparity ==1)then   ! have neutron parity + first, then -
        parstart = limxsd(2)%parmin
        parend   = limxsd(2)%parmax
        parstep  = 1
     else                    ! neutron parities in retrograde order
        parstart = limxsd(2)%parmax
        parend   = limxsd(2)%parmin
        parstep  = -1

     endif
  endif

  do parx = parstart,parend,parstep

     if(it == 1)then
        jzstart = limxsd(1)%par(parx)%jzmin
        jzend =   limxsd(1)%par(parx)%jzmax
        jzstep = 2
     else
        jzstart = limxsd(2)%par(parx)%jzmax
        jzend =   limxsd(2)%par(parx)%jzmin
        jzstep = -2
     endif
     do jzx = jzstart,jzend,jzstep
        if(limxsd(it)%par(parx)%jz(jzx)%nw==0)cycle
        do iw = 1,limxsd(it)%par(parx)%jz(jzx)%nw

           icount = icount +1

           if(create)then
              xsd(it)%sector(icount)%jzX = jzx
!--------- fill in other quantum numbers
              xsd(it)%sector(icount)%parx = parx
              xsd(it)%sector(icount)%wx   = limxsd(it)%par(parx)%jz(jzx)%wlist(iw)
           endif
        enddo ! iw
     enddo  ! jzx
  enddo  ! par

  if( .not. create ) then
     nsectors(it) = icount
     if ( iproc == 0 ) print*,'there are ',icount,' sectors ',it
	  if(icount ==0)then
		  if(iproc==0)then
			  print*,' WARNING: No sectors for species ',it
			  write(logfile,*)' WARNING: No sectors for species ',it
			  if(allsameW .and. allsameparity)then
				  print*,' Most likely Jz is set too large'
				  write(logfile,*)' Most likely Jz is set too large'
			  end if
           if(.not.allsameW .and. .not. allsameparity .and. abs(jz) < 2)then
				  print*,' Likely possibility: bad choice of parity with truncation '
				  write(logfile,*)' Likely possibility: bad choice of parity with truncation '
			  end if

		  end if
		  stop
	  end if
     if( associated( xsd(it)%sector) ) nullify(xsd(it)%sector)
     allocate(xsd(it)%sector(icount), stat=aerr)
     if(aerr /= 0) call memerror("count_create_sectors")
  endif

  return
end subroutine count_create_sectors

!##############################################################################
! subroutine count_fill_sectors_w_blocks
!
!  finds which haiku blocks can make up a sector
!
! CALLED BY: mastercombinedbasis
!

subroutine count_fill_sectors_w_blocks(it,is,fill)

use system_parameters
use blocks
use sectors
use slaterlimits
use sporbit

implicit none
integer it  ! label of species
integer is  ! label of sector
logical fill
integer N
integer nh,nhc
integer jzx,jzh,jzhc
integer parx, parh,parhc
integer parhstart,parhend
integer parhcstart,parhcend
integer icount
integer rhblock,lhblock
integer blocksize
integer(8) :: xsdstart
integer wx
integer iwh,iwhc,wh,whc
logical okay
integer :: aerr

N = np(it)
jzx = xsd(it)%sector(is)%jzx
parx = xsd(it)%sector(is)%parx
wx   = xsd(it)%sector(is)%wx

icount = 0
if(is ==1)then
   xsdstart = 1
else
   xsdstart = xsd(it)%sector(is-1)%xsdstart+xsd(it)%sector(is-1)%nxsd
endif
if(fill)xsd(it)%sector(is)%blockstart(1) = xsdstart
do nh = blockmap(it)%nhmin,blockmap(it)%nhmax
   nhc = N -nh
   if(nhc < blockmap(-it)%nhmin .or. nhc > blockmap(-it)%nhmax)cycle
   do parh = blockmap(it)%nh(nh)%parmin,blockmap(it)%nh(nh)%parmax
     parhc = parmult(parx,parh)
     if( parhc > blockmap(-it)%nh(nhc)%parmax .or. parhc < blockmap(-it)%nh(nhc)%parmin)cycle

     do jzh = blockmap(it)%nh(nh)%par(parh)%jzmin, blockmap(it)%nh(nh)%par(parh)%jzmax,2
        jzhc = jzx - jzh
        if( jzhc > blockmap(-it)%nh(nhc)%par(parhc)%jzmax .or. jzhc < blockmap(-it)%nh(nhc)%par(parhc)%jzmin)cycle

        do iwh = 1,blockmap(it)%nh(nh)%par(parh)%jz(jzh)%nw
          wh = blockmap(it)%nh(nh)%par(parh)%jz(jzh)%wlist(iwh)
          iwhc = 1
          okay = .false.
          whc = blockmap(-it)%nh(nhc)%par(parhc)%jz(jzhc)%wlist(iwhc)
          if(wh+whc == wx)okay = .true.
          do while(.not.okay .and. iwhc < blockmap(-it)%nh(nhc)%par(parhc)%jz(jzhc)%nw)
            iwhc = iwhc +1
            whc = blockmap(-it)%nh(nhc)%par(parhc)%jz(jzhc)%wlist(iwhc)
            if(wh+whc == wx)okay = .true.

          enddo
          if(.not.okay)cycle
          icount = icount+1
          if(fill)then
              rhblock = blockmap(it)%nh(nh)%par(parh)%jz(jzh)%hblock(iwh)
              lhblock = blockmap(-it)%nh(nhc)%par(parhc)%jz(jzhc)%hblock(iwhc)

              if(lhblock == 0 .or. rhblock==0)then
                print*,rhblock,lhblock
                print*,iwh,iwhc
                print*,blockmap(-it)%nh(nhc)%par(parhc)%jz(jzhc)%hblock
                print*,blockmap(-it)%nh(nhc)%par(parhc)%jz(jzhc)%nw

                stop
              endif
              xsd(it)%sector(is)%rhblock(icount) = rhblock
              xsd(it)%sector(is)%lhblock(icount) = lhblock

              blocksize = hblock(it)%list(rhblock)%nhsd * hblock(-it)%list(lhblock)%nhsd
              if(icount == 1)then
                 xsd(it)%sector(is)%blockstart(1) = xsdstart
              else
                 xsd(it)%sector(is)%blockstart(icount)= xsd(it)%sector(is)%blockend(icount-1)+1
              endif

              xsd(it)%sector(is)%blockend(icount) = xsd(it)%sector(is)%blockstart(icount)+blocksize - 1

!...... CHECK FLAG THAT THESE BLOCKS ARE BEING USED.............
              hblock(it)%list(rhblock)%used=.true.
              hblock(-it)%list(lhblock)%used=.true.

            endif
        enddo  ! iwh
     enddo ! jzh
  enddo ! parh
enddo  ! nh
if(.not.fill)then
  xsd(it)%sector(is)%nhblocks = icount
  if (associated( xsd(it)%sector(is)%rhblock ) ) nullify( xsd(it)%sector(is)%rhblock)
  if (associated( xsd(it)%sector(is)%lhblock ) ) nullify( xsd(it)%sector(is)%lhblock)
  allocate(xsd(it)%sector(is)%rhblock(icount),xsd(it)%sector(is)%lhblock(icount), stat=aerr)
  if(aerr /= 0) call memerror("count_fill_sectors_w_blocks 1")

  if (associated( xsd(it)%sector(is)%blockstart))nullify( xsd(it)%sector(is)%blockstart)
  if (associated( xsd(it)%sector(is)%blockend))nullify( xsd(it)%sector(is)%blockend)
  allocate(xsd(it)%sector(is)%blockstart(icount),xsd(it)%sector(is)%blockend(icount), stat=aerr)
  if(aerr /= 0) call memerror("count_fill_sectors_w_blocks 2")
endif
if(fill)then
   xsd(it)%sector(is)%xsdstart = xsdstart
   xsd(it)%sector(is)%nxsd = xsd(it)%sector(is)%blockend(icount) - xsdstart+1
   xsd(it)%sector(is)%xsdend = xsd(it)%sector(is)%blockend(icount)
endif
return
end subroutine count_fill_sectors_w_blocks

!##############################################################################
!
!subroutine match_conjugate_sectors
!
!  The basis has fixed quantum numbers: Jz, parity, and max W. It is
!  subdivided into "sectors" based upon proton and neutron quantum numbers.
!  For each proton sector (some Jzp, parp, Wp) there are a set of conjugate
!  neutron sectors that can be coupled to make the basis, and vice versa.
!  This routine, for a given species (it) and sector (is) finds the
!  matching conjugate sectors.
!
!  INPUT:
!    it = species
!    is = label of sector
!    fill = logical flag; if .true. then fill, else just count up
!
! CALLED BY: mastercombinedbasis
!
subroutine match_conjugate_sectors(it,is,fill)

use system_parameters
use W_info
use sectors
use sporbit

implicit none
integer it
integer is
logical fill

integer itc
integer isc
integer jzx,jzc
integer parx,parc
integer wx,wxc
integer icount
integer :: aerr

itc = 3 - it

jzx = xsd(it)%sector(is)%jzx
jzc = jz - jzx

parx = xsd(it)%sector(is)%parx
parc = parmult(parx, iparity)

wx =   xsd(it)%sector(is)%wx
wxc = maxWtot -wx
icount = 0
do isc = 1,nsectors(itc)
   if(jzc == xsd(itc)%sector(isc)%jzx .and. parc == xsd(itc)%sector(isc)%parx .and. wxc >= xsd(itc)%sector(isc)%wx )then
      icount = icount + 1
      if(fill)then
        xsd(it)%sector(is)%csector(icount) = isc
      endif
   endif

enddo !isc
if(.not.fill)then
   if(icount ==0)then
     print*,' problem, no conjugates '
     print*,it,is
     print*,jzx,parx,wx,maxWtot
     print*,jzc,wxc
     stop
   endif
   xsd(it)%sector(is)%ncsectors = icount
   if( associated( xsd(it)%sector(is)%csector)) nullify( xsd(it)%sector(is)%csector)
   allocate(xsd(it)%sector(is)%csector(icount), stat=aerr)
   if(aerr /= 0) call memerror("match_conjugate_sectors")
endif
return
end subroutine match_conjugate_sectors

!##############################################################################
!subroutine combinebasis
! key routine to generate the combined basis from proton and neutron SDs
!
! KEY RESULT is the construction of the arrays pstart, nstart,
!            where it = species and isd = which (proton/neutron) slater determinant
!            Given  a proton SD labeled by ip  and a neutron SD labeled by in
!            then pstart(ip) + nstart(in) = ibasis = label in combined basis
!
! The basis (that is, the xstart arrays) is generated by looping over
!  the proton sectors and then over the conjugate neutron sectors
!
!  CALLED BY: mastercombinedbasis
!
subroutine combinebasis

  use sectors
  use nodeinfo
  use bmpi_mod
  implicit none

  integer(4) :: ierr

  integer it
  integer ns
  integer nb,ib
  integer is, isc,jsc
  integer(8) :: ncount,pcount
  !integer pstart
  integer(8) :: ndim,pdim
  integer(8) :: ip,in
  integer :: aerr
!---------- # of SDs in each species
  nXsd = 0

! testing

!do it = 1,2
!  print*,' * * * '
!  do is = 1,nsectors(it)
!    print*,' sectors ',is,xsd(it)%sector(is)%nhblocks
!    do ib = 1,xsd(it)%sector(is)%nhblocks
!       print*,xsd(it)%sector(is)%blockstart(ib),xsd(it)%sector(is)%blockend(ib)
!    enddo
!  enddo
!enddo

  do it = 1,2
     ns = nsectors(it)
     nb = xsd(it)%sector(ns)%nhblocks
     nXsd(it) = xsd(it)%sector(ns)%blockend(nb)
     if ( iproc == 0 ) print*,nXsd(it),' SDs for species ',it
  end do ! it

! ---------- NOW COUPLE TOGETHER

  if( allocated( pstart )) deallocate( pstart)
  if( allocated( nstart )) deallocate( nstart)

  if(nxsd(1) >0) then
     allocate(pstart(nxsd(1)), stat=aerr)
     if(aerr /= 0) call memerror("combinebasis 1")
  end if
  if(nxsd(2) >0) then
     allocate(nstart(nxsd(2)), stat=aerr)
     if(aerr /= 0) call memerror("combinebasis 2")
  end if
  pstart = -1
  nstart = -1
  dimbasis = 1
  pcount = 0
  ncount = 0

  do is = 1,nsectors(1)  ! loop over proton sectors

     ndim = 0
     do isc = 1,xsd(1)%sector(is)%ncsectors
        jsc = xsd(1)%sector(is)%csector(isc)
        ndim = ndim + xsd(2)%sector(jsc)%nxsd
     end do ! isc

!  ALTHOUGH LOOP OVER PROTONS SECTORS, FILL NEUTRON SECTORS FIRST
!  IF AND ONLY IF THE FIRST CONJUGATE NEUTRON SECTOR HAS THIS PROTON SECTOR
!  AS FIRST CONJUGATE SECTOR

     jsc = xsd(1)%sector(is)%csector(1)
     if( is == xsd(2)%sector(jsc)%csector(1))then  ! FILL NEUTRON

!  set up values in xstart(2,...) by looping over conjugate neutron sectors
!                            and then looping over neutron SDs in each sectors
        do in = 1,ndim
           ncount = ncount + 1
           if ( ncount > nxsd(2) ) then
              if ( iproc == 0 ) then
                 print*,' overstepped (2) ',ncount,nxsd(2)
                 print*,is,nsectors(1)
              end if
              call BMPI_ABORT(icomm,101,ierr)
              stop
           end if
           nstart(ncount) = in
        end do  !in
     end if

     pdim = xsd(1)%sector(is)%nxsd  ! get dimension of this proton sector
 ! set values in xstart(1,...) by looping over these proton SDs

     do ip = 1,pdim
        pcount = pcount + 1

        if( pcount > nxsd(1) ) then
           if ( iproc == 0 ) print*,' overstepped (1) ',pcount,nxsd(1)
           call BMPI_ABORT(icomm,101,ierr)
           stop
        end if

        pstart(pcount) = dimbasis - 1
        dimbasis = dimbasis + ndim

     end do ! ip

  end do !is
  dimbasis = dimbasis - 1
  if ( iproc == 0 ) print*,' Total basis = ',dimbasis

!--------- ERROR TRAPS

  do ip = 1,nxsd(1)
     if ( pstart(ip) < 0 ) then
        if ( iproc == 0 )print*,' error in proton basis ',ip,pstart(ip)
        call BMPI_ABORT(icomm,101,ierr)
        stop
     end if
  end do !ip

  do in = 1,nxsd(2)
     if ( nstart(in) < 0 ) then
        if ( iproc == 0 ) print*,' error in neutron basis ',in,nstart(in)
        call BMPI_ABORT(icomm,101,ierr)
        stop
     end if
  end do !ip
  return
end subroutine combinebasis

end module basis
!##############################################################################

!##############################################################################

!##############################################################################
!subroutine sector_stats
!
!  CALLED BY: main routine
!  (after basis is created)
!
subroutine sector_stats(it)

use verbosity
use sectors
implicit none
integer it
integer is

integer nblocks,maxblocks

if(.not.verbose_sectors)return
nblocks = 0
maxblocks = 0
do is = 1,nsectors(it)
  nblocks = nblocks + xsd(it)%sector(is)%nhblocks
  maxblocks = max(maxblocks,nblocks + xsd(it)%sector(is)%nhblocks)
enddo  ! is

print*,' avg # of blocks per sector is ',nblocks/nsectors(it)
print*,' max # of blocks in a sector is ',maxblocks

return
end subroutine sector_stats
!##############################################################################
! subroutine checkbasis
!
! optional subroutine used strictly to make sure basis arrays are correct
!
!  called by main routine when reading in old wavefunction file
!
subroutine checkbasis

use basis
use sectors
implicit none

logical, allocatable :: check(:)

integer is,isc,jsc
integer(8) :: ip,in
integer :: aerr
integer(kind=basis_prec) :: ibasis

 allocate(check(dimbasis), stat=aerr)
 if(aerr /= 0) then
    call memerror("checkbasis 1")
    stop 5
 end if

 check(:) = .false.
 do is = 1,nsectors(1)
   do ip = xsd(1)%sector(is)%xsdstart,xsd(1)%sector(is)%xsdend

     do isc = 1,xsd(1)%sector(is)%ncsectors
        jsc = xsd(1)%sector(is)%csector(isc)

        do in = xsd(2)%sector(jsc)%xsdstart,xsd(2)%sector(jsc)%xsdend
          ibasis = pstart(ip)+nstart(in)
!----------------- ERROR TRAP --------------------
          if(check(ibasis))then
           print*,' state already occupied ! ',ibasis
           print*,ip,in
           print*,pstart(ip),nstart(in)
           stop
          endif

          check(ibasis) = .true.
        enddo
     enddo !isc
   enddo  !ip

 enddo  !is

 do ibasis = 1,dimbasis
   if(.not.check(ibasis))then
       print*,' missing basis state ',ibasis
       stop
   endif
 enddo
 print*,' All states present and accounted for '
 return
end subroutine checkbasis
!##############################################################################
! subroutine writeoutbasis
!
! optional subroutine to write out basis states to a file
!
! illustrates how the basis is created and implicitly stored
!
subroutine writeoutbasis

use spstate
use haiku_info
use blocks
use basis
use sectors
use verbosity
use precisions

implicit none

  character (len=15) :: filename
  character (len=1)  :: ychar
  integer ilast
  integer iunit
  integer it
  integer(8) :: i
  integer is  ! sector
  integer iblock, lblock,rblock
  integer(8) :: xsdstart, ix
  integer ladd,radd
  integer nradd,nladd
  logical, allocatable :: checkbasis(:)
  integer (kind=basis_prec), pointer :: start(:)
  integer :: aerr

  iunit = basis_file
  print*,' '
  print*,' Do you want to write out the basis (y/n)?'
  read(5,'(a)')ychar

  if(ychar=='n' .or. ychar=='N')return

  print*,' Print out basis (f) factorized (c) combined '
  do while( ychar /= 'f' .and. ychar /= 'c')
    read(5,'(a)')ychar
    if(ychar == 'F')ychar='f'
    if(ychar == 'C')ychar='c'
    if( ychar /= 'f' .and. ychar /= 'c')then
      print*,' (f) factorized means proton, neutron slaters printed out '
      print*,'     + start arrays '
      print*,' (c) combined means proton and neutron slaters side-by-side '
    endif
  enddo

!------------------- OPEN A FILE -------------------------------

  select case (ychar)

  case ('f')
    print*,' Enter output file (.basf) name '
    read(5,'(a)')filename
    ilast =  index(filename,' ') - 1
    open(unit=iunit,file=filename(1:ilast)//'.basf',status='unknown')
  case ('c')
    print*,' Enter output file (.basc) name '
    read(5,'(a)')filename
    ilast =  index(filename,' ') - 1
    open(unit=iunit,file=filename(1:ilast)//'.basc',status='unknown')

  end select

!------------------ WRITE OUT SINGLE PARTICLE STATES------------------------
!                   FOR NOW, ASSUME PROTON AND NEUTRON BASIS THE SAME
!------------------- LEFT BASIS ----------------------------------
it = 1
do i = 1,nhsps(it)
   write(iunit,101)hspsqn(it,i)%nr, hspsqn(it,i)%j,  hspsqn(it,i)%l, hspsqn(it,i)%m,  hspsqn(it,i)%w
101 format(5i4)
enddo
do i = 1,nhsps(-it)
   write(iunit,101)hspsqn(-it,i)%nr, hspsqn(-it,i)%j,  hspsqn(-it,i)%l,  hspsqn(-it,i)%m,  hspsqn(-it,i)%w
enddo

!------------------- FACTORED BASIS ----------------------------------------
select case (ychar)

case ('f')

do it = 1,2
  allocate(checkbasis( nxsd(it)), stat=aerr)
  if(aerr /= 0) then
     call memerror("writeoutbasis 1")
     stop 5
  end if
  checkbasis = .false.
  if(it==1)then
    start=>pstart
  else
    start=>nstart
  endif
  do is = 1,nsectors(it)
     do iblock = 1,xsd(it)%sector(is)%nhblocks
        rblock = xsd(it)%sector(is)%rhblock(iblock)
        lblock = xsd(it)%sector(is)%lhblock(iblock)
        xsdstart = xsd(it)%sector(is)%blockstart(iblock)-1

!---------------- always make left address the outermost loop (a convention)
        nradd = hblock(it)%list(rblock)%nhsd
        nladd = hblock(-it)%list(lblock)%nhsd

        do ladd = 1,nladd
            do radd = 1,nradd
                ix = xsdstart + radd+(ladd-1)*nradd
                if(checkbasis(ix))then
                   print*,' that state already exists '
                   print*,ix
                   stop
                endif
                checkbasis(ix) = .true.
!------------------- WRITE OUT -----------------------
write(iunit,102)ix,start(ix),(hblock(-it)%list(lblock)%hsd(i,ladd),i=1,nword(it)), &
                            (hblock(it)%list(rblock)%hsd(i,radd),i=1,nword(it))
102 format(2i10,4x,4i7)
            enddo  ! radd
        enddo  ! ladd

     enddo ! iblock

  enddo ! is
  do i = 1,nxsd(it)
     if(.not.checkbasis(i))then
       print*,' missing a basis state '
     endif
  enddo
  deallocate(checkbasis)
enddo ! it
!--------------------COMBINED BASIS ----------------------------------------
case ('c')

end select
close(iunit)
return
end subroutine writeoutbasis

!##############################################################################
!subroutine writeoutsectors
!  optional subroutine to write out sector information
!
 subroutine writeoutsectors(it)

 use sectors
 use verbosity
 use io
 implicit none
 integer it
 integer ilast

 integer is,ib
 integer :: ic,csd

 if(.not.print_sectors)return

 if(it==1)then
 if(writeout )then
    ilast = index(outfile,' ')-1
    open(unit=sector_file,file=outfile(1:ilast)//'.sectors',status='unknown')
 else
    open(unit=sector_file,file='sectors.bigstick',status='unknown')
 endif
endif

 write(sector_file,*)' SECTORS ',it
 write(sector_file,*)nsectors(it)
 do is = 1,nsectors(it)
    write(sector_file,101)is, xsd(it)%sector(is)%jzX,xsd(it)%sector(is)%parX, xsd(it)%sector(is)%wX, &
	    xsd(it)%sector(is)%basisstart,xsd(it)%sector(is)%basisend, xsd(it)%sector(is)%nxsd
101 format(i4,' jz = ',i3,' par = ',i2,' W = ',i3,', basis from ',i12,' to ',2i12)
       do ib = 1,xsd(it)%sector(is)%nhblocks
         write(sector_file,201)ib, xsd(it)%sector(is)%lhblock(ib), xsd(it)%sector(is)%rhblock(ib)
201 format(5x,' Block ',i3,' : ',2i4)
       enddo
!	   if(it==1)then
		   do ic = 1,xsd(it)%sector(is)%ncsectors
			   csd = xsd(it)%sector(is)%csector(ic)
			   write(sector_file,301)csd,xsd(2)%sector(csd)%nxsd
301 format(5x,' Conjugate sector ',i5,i12)

		   end do

!	   end if

 enddo ! is

 if(it==2)close(sector_file)

 return

 end subroutine writeoutsectors

!##############################################################################
!
! added in 7.4.9 by CWJ
!
! finds start and stop in basis for each proton sector
!

subroutine sectorboundaries

	use sectors
	use basis
	implicit none

	integer :: is,ics,cs
	integer(8) :: dimsofar,npsd,nnsd

	dimsofar = 0   ! summary dimension

	do is = 1,nsectors(1)  ! loop over proton sectors
		xsd(1)%sector(is)%basisstart = dimsofar+1
		npsd = xsd(1)%sector(is)%nxsd  ! # of proton SDs in this proton sector
		nnsd = 0
		do ics = 1,xsd(1)%sector(is)%ncsectors  ! loop over conjugate neutron sectors
			cs = xsd(1)%sector(is)%csector(ics) ! fetch index for conjugate neutron sector
			nnsd = nnsd + xsd(2)%sector(cs)%nxsd  ! count up # of neutron SDs in conjugate sectors
		end do  ! ics
		dimsofar = dimsofar + npsd*nnsd
		xsd(1)%sector(is)%basisend = dimsofar
	end do  ! is
! -----  CHECK IF DIMENSIONS AGREE ---

    if( dimsofar /= dimbasis)then
	    print*,' mismatch in dimensions ',dimsofar,dimbasis
		stop
    end if
	return
end subroutine sectorboundaries

!---


!***********************************************************************
! Computes daily, monthly, yearly, and total flow summaries of volumes
! and flows for all HRUs
!***********************************************************************
      MODULE PRMS_BASINSUM
      IMPLICIT NONE
!   Local Variables
      INTEGER, SAVE :: BALUNT, Totdays
      CHARACTER(LEN=9), SAVE :: MODNAME
      INTEGER, SAVE :: Header_prt, Endjday
      CHARACTER(LEN=32) :: Buffer32
      CHARACTER(LEN=40) :: Buffer40
      CHARACTER(LEN=48) :: Buffer48
      CHARACTER(LEN=80) :: Buffer80
      CHARACTER(LEN=120) :: Buffer120
      CHARACTER(LEN=151) :: Buffer151
      CHARACTER(LEN=151), PARAMETER :: DASHS = ' --------------------------------------------------------'// &
     &  '----------------------------------------------------------------------------------------------'
      CHARACTER(LEN=151), PARAMETER :: STARS = ' ********************************************************'// &
     &  '**********************************************************************************************'
      CHARACTER(LEN=151), PARAMETER :: EQULS = ' ========================================================'// &
     &  '=============================================================================================='
      LOGICAL, SAVE :: Dprt, Mprt, Yprt, Tprt
      DOUBLE PRECISION, SAVE :: Basin_swrad_yr, Basin_swrad_tot, Basin_swrad_mo
!   Declared Variables
      DOUBLE PRECISION, SAVE :: Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot
      DOUBLE PRECISION, SAVE :: Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot
      DOUBLE PRECISION, SAVE :: Basin_net_ppt_yr, Basin_net_ppt_tot, Watbal_sum
      DOUBLE PRECISION, SAVE :: Basin_max_temp_yr, Basin_max_temp_tot
      DOUBLE PRECISION, SAVE :: Basin_min_temp_yr, Basin_min_temp_tot
      DOUBLE PRECISION, SAVE :: Basin_potet_yr, Basin_potet_tot
      DOUBLE PRECISION, SAVE :: Basin_actet_yr, Basin_actet_tot
      DOUBLE PRECISION, SAVE :: Basin_snowmelt_yr, Basin_snowmelt_tot
      DOUBLE PRECISION, SAVE :: Basin_gwflow_yr, Basin_gwflow_tot
      DOUBLE PRECISION, SAVE :: Basin_ssflow_yr, Basin_ssflow_tot
      DOUBLE PRECISION, SAVE :: Basin_sroff_yr, Basin_sroff_tot
      DOUBLE PRECISION, SAVE :: Basin_stflow_yr, Basin_stflow_tot
      DOUBLE PRECISION, SAVE :: Basin_ppt_yr, Basin_ppt_tot, Last_basin_stor
      DOUBLE PRECISION, SAVE :: Basin_intcp_evap_yr, Basin_intcp_evap_tot, Basin_lakeevap_yr
      DOUBLE PRECISION, SAVE :: Obsq_inches_yr, Obsq_inches_tot
      DOUBLE PRECISION, SAVE :: Basin_net_ppt_mo, Obsq_inches_mo
      DOUBLE PRECISION, SAVE :: Basin_max_temp_mo, Basin_min_temp_mo
      DOUBLE PRECISION, SAVE :: Basin_actet_mo
      DOUBLE PRECISION, SAVE :: Basin_snowmelt_mo, Basin_gwflow_mo
      DOUBLE PRECISION, SAVE :: Basin_sroff_mo, Basin_stflow_mo
      DOUBLE PRECISION, SAVE :: Basin_intcp_evap_mo, Basin_storage
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_et_yr(:)
      DOUBLE PRECISION, SAVE :: Basin_storvol, Basin_potet_mo
      DOUBLE PRECISION, SAVE :: Basin_ssflow_mo, Basin_ppt_mo
      DOUBLE PRECISION, SAVE :: Obsq_inches
      DOUBLE PRECISION, SAVE :: Basin_runoff_ratio, Basin_runoff_ratio_mo
      DOUBLE PRECISION, SAVE :: Basin_lakeevap_mo
!   Declared Parameters
      INTEGER, SAVE :: Print_type, Print_freq, Outlet_sta
      END MODULE PRMS_BASINSUM

!***********************************************************************
!     Main basin_sum routine
!***********************************************************************
      INTEGER FUNCTION basin_sum()
      USE PRMS_MODULE, ONLY: Process, Save_vars_to_file
      IMPLICIT NONE
! Functions
      INTEGER, EXTERNAL :: sumbdecl, sumbinit, sumbrun
      EXTERNAL :: basin_sum_restart
!***********************************************************************
      basin_sum = 0

      IF ( Process(:3)=='run' ) THEN
        basin_sum = sumbrun()
      ELSEIF ( Process(:4)=='decl' ) THEN
        basin_sum = sumbdecl()
      ELSEIF ( Process(:4)=='init' ) THEN
        basin_sum = sumbinit()
      ELSEIF ( Process(:5)=='clean' ) THEN
        IF ( Save_vars_to_file==1 ) CALL basin_sum_restart(0)
      ENDIF

      END FUNCTION basin_sum

!***********************************************************************
!     sumbdecl - set up basin summary parameters
!   Declared Parameters
!     print_type, print_freq, outlet_sta
!***********************************************************************
      INTEGER FUNCTION sumbdecl()
      USE PRMS_BASINSUM
      USE PRMS_MODULE, ONLY: Model, Nhru, Nobs
      IMPLICIT NONE
! Functions
      INTEGER, EXTERNAL :: declparam, declvar
      EXTERNAL read_error, print_module
! Local Variables
      CHARACTER(LEN=80), SAVE :: Version_basin_sum
!***********************************************************************
      sumbdecl = 0

      Version_basin_sum = 'basin_sum.f90 2017-10-21 14:18:00Z'
      CALL print_module(Version_basin_sum, 'Summary                     ', 90)
      MODNAME = 'basin_sum'

      IF ( declvar(MODNAME, 'last_basin_stor', 'one', 1, 'double', &
     &     'Basin area-weighted average storage in all water storage reservoirs from previous time step', &
     &     'inches', Last_basin_stor)/=0 ) CALL read_error(3, 'last_basin_stor')
      IF ( declvar(MODNAME, 'watbal_sum', 'one', 1, 'double', &
     &     'Water balance aggregate', &
     &     'inches', Watbal_sum)/=0 ) CALL read_error(3, 'watbal_sum')
      IF ( declvar(MODNAME, 'obs_runoff_mo', 'one', 1, 'double', &
     &     'Monthly measured streamflow at basin outlet', &
     &     'cfs', Obs_runoff_mo)/=0 ) CALL read_error(3, 'obs_runoff_mo')
      IF ( declvar(MODNAME, 'basin_cfs_mo', 'one', 1, 'double', &
     &     'Monthly total streamflow to stream network', &
     &     'cfs', Basin_cfs_mo)/=0 ) CALL read_error(3, 'basin_cfs_mo')
      IF ( declvar(MODNAME, 'obs_runoff_yr', 'one', 1, 'double', &
     &     'Yearly measured streamflow at basin outlet', &
     &     'cfs', Obs_runoff_yr)/=0 ) CALL read_error(3, 'obs_runoff_yr')
      IF ( declvar(MODNAME, 'basin_cfs_yr', 'one', 1, 'double', &
     &     'Yearly total streamflow to stream network', &
     &     'cfs', Basin_cfs_yr)/=0 ) CALL read_error(3, 'basin_cfs_yr')
      IF ( declvar(MODNAME, 'basin_net_ppt_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average net precipitation', &
     &     'inches', Basin_net_ppt_yr)/=0 ) CALL read_error(3, 'basin_net_ppt_yr')
      IF ( declvar(MODNAME, 'basin_max_temp_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average maximum temperature', &
     &     'temp_units', Basin_max_temp_yr)/=0) CALL read_error(3,'basin_max_temp_yr')
      IF ( declvar(MODNAME, 'basin_min_temp_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average minimum temperature', &
     &     'temp_units', Basin_min_temp_yr)/=0) CALL read_error(3,'basin_min_temp_yr')
      IF ( declvar(MODNAME, 'basin_potet_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average potential ET', &
     &     'temp_units', Basin_potet_yr)/=0 ) CALL read_error(3, 'basin_potet_yr')
      IF ( declvar(MODNAME, 'basin_actet_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average actual ET', &
     &     'inches', Basin_actet_yr)/=0 ) CALL read_error(3, 'basin_actet_yr')
      IF ( declvar(MODNAME, 'basin_snowmelt_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average snowmelt', &
     &     'inches', Basin_snowmelt_yr)/=0) CALL read_error(3,'basin_snowmelt_yr')
      IF ( declvar(MODNAME, 'basin_gwflow_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average groundwater discharge', &
     &     'inches', Basin_gwflow_yr)/=0 ) CALL read_error(3, 'basin_gwflow_yr')
      IF ( declvar(MODNAME, 'basin_ssflow_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average interflow', &
     &     'inches', Basin_ssflow_yr)/=0 ) CALL read_error(3, 'basin_ssflow_yr')
      IF ( declvar(MODNAME, 'basin_sroff_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average overland runoff', &
     &     'inches', Basin_sroff_yr)/=0 ) CALL read_error(3, 'basin_sroff_yr')
      IF ( declvar(MODNAME, 'basin_ppt_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average precipitation', &
     &     'inches', Basin_ppt_yr)/=0 ) CALL read_error(3, 'basin_ppt_yr')
      IF ( declvar(MODNAME, 'basin_stflow_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average streamflow', &
     &     'inches', Basin_stflow_yr)/=0 ) CALL read_error(3, 'basin_stflow_yr')
      IF ( declvar(MODNAME, 'obsq_inches_yr', 'one', 1, 'double', &
     &     'Yearly measured streamflow at specified outlet station', &
     &     'inches', Obsq_inches_yr)/=0 ) CALL read_error(3, 'obsq_inches_yr')
      IF ( declvar(MODNAME, 'basin_intcp_evap_yr', 'one', 1, 'double', &
     &     'Yearly basin area-weighted average canopy evaporation', &
     &     'inches', Basin_intcp_evap_yr)/=0 ) CALL read_error(3, 'basin_intcp_evap_yr')
      IF ( declvar(MODNAME, 'obs_runoff_tot', 'one', 1, 'double', &
     &     'Total simulation measured streamflow at basin outlet', &
     &     'cfs', Obs_runoff_tot)/=0 ) CALL read_error(3, 'obs_runoff_tot')
      IF ( declvar(MODNAME, 'basin_cfs_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average streamflow', &
     &     'inches', Basin_cfs_tot)/=0 ) CALL read_error(3, 'basin_cfs_tot')
      IF ( declvar(MODNAME, 'basin_ppt_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average precipitation', &
     &     'inches', Basin_ppt_tot)/=0 ) CALL read_error(3, 'basin_ppt_tot')
      IF ( declvar(MODNAME, 'basin_max_temp_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average maximum temperature', &
     &     'temp_units', Basin_max_temp_tot)/=0 ) CALL read_error(3, 'basin_max_temp_tot')
      IF ( declvar(MODNAME, 'basin_min_temp_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average minimum temperature', &
     &     'temp_units', Basin_min_temp_tot)/=0 ) CALL read_error(3, 'basin_min_temp_tot')
      IF ( declvar(MODNAME, 'basin_potet_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average potential ET', &
     &     'inches', Basin_potet_tot)/=0 ) CALL read_error(3, 'basin_potet_tot')
      IF ( declvar(MODNAME, 'basin_actet_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average actual ET', &
     &     'inches', Basin_actet_tot)/=0 ) CALL read_error(3, 'basin_actet_tot')
      IF ( declvar(MODNAME, 'basin_snowmelt_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average snowmelt', &
     &     'inches', Basin_snowmelt_tot)/=0 ) CALL read_error(3, 'basin_snowmelt_tot')
      IF ( declvar(MODNAME, 'basin_gwflow_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average groundwater discharge' , &
     &     'inches', Basin_gwflow_tot)/=0 ) CALL read_error(3, 'basin_gwflow_tot')
      IF ( declvar(MODNAME, 'basin_ssflow_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average interflow', &
     &     'inches', Basin_ssflow_tot)/=0 ) CALL read_error(3, 'basin_ssflow_tot')
      IF ( declvar(MODNAME, 'basin_sroff_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average overland flow', &
     &     'inches', Basin_sroff_tot)/=0 ) CALL read_error(3, 'basin_sroff_tot')
      IF ( declvar(MODNAME, 'basin_stflow_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average streamflow', &
     &     'inches', Basin_stflow_tot)/=0 ) CALL read_error(3, 'basin_stflow_tot')
      IF ( declvar(MODNAME, 'obsq_inches_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average measured streamflow at specified outlet station', &
     &     'inches', Obsq_inches_tot)/=0 ) CALL read_error(3, 'obsq_inches_tot')
      IF ( declvar(MODNAME, 'basin_intcp_evap_tot', 'one', 1, 'double', &
     &     'Total simulation basin area-weighted average canopy evaporation', &
     &     'inches', Basin_intcp_evap_tot)/=0 ) CALL read_error(3, 'basin_intcp_evap_tot')

! declare parameters
      IF ( Nobs>0 .OR. Model==99 ) THEN
        IF ( declparam(MODNAME, 'outlet_sta', 'one', 'integer', &
     &       '0', 'bounded', 'nobs', &
     &       'Index of measurement station to use for basin outlet', &
     &       'Index of measured streamflow station corresponding to the basin outlet', &
     &       'none')/=0 ) CALL read_error(1, 'outlet_sta')
      ENDIF

      IF ( declparam(MODNAME, 'print_type', 'one', 'integer', &
     &     '1', '0', '2', &
     &     'Type of output written to output file', &
     &     'Flag to select the type of results written to the output'// &
     &     ' file (0=measured and simulated flow only;'// &
     &     ' 1=water balance table; 2=detailed output)', &
     &     'none')/=0 ) CALL read_error(1, 'print_type')

      IF ( declparam(MODNAME, 'print_freq', 'one', 'integer', &
     &     '3', '0', '15', &
     &     'Frequency for the output frequency', &
     &     'Flag to select the output frequency; for combinations,'// &
     &     ' add index numbers, e.g., daily plus yearly = 10;'// &
     &     ' yearly plus total = 3 (0=none; 1=run totals; 2=yearly;'// &
     &     ' 4=monthly; 8=daily; or additive combinations)', &
     &     'none')/=0 ) CALL read_error(1, 'print_freq')

      IF ( declvar(MODNAME, 'basin_intcp_evap_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average interception evaporation', &
     &     'inches', Basin_intcp_evap_mo)/=0 ) CALL read_error(3, 'basin_intcp_evap_mo')

      IF ( declvar(MODNAME, 'basin_storage', 'one', 1, 'double', &
     &     'Basin area-weighted average storage in all water storage reservoirs', &
     &     'inches', Basin_storage)/=0 ) CALL read_error(3, 'basin_storage')

!******************basin_storage volume:
      IF ( declvar(MODNAME, 'basin_storvol', 'one', 1, 'double', &
     &     'Basin area-weighted average storage volume in all water storage reservoirs', &
     &     'acre-inches', Basin_storvol)/=0 ) CALL read_error(3, 'basin_storvol')

      IF ( declvar(MODNAME, 'obsq_inches', 'one', 1, 'double', &
     &     'Measured streamflow at specified outlet station', &
     &     'inches', Obsq_inches)/=0 ) CALL read_error(3, 'obsq_inches')

      IF ( declvar(MODNAME, 'basin_ppt_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average precipitation', &
     &     'inches', Basin_ppt_mo)/=0 ) CALL read_error(3, 'basin_ppt_mo')

      IF ( declvar(MODNAME, 'basin_net_ppt_mo', 'one', 1, 'double', &
     &     'Monthly area-weighted average net precipitation', &
     &     'inches', Basin_net_ppt_mo)/=0 ) CALL read_error(3, 'basin_net_ppt_mo')

      IF ( declvar(MODNAME, 'basin_max_temp_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average maximum air temperature', &
     &     'temp_units', Basin_max_temp_mo)/=0 ) CALL read_error(3, 'basin_max_temp_mo')

      IF ( declvar(MODNAME, 'basin_min_temp_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average minimum air temperature', &
     &     'temp_units', Basin_min_temp_mo)/=0 ) CALL read_error(3, 'basin_min_temp_mo')

      IF ( declvar(MODNAME, 'basin_potet_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average potential ET', &
     &     'inches', Basin_potet_mo)/=0 ) CALL read_error(3, 'basin_potet_mo')

      IF ( declvar(MODNAME, 'basin_actet_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average actual ET', &
     &     'inches', Basin_actet_mo)/=0 ) CALL read_error(3, 'basin_actet_mo')

      IF ( declvar(MODNAME, 'basin_snowmelt_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average snowmelt', &
     &     'inches', Basin_snowmelt_mo)/=0 ) CALL read_error(3, 'basin_snowmelt_mo')

      IF ( declvar(MODNAME, 'basin_gwflow_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average groundwater discharge', &
     &     'inches', Basin_gwflow_mo)/=0 ) CALL read_error(3, 'basin_gwflow_mo')

      IF ( declvar(MODNAME, 'basin_ssflow_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average interflow', &
     &     'inches', Basin_ssflow_mo)/=0 ) CALL read_error(3, 'basin_ssflow_mo')

      IF ( declvar(MODNAME, 'basin_sroff_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average surface runoff', &
     &     'inches', Basin_sroff_mo)/=0 ) CALL read_error(3, 'basin_sroff_mo')

      IF ( declvar(MODNAME, 'basin_stflow_mo', 'one', 1, 'double', &
     &     'Monthly basin area-weighted average simulated streamflow', &
     &     'inches', Basin_stflow_mo)/=0 ) CALL read_error(3, 'basin_stflow_mo')

      IF ( declvar(MODNAME, 'obsq_inches_mo', 'one', 1, 'double', &
     &     'Monthly measured streamflow at specified outlet station', &
     &     'inches', Obsq_inches_mo)/=0 ) CALL read_error(3, 'obsq_inches_mo')

      ALLOCATE ( Hru_et_yr(Nhru) )
      IF ( declvar(MODNAME, 'hru_et_yr', 'nhru', Nhru, 'double', &
     &     'Yearly area-weighted average actual ET for each HRU', &
     &     'inches', Hru_et_yr)/=0 ) CALL read_error(3, 'hru_et_yr')

      IF ( declvar(MODNAME, 'basin_runoff_ratio_mo', 'one', 1, 'double', &
     &     'Monthly area-weighted average discharge/precipitation', &
     &     'decimal fraction', Basin_runoff_ratio_mo)/=0 ) CALL read_error(3, 'basin_runoff_ratio_mo')

      IF ( declvar(MODNAME, 'basin_runoff_ratio', 'one', 1, 'double', &
     &     'Basin area-weighted average discharge/precipitation', &
     &     'decimal fraction', Basin_runoff_ratio)/=0 ) CALL read_error(3, 'basin_runoff_ratio')

      END FUNCTION sumbdecl

!***********************************************************************
!     sumbinit - Initialize basinsum module - get parameter values
!***********************************************************************
      INTEGER FUNCTION sumbinit()
      USE PRMS_BASINSUM
      USE PRMS_MODULE, ONLY: Print_debug, Nobs, Init_vars_from_file
      USE PRMS_FLOWVARS, ONLY: Basin_soil_moist, Basin_ssstor, Basin_lake_stor
      USE PRMS_INTCP, ONLY: Basin_intcp_stor
      USE PRMS_SNOW, ONLY: Basin_pweqv
      USE PRMS_SRUNOFF, ONLY: Basin_imperv_stor, Basin_dprst_volcl, Basin_dprst_volop
      USE PRMS_GWFLOW, ONLY: Basin_gwstor
      IMPLICIT NONE
      INTRINSIC MAX, MOD
      INTEGER, EXTERNAL :: getparam, julian_day
      EXTERNAL :: header_print, read_error, write_outfile, basin_sum_restart, PRMS_open_module_file
! Local Variables
      INTEGER :: pftemp
!***********************************************************************
      sumbinit = 0

      IF ( Nobs>0 ) THEN
        IF ( getparam(MODNAME, 'outlet_sta', 1, 'integer', Outlet_sta) &
     &       /=0 ) CALL read_error(2, 'outlet_sta')
        IF ( Outlet_sta==0 ) Outlet_sta = 1
      ENDIF

      IF ( getparam(MODNAME, 'print_type', 1, 'integer', Print_type) &
     &     /=0 ) CALL read_error(2, 'print_type')

      IF ( getparam(MODNAME, 'print_freq', 1, 'integer', Print_freq) &
     &     /=0 ) CALL read_error(2, 'print_freq')

      IF ( Init_vars_from_file==1 ) THEN
        CALL basin_sum_restart(1)
      ELSE
!  Zero stuff out when Timestep = 0
        Watbal_sum = 0.0D0

        Obs_runoff_mo = 0.0D0
        Basin_cfs_mo = 0.0D0
        Basin_ppt_mo = 0.0D0
        Basin_net_ppt_mo = 0.0D0
        Basin_swrad_mo = 0.0D0
        Basin_max_temp_mo = 0.0D0
        Basin_min_temp_mo = 0.0D0
        Basin_intcp_evap_mo = 0.0D0
        Basin_potet_mo = 0.0D0
        Basin_actet_mo = 0.0D0
        Basin_snowmelt_mo = 0.0D0
        Basin_gwflow_mo = 0.0D0
        Basin_ssflow_mo = 0.0D0
        Basin_sroff_mo = 0.0D0
        Basin_stflow_mo = 0.0D0
        Obsq_inches_mo = 0.0D0
        Basin_runoff_ratio = 0.0D0
        Basin_runoff_ratio_mo = 0.0D0
        Basin_lakeevap_mo = 0.0D0

        Obs_runoff_yr = 0.0D0
        Basin_cfs_yr = 0.0D0
        Basin_ppt_yr = 0.0D0
        Basin_net_ppt_yr = 0.0D0
        Basin_swrad_yr = 0.0D0
        Basin_max_temp_yr = 0.0D0
        Basin_min_temp_yr = 0.0D0
        Basin_intcp_evap_yr = 0.0D0
        Basin_lakeevap_yr = 0.0D0
        Basin_potet_yr = 0.0D0
        Basin_actet_yr = 0.0D0
        Basin_snowmelt_yr = 0.0D0
        Basin_gwflow_yr = 0.0D0
        Basin_ssflow_yr = 0.0D0
        Basin_sroff_yr = 0.0D0
        Basin_stflow_yr = 0.0D0
        Obsq_inches_yr = 0.0D0

        Obs_runoff_tot = 0.0D0
        Basin_cfs_tot = 0.0D0
        Basin_ppt_tot = 0.0D0
        Basin_net_ppt_tot = 0.0D0
        Basin_swrad_tot = 0.0D0
        Basin_max_temp_tot = 0.0D0
        Basin_min_temp_tot = 0.0D0
        Basin_intcp_evap_tot = 0.0D0
        Basin_potet_tot = 0.0D0
        Basin_actet_tot = 0.0D0
        Basin_snowmelt_tot = 0.0D0
        Basin_gwflow_tot = 0.0D0
        Basin_ssflow_tot = 0.0D0
        Basin_sroff_tot = 0.0D0
        Basin_stflow_tot = 0.0D0
        Obsq_inches_tot = 0.0D0
        Hru_et_yr = 0.0D0
        Totdays = 0
        Obsq_inches = 0.0D0
        Basin_storage = 0.0D0
        Basin_storvol = 0.0D0
      ENDIF

!******Set daily print switch
      IF ( Print_freq>7 ) THEN
        Dprt = .TRUE.
      ELSE
        Dprt = .FALSE.
      ENDIF

!******Set monthly print switch
      IF ( Print_freq>3 .AND. (Print_freq<8 .OR. Print_freq>11) ) THEN
        Mprt = .TRUE.
      ELSE
        Mprt = .FALSE.
      ENDIF

!******Set yearly print switch
      IF ( Print_freq==2 .OR. Print_freq==3 .OR. Print_freq==6 .OR. Print_freq==7 .OR. &
     &     Print_freq==10.OR.Print_freq==11.OR.Print_freq==14.OR.Print_freq==15 ) THEN
        Yprt = .TRUE.
      ELSE
        Yprt = .FALSE.
      ENDIF

!******Set total print switch
      pftemp = MOD( Print_freq, 2 )
      IF ( pftemp==1 ) THEN
        Tprt = .TRUE.
      ELSE
        Tprt = .FALSE.
      ENDIF

!******Set header print switch (1 prints a new header after every month
!****** summary, 2 prints a new header after every year summary)
      Header_prt = 0
      IF ( Print_freq==6 .OR. Print_freq==7 .OR. Print_freq==10 .OR. Print_freq==11 ) Header_prt = 1
      IF ( Print_freq>=12 ) Header_prt = 2
      IF ( .NOT.Dprt .AND. Print_type==1 ) Header_prt = 3

      Basin_storage = Basin_soil_moist + Basin_intcp_stor + &
     &                Basin_gwstor + Basin_ssstor + Basin_pweqv + &
     &                Basin_imperv_stor + Basin_lake_stor + &
     &                Basin_dprst_volop + Basin_dprst_volcl

      IF ( Print_freq/=0 ) THEN
        CALL header_print(Print_type)
! Print span dashes and initial storage
        IF ( Print_type==1 ) THEN
          WRITE (Buffer48, "(' initial', 27X,F9.3)") Basin_storage
          CALL write_outfile(Buffer48(:44))

        ELSEIF ( Print_type==2 ) THEN
          WRITE (Buffer120, 9001) Basin_intcp_stor, &
     &                            Basin_soil_moist, Basin_pweqv, Basin_gwstor, Basin_ssstor
          CALL write_outfile(Buffer120(:98))
        ENDIF
      ENDIF

      Endjday = julian_day('end', 'calendar')

      IF ( Print_debug==4 ) CALL PRMS_open_module_file(BALUNT, 'basin_sum.dbg')

 9001 FORMAT (' initial', 33X, F6.2, 20X, 2F6.2, F13.2, F6.2)

      END FUNCTION sumbinit

!***********************************************************************
!     sumbrun - Computes summary values
!***********************************************************************
      INTEGER FUNCTION sumbrun()
      USE PRMS_BASINSUM
      USE PRMS_MODULE, ONLY: Print_debug, Nobs, End_year, Strmflow_flag
      USE PRMS_BASIN, ONLY: Active_area, Active_hrus, Hru_route_order
      USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_lakeevap, &
     &    Basin_actet, Basin_perv_et, Basin_swale_et, Hru_actet, &
     &    Basin_ssstor, Basin_soil_moist, Basin_cfs, Basin_stflow_out, Basin_lake_stor
      USE PRMS_CLIMATEVARS, ONLY: Basin_potsw, Basin_ppt, Basin_potet, Basin_tmax, Basin_tmin
      USE PRMS_SET_TIME, ONLY: Jday, Modays, Yrdays, Julwater, Nowyear, Nowmonth, Nowday, Cfs2inches
      USE PRMS_OBS, ONLY: Streamflow_cfs
      USE PRMS_GWFLOW, ONLY: Basin_gwflow, Basin_gwstor, Basin_gwsink, Basin_gwstor_minarea_wb
      USE PRMS_INTCP, ONLY: Basin_intcp_evap, Basin_intcp_stor, Basin_net_ppt
      USE PRMS_SNOW, ONLY: Basin_snowmelt, Basin_pweqv, Basin_snowevap
      USE PRMS_SRUNOFF, ONLY: Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, &
     &    Basin_dprst_evap, Basin_dprst_volcl, Basin_dprst_volop
      USE PRMS_MUSKINGUM, ONLY: Basin_segment_storage
      IMPLICIT NONE
! Functions
      INTRINSIC SNGL, ABS, ALOG, DBLE
      EXTERNAL :: header_print, write_outfile
! Local variables
      INTEGER :: i, j, wyday, endrun, monthdays
      DOUBLE PRECISION :: wat_bal, obsrunoff
!***********************************************************************
      sumbrun = 0

      wyday = Julwater

      IF ( Nowyear==End_year .AND. Jday==Endjday ) THEN
        endrun = 1
      ELSE
        endrun = 0
      ENDIF

!*****Compute aggregated values

      Last_basin_stor = Basin_storage
      Basin_storage = Basin_soil_moist + Basin_intcp_stor + &
     &                Basin_gwstor + Basin_ssstor + Basin_pweqv + &
     &                Basin_imperv_stor + Basin_lake_stor + Basin_dprst_volop + Basin_dprst_volcl
      IF ( Strmflow_flag==4 ) Basin_storage = Basin_storage + Basin_segment_storage

! volume calculation for storage
      Basin_storvol = Basin_storage*Active_area

      obsrunoff = 0.0D0
      IF ( Nobs>0 ) obsrunoff = Streamflow_cfs(Outlet_sta)
      Obsq_inches = obsrunoff*Cfs2inches

      wat_bal = Last_basin_stor - Basin_storage + Basin_ppt + Basin_gwstor_minarea_wb &
     &          - Basin_actet - Basin_stflow_out - Basin_gwsink

      IF ( Basin_stflow_out>0.0 ) THEN
        Basin_runoff_ratio = Basin_ppt/Basin_stflow_out
      ELSE
        Basin_runoff_ratio = 0.0
      ENDIF

      IF ( Print_debug==4 ) THEN
        WRITE ( BALUNT, "(A,2I4,7F8.4)" ) ' bsto-sm-in-gw-ss-sn-iv ', &
     &          Nowmonth, Nowday, Basin_storage, Basin_soil_moist, &
     &          Basin_intcp_stor, Basin_gwstor, Basin_ssstor, &
     &          Basin_pweqv, Basin_imperv_stor

        WRITE ( BALUNT, "(A,I6,8F8.4)" )' bet-pv-iv-in-sn-lk-sw-dp', Nowday, &
     &          Basin_actet, Basin_perv_et, Basin_imperv_evap, &
     &          Basin_intcp_evap, Basin_snowevap, Basin_lakeevap, &
     &          Basin_swale_et, Basin_dprst_evap

        WRITE ( BALUNT, "(A,I6,7F8.4,/)" ) ' bal-pp-et-st-ls-bs-gs ', &
     &          Nowday, wat_bal, Basin_ppt, Basin_actet, Basin_stflow_out, &
     &          Last_basin_stor, Basin_storage, Basin_gwsink
      ENDIF

      Watbal_sum = Watbal_sum + wat_bal

!******Check for daily print

      IF ( Dprt ) THEN
        IF ( Print_type==0 ) THEN
          WRITE ( Buffer40, "(I7,2I5,F11.2,F12.2)" ) Nowyear, &
     &            Nowmonth, Nowday, obsrunoff, Basin_cfs
          CALL write_outfile(Buffer40)

        ELSEIF ( Print_type==1 ) THEN
          WRITE ( Buffer80, "(I7,2I5,7F9.3)" ) Nowyear, &
     &            Nowmonth, Nowday, Basin_ppt, Basin_actet, Basin_storage, &
     &            Basin_stflow_out, Obsq_inches, wat_bal, Watbal_sum
          CALL write_outfile(Buffer80)

        ELSEIF ( Print_type==2 ) THEN
          WRITE ( Buffer151, 9001 ) Nowyear, Nowmonth, Nowday, Basin_potsw, &
     &            Basin_tmax, Basin_tmin, Basin_ppt, Basin_net_ppt, &
     &            Basin_intcp_stor, Basin_intcp_evap, Basin_potet, &
     &            Basin_actet, Basin_soil_moist, Basin_pweqv, &
     &            Basin_snowmelt, Basin_gwstor, Basin_ssstor, &
     &            Basin_gwflow, Basin_ssflow, Basin_sroff, &
     &            Basin_stflow_out, Basin_cfs, obsrunoff, Basin_lakeevap
          CALL write_outfile(Buffer151)

        ENDIF
      ENDIF
      IF ( Print_debug==4 ) WRITE ( BALUNT, * ) 'wat_bal =', wat_bal, &
     &                                          ' watbal_sum=', Watbal_sum

!******Compute monthly values
      IF ( Nowday==1 ) THEN
        Obs_runoff_mo = 0.0D0
        Basin_cfs_mo = 0.0D0
        Basin_ppt_mo = 0.0D0
        Basin_net_ppt_mo = 0.0D0
        Basin_swrad_mo = 0.0D0
        Basin_max_temp_mo = 0.0D0
        Basin_min_temp_mo = 0.0D0
        Basin_intcp_evap_mo = 0.0D0
        Basin_potet_mo = 0.0D0
        Basin_actet_mo = 0.0D0
        Basin_snowmelt_mo = 0.0D0
        Basin_gwflow_mo = 0.0D0
        Basin_ssflow_mo = 0.0D0
        Basin_sroff_mo = 0.0D0
        Basin_stflow_mo = 0.0D0
        Obsq_inches_mo = 0.0D0
        Basin_lakeevap_mo = 0.0D0
      ENDIF

      Obs_runoff_mo = Obs_runoff_mo + obsrunoff
      Obsq_inches_mo = Obsq_inches_mo + obsrunoff*Cfs2inches
      Basin_cfs_mo = Basin_cfs_mo + Basin_cfs
      Basin_ppt_mo = Basin_ppt_mo + Basin_ppt
      Basin_net_ppt_mo = Basin_net_ppt_mo + Basin_net_ppt
      Basin_swrad_mo = Basin_swrad_mo + Basin_potsw
      Basin_max_temp_mo = Basin_max_temp_mo + Basin_tmax
      Basin_min_temp_mo = Basin_min_temp_mo + Basin_tmin
      Basin_intcp_evap_mo = Basin_intcp_evap_mo + Basin_intcp_evap
      Basin_potet_mo = Basin_potet_mo + Basin_potet
      Basin_actet_mo = Basin_actet_mo + Basin_actet
      Basin_snowmelt_mo = Basin_snowmelt_mo + Basin_snowmelt
      Basin_gwflow_mo = Basin_gwflow_mo + Basin_gwflow
      Basin_ssflow_mo = Basin_ssflow_mo + Basin_ssflow
      Basin_sroff_mo = Basin_sroff_mo + Basin_sroff
      Basin_stflow_mo = Basin_stflow_mo + Basin_stflow_out
      Basin_lakeevap_mo = Basin_lakeevap_mo + Basin_lakeevap

      IF ( Nowday==Modays(Nowmonth) ) THEN
        monthdays = Modays(Nowmonth)
        Basin_swrad_mo = Basin_swrad_mo/monthdays
        Basin_max_temp_mo = Basin_max_temp_mo/monthdays
        Basin_min_temp_mo = Basin_min_temp_mo/monthdays
        Obs_runoff_mo = Obs_runoff_mo/monthdays
        Basin_cfs_mo = Basin_cfs_mo/monthdays
        Basin_runoff_ratio_mo = Basin_ppt_mo/monthdays/Basin_stflow_mo
        Basin_lakeevap_mo = Basin_lakeevap_mo/monthdays

        IF ( Mprt ) THEN
          IF ( Print_type==0 ) THEN
            IF ( Dprt ) CALL write_outfile(DASHS(:40))
            WRITE ( Buffer40, "(I7,I5,F16.2,F12.2)" ) Nowyear, Nowmonth, Obs_runoff_mo, Basin_cfs_mo
            CALL write_outfile(Buffer40)
            IF ( Dprt ) CALL write_outfile(DASHS(:40))

          ELSEIF ( Print_type==1 ) THEN
            IF ( Dprt ) CALL write_outfile(DASHS(:62))
            WRITE ( Buffer80, "(I7,I5,5X,5F9.3)" ) Nowyear, &
     &              Nowmonth, Basin_ppt_mo, Basin_actet_mo, Basin_storage, &
     &              Basin_stflow_mo, Obsq_inches_mo
            CALL write_outfile(Buffer80(:62))
            IF ( Dprt ) CALL write_outfile(DASHS(:62))

          ELSEIF ( Print_type==2 ) THEN
            IF ( Dprt ) CALL write_outfile(DASHS)
            WRITE ( Buffer151, 9006 ) Nowyear, Nowmonth, Basin_swrad_mo, Basin_max_temp_mo, &
     &              Basin_min_temp_mo, Basin_ppt_mo, Basin_net_ppt_mo, &
     &              Basin_intcp_evap_mo, Basin_potet_mo, Basin_actet_mo, &
     &              Basin_soil_moist, Basin_pweqv, Basin_snowmelt_mo, &
     &              Basin_gwstor, Basin_ssstor, Basin_gwflow_mo, &
     &              Basin_ssflow_mo, Basin_sroff_mo, Basin_stflow_mo, &
     &              Basin_cfs_mo, Obs_runoff_mo, Basin_lakeevap_mo
            CALL write_outfile(Buffer151)
            IF ( Dprt ) CALL write_outfile(DASHS)
          ENDIF

        ENDIF
      ENDIF

!******Check for year print

      IF ( Yprt ) THEN
        Obs_runoff_yr = Obs_runoff_yr + obsrunoff
        Obsq_inches_yr = Obsq_inches_yr + obsrunoff*Cfs2inches
        Basin_cfs_yr = Basin_cfs_yr + Basin_cfs
        Basin_ppt_yr = Basin_ppt_yr + Basin_ppt
        Basin_net_ppt_yr = Basin_net_ppt_yr + Basin_net_ppt
        Basin_swrad_yr = Basin_swrad_yr + Basin_potsw
        Basin_max_temp_yr = Basin_max_temp_yr + Basin_tmax
        Basin_min_temp_yr = Basin_min_temp_yr + Basin_tmin
        Basin_intcp_evap_yr = Basin_intcp_evap_yr + Basin_intcp_evap
        Basin_lakeevap_yr = Basin_lakeevap_yr + Basin_lakeevap
        Basin_potet_yr = Basin_potet_yr + Basin_potet
        Basin_actet_yr = Basin_actet_yr + Basin_actet
        Basin_snowmelt_yr = Basin_snowmelt_yr + Basin_snowmelt
        Basin_gwflow_yr = Basin_gwflow_yr + Basin_gwflow
        Basin_ssflow_yr = Basin_ssflow_yr + Basin_ssflow
        Basin_sroff_yr = Basin_sroff_yr + Basin_sroff
        Basin_stflow_yr = Basin_stflow_yr + Basin_stflow_out
        DO j = 1, Active_hrus
          i = Hru_route_order(j)
          Hru_et_yr(i) = Hru_et_yr(i) + DBLE( Hru_actet(i) )
        ENDDO

        IF ( wyday==Yrdays ) THEN
          IF ( Print_type==0 ) THEN

            Obs_runoff_yr = Obs_runoff_yr/Yrdays
            Basin_cfs_yr = Basin_cfs_yr/Yrdays
            IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:40))
            WRITE ( Buffer40, "(I7,F21.2,F12.2)" ) Nowyear, Obs_runoff_yr, Basin_cfs_yr
            CALL write_outfile(Buffer40)
            IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:40))

! ****annual summary here
          ELSEIF ( Print_type==1 ) THEN
            IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:62))
            WRITE ( Buffer80, "(I7,10X,5F9.3)" ) Nowyear, Basin_ppt_yr, &
     &              Basin_actet_yr, Basin_storage, Basin_stflow_yr, Obsq_inches_yr
            CALL write_outfile(Buffer80(:62))
            IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:62))

          ELSEIF ( Print_type==2 ) THEN
            Basin_swrad_yr = Basin_swrad_yr/Yrdays
            Basin_max_temp_yr = Basin_max_temp_yr/Yrdays
            Basin_min_temp_yr = Basin_min_temp_yr/Yrdays
            Obs_runoff_yr = Obs_runoff_yr/Yrdays
            Basin_cfs_yr = Basin_cfs_yr/Yrdays
            IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS)
            WRITE ( Buffer151, 9007 ) Nowyear, Basin_swrad_yr, Basin_max_temp_yr, &
     &              Basin_min_temp_yr, Basin_ppt_yr, Basin_net_ppt_yr, &
     &              Basin_intcp_stor, Basin_intcp_evap_yr, Basin_potet_yr, Basin_actet_yr, &
     &              Basin_soil_moist, Basin_pweqv, Basin_snowmelt_yr, &
     &              Basin_gwstor, Basin_ssstor, Basin_gwflow_yr, &
     &              Basin_ssflow_yr, Basin_sroff_yr, Basin_stflow_yr, &
     &              Basin_cfs_yr, Obs_runoff_yr, Basin_lakeevap_yr
            CALL write_outfile(Buffer151)
            IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS)
          ENDIF

          Obs_runoff_yr = 0.0D0
          Basin_cfs_yr = 0.0D0
          Basin_ppt_yr = 0.0D0
          Basin_net_ppt_yr = 0.0D0
          Basin_swrad_yr = 0.0D0
          Basin_max_temp_yr = 0.0D0
          Basin_min_temp_yr = 0.0D0
          Basin_intcp_evap_yr = 0.0D0
          Basin_lakeevap_yr = 0.0D0
          Basin_potet_yr = 0.0D0
          Basin_actet_yr = 0.0D0
          Basin_snowmelt_yr = 0.0D0
          Basin_gwflow_yr = 0.0D0
          Basin_ssflow_yr = 0.0D0
          Basin_sroff_yr = 0.0D0
          Basin_stflow_yr = 0.0D0
          Obsq_inches_yr = 0.0D0
          Hru_et_yr = 0.0D0

        ENDIF
      ENDIF

!******Check for total print

      IF ( Tprt ) THEN
!******Print heading if needed
!        IF ( endrun==1 ) THEN
!            CALL write_outfile(' ')
!            IF ( .NOT.Dprt .OR. .NOT.Mprt .OR. .NOT.Yprt ) CALL header_print(Print_type)
!        ENDIF

        Totdays = Totdays + 1
        Obs_runoff_tot = Obs_runoff_tot + obsrunoff
        Obsq_inches_tot = Obsq_inches_tot + obsrunoff*Cfs2inches
        Basin_cfs_tot = Basin_cfs_tot + Basin_cfs
        Basin_ppt_tot = Basin_ppt_tot + Basin_ppt
        Basin_net_ppt_tot = Basin_net_ppt_tot + Basin_net_ppt
        Basin_swrad_tot = Basin_swrad_tot + Basin_potsw
        Basin_max_temp_tot = Basin_max_temp_tot + Basin_tmax
        Basin_min_temp_tot = Basin_min_temp_tot + Basin_tmin
        Basin_intcp_evap_tot = Basin_intcp_evap_tot + Basin_intcp_evap
        Basin_potet_tot = Basin_potet_tot + Basin_potet
        Basin_actet_tot = Basin_actet_tot + Basin_actet
        Basin_snowmelt_tot = Basin_snowmelt_tot + Basin_snowmelt
        Basin_gwflow_tot = Basin_gwflow_tot + Basin_gwflow
        Basin_ssflow_tot = Basin_ssflow_tot + Basin_ssflow
        Basin_sroff_tot = Basin_sroff_tot + Basin_sroff
        Basin_stflow_tot = Basin_stflow_tot + Basin_stflow_out

        IF ( endrun==1 ) THEN

          IF ( Print_type==0 ) THEN
            Obs_runoff_tot = Obs_runoff_tot/Totdays
            Basin_cfs_tot = Basin_cfs_tot/Totdays
            CALL write_outfile(STARS(:40))
            WRITE ( Buffer48, "(A,F14.2,F12.2)" ) ' Total for run', Obs_runoff_tot, Basin_cfs_tot
            CALL write_outfile(Buffer48(:40))
            CALL write_outfile(STARS(:40))

          ELSEIF ( Print_type==1 ) THEN
            CALL write_outfile(STARS(:62))
            WRITE ( Buffer80, 9005 ) ' Total for run', Basin_ppt_tot, &
     &              Basin_actet_tot, Basin_storage, Basin_stflow_tot, Obsq_inches_tot
            CALL write_outfile(Buffer80(:62))
            CALL write_outfile(STARS(:62))

          ELSEIF ( Print_type==2 ) THEN
            Obs_runoff_tot = Obs_runoff_tot/Totdays
            Basin_cfs_tot = Basin_cfs_tot/Totdays
            CALL write_outfile(STARS)
            WRITE ( Buffer151, 9004 ) ' Total for run', Basin_ppt_tot, &
     &              Basin_net_ppt_tot, Basin_intcp_evap_tot, &
     &              Basin_potet_tot, Basin_actet_tot, Basin_soil_moist, &
     &              Basin_pweqv, Basin_snowmelt_tot, Basin_gwstor, &
     &              Basin_ssstor, Basin_gwflow_tot, Basin_ssflow_tot, &
     &              Basin_sroff_tot, Basin_stflow_tot, Basin_cfs_tot, Obs_runoff_tot, Basin_lakeevap_yr
            CALL write_outfile(Buffer151)
            CALL write_outfile(STARS)
          ENDIF
        ENDIF
      ENDIF

 9001 FORMAT (I6, 2I3, F5.0, 2F5.1, 2F7.2, 2F6.2, 2F7.2, F6.2, F6.3, F7.3, 2F6.3, 3F7.2, F7.4, F9.1, F9.2, F7.2)
 9004 FORMAT (A, 13X, 2F7.2, F12.1, 2F7.2, 2F6.2, F7.2, 2F6.2, 4F7.2, F9.1, F9.2, F7.2)
 9005 FORMAT (A, 3X, 6F9.3)
 9006 FORMAT (I6, I3, 3X, 3F5.1, 2F7.2, F12.1, 2F7.2, 2F6.2, F7.2, 2F6.2, 3F7.2, F9.1, F9.2, 2F7.2)
 9007 FORMAT (I6, 6X, 3F5.1, 2F7.2, 2F6.2, 2F7.2, 2F6.2, F7.2, 2F6.2, 3F7.2, F9.2, F9.2, 2F7.2)

      END FUNCTION sumbrun

!***********************************************************************
! Print headers for tables
! This writes the measured and simulated table header.
!***********************************************************************
      SUBROUTINE header_print(Print_type)
      USE PRMS_BASINSUM, ONLY: DASHS, Buffer80, Print_freq, Header_prt
      IMPLICIT NONE
      EXTERNAL write_outfile
! Arguments
      INTEGER, INTENT(IN) :: Print_type
!***********************************************************************
      CALL write_outfile(' ')
!  This writes the water balance table header.
      IF ( Header_prt==3 ) THEN
        CALL write_outfile('   Year Month Day   Precip     ET    Storage S-Runoff M-Runoff')
        WRITE (Buffer80, 9002)
        CALL write_outfile(Buffer80(:62))
        CALL write_outfile(DASHS(:62))

      ELSEIF ( Print_type==0 ) THEN
        IF ( Print_freq==1 ) THEN
          CALL write_outfile('                    Measured   Simulated')
        ELSE
          CALL write_outfile('   Year Month Day   Measured   Simulated')
        ENDIF
        CALL write_outfile('                      (cfs)      (cfs)')
        CALL write_outfile(DASHS(:40))

!  This writes the water balance table header.
      ELSEIF ( Print_type==1 ) THEN
        CALL write_outfile('   Year Month Day   Precip     ET    Storage S-Runoff M-Runoff   Watbal  WBalSum')
        WRITE (Buffer80, 9001)
        CALL write_outfile(Buffer80)
        CALL write_outfile(DASHS(:80))

!  This writes the detailed table header.
      ELSEIF ( Print_type==2 ) THEN
        CALL write_outfile(' Year mo day srad  tmx  tmn    ppt  n-ppt  ints  intl  potet'// &
     &    '  actet  smav pweqv   melt gwsto sssto gwflow ssflow  sroff tot-fl     sim     meas  lkevap')
        CALL write_outfile('             (ly) (F/C)(F/C)  (in)   (in)  (in)  (in)   (in)'// &
     &    '   (in)  (in)  (in)   (in)  (in)  (in)   (in)   (in)   (in)   (in)    (cfs)    (cfs)   (in)')
        CALL write_outfile(DASHS)

      ENDIF

 9001 FORMAT (17X, 7(' (inches)'))
 9002 FORMAT (17X, 5(' (inches)'))

      END SUBROUTINE header_print

!***********************************************************************
!     Write or read restart file
!***********************************************************************
      SUBROUTINE basin_sum_restart(In_out)
      USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit
      USE PRMS_BASINSUM
      IMPLICIT NONE
      ! Argument
      INTEGER, INTENT(IN) :: In_out
      EXTERNAL check_restart
      ! Local Variable
      CHARACTER(LEN=9) :: module_name
!***********************************************************************
      IF ( In_out==0 ) THEN
        WRITE ( Restart_outunit ) MODNAME
        WRITE ( Restart_outunit ) Totdays, Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot, Watbal_sum
        WRITE ( Restart_outunit ) Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot, Basin_net_ppt_yr, Basin_net_ppt_tot
        WRITE ( Restart_outunit ) Basin_max_temp_yr, Basin_max_temp_tot, Basin_min_temp_yr, Basin_min_temp_tot
        WRITE ( Restart_outunit ) Basin_potet_yr, Basin_potet_tot, Basin_actet_yr, Basin_actet_tot
        WRITE ( Restart_outunit ) Last_basin_stor, Basin_snowmelt_yr, Basin_snowmelt_tot, Basin_gwflow_yr, Basin_gwflow_tot
        WRITE ( Restart_outunit ) Basin_ssflow_yr, Basin_ssflow_tot, Basin_sroff_yr, Basin_sroff_tot
        WRITE ( Restart_outunit ) Basin_stflow_yr, Basin_stflow_tot, Basin_ppt_yr, Basin_ppt_tot
        WRITE ( Restart_outunit ) Basin_intcp_evap_yr, Basin_intcp_evap_tot, Obsq_inches_yr, Obsq_inches_tot, Basin_lakeevap_yr
        WRITE ( Restart_outunit ) Basin_net_ppt_mo, Obsq_inches_mo, Basin_max_temp_mo, Basin_min_temp_mo, Basin_actet_mo
        WRITE ( Restart_outunit ) Basin_snowmelt_mo, Basin_gwflow_mo, Basin_sroff_mo, Basin_stflow_mo
        WRITE ( Restart_outunit ) Basin_intcp_evap_mo, Basin_storage, Basin_storvol, Basin_potet_mo
        WRITE ( Restart_outunit ) Basin_ssflow_mo, Basin_ppt_mo, Obsq_inches, Basin_runoff_ratio, Basin_runoff_ratio_mo
        WRITE ( Restart_outunit ) Hru_et_yr
      ELSE
        READ ( Restart_inunit ) module_name
        CALL check_restart(MODNAME, module_name)
        READ ( Restart_inunit ) Totdays, Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot, Watbal_sum
        READ ( Restart_inunit ) Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot, Basin_net_ppt_yr, Basin_net_ppt_tot
        READ ( Restart_inunit ) Basin_max_temp_yr, Basin_max_temp_tot, Basin_min_temp_yr, Basin_min_temp_tot
        READ ( Restart_inunit ) Basin_potet_yr, Basin_potet_tot, Basin_actet_yr, Basin_actet_tot
        READ ( Restart_inunit ) Last_basin_stor, Basin_snowmelt_yr, Basin_snowmelt_tot, Basin_gwflow_yr, Basin_gwflow_tot
        READ ( Restart_inunit ) Basin_ssflow_yr, Basin_ssflow_tot, Basin_sroff_yr, Basin_sroff_tot
        READ ( Restart_inunit ) Basin_stflow_yr, Basin_stflow_tot, Basin_ppt_yr, Basin_ppt_tot
        READ ( Restart_inunit ) Basin_intcp_evap_yr, Basin_intcp_evap_tot, Obsq_inches_yr, Obsq_inches_tot, Basin_lakeevap_yr
        READ ( Restart_inunit ) Basin_net_ppt_mo, Obsq_inches_mo, Basin_max_temp_mo, Basin_min_temp_mo, Basin_actet_mo
        READ ( Restart_inunit ) Basin_snowmelt_mo, Basin_gwflow_mo, Basin_sroff_mo, Basin_stflow_mo
        READ ( Restart_inunit ) Basin_intcp_evap_mo, Basin_storage, Basin_storvol, Basin_potet_mo
        READ ( Restart_inunit ) Basin_ssflow_mo, Basin_ppt_mo, Obsq_inches, Basin_runoff_ratio, Basin_runoff_ratio_mo
        READ ( Restart_inunit ) Hru_et_yr
      ENDIF
      END SUBROUTINE basin_sum_restart


       subroutine genfun(mf, nx, xv, fv, iend)
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
c purpose:  generic function for lmdif1 minimization
c
c arguments:
c      mf       number of points in ffit                [in]
c      nx       number of points in xv                  [in]
c      xv       vector of variables                     [in]
c      fv       output vector to be minimized           [out]
c      iend     information tag                         [out]
c
       implicit none
       include 'consts.h'
       include 'arrays.h'
       include 'feffit.h'
       include 'keywrd.h'
c local variables
       integer   nx, mf, iend, i, j, iter, nf1, ne1, get_array
       integer   ier, iff_eval_dp, mfx
       double precision  xv(nx), fv(mf), epsmin, getsca, tmpval
       double precision  fitarr(maxpts)
       parameter (epsmin = 1.d-9)
       external getsca, get_array, iff_eval_dp
       save
       if (nx.ne.nvarys) iend = 1
       if (mf.ne.mfit)   iend = 2
       do 20 i =1, nx
          scalar(i) = xv(i)
 20    continue
c
c synchronize variables and their dependencies
       call synvar
c
c look up function to minimize
       nf1 = get_array(cfmin_arr, cfmin_pre, 0, fitarr)
       ne1 = get_array(cfmin_err, cfmin_pre, 0, tmparr)
cc       print*, ' genfun = ', nf1, ne1, ':', cfmin_arr(1:40), '/',
cc     $      cfmin_err(1:40)
cc       print*, ' mf     = ', mf, ifitx1, ifitx2, usewgt,ne1
cc       print*, ' tmparr = ', tmparr(1), tmparr(2),tmparr(3)

       mfx = mf - nrestraint(1)
       if (usewgt.and.(ne1.gt.0)) then
          do 50 i = 1, mfx
             j = ifitx1 - 1 + i
             fv(i) = fitarr(j) / max(epsmin, tmparr(j))
 50       continue
       else
          do 70 i = 1, mfx
             j = ifitx1 - 1 + i
             fv(i) = fitarr(j)
 70       continue
       end if
       if (nrestraint(1) .ge. 1) then
          do 90 i =  1, nrestraint(1)
             if ((restraint(i,1).ne.'').and.
     $            (restraint(i,1).ne.undef)) then
                ier       = iff_eval_dp(restraint(i,1),tmpval)
                fv(mfx+i) = tmpval
             endif
 90       continue
       endif

c
c execute user-defined macro
       iter  =  int(getsca('&fit_iteration',0))
       if ((iter.gt.itera) .and. (ifit_mac.gt.0)) then
          itera = iter
          call iff_macro_do(ifit_mac, fit_m_arg, 0,.false.)
       endif
       return
c end subroutine genfun
       end


!
!     -------------------------------------------------------------
!      R L S P 0 0
!     -------------------------------------------------------------
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville             October 1996   *
!
      SUBROUTINE RLSP00(K, JA1, JA2, JA3, JA4, KA, IAT)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE MEDEFN_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  12:24:23  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: K
      INTEGER , INTENT(IN) :: JA1
      INTEGER , INTENT(IN) :: JA2
      INTEGER , INTENT(IN) :: JA3
      INTEGER , INTENT(IN) :: JA4
      INTEGER  :: KA
      INTEGER , INTENT(OUT) :: IAT
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: KK, LK, LD, I, J, JJ, ISKR, JI
!-----------------------------------------------
      IF (K /= 1) THEN
         IAT = 0
         KK = IHSH + IHSH - 1
         LK = J1QN1(KK,K) - 1
         LD = J1QN2(KK,K) - 1
         IF (ITTK(LK,LD,KA) == 0) RETURN
      ENDIF
      IAT = 1
      IF (IHSH == 1) RETURN
      DO I = 1, IHSH
         IF (JA1 == I) CYCLE
         IF (JA2 == I) CYCLE
         IF (JA3 == I) CYCLE
         IF (JA4 == I) CYCLE
         IF (J1QN1(I,K) == J1QN2(I,K)) CYCLE
         IAT = 0
      END DO
      IF (IAT == 0) RETURN
      IF (K == 1) RETURN
      IF (IHSH <= 2) RETURN
      IF (JA1 <= 2) RETURN
      DO J = 3, JA1
         JJ = IHSH - 2 + J
         IF (J1QN1(JJ,K) /= J1QN2(JJ,K)) IAT = 0
         IF (IAT /= 0) CYCLE
         RETURN
      END DO
! cia dabar
      ISKR = IHSH - JA3
      IF (ISKR > 0) THEN
         DO JI = 1, ISKR
            KK = IHSH + JA3 - 2 + JI
            LK = J1QN1(KK,K) - 1
            LD = J1QN2(KK,K) - 1
            IF (ITTK(LK,LD,KA) == 0) IAT = 0
            IF (IAT /= 0) CYCLE
            RETURN
         END DO
      ENDIF
! cia dabar
      RETURN
      END SUBROUTINE RLSP00


      subroutine tfgeo(calgeo0)
      use kyparam
      use tfstk
      use ffs
      use ffs_flag
      use ffs_pointer
      use tffitcode
      use geolib
      implicit none
      type (sad_comp), pointer :: cmp
      logical*4 ,intent(in):: calgeo0
      integer*4 i,lxp,lt,nv,j,it
      real*8 geo1(3,4),geo2(3,3),vsave(256),dpos,offset,xp,fr,pos0,
     $     dgo(3),tffsmarkoffset,rgetgl1,poso,posi
      logical*4 calgeo,calpol0,chg
      call tfsetparam
      if(.not. geocal)then
        if(gammab(1) .ne. p0)then
          gammab(1)=p0
          call tfgeo1(1,nlat,calgeo,.true.)
          go to 9000
        endif
        return
      endif
      irad=6
      calpol0=calpol
      calpol=.false.
      calgeo=calgeo0
      if(.not. calgeo)then
        do i=1,nlat-1
          if(idtypec(i) .eq. 20)then
            calgeo=.true.
            exit
          endif
        enddo
      endif
      if(calgeo)then
        geo(:,:,1)=geoini
      endif
      pos(1)=0.d0
      gammab(1)=p0
      inext=0
      iprev=0
      call tfgeo1(1,nlat,calgeo,.false.)
      do i=1,nlat-1
        it=idtypec(i)
        if(it .eq. icMARK)then
          offset=tffsmarkoffset(i)
          if(offset .ne. 0.d0)then
            xp=max(1.d0,min(dble(nlat),offset+dble(i)))
            lxp=int(xp)
            fr=xp-lxp
            if(fr .eq. 0.d0)then
              geo(:,:,i)=geo(:,:,lxp)
              pos(i)=pos(lxp)
            else
              lt=idtypec(lxp)
              nv=kytbl(kwmax,lt)-1
              vsave(1:nv)=merge(rlist(idvalc(lxp)+1:idvalc(lxp)+nv),
     $             rlist(latt(lxp)+1:latt(lxp)+nv),ideal)
              call compelc(lxp,cmp)
              call qfraccomp(cmp,0.d0,fr,ideal,chg)
              if(chg)then
                geo1=geo(:,:,lxp+1)
                pos0=pos(lxp+1)
                call tfgeo1(lxp,lxp+1,calgeo,.false.)
                if(i .ne. lxp+1)then
                  geo(:,:,i)=geo(:,:,lxp+1)
                  pos(i)=pos(lxp+1)
                  geo(:,:,lxp+1)=geo1
                  pos(lxp+1)=pos0
                endif
              else
                geo(:,:,i)=geo(:,:,lxp+1)
                pos(i)=pos(lxp+1)
              endif
              if(ideal)then
                rlist(idvalc(lxp)+1:idvalc(lxp)+nv)=vsave(1:nv)
              else
                rlist(latt(lxp)+1:latt(lxp)+nv)=vsave(1:nv)
              endif
              if(i .eq. 1)then
                dpos=pos(1)
                pos=pos-dpos
              endif
              if(i .eq. nlat-1)then
                geo(:,:,nlat)=geo(:,:,i)
                pos(nlat)=pos(i)
              endif
            endif
          endif
        else
          j=i+1
          posi=pos(j)
          do
            if(pos(j) .ne. posi)then
              exit
            elseif(j .eq. nlat)then
              j=0
              posi=pos(1)
            elseif(idtypec(j) .eq. it)then
              inext(i)=j
              iprev(j)=i
              exit
            endif
            j=j+1
          enddo
        endif
      enddo
      if(sorg)then
        poso=pos(iorgr)
        pos=pos-poso
      endif
      if(calgeo)then
        dgo=geo(:,4,iorgr)+ffv%geo0(1,4)*geo(:,3,iorgr)
     $       -ffv%geo0(2,4)*geo(:,1,iorgr)-ffv%geo0(3,4)*geo(:,2,iorgr)
        do concurrent (i=1:nlat)
          geo(:,4,i)=geo(:,4,i)-dgo
        enddo
        geo2=matmul(ffv%geo0(:,1:3),transpose(geo(:,1:3,iorgr)))
        do concurrent (i=1:nlat)
          geo(:,1:4,i)=matmul(geo2,geo(:,1:4,i))
        enddo
        if(sorg)then
          poso=pos(iorgr)
          pos=pos-poso
        endif
      endif
      calpol=calpol0
 9000 pgev=rgetgl1('MOMENTUM')
      call tphyzp
      circ=pos(nlat)-pos(1)
      rlist(elatt%aux+1)=circ
      dleng=rgetgl1('FSHIFT')*circ
      if(circ .ne. 0.d0)then
        omega0=pi2*c*p0/h0/circ
        if(omega0 .eq. 0.d0)then
          write(*,*)'Design orbit length =',circ
        endif
        call rsetgl1('OMEGA0',omega0)
      endif
      return
      end

      subroutine tfgeo1(istart0,istop,calgeo,acconly)
      use kyparam
      use tfstk
      use ffs
      use ffs_pointer
      use tffitcode
      use sad_main
      use tfcsi, only:icslfno
      use mathfun
      use geolib
      use kradlib, only:tallocvar,bsi
      implicit none
      type (sad_comp), pointer :: cmp
      integer*4 ,intent(in):: istart0,istop
      logical*4 ,intent(in):: calgeo,acconly
      integer*4 istart,ke,ke1,i,k,i1
      integer*8 id
      real*8 p1,h1,ali,v,dchi3,rho0,sp0,cp0,r1,r2,cchi1,schi1,
     $     cchi2,schi2,cchi3,schi3,dx,dy,dz,r11,r12,r13,
     $     r31,r32,r33,oneev,phi,fb1,fb2,x(3),y(3),
     $     theta,cost,sint,r21,r22,r23,ald,tfacc
      parameter (oneev=1.d0+3.83d-12)
      logical*4 sol,dir
      call tallocvar(bsi,1)
c     begin initialize for preventing compiler warning
      cost=1.d0
      sint=0.d0
c     end   initialize for preventing compiler warning
      sol=.false.
      istart=istart0
 1    ke=0
      ke1=0
      p1=gammab(istart)
      h1=p2h(p1)
c      h1=p1*sqrt(1.d0+1.d0/p1**2)
c      h1=sqrt(1.d0+p1**2)
      do i=istart,istop-1
        k=idtypec(i)
        if(trpt .and. (k .eq. icCAVI .or. k .eq. icMULT))then
          p1=tfacc(i,p1,h1,.true.)
        endif
        gammab(i+1)=p1
      enddo
      if(acconly)then
        return
      endif
      dvfs=0.d0
      call tesetdv(0.d0)
      do i=istart,istop-1
        i1=i+1
        if(sol)then
          sol=i .lt. ke
          cycle
        endif
        k=idtypec(i)
        id=merge(idvalc(i),elatt%comp(i),ideal)
        if(k .eq. icSOL)then
          call tsgeo(i,ke,ke1,sol)
          cycle
        endif
        call compelc(i,cmp)
        ali=merge(cmp%value(kytbl(kwL,k)),0.d0,kytbl(kwL,k) .gt. 0)
        if(kytbl(kwANGL,k) .ne. 0)then
          phi=cmp%value(kytbl(kwANGL,k))
          if(cmp%value(kytbl(kwFRMD,k)) .ne. 0.d0)then
            if(phi*ali .ne. 0.d0)then
              if(k .eq. icBEND)then
                fb1=cmp%value(kytbl(kwF1,icBEND))
     $               +cmp%value(kytbl(kwFB1,icBEND))
                fb2=cmp%value(kytbl(kwF1,icBEND))
     $               +cmp%value(kytbl(kwFB2,icBEND))
              else
                fb1=cmp%value(kytbl(kwFB1,k))
                fb2=cmp%value(kytbl(kwFB2,k))
              endif
              if(fb1 .ne. 0.d0 .or. fb2 .ne. 0.d0)then
                ali=ali-((phi*fb1)**2+(phi*fb2)**2)/ali/48.d0
     $               *sin(.5d0*(phi*(1.d0-cmp%value(kytbl(kwE1,k))
     $               -cmp%value(kytbl(kwE2,k)))
     $               -cmp%value(kytbl(kwAE1,k))
     $               -cmp%value(kytbl(kwAE2,k))))
     $               /sin(.5d0*phi)
              endif
            endif
          endif
        endif
        pos(i1)=pos(i)+ali
        if(calgeo)then
          if(k .eq. icMARK)then
            if(ke .ne. 0 .and. ke1 .ne. 0)then
              if(rlist(idvalc(i)+ky_GEO_MARK) .ne. 0)then
                dchi3=tfchi(geo(:,:,i),3)
                geo(:,1:3,ke1)=matmul(matmul(
     $               tfderotgeo(geo(:,1:3,i),(/0.d0,0.d0,dchi3/)),
     $               transpose(geo(:,1:3,i))),geo(:,1:3,ke1))
                call compelc(ke,cmp)
                cmp%value(ky_CHI1_SOL:ky_CHI3_SOL)=
     $               tgrot(geo(:,1:3,ke),geo(:,1:3,ke1))
                istart=ke1
                go to 1
              endif
            endif
          endif
          if(k .ge. 36)then
            geo(:,:,i1)=geo(:,:,i)
          endif
          if(kytbl(kwANGL,k) .ne. 0)then
            v=cmp%value(kytbl(kwANGL,k))
            ald=ali
            if(v .eq. 0.d0)then
              geo(:,4,i1)=geo(:,3,i)*ald+geo(:,4,i)
              geo(:,1:3,i1)=geo(:,1:3,i)
            else
              theta=merge(cmp%value(kytbl(kwROT,k)),0.d0,
     $             kytbl(kwROT,k) .ne. 0)
              if(theta .ne. 0.d0)then
                cost=cos(theta)
                sint=sin(theta)
                x= cost*geo(:,1,i)-sint*geo(:,2,i)
                y= sint*geo(:,1,i)+cost*geo(:,2,i)
              else
                x= geo(:,1,i)
                y=0.d0
              endif
              rho0=ald/v
              sp0=sin(v)
              cp0=cos(v)
              r1=rho0*sp0
              r2=merge(rho0*sp0**2/(1.d0+cp0),rho0*(1.d0-cp0),
     $             cp0 .ge. 0.d0)
c              r2=2.d0*rho0*sin(v*.5d0)**2
              geo(:,4,i1)=geo(:,4,i)+(r1*geo(:,3,i)-r2*x)
              geo(:,1,i1)= cp0*x+sp0*geo(:,3,i)
              geo(:,3,i1)=-sp0*x+cp0*geo(:,3,i)
              if(theta .ne. 0.d0)then
                geo(:,2,i1)=-sint*geo(:,1,i1)+cost*y
                geo(:,1,i1)= cost*geo(:,1,i1)+sint*y
              else
                geo(:,2,i1)=geo(:,2,i)
              endif
            endif
          else
            select case (k)
            case (icMAP)
              call tgmap(i)
            case (icCOORD)
              id=idvalc(i)
              cchi1=cos(cmp%value(ky_CHI1_COORD))
              schi1=sin(cmp%value(ky_CHI1_COORD))
              cchi2=cos(cmp%value(ky_CHI2_COORD))
              schi2=sin(cmp%value(ky_CHI2_COORD))
              cchi3=cos(cmp%value(ky_CHI3_COORD))
              schi3=sin(cmp%value(ky_CHI3_COORD))
              dir=cmp%value(ky_DIR_COORD) .eq. 0.d0
              if(dir)then
                dx=cmp%value(ky_DX_COORD)
                dy=cmp%value(ky_DY_COORD)
                dz=cmp%value(ky_DZ_COORD)
                r11= cchi1*cchi3+schi1*schi2*schi3
                r12=-cchi2*schi3
                r13= schi1*cchi3-cchi1*schi2*schi3
                r21=-schi1*schi2*cchi3+cchi1*schi3
                r22= cchi2*cchi3
                r23= cchi1*schi2*cchi3+schi1*schi3
                r31=-schi1*cchi2
                r32=-schi2
                r33= cchi1*cchi2
                geo(:,4,i1)=geo(:,4,i)
     1               +dx*geo(:,1,i)+dy*geo(:,2,i)+dz*geo(:,3,i)
              else
                dx=-cmp%value(ky_DX_COORD)
                dy= cmp%value(ky_DY_COORD)
                dz= cmp%value(ky_DZ_COORD)
                r11= cchi1*cchi3+schi1*schi2*schi3
                r21= cchi2*schi3
                r31=-schi1*cchi3+cchi1*schi2*schi3
                r12= schi1*schi2*cchi3-cchi1*schi3
                r22= cchi2*cchi3
                r32= cchi1*schi2*cchi3+schi1*schi3
                r13= schi1*cchi2
                r23=-schi2
                r33= cchi1*cchi2
              endif
              geo(:,1,i1)=r11*geo(:,1,i)+r12*geo(:,2,i)+r13*geo(:,3,i)
              geo(:,2,i1)=r21*geo(:,1,i)+r22*geo(:,2,i)+r23*geo(:,3,i)
              geo(:,3,i1)=r31*geo(:,1,i)+r32*geo(:,2,i)+r33*geo(:,3,i)
              if(.not. dir)then
                geo(:,4,i1)=geo(:,4,i)
     1               +dx*geo(:,1,i1)+dy*geo(:,2,i1)+dz*geo(:,3,i1)
              endif
            case default
              geo(:,4,i1)=geo(:,3,i)*ali+geo(:,4,i)
              geo(:,1:3,i1)=geo(:,1:3,i)
            end select
          endif
        endif
      enddo
      call tsetdvfs
      call tesetdv(0.d0)
      return
      end

      subroutine tfinitgeo
      use tfstk
      use ffs_flag, only:geocal
      use tmacro , only:omega0
      use tfcsi , only:lfni
      implicit none
      type (sad_descriptor) kx
      integer*4 irtc
      logical*4 err,geocal0
      if(geocal .or. omega0 .eq. 0.d0)then
        geocal0=geocal
        geocal=.true.
        call tffsa(0,lfni,kx,irtc)
        geocal=geocal0
      endif
      call tffssaveparams(0,-1,err)
      return
      end

      real*8 function tfacc(i,p1,h1,dir)
      use tfstk
      use ffs
      use ffs_pointer
      use tffitcode
      use mathfun ,only:h2p
      implicit none
      integer*4 ,intent(in):: i
      real*8 ,intent(inout):: h1,p1
      logical*4 ,intent(in):: dir
      integer*4 id
      integer*8 ip
      real*8 harm,w,v,phic,dh,h2,p2
      real*8 , parameter :: oneev=1.d0+3.83d-12
      ip=merge(idvalc(i),latt(i),ideal)
      id=idtypec(i)
      v=merge(1.d0,-1.d0,dir)*
     $       abs(charge)*rlist(ip+kytbl(kwVOLT,id))/amass
      if(v .ne. 0.d0)then
        harm=rlist(ip+kytbl(kwHARM,id))
        w=merge(pi2*rlist(ip+kytbl(kwFREQ,id)),omega0*harm,
     $       harm .eq. 0.d0)/c
        phic=rlist(ip+kytbl(kwPHI,id))*sign(1.d0,charge)
        dh=max(oneev-h1,-v*sin(phic))
        h2=h1+dh
        p2=h2p(h2)
        p1=p1+dh*(h2+h1)/(p2+p1)
        h1=h2
      endif
      tfacc=p1
      return
      end