!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The subroutine below isbased on GSLIB code,
! version 2.0 of the gslib code written in fortran 77
!
!-----------------------------------------------------------------------

!*********************************************************************************
!     Subroutines in GSLIB (auxiliary functions)
!*********************************************************************************
include 'setrot.f90'
include 'cova3.f90'
include 'sqdist.f90'
! include 'getindx.f90'
! include 'locate.f90'
! this includes sortem and dsortem
! include 'sortem.f90'
! include 'acorni.f90'
! include 'gauinv.f90'
! include 'powint.f90'
! include 'gcum.f90'

subroutine block_covariance(xdb,ydb,zdb, ndb, &
                            nst,it,c0,cc,aa,aa1,aa2,ang1,ang2,ang3, &
                            unbias,cbb)
    !-----------------------------------------------------------------------

    !                    Block Covariance
    !                    *****************************

    ! This subroutine calculate the block covariance associated with a variogram
    ! model specified by a nugget effect and nested varigoram structures.
    ! The anisotropy definition can be different for each nested structure.
    ! The block size is defined with input discretization points with
    ! arbitrary locations (for example regular discretization, random
    ! discretization or discretization points in an irregular polygon)

    ! INPUT VARIABLES:

    !   xdb,ydb,zdb      coordinates of discretization points
    !   ndb              number of discretization points
    !   nst(ivarg)       number of nested structures (maximum of 4)
    !   c0(ivarg)        isotropic nugget constant
    !   it(i)            type of each nested structure:
    !                      1. spherical model of range a;
    !                      2. exponential model of parameter a;
    !                           i.e. practical range is 3a
    !                      3. gaussian model of parameter a;
    !                           i.e. practical range is a*sqrt(3)
    !                      4. power model of power a (a must be gt. 0  and
    !                           lt. 2).  if linear model, a=1,c=slope.
    !                      5. hole effect model
    !   cc(i)            multiplicative factor of each nested structure.
    !                      (sill-c0) for spherical, exponential,and gaussian
    !                      slope for linear model.
    !   aa,aa1,aa2       parameters "a" of each nested structure.
    !   aa,aa1,aa2       rotation angles for each nested structure
    !
    ! OUTPUT VARIABLES:

    !   unbias           unbias variable, need internally for kriging
    !   cbb              block covariance

    ! Notes

    ! This functions was created from code lines in kt3d program
    !
    !
    ! Adrian Martinez  2015
    !-----------------------------------------------------------------------

    IMPLICIT NONE

    ! in
    ! variogram
    integer, intent(in)                 :: nst
    real*8, intent(in),   dimension(1)  :: c0
    integer, intent(in), dimension(nst) :: it
    real*8, intent(in), dimension(nst)  :: cc,aa, aa1, aa2,ang1,ang2,ang3
    !discretization points of the last block
    integer, intent (in) :: ndb   ! number of discretization points
    real*8, intent (in), dimension(ndb) :: xdb,ydb,zdb      !coordinates of discretization points

    !out
    real*8, intent(out) :: unbias, cbb

    ! internal
    ! variogram
    real*8 :: cmax,covmax, cov
    real*8, dimension(nst) :: anis1, anis2
    real*8, dimension(nst,3,3) :: rotmat
    real*8 ::  EPSLON=1.e-20, PMX=999.
    integer :: i, is, j

    do i=1,nst
        anis1(i) = aa1(i) / max(aa(i),EPSLON)
        anis2(i) = aa2(i) / max(aa(i),EPSLON)

        ! print *, aa(i), aa1(i), aa2(i), anis1(i), anis2(i)

        if(it(i).eq.4) then
              if(aa(i).lt.0.0) stop ' INVALID power variogram'
              if(aa(i).gt.2.0) stop ' INVALID power variogram'
        end if
    end do

    ! get the rotation matrix
    do is=1,nst
        ! bug fixed: setrot with doubles require dsetrot
        call dsetrot(ang1(is),ang2(is),ang3(is),anis1(is),anis2(is), &
        is,nst,rotmat)
        if(it(is) == 4) then
            covmax = covmax + PMX
        else
            covmax = covmax + cc(is)
        endif
    end do

    ! Calculate Block Covariance. Check for point kriging.
    ! bug fixed: dcova3 with doubles require dsetrot
    call dcova3(xdb(1),ydb(1),zdb(1),xdb(1),ydb(1),zdb(1),1,nst, &
                c0,it,cc,aa,1,nst,rotmat,cmax,cov)

    ! Set the 'unbias' variable so that the matrix solution is more stable

    unbias = cov
    cbb    = dble(cov)
    if(ndb > 1) then
        cbb = 0.0
        do i=1,ndb
            do j=1,ndb
                call dcova3(xdb(i),ydb(i),zdb(i),xdb(j),ydb(j),zdb(j), &
                           1,nst,c0,it,cc,aa,1,nst,rotmat,cmax,cov)
                if(i == j) cov = cov - c0 (1)
                cbb = cbb + dble(cov)
            end do
        end do
        cbb = cbb/dble(ndb*ndb)
    end if

    return

end subroutine block_covariance


	program n_complex
	real t1,t2,r1,r2,z1,z2
	complex z
	character*1 op
	read(*,*)op,r1,t1,r2,t2
	if(op.EQ.'m')then
		z1 = r1*r2
		z2 = t1+t2
		write(*,*)z1,'*','exp','(i*',z2,')'
	end if
	if(op.EQ.'d')then
		z1 = r1/r2
		z2 = t1-t2
		write(*,*)z1,'/','exp','(i*',z2,')'
	end if
	stop
	end


subroutine src1(meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)

    ! Called to update q by solving source term equation
    ! $q_t = \psi(q)$ over time dt starting at time t.
    !
    ! This default version integrates manning friction or other friction terms if present

    use geoclaw_module, only: dry_tolerance, grav, DEG2RAD
    use geoclaw_module, only: ifrictiontype => friction_forcing
    use geoclaw_module, only: frictioncoeff => friction_coefficient
    use setprob_module, only: xgrid,zgrid,mx_grid

    implicit none
    integer, intent(in) :: mbc,mx,meqn,maux
    real(kind=8), intent(in) :: xlower,dx,t,dt
    real(kind=8), intent(in) ::  aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) ::  q(meqn,1-mbc:mx+mbc)

    !Locals
    real(kind=8) :: gamma
    integer :: i
    real(kind=8) :: u, rcell
    integer :: ndim

    if (frictioncoeff.eq.0.d0 .or. ifrictiontype.eq.0) go to 800
      ! integrate source term based on Manning formula
    if (ifrictiontype.eq.1) then
      do i=1,mx
         if (q(1,i)<=dry_tolerance) then
            q(2,i) = 0.0
         else
            gamma= dsqrt(q(2,i)**2)*(grav*frictioncoeff**2)/(q(1,i)**(7.0/3.0))
            q(2,i)= q(2,i)/(1.d0 + dt*gamma)
        endif
      enddo
    elseif (ifrictiontype.eq.2) then
      do i=1,mx
         if (q(1,i)<=dry_tolerance) then
            q(2,i) = 0.0
         else
            gamma= q(1,i)*grav*dtan(frictioncoeff*DEG2RAD)
            gamma = max(0.d0, abs(q(2,i)) - dt*abs(gamma))
            q(2,i) = sign(gamma, q(2,i))
        endif
      enddo
    endif

 800 continue

    ! add radial source term if ndim==2:

    ndim = 1
    do i=1,mx
         rcell = 0.5*(xgrid(i) + xgrid(i+1)) - xgrid(1)  ! r = dist from center
         q(1,i) = q(1,i) - dt*(ndim-1)/rcell * q(2,i)
         if (q(1,i) .gt. dry_tolerance) then
             u = q(2,i)/q(1,i)
           else
             u = 0.d0
           endif
         q(2,i) = q(2,i) - dt*(ndim-1)/rcell * q(1,i)*u**2
         enddo

end subroutine src1


module szcmb
  use precision1, only : dp
  use constants
  use utils ,only : vec2ang,ang2vec,rotate
  use pix_tools, only : pix2ang_ring,nside2npix
  use alm_tools, only : map2alm,alm2cl
  implicit none

contains

    subroutine cmbcal(nside,dtt,iwrite)
!
!   Calculate CMB sky at observer
!   and return (T0-<T0>)/<T0> as a healpix map
!
        use cosmo_params, only : r_obs,theta_obs,model
        use sznullgeo, only : rayshoot_dr
        implicit none
        integer, intent(in) :: nside
        integer, intent(in) :: iwrite
        real(dp), dimension(0:12*nside*nside-1), intent(out) :: dtt
        real(dp), dimension(0:12*nside*nside-1) :: zp1_inv !1/(z+1)
        real(dp) :: tht_ls,phi_ls,z,zp1_inv_ave,obs_pos(3)
        integer :: npix,ipix
        character(len=28) :: filename

        obs_pos=(/r_obs,theta_obs,0.543*PI/)
! sky appears the same for any azimuthal angle (phi arbitrary)

        npix=nside2npix(nside)
!$omp parallel do private(z,tht_ls,phi_ls) &
!$omp shared(obs_pos,zp1_inv) &
!$omp schedule(guided)
        do ipix=0,npix-1
            call pix2ang_ring(nside,ipix,theta=tht_ls,phi=phi_ls)
            call rayshoot_dr(obs_pos,tht_ls,phi_ls,z,iexit=0,val_exit=-400._dp)
            zp1_inv(ipix)=1._dp/(1._dp+z)
        end do
!$omp end parallel do

        zp1_inv_ave=sum(zp1_inv)/real(npix,kind=dp)
        dtt=zp1_inv/zp1_inv_ave-1._dp

        if (iwrite == 1) then
            write(filename,'(a,a,a,i4.4,a)') &
                    'map_',model,'_Nside',nside,'.txt'
            open(unit=44, file=filename, status='replace')
            do ipix=1,npix
                write(44,*) zp1_inv(ipix), dtt(ipix)
            end do
            close(44)
        end if
        return
    end subroutine cmbcal

    subroutine cmbstats(nside,map)
!
!   Compute dipole and quadrupole
!
        use cosmo_params, only : T0CMB
        implicit none
        real(dp), dimension(:), intent(in) :: map
        integer, intent(in) :: nside
        integer, parameter :: lmax=2,mmax=2
        real(dp), dimension(1:2*nside,1) :: dw8
        complex(dp), dimension(1,0:lmax,0:mmax) :: alm
        real(dp), dimension(0:lmax,1) :: cl
        real(dp) :: dipole,quadrupole,map_max,map_min
        real(dp) :: z,zbounds(2)
        dw8=1._dp
        z=1._dp
        zbounds=(/-z,z/) !(/-1,1/) means no mask
        call map2alm(nside,lmax,mmax,map,alm,zbounds,dw8)
        call alm2cl(lmax,mmax,alm,cl)

        map_max=maxval(map)
        map_min=minval(map)

        write(*,*) 'C_0 :', cl(0,1)
        write(*,*) 'C_1 :', cl(1,1)
        write(*,*) 'C_2 :', cl(2,1)
        write(*,*) 'DT/T dpl :', 1.5_dp*sqrt(cl(1,1)/PI)
        write(*,*) 'map maxval :', map_max
        write(*,*) 'map minval :', map_min
        dipole=1.5_dp*sqrt(cl(1,1)/PI)*T0CMB
        quadrupole=(3._dp/PI)*cl(2,1)*T0CMB**2

        write(*,*) '---------------------------------------------'
        write(*,*) 'Dipole [mK] =', dipole * 1e3_dp
        write(*,*) 'Quad [uK^2] =', quadrupole * 1e12_dp
        write(*,*) '---------------------------------------------'

    end subroutine cmbstats

    function chi_squared(nside)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This routine computes the chi^2 of the composite sample for the    !
! input Szekeres model:                                              !
!                                                                    !
!     chi^2 = \sum_i [(di - dL) / \sigma di]^2                       !
!                                                                    !
! where di is the observed luminosity distance, dL is the            !
! model luminosity distance and depends on the model parameters, and !
! \sigma di is the error.                                            !
! The luminosity distance as a power series is given by              !
!                                                                    !
!     dL = c/H_0  [z + 1/2 (1-q0)z^2 + ...]                          !
!                                                                    !
! where q0 is the deceleration parameter see Weinberg 2008 (1.4.9),  !
! Visser 2004 [gr-qc/0309109].                                       !
! Then the error (to leading order) is                               !
!                                                                    !
!    \sigma dL \sim \sigma (c z / H_0) = \sigma_v / H_0              !
!                                                                    !
! where cz is the velocity and \sigma_v = c \sigma z.                !
!                                                                    !
! This routine computes dL for the Szekeres model such that the      !
! computed redshift coincides with the observed redshift.            !
! The variables tht \in [0,pi] and phi \in [0,2pi] are the local sky !
! angular coordinates related to the observer's celestial sphere     !
! NOT spacetime theta,phi.                                           !
!                                                                    !
! Composite_LG.txt has 4534 lines and 6 columns corresponding to     !
!                                                                    !
!   v[km/s], dL[Mpc/h], v_pec[km/s], sigma_v[km/s], l[deg], b[deg]   !
!                                                                    !
! where v=cz                                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        use cosmo_params, only : r_obs,theta_obs,FLRW, &
                                 ldipole,bdipole,alpha,amp,r0
        use sznullgeo, only : rayshoot_dr
        implicit none
        real(dp) :: chi_squared
        integer,  intent(in) :: nside
        integer,  parameter  :: Ntot=4534
        real(dp), dimension(0:12*nside*nside-1) :: dtt
        real(dp), dimension(1:Ntot) :: chi2_arr
        real(dp), dimension(1:3)    :: dpl_vec
        real(dp), dimension(1:3)    :: obs_pos
        real(dp) :: vi,di,vpeci,sig_vi,li,bi,sig_di
        real(dp) :: tht_dpl,phi_dpl,tht_dpl0,phi_dpl0
        real(dp) :: tht,phi,dL,z_exit,a1,a2,b1,b2
        real(dp) :: eps,Tdpl
        integer  :: i
        real(dp), parameter :: H_0=100._dp*FLRW%h !km/s/Mpc
        real(dp), parameter :: Tdpl0=5.64_dp,Tdpl_sig=0.03_dp
        real(dp), parameter :: &
                VEL2RED=1._dp/(SPEED_OF_LIGHT*1.0e-3_dp)
! observed dipole angle
        tht_dpl0=HALFPI-bdipole*DEG2RAD
        phi_dpl0=ldipole*DEG2RAD

        call cmbcal(nside,dtt,iwrite=0)
        call dipole_vec(nside,dtt,dpl_vec,Tdpl)
        eps=abs(Tdpl-Tdpl0)
        chi_squared=(eps/Tdpl_sig)**2
        print *, Tdpl
        call vec2ang(dpl_vec,tht_dpl,phi_dpl)

        obs_pos=(/ r_obs, theta_obs, 0.543*PI /)

        a1=phi_dpl0
        a2=HALFPI-tht_dpl0
        b1=HALFPI-tht_dpl
        b2=phi_dpl

        open(unit=77,file='Composite_LG.txt',status='OLD',action='READ')

!$omp parallel do private(vi,di,vpeci,sig_vi,li,bi,sig_di,tht,phi,dL,z_exit) &
!$omp shared(obs_pos,chi2_arr,a1,a2,b1,b2)
        do i=1,Ntot
            read(77,*) vi,di,vpeci,sig_vi,li,bi
            di=di/FLRW%h !evaluate h to get in units Mpc
            sig_di=sig_vi/H_0
            z_exit=vi*VEL2RED
            call galactic2szekeres(li,bi,tht,phi,a1,a2,b1,b2)
            call rayshoot_dr(obs_pos,tht,phi,dL,iexit=1,val_exit=z_exit)
            chi2_arr(i)=((di-dL)/sig_di)**2
        end do
!$omp end parallel do

        chi_squared=chi_squared+sum(chi2_arr)

        close(77)
        return
    end function chi_squared

    subroutine dipole_vec(nside,map,dpl_vec,Tdipole)
        use cosmo_params, only : T0CMB
        implicit none
        integer, intent(in) :: nside
        real(dp), dimension(:), intent(in) :: map
        real(dp), dimension(3), intent(out) :: dpl_vec
        real(dp), dimension(1:2*nside,1) :: dw8
        real(dp), dimension(2) :: zbounds=(/-1._dp,1._dp/)
        integer, parameter :: lmax=2,mmax=2
        complex(dp), dimension(1,0:lmax,0:mmax) :: alm
        real(dp), dimension(0:lmax,1) :: cl
        real(dp) :: a10,a11r,a11i,norm,Tdipole
        dw8=1._dp
        call map2alm(nside,lmax,mmax,map,alm,zbounds,dw8)
        a10=real(alm(1,1,0))
        a11r=real(alm(1,1,1))
        a11i=aimag(alm(1,1,1))
        dpl_vec(1)=-SQRT2*a11r
        dpl_vec(2)=+SQRT2*a11i
        dpl_vec(3)=+a10
        norm=sqrt(a10*a10+2._dp*(a11r**2+a11i**2))
        dpl_vec=dpl_vec/norm
! compute Temperature dipole (magnitude)
        call alm2cl(lmax,mmax,alm,cl)
        Tdipole=1.5_dp*sqrt(cl(1,1)/PI)*T0CMB*1e3_dp
    end subroutine dipole_vec

    subroutine galactic2szekeres(l,b,theta,phi,a1,a2,b1,b2) !formerly invrotmap
!
!   Maps galactic coordinates (l,b) [deg] to szekeres local
!   sky coordinates (theta,phi) (NOT spacetime theta,phi)
!
        implicit none
        real(dp), intent(in) :: l,b
        real(dp), intent(out) :: theta,phi
        real(dp), intent(in) :: a1,a2,b1,b2
        real(dp), dimension(3) :: vector
        theta=HALFPI-b*DEG2RAD
        phi=l*DEG2RAD
        call ang2vec(theta,phi,vector)
! rotate dipole vector onto ex=(1,0,0)
        call rotate(vector,psi=-a1,axis='z')
        call rotate(vector,psi=-a2,axis='y')
! rotate ex onto the found dipole in szekeres
        call rotate(vector,psi=+b1,axis='y')
        call rotate(vector,psi=+b2,axis='z')
        call vec2ang(vector,theta,phi)
    end subroutine galactic2szekeres

end module szcmb


      subroutine unit_hyd

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    This subroutine computes variables related to the watershed hydrology:
!!    the time of concentration for the subbasins, lagged surface runoff,
!!    the coefficient for the peak runoff rate equation, and lateral flow travel
!!    time.

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~1
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch_n(1,:)   |none          |Manning"s "n" value for the tributary channels
!!    ch_s(1,:)   |m/m           |average slope of tributary channels
!!    gdrain(:)   |hrs           |drain tile lag time: the amount of time
!!                               |between the transfer of water from the soil
!!                               |to the drain tile and the release of the
!!                               |water from the drain tile to the reach.
!!    hru_km(:)   |km2           |area of HRU in square kilometers
!!    lat_ttime(:)|days          |lateral flow travel time
!!    slsoil(:)   |m             |slope length for lateral subsurface flow
!!    slsubbsn(:) |m             |average slope length for subbasin
!!    tconc(:)     |hr           |time of concentration
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    lat_ttime(:)|none          |Exponential of the lateral flow travel time
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    l           |none          |counter
!!    scmx        |mm/hr         |maximum soil hydraulic conductivity
!!    t_ch        |hr            |time for flow entering the farthest upstream
!!                               |channel to reach the subbasin outlet
!!    xx          |none          |variable to hold calculation result
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: Ttcoef

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use hru_module, only : itb, tconc, uh

      use climate_module
      use basin_module
      use channel_module
      use time_module
      use hydrograph_module, only : sp_ob

      implicit none

      integer :: j             !none          |counter
      real :: ql               !              |
      real :: sumq             !              |
      real :: tb               !              |
      real :: tp               !              |
      integer :: int           !              |
      integer :: i             !none          |counter
      real :: xi               !              |
      real :: q                !              |
      integer :: max           !              |
      integer :: ij            !              |

!!    compute unit hydrograph for computing subbasin hydrograph from direct runoff
      do j = 1, sp_ob%hru
        ql = 0.
        sumq = 0.
        tb = .5 + .6 * tconc(j) + bsn_prm%tb_adj    !baseflow time, hr
        if (tb > 48.) tb = 48.			   !maximum 48hrs
        tp = .375 * tb                       ! time to peak flow
	  !! convert to time step (from hr), J.Jeong March 2009
	  tb = ceiling(tb * 60./ real(time%dtm))
	  tp = int(tp * 60./ real(time%dtm))

	  if(tp==0) tp = 1
	  if(tb==tp) tb = tb + 1
	  itb(j) = int(tb)

	  ! Triangular Unit Hydrograph
	  if (bsn_cc%uhyd == 0) then
	    do i = 1, itb(j)
          xi = float(i)
 	      if (xi < tp) then           !! rising limb of hydrograph
            q = xi / tp
          else                        !! falling limb of hydrograph
            q = (tb - xi) / (tb - tp)
          end if
          q = Max(0.,q)
          uh(j,i) = (q + ql) / 2.
          ql = q
          sumq = sumq + uh(j,i)
        end do

		do i = 1, itb(j)
            uh(j,i) = uh(j,i) / sumq
        end do

	  ! Gamma Function Unit Hydrograph
	  elseif (bsn_cc%uhyd == 1) then
          i = 1; q = 1.
		do while (q > 0.0001)
            xi = float(i)
		   q = (xi / tp) ** bsn_prm%uhalpha * exp((1.- xi / tp) *             &
                          bsn_prm%uhalpha)
            q = Max(0.,q)
            uh(j,i) = (q + ql) / 2.
            ql = q
            sumq = sumq + uh(j,i)
	      i = i + 1
	      if (i>3.*time%step) exit
	    end do
	    itb(ij) = i - 1
          do i = 1, itb(j)
            uh(j,i) = uh(j,i) / sumq
          end do
	  endif

      end do

      return
      end subroutine unit_hyd


SUBROUTINE HelmSRKPR(nc,ND,NT,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)

    IMPLICIT DOUBLE PRECISION (A-H,O-Z)

    PARAMETER (nco=20,RGAS=0.08314472d0)

	dimension rn(nc),Arn(nc),ArVn(nc),ArTn(nc),Arn2(nc,nc)
	dimension dBi(nc),dBij(nc,nc)
	dimension dDi(nc),dDij(nc,nc),dDiT(nc)
	dimension aij(nc,nc),daijdT(nc,nc),daijdT2(nc,nc)

    DOUBLE PRECISION Kij(nco,nco)
	dimension ac(nco),b(nco),del1(nco),rm(nco)

	COMMON /COMPONENTS/ ac,b,del1,rm,Kij,NTdep
	COMMON /rule/ncomb

    TOTN = sum(rn)
    D1=del1(1)
    D2=(1-D1)/(1+D1)

	if(ncomb.lt.2)then
        call Bnder(nc,rn,Bmix,dBi,dBij)
        call DandTnder(NT,nc,T,rn,D,dDi,dDiT,dDij,dDdT,dDdT2)
	else

! 	call Bcubicnder(nc,rn,Bmix,dBi,dBij)
! 	call DCubicandTnder(NT,nc,T,rn,D,dDi,dDiT,dDij,dDdT,dDdT2)
	end if

!   The f's and g's used here are for Ar, not F (reduced Ar)					***********
!   This requires to multiply by R all g, f and its derivatives as defined by Mollerup ****

    f=log((V+D1*Bmix)/(V+D2*Bmix))/Bmix/(D1-D2)
    g=RGAS*log(1-Bmix/V)
    fv=-1/((V+D1*Bmix)*(V+D2*Bmix))
    fB=-(f+V*fv)/Bmix
    gv=RGAS*Bmix/(V*(V-Bmix))
    fv2=(-1/(V+D1*Bmix)**2+1/(V+D2*Bmix)**2)/Bmix/(D1-D2)
    gv2=RGAS*(1/V**2-1/(V-Bmix)**2)

!   Reduced Helmholtz Energy and derivatives
    Ar=-TOTN*g*T-D*f
    ArV=-TOTN*gv*T-D*fv
    ArV2=-TOTN*gv2*T-D*fv2

    AUX=RGAS*T/(V-Bmix)
    FFB=TOTN*AUX-D*fB
    FFBV=-TOTN*AUX/(V-Bmix)+D*(2*fv+V*fv2)/Bmix
    FFBB=TOTN*AUX/(V-Bmix)-D*(2*f+4*V*fv+V**2*fv2)/Bmix**2

	do i=1,nc
        Arn(i)=-g*T+FFB*dBi(i)-f*dDi(i)
        ArVn(i)=-gv*T+FFBV*dBi(i)-fv*dDi(i)
	    IF (ND.EQ.2) THEN
	        do j=1,i
                Arn2(i,j)=AUX*(dBi(i)+dBi(j))-fB*(dBi(i)*dDi(j)+dBi(j)*dDi(i))  &
                          +FFB*dBij(i,j)+FFBB*dBi(i)*dBi(j)-f*dDij(i,j)
                Arn2(j,i)=Arn2(i,j)
	        end do
	    END IF
	end do

! TEMPERATURE DERIVATIVES
	IF (NT.EQ.1) THEN
        ArT=-TOTN*g-dDdT*f
        ArTV=-TOTN*gv-dDdT*fV
        ArTT=-dDdT2*f

	    do i=1,nc
            ArTn(i)=-g+(TOTN*AUX/T-dDdT*fB)*dBi(i)-f*dDiT(i)
	    end do

	END IF

	end

# SUBROUTINE HelmSRKPR(nc,ND,NT,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)

#    IMPLICIT DOUBLE PRECISION (A-H,O-Z)

#    PARAMETER (nco=20,RGAS=0.08314472d0)

# 	dimension rn(nc),Arn(nc),ArVn(nc),ArTn(nc),Arn2(nc,nc)
# 	dimension dBi(nc),dBij(nc,nc)
# 	dimension dDi(nc),dDij(nc,nc),dDiT(nc)
# 	dimension aij(nc,nc),daijdT(nc,nc),daijdT2(nc,nc)

#     DOUBLE PRECISION Kij(nco,nco)
# 	dimension ac(nco),b(nco),del1(nco),rm(nco)

# 	COMMON /COMPONENTS/ ac,b,del1,rm,Kij,NTdep
# 	COMMON /rule/ncomb

#     TOTN = sum(rn)
#     D1=del1(1)
#     D2=(1-D1)/(1+D1)

# 	if(ncomb.lt.2)then
#         call Bnder(nc,rn,Bmix,dBi,dBij)
#         call DandTnder(NT,nc,T,rn,D,dDi,dDiT,dDij,dDdT,dDdT2)
# 	else

# ! 	call Bcubicnder(nc,rn,Bmix,dBi,dBij)
# ! 	call DCubicandTnder(NT,nc,T,rn,D,dDi,dDiT,dDij,dDdT,dDdT2)
# 	end if

# !   The f's and g's used here are for Ar, not F (reduced Ar)					***********
# !   This requires to multiply by R all g, f and its derivatives as defined by Mollerup ****

#     f=log((V+D1*Bmix)/(V+D2*Bmix))/Bmix/(D1-D2)
#     g=RGAS*log(1-Bmix/V)
#     fv=-1/((V+D1*Bmix)*(V+D2*Bmix))
#     fB=-(f+V*fv)/Bmix
#     gv=RGAS*Bmix/(V*(V-Bmix))
#     fv2=(-1/(V+D1*Bmix)**2+1/(V+D2*Bmix)**2)/Bmix/(D1-D2)
#     gv2=RGAS*(1/V**2-1/(V-Bmix)**2)

# !   Reduced Helmholtz Energy and derivatives
#     Ar=-TOTN*g*T-D*f
#     ArV=-TOTN*gv*T-D*fv
#     ArV2=-TOTN*gv2*T-D*fv2

#     AUX=RGAS*T/(V-Bmix)
#     FFB=TOTN*AUX-D*fB
#     FFBV=-TOTN*AUX/(V-Bmix)+D*(2*fv+V*fv2)/Bmix
#     FFBB=TOTN*AUX/(V-Bmix)-D*(2*f+4*V*fv+V**2*fv2)/Bmix**2

# 	do i=1,nc
#         Arn(i)=-g*T+FFB*dBi(i)-f*dDi(i)
#         ArVn(i)=-gv*T+FFBV*dBi(i)-fv*dDi(i)
# 	    IF (ND.EQ.2) THEN
# 	        do j=1,i
#                 Arn2(i,j)=AUX*(dBi(i)+dBi(j))-fB*(dBi(i)*dDi(j)+dBi(j)*dDi(i))  &
#                           +FFB*dBij(i,j)+FFBB*dBi(i)*dBi(j)-f*dDij(i,j)
#                 Arn2(j,i)=Arn2(i,j)
# 	        end do
# 	    END IF
# 	end do

# ! TEMPERATURE DERIVATIVES
# 	IF (NT.EQ.1) THEN
#         ArT=-TOTN*g-dDdT*f
#         ArTV=-TOTN*gv-dDdT*fV
#         ArTT=-dDdT2*f

# 	    do i=1,nc
#             ArTn(i)=-g+(TOTN*AUX/T-dDdT*fB)*dBi(i)-f*dDiT(i)
# 	    end do

# 	END IF

# 	end


module algorithm
  implicit none
  private

  !> floating point accuracy
  integer, parameter :: wp = selected_real_kind(15)

  public :: calc_e_kin, calc_force
contains
  subroutine calc_force(natom, xyz, f, l, e_pot_lj)
    implicit none

    !> number of atoms
    integer, intent(in) :: natom

    !> atom coordinates of particles
    real(wp), dimension(3, natom), intent(in) :: xyz
    !> distance vector between two particles
    real(wp), dimension(3) :: xyz_r
    !> squared distance between two particles
    real(wp) :: xyzij2

    !> forces
    real(wp), dimension(3, natom), intent(out) :: f
    !> force: derivate of LJ potential
    real(wp) :: ff

    !> length of cubic box
    real(wp), intent(in) :: l

    !> parameter in LJ potential
    real(wp), parameter :: sigma = 3.405_wp
    real(wp), parameter :: sigma2 = sigma*sigma
    real(wp) :: sigmar2
    real(wp) :: sigmar6
    real(wp) :: sigmar12

    !> parameter in LJ potential
    real(wp), parameter :: epsilon = 120.0_wp

    !> cutoff parameters for interaction radius
    real(wp) :: rcutoff
    real(wp) :: rcutoff2

    !> potential energy
    real(wp), intent(out) :: e_pot_lj

    !> iteration variable
    integer :: i, j

    rcutoff = 0.50_wp*l
    rcutoff2 = rcutoff*rcutoff

    f = 0.0_wp
    e_pot_lj = 0.0_wp
    do i = 1, natom - 1
      do j = i + 1, natom
        ! periodic boundary conditions
        xyz_r = xyz(:, i) - xyz(:, j)
        xyz_r = xyz_r - l*anint(xyz_r/l)

        xyzij2 = sum(xyz_r**2)
        if (xyzij2 .lt. rcutoff2) then
          sigmar2 = sigma2/xyzij2
          sigmar6 = sigmar2*sigmar2*sigmar2
          sigmar12 = sigmar6*sigmar6

          ! update force
          ff = (48.0_wp*epsilon*(sigmar12 - (0.5_wp*sigmar6)))/xyzij2
          f(:, i) = f(:, i) + ff*xyz_r
          f(:, j) = f(:, j) + ff*xyz_r

          ! energy evaluation
          e_pot_lj = e_pot_lj + sigmar12 - sigmar6 + 3.83738839608178386E-3_wp
        end if
      end do
    end do
    e_pot_lj = 4.0_wp*epsilon*e_pot_lj
  end subroutine calc_force

  subroutine calc_e_kin(natom, v, mass, e_kin)
    implicit none

    !> number of atoms
    integer, intent(in) :: natom

    !> atom coordinates of the system
    real(wp), dimension(3, natom), intent(in) :: v

    !> mass of particle
    real(wp), intent(in) :: mass

    !> potential energy
    real(wp), intent(out) :: e_kin

    !> iteration variable
    integer :: i

    e_kin = 0.0_wp
    do i = 1, natom
      e_kin = e_kin + 0.5_wp*mass*sum(v(:, i)**2)
    end do

  end subroutine calc_e_kin

  !*************************************************************
  !******************** HARMONIC OSCILLATOR ********************
  !*************************************************************

  subroutine calc_force_harm(natom, xyz, f, a)
    implicit none

    !> number of atoms
    integer, intent(in) :: natom

    !> atom coordinates of the system
    real(wp), dimension(3, natom), intent(in) :: xyz

    !> forces
    real(wp), dimension(3, natom), intent(out) :: f

    !> whatever
    real(wp), dimension(3, natom), intent(in) :: a

    !> force constant
    real(wp), parameter :: k = 1.0_wp

    !> iteration
    integer :: i

    f = 0.0_wp
    do i = 1, natom
      f(:, i) = -k*(xyz(:, i) - a(:, i))
    end do

  end subroutine calc_force_harm

  subroutine calc_pot_harm(natom, xyz, a, k, e_pot_harm)
    implicit none

    !> number of atoms
    integer, intent(in) :: natom

    !> atom coordinates of the system
    real(wp), dimension(3, natom), intent(in) :: xyz

    !> whatever
    real(wp), dimension(3, natom), intent(in) :: a

    !> force constant
    real(wp), intent(in) :: k

    !> potential energy
    real(wp), intent(out) :: e_pot_harm

    !> iteration variable
    integer :: i

    e_pot_harm = 0.0_wp
    do i = 1, natom
      e_pot_harm = e_pot_harm + 0.5_wp*k*sum((xyz(:, i) - a(:, i))**2)
    end do

  end subroutine calc_pot_harm

end module algorithm


program grad
	real*8 x(2),t,g(2),A(2,2),f,ans,aro(2)
	data x /2,2/
	data A /2,0,0,50/
	open(13,file="grad")
	write(13,"(5A13)")"f","x1","x2","g1","g2"
	do
	g=matmul(A,x)
	f=x(1)*x(1)+25.0*x(2)*x(2)
	write(13,"(5f13.6)")f,x,g
	call onedimenmul(g,g,2,ans)
	if(ans<0.01) exit
	t=ans
	aro=matmul(g,A)
	call onedimenmul(aro,g,2,ans)
	t=t/ans

	x=x-t*g
	end do
	close(13)
end program grad

	subroutine onedimenmul(m1,m2,n,ans)
	integer n
	real*8 m1(n),m2(n),ans
	ans=0
	do i=1,n
		ans=m1(i)*m2(i)+ans
	end do
	end subroutine onedimenmul


module timedisc_const_mod

use constants_mod

real(dp), parameter :: a_1 = REAL(  0.0_dp                                , dp)
real(dp), parameter :: a_2 = REAL( -567301805773.0_dp /  1357537059087.0_dp,dp)
real(dp), parameter :: a_3 = REAL(-2404267990393.0_dp /  2016746695238.0_dp,dp)
real(dp), parameter :: a_4 = REAL(-3550918686646.0_dp /  2091501179385.0_dp,dp)
real(dp), parameter :: a_5 = REAL(-1275806237668.0_dp /   842570457699.0_dp,dp)

real(dp), parameter :: b_1 = REAL( 0.0_dp                                  ,dp)
real(dp), parameter :: b_2 = REAL( 1432997174477.0_dp /  9575080441755.0_dp,dp)
real(dp), parameter :: b_3 = REAL( 2526269341429.0_dp /  6820363962896.0_dp,dp)
real(dp), parameter :: b_4 = REAL( 2006345519317.0_dp /  3224310063776.0_dp,dp)
real(dp), parameter :: b_5 = REAL( 2802321613138.0_dp /  2924317926251.0_dp,dp)

real(dp), parameter :: c_1 = REAL( 1432997174477.0_dp /  9575080441755.0_dp,dp)
real(dp), parameter :: c_2 = REAL( 5161836677717.0_dp / 13612068292357.0_dp,dp)
real(dp), parameter :: c_3 = REAL( 1720146321549.0_dp /  2090206949498.0_dp,dp)
real(dp), parameter :: c_4 = REAL( 3134564353537.0_dp /  4481467310338.0_dp,dp)
real(dp), parameter :: c_5 = REAL( 2277821191437.0_dp / 14882151754819.0_dp,dp)

integer, parameter :: nstages = 5

real(dp), parameter :: a_rk(nstages) = (/ a_1,a_2,a_3,a_4,a_5 /)
real(dp), parameter :: b_rk(nstages) = (/ b_1,b_2,b_3,b_4,b_5 /)
real(dp), parameter :: c_rk(nstages) = (/ c_1,c_2,c_3,c_4,c_5 /)

real(dp), parameter :: dt_coeffs(nstages) = b_rk

end module


! { dg-do compile }
! { dg-options "-O -fdump-tree-original -Warray-temporaries -finline-matmul-limit=0" }
subroutine xx(n, m, a, b, c, d, x, z, i, s_in, s_out)
  implicit none
  integer, intent(in) :: n, m
  real, intent(in), dimension(n,n) :: a, b, c
  real, intent(out), dimension(n,n) :: d
  real, intent(in), dimension(n,m) :: s_in
  real, intent(out), dimension(m) :: s_out
  integer, intent(out) :: i
  real, intent(inout) :: x
  real, intent(out) :: z
  character(60) :: line
  real, external :: ext_func
  integer :: one = 1
  interface
     elemental function element(x)
       real, intent(in) :: x
       real :: elem
     end function element
     pure function mypure(x)
       real, intent(in) :: x
       integer :: mypure
     end function mypure
     elemental impure function elem_impure(x)
       real, intent(in) :: x
       real :: elem_impure
     end function elem_impure
  end interface

  d = matmul(a,b) + matmul(a,b)    ! { dg-warning "Creating array temporary" }
  z = sin(x) + cos(x) + sin(x) + cos(x)
  x = ext_func(a) + 23 + ext_func(a)
  z = element(x) + element(x)
  i = mypure(x) - mypure(x)
  z = elem_impure(x) - elem_impure(x)
  s_out = sum(s_in,one) + 3.14 / sum(s_in,one) ! { dg-warning "Creating array temporary" }
end subroutine xx
! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_func" 2 "original" } }
! { dg-final { scan-tree-dump-times "element" 1 "original" } }
! { dg-final { scan-tree-dump-times "mypure" 1 "original" } }
! { dg-final { scan-tree-dump-times "elem_impure" 2 "original" } }
! { dg-final { scan-tree-dump-times "sum_r4" 1 "original" } }


C######################################################################|
      module physical_constants
C----------------------------------------------------------------------|
C     Provides several, mostyl physical constants.
C----------------------------------------------------------------------|
      use double

      implicit none

      private

      public ::
     >  e,
     >  epsilon_0,
     >  alpha,
     >
     >  m_e,
     >  m_ec,
     >
     >  pi

        ! ----- Parameters --------------------------------------------|
      real(kind=dp), parameter ::
     >  e       = 1.602176634e-19_dp,       ! electron charge (C)
     >  epsilon_0 = 8.8541878128e-12_dp,    ! vacuum permittivity (F/m)
     >  alpha   = 7.2973525693e-3_dp,       ! fine-structure constant
     >
     >  m_e     = 9.1093837015e-31_dp,      ! electron mass (kg)
     >  m_ec    = 5.1099895000e+5_dp,       ! electron mass (eV)
     >
     >  pi      = 3.1415926535897931_dp     ! this one you should know

      contains

      end module physical_constants
C######################################################################|


MODULE double_complex_erf

! Double precision complex error function
! Adapted from the Naval Surface Warfare Center Mathematics Library
! by Alan.Miller @ vic.cmis.csiro.au
! http://www.ozemail.com.au/~milleraj

! Latest revision - 18 September 2000

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

CONTAINS

FUNCTION dnorm(x, y) RESULT(fn_val)
! Replaces the statement function anorm in the F77 code.

REAL (dp), INTENT(IN) :: x, y
REAL (dp)             :: fn_val

fn_val = MAX(ABS(x), ABS(y))
RETURN
END FUNCTION dnorm

SUBROUTINE dcrec (x, y, u, v)
!-----------------------------------------------------------------------
!             COMPLEX RECIPROCAL U + I*V = 1/(X + I*Y)
!-----------------------------------------------------------------------

REAL (dp), INTENT(IN)   :: x, y
REAL (dp), INTENT(OUT)  :: u, v

REAL (dp) :: d, t

IF (ABS(x) > ABS(y)) GO TO 10
t = x/y
d = y + t*x
u = t/d
v = -1._dp/d
RETURN

10 t = y/x
d = x + t*y
u = 1._dp/d
v = -t/d

RETURN
END SUBROUTINE dcrec

SUBROUTINE cdivid (ar, ai, br, bi, cr, ci)
!-----------------------------------------------------------------------
!     REAL (dp) COMPLEX DIVISION C = A/B AVOIDING OVERFLOW
!-----------------------------------------------------------------------

REAL (dp), INTENT(IN)   :: ar, ai, br, bi
REAL (dp), INTENT(OUT)  :: cr, ci

REAL (dp) :: d, t, u, v

IF (ABS(br) <= ABS(bi)) GO TO 10
t = bi/br
d = br + t*bi
u = (ar + ai*t)/d
v = (ai - ar*t)/d
cr = u
ci = v
RETURN

10 IF (bi == 0._dp) GO TO 20
t = br/bi
d = bi + t*br
u = (ar*t + ai)/d
v = (ai*t - ar)/d
cr = u
ci = v
RETURN

!     DIVISION BY ZERO. C = INFINITY

20 cr = HUGE(1.0_dp)
ci = cr

RETURN
END SUBROUTINE cdivid

SUBROUTINE dcerf (mo, z, w)
!-----------------------------------------------------------------------

!               COMPUTATION OF THE COMPLEX ERROR FUNCTION

!                          -----------------

!                       W = ERF(Z)    IF MO = 0
!                       W = ERFC(Z)   OTHERWISE

!-----------------------------------------------------------------------

INTEGER, INTENT(IN)     :: mo
REAL (dp), INTENT(IN)   :: z(2)
REAL (dp), INTENT(OUT)  :: w(2)

REAL (dp) :: m, n, n2, n4, np1
REAL (dp) :: c2, d, d2, e, eps, r, sn, tol, x, y
REAL (dp) :: a0(2), an(2), b0(2), bn(2)
REAL (dp) :: g0(2), gn(2), h0(2), hn(2)
REAL (dp) :: qf(2), sm(2), sz(2), tm(2), ts(2), w0(2), wn(2)
!------------------------
!     C = 1/SQRT(PI)
!------------------------
REAL (dp), PARAMETER :: c = .56418958354775628694807945156077_dp
!------------------------

!     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
!            SMALLEST NUMBER SUCH THAT 1._dp + EPS > 1._dp.

eps = EPSILON(1.0_dp)

!------------------------
x = z(1)
y = z(2)
sn = 1._dp
IF (x >= 0._dp) GO TO 10
x = -x
y = -y
sn = -1._dp

10 r = x*x + y*y
sz(1) = x*x - y*y
sz(2) = 2._dp*x*y

IF (r <= 1._dp) GO TO 20
IF (r >= 144._dp) GO TO 100
IF (ABS(y) > 31.8_dp*x) GO TO 50
IF (ABS(y) > 7.0_dp*x .AND. r < 64._dp) GO TO 50
IF (ABS(y) > 3.2_dp*x .AND. r < 49._dp) GO TO 50
IF (ABS(y) > 2.0_dp*x .AND. r < 36._dp) GO TO 50
IF (ABS(y) > 1.2_dp*x .AND. r < 25._dp) GO TO 50
IF (ABS(y) > 0.9_dp*x .AND. r < 16._dp) GO TO 50
IF (r >= 6.25_dp) GO TO 80
IF (ABS(y) > 0.6_dp*x) GO TO 50
IF (r >= 4.0_dp) GO TO 40

d = x - 2._dp
IF (d*d + y*y < 1._dp) GO TO 40
GO TO 50

!                          TAYLOR SERIES

20 c2 = c + c
tm(1) = c2*x
tm(2) = c2*y
sm(1) = tm(1)
sm(2) = tm(2)
tol = 2._dp*eps
m = 0._dp

21 m = m + 1._dp
d = m + m + 1._dp
ts(1) = tm(1)*sz(1) - tm(2)*sz(2)
ts(2) = tm(1)*sz(2) + tm(2)*sz(1)
tm(1) = -ts(1)/m
tm(2) = -ts(2)/m
ts(1) = tm(1)/d
ts(2) = tm(2)/d
sm(1) = sm(1) + ts(1)
sm(2) = sm(2) + ts(2)
IF (dnorm(ts(1),ts(2)) > tol*dnorm(sm(1),sm(2))) GO TO 21

IF (mo /= 0) GO TO 30
w(1) = sn*sm(1)
w(2) = sn*sm(2)
RETURN

30 IF (sn == 1._dp) GO TO 31
w(1) = 1._dp + sm(1)
w(2) = sm(2)
RETURN

31 w(1) = 0.5_dp + (0.5_dp - sm(1))
w(2) = -sm(2)
RETURN

!                  TAYLOR SERIES AROUND Z0 = 2

40 tm(1) = x
tm(2) = y
CALL erfcm2 (0, tm, w)
IF (mo /= 0) GO TO 41
w(1) = sn*(0.5_dp + (0.5_dp - w(1)))
w(2) = - sn*w(2)
RETURN
41 IF (sn > 0._dp) RETURN
w(1) = 2._dp - w(1)
w(2) = - w(2)
RETURN

!            PADE APPROXIMATION FOR THE TAYLOR SERIES
!                    FOR  (EXP(Z*Z)/Z)*ERF(Z)

50 d = 4._dp
IF (r > 16._dp) d = 16._dp
IF (r > 64._dp) d = 64._dp
d2 = d*d
CALL dcrec (sz(1), sz(2), w(1), w(2))
a0(1) = 1._dp
a0(2) = 0._dp
an(1) = (w(1) + 4._dp/15._dp)*d
an(2) = w(2)*d
b0(1) = 1._dp
b0(2) = 0._dp
bn(1) = (w(1) - 0.4_dp)*d
bn(2) = w(2)*d
CALL cdivid (an(1), an(2), bn(1), bn(2), wn(1), wn(2))
tol = 10._dp*eps
n4 = 0._dp

60 n4 = n4 + 4._dp
e = (n4 + 1._dp)*(n4 + 5._dp)
tm(1) = d*(w(1) - 2._dp/e)
tm(2) = d*w(2)
e = d2*(n4*(n4 + 2.0))/((n4 - 1.0)*(n4 + 3.0)*(n4 + 1.0)**2)

qf(1) = (tm(1)*an(1) - tm(2)*an(2)) + e*a0(1)
qf(2) = (tm(1)*an(2) + tm(2)*an(1)) + e*a0(2)
a0(1) = an(1)
a0(2) = an(2)
an(1) = qf(1)
an(2) = qf(2)
qf(1) = (tm(1)*bn(1) - tm(2)*bn(2)) + e*b0(1)
qf(2) = (tm(1)*bn(2) + tm(2)*bn(1)) + e*b0(2)
b0(1) = bn(1)
b0(2) = bn(2)
bn(1) = qf(1)
bn(2) = qf(2)

w0(1) = wn(1)
w0(2) = wn(2)
CALL cdivid (an(1), an(2), bn(1), bn(2), wn(1), wn(2))
IF (dnorm(wn(1) - w0(1), wn(2) - w0(2)) > tol*dnorm(wn(1), wn(2))) GO TO 60

c2 = c + c
sm(1) = c2*(x*wn(1) - y*wn(2))
sm(2) = c2*(x*wn(2) + y*wn(1))
e = EXP(-sz(1))
qf(1) = e*COS(-sz(2))
qf(2) = e*SIN(-sz(2))
tm(1) = qf(1)*sm(1) - qf(2)*sm(2)
tm(2) = qf(1)*sm(2) + qf(2)*sm(1)

w(1) = sn*tm(1)
w(2) = sn*tm(2)
IF (mo == 0) RETURN
w(1) = 1._dp - w(1)
w(2) = - w(2)
RETURN

!         PADE APPROXIMATION FOR THE ASYMPTOTIC EXPANSION
!                    FOR  Z*EXP(Z*Z)*ERFC(Z)

80 d = 4._dp*r
IF (r < 16._dp) d = 16._dp*r
d2 = d*d
tm(1) = sz(1) + sz(1)
tm(2) = sz(2) + sz(2)
g0(1) = 1._dp
g0(2) = 0._dp
gn(1) = (2._dp + tm(1))/d
gn(2) = tm(2)/d
h0(1) = 1._dp
h0(2) = 0._dp
tm(1) = 3._dp + tm(1)
hn(1) = tm(1)/d
hn(2) = tm(2)/d
CALL cdivid (gn(1), gn(2), hn(1), hn(2), wn(1), wn(2))
np1 = 1._dp
tol = 10._dp*eps

90 n = np1
np1 = n + 1._dp
n2 = n + n
e = (n2*(n2 + 1._dp))/d2
tm(1) = tm(1) + 4._dp
qf(1) = (tm(1)*gn(1) - tm(2)*gn(2))/d - e*g0(1)
qf(2) = (tm(1)*gn(2) + tm(2)*gn(1))/d - e*g0(2)
g0(1) = gn(1)
g0(2) = gn(2)
gn(1) = qf(1)
gn(2) = qf(2)
qf(1) = (tm(1)*hn(1) - tm(2)*hn(2))/d - e*h0(1)
qf(2) = (tm(1)*hn(2) + tm(2)*hn(1))/d - e*h0(2)
h0(1) = hn(1)
h0(2) = hn(2)
hn(1) = qf(1)
hn(2) = qf(2)

w0(1) = wn(1)
w0(2) = wn(2)
CALL cdivid (gn(1), gn(2), hn(1), hn(2), wn(1), wn(2))
IF (dnorm(wn(1) - w0(1), wn(2) - w0(2)) > tol*dnorm(wn(1), wn(2))) GO TO 90

tm(1) = x*hn(1) - y*hn(2)
tm(2) = x*hn(2) + y*hn(1)
CALL cdivid (c*gn(1), c*gn(2), tm(1), tm(2), sm(1), sm(2))
GO TO 130

!                      ASYMPTOTIC EXPANSION

100 CALL dcrec (x, y, tm(1), tm(2))
sm(1) = tm(1)
sm(2) = tm(2)
qf(1) = tm(1)*tm(1) - tm(2)*tm(2)
qf(2) = 2._dp*tm(1)*tm(2)
tol = 2._dp*eps
d = -0.5_dp
110 d = d + 1._dp
ts(1) = tm(1)*qf(1) - tm(2)*qf(2)
ts(2) = tm(1)*qf(2) + tm(2)*qf(1)
tm(1) = -d*ts(1)
tm(2) = -d*ts(2)
sm(1) = sm(1) + tm(1)
sm(2) = sm(2) + tm(2)
IF (dnorm(tm(1), tm(2)) > tol*dnorm(sm(1), sm(2))) GO TO 110
sm(1) = c*sm(1)
sm(2) = c*sm(2)
IF (x < 1.d-2) GO TO 200

!                       TERMINATION

130 e = EXP(-sz(1))
qf(1) = e*COS(-sz(2))
qf(2) = e*SIN(-sz(2))
ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
sm(1) = ts(1)
sm(2) = ts(2)

IF (mo /= 0) GO TO 140
w(1) = sn*(0.5_dp + (0.5_dp - sm(1)))
w(2) = - sn*sm(2)
RETURN

140 IF (sn == 1._dp) GO TO 141
w(1) = 2._dp - sm(1)
w(2) = -sm(2)
RETURN

141 w(1) = sm(1)
w(2) = sm(2)
RETURN

!               MODIFIED ASYMPTOTIC EXPANSION

200 e = EXP(-sz(1))
qf(1) = e*COS(-sz(2))
qf(2) = e*SIN(-sz(2))
w(1) = qf(1)*sm(1) - qf(2)*sm(2)
w(2) = qf(1)*sm(2) + qf(2)*sm(1)
IF (mo == 0) GO TO 210
w(1) = 1._dp + sn*w(1)
w(2) = sn*w(2)
RETURN

210 IF (sn < 0.0) RETURN
w(1) = - w(1)
w(2) = - w(2)

RETURN
END SUBROUTINE dcerf

SUBROUTINE erfcm2 (mo, z, w)
!-----------------------------------------------------------------------
!           CALCULATION OF ERFC(Z) USING THE TAYLOR SERIES
!                          AROUND Z0 = 2
!-----------------------------------------------------------------------

INTEGER, INTENT(IN)     :: mo
REAL (dp), INTENT(IN)   :: z(2)
REAL (dp), INTENT(OUT)  :: w(2)

REAL (dp) :: eps, h(2), t(2), tol, x, y
INTEGER   :: j, n
!------------------------------
!     C = (2/SQRT(PI))*EXP(-4)
!     E = ERFC(2)
!------------------------------
REAL (dp), PARAMETER :: c = .020666985354092053857068941306585476_dp,  &
                        e = .0046777349810472658379307436327470714_dp
!------------------------------
REAL (dp) :: a(63) = (/ .20000000000000000000000000000000000D+01,  &
   .23333333333333333333333333333333333D+01,  .16666666666666666666666666666666667D+01,  &
   .63333333333333333333333333333333333D+00, -.22222222222222222222222222222222222D-01,  &
  -.16349206349206349206349206349206349D+00, -.76984126984126984126984126984126984D-01,  &
  -.24250440917107583774250440917107584D-02,  .12716049382716049382716049382716049D-01,  &
   .50208433541766875100208433541766875D-02, -.25305969750414194858639303083747528D-03,  &
  -.78593217482106370995259884148773038D-03, -.19118154038788959423880058800693721D-03,  &
   .46324144207742091339974937858535742D-04,  .33885549097189308829520469732109944D-04,  &
   .28637897646612243562134629672756034D-05, -.29071891082127275370004560446169188D-05,  &
  -.89674405786490646425523560263096103D-06,  .96069103941908684338469767911200105D-07,  &
   .99432863129093191401848891268744113D-07,  .97610310501460621303387795457283579D-08,  &
  -.65557500375673133822289344530892436D-08, -.18706782059105426900361744016236561D-08,  &
   .20329898993447386223176373714372370D-09,  .16941915827254374668448114614201210D-09,  &
   .10619149520827430973786114446699534D-10, -.10136148256511788733365237088810952D-10,  &
  -.21042890133669970575386166675721692D-11,  .37186985840699828780916522245407087D-12,  &
   .17921843632701679986488128324051002D-12, -.89823991804248069863542565948598397D-16,  &
  -.10533182313660970970232171410372199D-13, -.12340742690978398320850088252659714D-14,  &
   .44315624546581333350568244777175883D-15,  .11584041639989442481950487524296214D-15,  &
  -.10765703619385988116658460442219647D-16, -.70653158723054941879586082239984222D-17,  &
  -.18708903154917138727191793341667090D-18,  .32549879318817103966053527398133297D-18,  &
   .40654116689599228385911733319215613D-19, -.11250074516817311101947327325293424D-19,  &
  -.28923865378584966737386008432031980D-20,  .23653053641701517160704870522922706D-21,  &
   .14665384680061888088099002254334292D-21,  .26971039707314316218154193225264469D-23,  &
  -.58753834789274356433279671015522650D-23, -.59960357240498652932299485494869633D-24,  &
   .18586826578121663981412155416486531D-24,  .38364131854692721721867481914852428D-25,  &
  -.41342210492630142578080062451711039D-26, -.17646283105274988992381528904600860D-26,  &
   .19828685934364181151988692232131608D-28,  .65592252170840353572672782446212733D-28,  &
   .40626551379996340638338449938639730D-29, -.20097984104191034713653294173834095D-29,  &
  -.28104226475997460044096389060743131D-30,  .48705319298749358709127987806547949D-31,  &
   .12664655832830787747161769929972617D-31, -.75168312488894341862391776330113688D-33,  &
  -.45760473722605993842481669806804415D-33, -.56725491529575395930156379514718000D-35,  &
   .13932664042920082608489441616061541D-34,  .10452448992516358449586503951463322D-35 /)
!------------------------------

!     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
!            SMALLEST NUMBER SUCH THAT 1._dp + EPS .GT. 1._dp

eps = EPSILON(1.0_dp)

!------------------------------
tol = eps*1.d+12
h(1) = 1._dp + (1._dp - z(1))
h(2) = - z(2)

x = 1._dp
y = 0._dp
w(1) = a(30)
w(2) = 0._dp
DO n = 31,63
  t(1) = x*h(1) - y*h(2)
  t(2) = x*h(2) + y*h(1)
  x = t(1)
  y = t(2)
  t(1) = a(n)*x
  t(2) = a(n)*y
  w(1) = w(1) + t(1)
  w(2) = w(2) + t(2)
  IF (dnorm(t(1), t(2)) <= tol*dnorm(w(1), w(2))) EXIT
END DO

DO j = 1,29
  n = 30 - j
  x = h(1)*w(1) - h(2)*w(2)
  w(2) = h(1)*w(2) + h(2)*w(1)
  w(1) = a(n) + x
END DO
x = h(1)*w(1) - h(2)*w(2)
w(2) = h(1)*w(2) + h(2)*w(1)
w(1) = 1._dp + x

x = c*(h(1)*w(1) - h(2)*w(2))
w(2) = c*(h(1)*w(2) + h(2)*w(1))
w(1) = e + x
IF (mo == 0) RETURN

!                     COMPUTE EXP(Z*Z)*ERFC(Z)

x = z(1)*z(1) - z(2)*z(2)
y = 2._dp*z(1)*z(2)
x = EXP(x)
t(1) = x*COS(y)
t(2) = x*SIN(y)
x = t(1)*w(1) - t(2)*w(2)
y = t(1)*w(2) + t(2)*w(1)
w(1) = x
w(2) = y

RETURN
END SUBROUTINE erfcm2

END MODULE double_complex_erf


      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
      INTEGER INCX,INCY,N
      DOUBLE PRECISION DX(*),DY(*)
      DOUBLE PRECISION DTEMP
      INTEGER I,IX,IY,M,MP1
      INTRINSIC MOD
      DDOT = 0.0d0
      DTEMP = 0.0d0
      IF (N.LE.0) RETURN
      IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
         M = MOD(N,5)
         IF (M.NE.0) THEN
            DO I = 1,M
               DTEMP = DTEMP + DX(I)*DY(I)
            END DO
            IF (N.LT.5) THEN
               DDOT=DTEMP
            RETURN
            END IF
         END IF
         MP1 = M + 1
         DO I = MP1,N,5
          DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) +
     $            DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
         END DO
      ELSE
         IX = 1
         IY = 1
         IF (INCX.LT.0) IX = (-N+1)*INCX + 1
         IF (INCY.LT.0) IY = (-N+1)*INCY + 1
         DO I = 1,N
            DTEMP = DTEMP + DX(IX)*DY(IY)
            IX = IX + INCX
            IY = IY + INCY
         END DO
      END IF
      DDOT = DTEMP
      RETURN
      END
      SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
      DOUBLE PRECISION ALPHA,BETA
      INTEGER K,LDA,LDB,LDC,M,N
      CHARACTER TRANSA,TRANSB
      DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
      LOGICAL LSAME
      EXTERNAL LSAME
      EXTERNAL XERBLA
      INTRINSIC MAX
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
      LOGICAL NOTA,NOTB
      DOUBLE PRECISION ONE,ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
      NOTA = LSAME(TRANSA,'N')
      NOTB = LSAME(TRANSB,'N')
      IF (NOTA) THEN
          NROWA = M
          NCOLA = K
      ELSE
          NROWA = K
          NCOLA = M
      END IF
      IF (NOTB) THEN
          NROWB = K
      ELSE
          NROWB = N
      END IF
      INFO = 0
      IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
     +    (.NOT.LSAME(TRANSA,'T'))) THEN
          INFO = 1
      ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
     +         (.NOT.LSAME(TRANSB,'T'))) THEN
          INFO = 2
      ELSE IF (M.LT.0) THEN
          INFO = 3
      ELSE IF (N.LT.0) THEN
          INFO = 4
      ELSE IF (K.LT.0) THEN
          INFO = 5
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 8
      ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
          INFO = 10
      ELSE IF (LDC.LT.MAX(1,M)) THEN
          INFO = 13
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DGEMM ',INFO)
          RETURN
      END IF
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
     +    (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
      IF (ALPHA.EQ.ZERO) THEN
          IF (BETA.EQ.ZERO) THEN
              DO 20 J = 1,N
                  DO 10 I = 1,M
                      C(I,J) = ZERO
   10             CONTINUE
   20         CONTINUE
          ELSE
              DO 40 J = 1,N
                  DO 30 I = 1,M
                      C(I,J) = BETA*C(I,J)
   30             CONTINUE
   40         CONTINUE
          END IF
          RETURN
      END IF
      IF (NOTB) THEN
          IF (NOTA) THEN
              DO 90 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 50 I = 1,M
                          C(I,J) = ZERO
   50                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 60 I = 1,M
                          C(I,J) = BETA*C(I,J)
   60                 CONTINUE
                  END IF
                  DO 80 L = 1,K
                      IF (B(L,J).NE.ZERO) THEN
                          TEMP = ALPHA*B(L,J)
                          DO 70 I = 1,M
                              C(I,J) = C(I,J) + TEMP*A(I,L)
   70                     CONTINUE
                      END IF
   80             CONTINUE
   90         CONTINUE
          ELSE
              DO 120 J = 1,N
                  DO 110 I = 1,M
                      TEMP = ZERO
                      DO 100 L = 1,K
                          TEMP = TEMP + A(L,I)*B(L,J)
  100                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  110             CONTINUE
  120         CONTINUE
          END IF
      ELSE
          IF (NOTA) THEN
              DO 170 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 130 I = 1,M
                          C(I,J) = ZERO
  130                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 140 I = 1,M
                          C(I,J) = BETA*C(I,J)
  140                 CONTINUE
                  END IF
                  DO 160 L = 1,K
                      IF (B(J,L).NE.ZERO) THEN
                          TEMP = ALPHA*B(J,L)
                          DO 150 I = 1,M
                              C(I,J) = C(I,J) + TEMP*A(I,L)
  150                     CONTINUE
                      END IF
  160             CONTINUE
  170         CONTINUE
          ELSE
              DO 200 J = 1,N
                  DO 190 I = 1,M
                      TEMP = ZERO
                      DO 180 L = 1,K
                          TEMP = TEMP + A(L,I)*B(J,L)
  180                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  190             CONTINUE
  200         CONTINUE
          END IF
      END IF
      RETURN
      END
      SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
      DOUBLE PRECISION ALPHA,BETA
      INTEGER INCX,INCY,LDA,M,N
      CHARACTER TRANS
      DOUBLE PRECISION A(LDA,*),X(*),Y(*)
      DOUBLE PRECISION ONE,ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
      LOGICAL LSAME
      EXTERNAL LSAME
      EXTERNAL XERBLA
      INTRINSIC MAX
      INFO = 0
      IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
     +    .NOT.LSAME(TRANS,'C')) THEN
          INFO = 1
      ELSE IF (M.LT.0) THEN
          INFO = 2
      ELSE IF (N.LT.0) THEN
          INFO = 3
      ELSE IF (LDA.LT.MAX(1,M)) THEN
          INFO = 6
      ELSE IF (INCX.EQ.0) THEN
          INFO = 8
      ELSE IF (INCY.EQ.0) THEN
          INFO = 11
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DGEMV ',INFO)
          RETURN
      END IF
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
     +    ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
      IF (LSAME(TRANS,'N')) THEN
          LENX = N
          LENY = M
      ELSE
          LENX = M
          LENY = N
      END IF
      IF (INCX.GT.0) THEN
          KX = 1
      ELSE
          KX = 1 - (LENX-1)*INCX
      END IF
      IF (INCY.GT.0) THEN
          KY = 1
      ELSE
          KY = 1 - (LENY-1)*INCY
      END IF
      IF (BETA.NE.ONE) THEN
          IF (INCY.EQ.1) THEN
              IF (BETA.EQ.ZERO) THEN
                  DO 10 I = 1,LENY
                      Y(I) = ZERO
   10             CONTINUE
              ELSE
                  DO 20 I = 1,LENY
                      Y(I) = BETA*Y(I)
   20             CONTINUE
              END IF
          ELSE
              IY = KY
              IF (BETA.EQ.ZERO) THEN
                  DO 30 I = 1,LENY
                      Y(IY) = ZERO
                      IY = IY + INCY
   30             CONTINUE
              ELSE
                  DO 40 I = 1,LENY
                      Y(IY) = BETA*Y(IY)
                      IY = IY + INCY
   40             CONTINUE
              END IF
          END IF
      END IF
      IF (ALPHA.EQ.ZERO) RETURN
      IF (LSAME(TRANS,'N')) THEN
          JX = KX
          IF (INCY.EQ.1) THEN
              DO 60 J = 1,N
                  IF (X(JX).NE.ZERO) THEN
                      TEMP = ALPHA*X(JX)
                      DO 50 I = 1,M
                          Y(I) = Y(I) + TEMP*A(I,J)
   50                 CONTINUE
                  END IF
                  JX = JX + INCX
   60         CONTINUE
          ELSE
              DO 80 J = 1,N
                  IF (X(JX).NE.ZERO) THEN
                      TEMP = ALPHA*X(JX)
                      IY = KY
                      DO 70 I = 1,M
                          Y(IY) = Y(IY) + TEMP*A(I,J)
                          IY = IY + INCY
   70                 CONTINUE
                  END IF
                  JX = JX + INCX
   80         CONTINUE
          END IF
      ELSE
          JY = KY
          IF (INCX.EQ.1) THEN
              DO 100 J = 1,N
                  TEMP = ZERO
                  DO 90 I = 1,M
                      TEMP = TEMP + A(I,J)*X(I)
   90             CONTINUE
                  Y(JY) = Y(JY) + ALPHA*TEMP
                  JY = JY + INCY
  100         CONTINUE
          ELSE
              DO 120 J = 1,N
                  TEMP = ZERO
                  IX = KX
                  DO 110 I = 1,M
                      TEMP = TEMP + A(I,J)*X(IX)
                      IX = IX + INCX
  110             CONTINUE
                  Y(JY) = Y(JY) + ALPHA*TEMP
                  JY = JY + INCY
  120         CONTINUE
          END IF
      END IF
      RETURN
      END
      LOGICAL FUNCTION DISNAN( DIN )
      DOUBLE PRECISION   DIN
      LOGICAL DLAISNAN
      EXTERNAL DLAISNAN
      DISNAN = DLAISNAN(DIN,DIN)
      RETURN
      END
      LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
      DOUBLE PRECISION   DIN1, DIN2
      DLAISNAN = (DIN1.NE.DIN2)
      RETURN
      END
      SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   A( LDA, * )
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      LOGICAL            UPPER
      INTEGER            J
      DOUBLE PRECISION   AJJ
      LOGICAL            LSAME, DISNAN
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT, DISNAN
      EXTERNAL           DGEMV, DSCAL, XERBLA
      INTRINSIC          MAX, SQRT
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOTF2', -INFO )
         RETURN
      END IF
      IF( N.EQ.0 )
     $   RETURN
      IF( UPPER ) THEN
         DO 10 J = 1, N
            AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 )
            IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
               A( J, J ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            A( J, J ) = AJJ
            IF( J.LT.N ) THEN
               CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ),
     $                     LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
               CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
            END IF
   10    CONTINUE
      ELSE
         DO 20 J = 1, N
            AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ),
     $            LDA )
            IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
               A( J, J ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            A( J, J ) = AJJ
            IF( J.LT.N ) THEN
               CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ),
     $                     LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
               CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
      GO TO 40
   30 CONTINUE
      INFO = J
   40 CONTINUE
      RETURN
      END
      SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   A( LDA, * )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      LOGICAL            UPPER
      INTEGER            J, JB, NB
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
      EXTERNAL           DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA
      INTRINSIC          MAX, MIN
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOTRF', -INFO )
         RETURN
      END IF
      IF( N.EQ.0 )
     $   RETURN
      NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
         CALL DPOTF2( UPLO, N, A, LDA, INFO )
      ELSE
         IF( UPPER ) THEN
            DO 10 J = 1, N, NB
               JB = MIN( NB, N-J+1 )
               CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
     $                     A( 1, J ), LDA, ONE, A( J, J ), LDA )
               CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
               IF( INFO.NE.0 )
     $            GO TO 30
               IF( J+JB.LE.N ) THEN
                  CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1,
     $                        J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ),
     $                        LDA, ONE, A( J, J+JB ), LDA )
                  CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
     $                        JB, N-J-JB+1, ONE, A( J, J ), LDA,
     $                        A( J, J+JB ), LDA )
               END IF
   10       CONTINUE
         ELSE
            DO 20 J = 1, N, NB
               JB = MIN( NB, N-J+1 )
               CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE,
     $                     A( J, 1 ), LDA, ONE, A( J, J ), LDA )
               CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
               IF( INFO.NE.0 )
     $            GO TO 30
               IF( J+JB.LE.N ) THEN
                  CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
     $                        J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ),
     $                        LDA, ONE, A( J+JB, J ), LDA )
                  CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
     $                        N-J-JB+1, JB, ONE, A( J, J ), LDA,
     $                        A( J+JB, J ), LDA )
               END IF
   20       CONTINUE
         END IF
      END IF
      GO TO 40
   30 CONTINUE
      INFO = INFO + J - 1
   40 CONTINUE
      RETURN
      END
      SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      LOGICAL            UPPER
      LOGICAL            LSAME
      EXTERNAL           LSAME
      EXTERNAL           DTRSM, XERBLA
      INTRINSIC          MAX
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOTRS', -INFO )
         RETURN
      END IF
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
      IF( UPPER ) THEN
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, A, LDA, B, LDB )
      ELSE
         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, A, LDA, B, LDB )
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
      END IF
      RETURN
      END
      SUBROUTINE DSCAL(N,DA,DX,INCX)
      DOUBLE PRECISION DA
      INTEGER INCX,N
      DOUBLE PRECISION DX(*)
      INTEGER I,M,MP1,NINCX
      INTRINSIC MOD
      IF (N.LE.0 .OR. INCX.LE.0) RETURN
      IF (INCX.EQ.1) THEN
         M = MOD(N,5)
         IF (M.NE.0) THEN
            DO I = 1,M
               DX(I) = DA*DX(I)
            END DO
            IF (N.LT.5) RETURN
         END IF
         MP1 = M + 1
         DO I = MP1,N,5
            DX(I) = DA*DX(I)
            DX(I+1) = DA*DX(I+1)
            DX(I+2) = DA*DX(I+2)
            DX(I+3) = DA*DX(I+3)
            DX(I+4) = DA*DX(I+4)
         END DO
      ELSE
         NINCX = N*INCX
         DO I = 1,NINCX,INCX
            DX(I) = DA*DX(I)
         END DO
      END IF
      RETURN
      END
      SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
      DOUBLE PRECISION ALPHA,BETA
      INTEGER K,LDA,LDC,N
      CHARACTER TRANS,UPLO
      DOUBLE PRECISION A(LDA,*),C(LDC,*)
      LOGICAL LSAME
      EXTERNAL LSAME
      EXTERNAL XERBLA
      INTRINSIC MAX
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,J,L,NROWA
      LOGICAL UPPER
      DOUBLE PRECISION ONE,ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
      IF (LSAME(TRANS,'N')) THEN
          NROWA = N
      ELSE
          NROWA = K
      END IF
      UPPER = LSAME(UPLO,'U')
      INFO = 0
      IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
          INFO = 1
      ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
     +         (.NOT.LSAME(TRANS,'T')) .AND.
     +         (.NOT.LSAME(TRANS,'C'))) THEN
          INFO = 2
      ELSE IF (N.LT.0) THEN
          INFO = 3
      ELSE IF (K.LT.0) THEN
          INFO = 4
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 7
      ELSE IF (LDC.LT.MAX(1,N)) THEN
          INFO = 10
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DSYRK ',INFO)
          RETURN
      END IF
      IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
     +    (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
      IF (ALPHA.EQ.ZERO) THEN
          IF (UPPER) THEN
              IF (BETA.EQ.ZERO) THEN
                  DO 20 J = 1,N
                      DO 10 I = 1,J
                          C(I,J) = ZERO
   10                 CONTINUE
   20             CONTINUE
              ELSE
                  DO 40 J = 1,N
                      DO 30 I = 1,J
                          C(I,J) = BETA*C(I,J)
   30                 CONTINUE
   40             CONTINUE
              END IF
          ELSE
              IF (BETA.EQ.ZERO) THEN
                  DO 60 J = 1,N
                      DO 50 I = J,N
                          C(I,J) = ZERO
   50                 CONTINUE
   60             CONTINUE
              ELSE
                  DO 80 J = 1,N
                      DO 70 I = J,N
                          C(I,J) = BETA*C(I,J)
   70                 CONTINUE
   80             CONTINUE
              END IF
          END IF
          RETURN
      END IF
      IF (LSAME(TRANS,'N')) THEN
          IF (UPPER) THEN
              DO 130 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 90 I = 1,J
                          C(I,J) = ZERO
   90                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 100 I = 1,J
                          C(I,J) = BETA*C(I,J)
  100                 CONTINUE
                  END IF
                  DO 120 L = 1,K
                      IF (A(J,L).NE.ZERO) THEN
                          TEMP = ALPHA*A(J,L)
                          DO 110 I = 1,J
                              C(I,J) = C(I,J) + TEMP*A(I,L)
  110                     CONTINUE
                      END IF
  120             CONTINUE
  130         CONTINUE
          ELSE
              DO 180 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 140 I = J,N
                          C(I,J) = ZERO
  140                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 150 I = J,N
                          C(I,J) = BETA*C(I,J)
  150                 CONTINUE
                  END IF
                  DO 170 L = 1,K
                      IF (A(J,L).NE.ZERO) THEN
                          TEMP = ALPHA*A(J,L)
                          DO 160 I = J,N
                              C(I,J) = C(I,J) + TEMP*A(I,L)
  160                     CONTINUE
                      END IF
  170             CONTINUE
  180         CONTINUE
          END IF
      ELSE
          IF (UPPER) THEN
              DO 210 J = 1,N
                  DO 200 I = 1,J
                      TEMP = ZERO
                      DO 190 L = 1,K
                          TEMP = TEMP + A(L,I)*A(L,J)
  190                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  200             CONTINUE
  210         CONTINUE
          ELSE
              DO 240 J = 1,N
                  DO 230 I = J,N
                      TEMP = ZERO
                      DO 220 L = 1,K
                          TEMP = TEMP + A(L,I)*A(L,J)
  220                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  230             CONTINUE
  240         CONTINUE
          END IF
      END IF
      RETURN
      END
      SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
      DOUBLE PRECISION ALPHA
      INTEGER LDA,LDB,M,N
      CHARACTER DIAG,SIDE,TRANSA,UPLO
      DOUBLE PRECISION A(LDA,*),B(LDB,*)
      LOGICAL LSAME
      EXTERNAL LSAME
      EXTERNAL XERBLA
      INTRINSIC MAX
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,J,K,NROWA
      LOGICAL LSIDE,NOUNIT,UPPER
      DOUBLE PRECISION ONE,ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
      LSIDE = LSAME(SIDE,'L')
      IF (LSIDE) THEN
          NROWA = M
      ELSE
          NROWA = N
      END IF
      NOUNIT = LSAME(DIAG,'N')
      UPPER = LSAME(UPLO,'U')
      INFO = 0
      IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
          INFO = 1
      ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
          INFO = 2
      ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
     +         (.NOT.LSAME(TRANSA,'T')) .AND.
     +         (.NOT.LSAME(TRANSA,'C'))) THEN
          INFO = 3
      ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
          INFO = 4
      ELSE IF (M.LT.0) THEN
          INFO = 5
      ELSE IF (N.LT.0) THEN
          INFO = 6
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 9
      ELSE IF (LDB.LT.MAX(1,M)) THEN
          INFO = 11
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DTRSM ',INFO)
          RETURN
      END IF
      IF (M.EQ.0 .OR. N.EQ.0) RETURN
      IF (ALPHA.EQ.ZERO) THEN
          DO 20 J = 1,N
              DO 10 I = 1,M
                  B(I,J) = ZERO
   10         CONTINUE
   20     CONTINUE
          RETURN
      END IF
      IF (LSIDE) THEN
          IF (LSAME(TRANSA,'N')) THEN
              IF (UPPER) THEN
                  DO 60 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 30 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
   30                     CONTINUE
                      END IF
                      DO 50 K = M,1,-1
                          IF (B(K,J).NE.ZERO) THEN
                              IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
                              DO 40 I = 1,K - 1
                                  B(I,J) = B(I,J) - B(K,J)*A(I,K)
   40                         CONTINUE
                          END IF
   50                 CONTINUE
   60             CONTINUE
              ELSE
                  DO 100 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 70 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
   70                     CONTINUE
                      END IF
                      DO 90 K = 1,M
                          IF (B(K,J).NE.ZERO) THEN
                              IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
                              DO 80 I = K + 1,M
                                  B(I,J) = B(I,J) - B(K,J)*A(I,K)
   80                         CONTINUE
                          END IF
   90                 CONTINUE
  100             CONTINUE
              END IF
          ELSE
              IF (UPPER) THEN
                  DO 130 J = 1,N
                      DO 120 I = 1,M
                          TEMP = ALPHA*B(I,J)
                          DO 110 K = 1,I - 1
                              TEMP = TEMP - A(K,I)*B(K,J)
  110                     CONTINUE
                          IF (NOUNIT) TEMP = TEMP/A(I,I)
                          B(I,J) = TEMP
  120                 CONTINUE
  130             CONTINUE
              ELSE
                  DO 160 J = 1,N
                      DO 150 I = M,1,-1
                          TEMP = ALPHA*B(I,J)
                          DO 140 K = I + 1,M
                              TEMP = TEMP - A(K,I)*B(K,J)
  140                     CONTINUE
                          IF (NOUNIT) TEMP = TEMP/A(I,I)
                          B(I,J) = TEMP
  150                 CONTINUE
  160             CONTINUE
              END IF
          END IF
      ELSE
          IF (LSAME(TRANSA,'N')) THEN
              IF (UPPER) THEN
                  DO 210 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 170 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
  170                     CONTINUE
                      END IF
                      DO 190 K = 1,J - 1
                          IF (A(K,J).NE.ZERO) THEN
                              DO 180 I = 1,M
                                  B(I,J) = B(I,J) - A(K,J)*B(I,K)
  180                         CONTINUE
                          END IF
  190                 CONTINUE
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(J,J)
                          DO 200 I = 1,M
                              B(I,J) = TEMP*B(I,J)
  200                     CONTINUE
                      END IF
  210             CONTINUE
              ELSE
                  DO 260 J = N,1,-1
                      IF (ALPHA.NE.ONE) THEN
                          DO 220 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
  220                     CONTINUE
                      END IF
                      DO 240 K = J + 1,N
                          IF (A(K,J).NE.ZERO) THEN
                              DO 230 I = 1,M
                                  B(I,J) = B(I,J) - A(K,J)*B(I,K)
  230                         CONTINUE
                          END IF
  240                 CONTINUE
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(J,J)
                          DO 250 I = 1,M
                              B(I,J) = TEMP*B(I,J)
  250                     CONTINUE
                      END IF
  260             CONTINUE
              END IF
          ELSE
              IF (UPPER) THEN
                  DO 310 K = N,1,-1
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(K,K)
                          DO 270 I = 1,M
                              B(I,K) = TEMP*B(I,K)
  270                     CONTINUE
                      END IF
                      DO 290 J = 1,K - 1
                          IF (A(J,K).NE.ZERO) THEN
                              TEMP = A(J,K)
                              DO 280 I = 1,M
                                  B(I,J) = B(I,J) - TEMP*B(I,K)
  280                         CONTINUE
                          END IF
  290                 CONTINUE
                      IF (ALPHA.NE.ONE) THEN
                          DO 300 I = 1,M
                              B(I,K) = ALPHA*B(I,K)
  300                     CONTINUE
                      END IF
  310             CONTINUE
              ELSE
                  DO 360 K = 1,N
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(K,K)
                          DO 320 I = 1,M
                              B(I,K) = TEMP*B(I,K)
  320                     CONTINUE
                      END IF
                      DO 340 J = K + 1,N
                          IF (A(J,K).NE.ZERO) THEN
                              TEMP = A(J,K)
                              DO 330 I = 1,M
                                  B(I,J) = B(I,J) - TEMP*B(I,K)
  330                         CONTINUE
                          END IF
  340                 CONTINUE
                      IF (ALPHA.NE.ONE) THEN
                          DO 350 I = 1,M
                              B(I,K) = ALPHA*B(I,K)
  350                     CONTINUE
                      END IF
  360             CONTINUE
              END IF
          END IF
      END IF
      RETURN
      END
      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
      INTEGER            ISPEC
      REAL               ONE, ZERO
      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
     $                   NEGZRO, NEWZRO, POSINF
      IEEECK = 1
      POSINF = ONE / ZERO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
      NEGINF = -ONE / ZERO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
      NEGZRO = ONE / ( NEGINF+ONE )
      IF( NEGZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
      NEGINF = ONE / NEGZRO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
      NEWZRO = NEGZRO + ZERO
      IF( NEWZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
      POSINF = ONE / NEWZRO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
      NEGINF = NEGINF*POSINF
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
      POSINF = POSINF*POSINF
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
      IF( ISPEC.EQ.0 )
     $   RETURN
      NAN1 = POSINF + NEGINF
      NAN2 = POSINF / NEGINF
      NAN3 = POSINF / POSINF
      NAN4 = POSINF*ZERO
      NAN5 = NEGINF*NEGZRO
      NAN6 = NAN5*ZERO
      IF( NAN1.EQ.NAN1 ) THEN
         IEEECK = 0
         RETURN
      END IF
      IF( NAN2.EQ.NAN2 ) THEN
         IEEECK = 0
         RETURN
      END IF
      IF( NAN3.EQ.NAN3 ) THEN
         IEEECK = 0
         RETURN
      END IF
      IF( NAN4.EQ.NAN4 ) THEN
         IEEECK = 0
         RETURN
      END IF
      IF( NAN5.EQ.NAN5 ) THEN
         IEEECK = 0
         RETURN
      END IF
      IF( NAN6.EQ.NAN6 ) THEN
         IEEECK = 0
         RETURN
      END IF
      RETURN
      END
      INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
      INTEGER            I, IC, IZ, NB, NBMIN, NX
      LOGICAL            CNAME, SNAME
      CHARACTER          C1*1, C2*2, C4*2, C3*3, SUBNAM*6
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
      INTEGER            IEEECK, IPARMQ
      EXTERNAL           IEEECK, IPARMQ
      GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
     $        130, 140, 150, 160, 160, 160, 160, 160 )ISPEC
      ILAENV = -1
      RETURN
   10 CONTINUE
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1: 1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1: 1 ) = CHAR( IC-32 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I: I ) )
               IF( IC.GE.97 .AND. IC.LE.122 )
     $            SUBNAM( I: I ) = CHAR( IC-32 )
   20       CONTINUE
         END IF
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $       ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1: 1 ) = CHAR( IC+64 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I: I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $             ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $             ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I:
     $             I ) = CHAR( IC+64 )
   30       CONTINUE
         END IF
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1: 1 ) = CHAR( IC-32 )
            DO 40 I = 2, 6
               IC = ICHAR( SUBNAM( I: I ) )
               IF( IC.GE.225 .AND. IC.LE.250 )
     $            SUBNAM( I: I ) = CHAR( IC-32 )
   40       CONTINUE
         END IF
      END IF
      C1 = SUBNAM( 1: 1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) )
     $   RETURN
      C2 = SUBNAM( 2: 3 )
      C3 = SUBNAM( 4: 6 )
      C4 = C3( 2: 3 )
      GO TO ( 50, 60, 70 )ISPEC
   50 CONTINUE
      NB = 1
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $            C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'PO' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NB = 32
         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            NB = 64
         ELSE IF( C3.EQ.'TRD' ) THEN
            NB = 32
         ELSE IF( C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NB = 32
            END IF
         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NB = 32
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NB = 32
            END IF
         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NB = 32
            END IF
         END IF
      ELSE IF( C2.EQ.'GB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'PB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'TR' ) THEN
         IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'LA' ) THEN
         IF( C3.EQ.'UUM' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
         IF( C3.EQ.'EBZ' ) THEN
            NB = 1
         END IF
      END IF
      ILAENV = NB
      RETURN
   60 CONTINUE
      NBMIN = 2
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
     $       'QLF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 8
            ELSE
               NBMIN = 8
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NBMIN = 2
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NBMIN = 2
            END IF
         END IF
      END IF
      ILAENV = NBMIN
      RETURN
   70 CONTINUE
      NX = 0
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
     $       'QLF' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NX = 32
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 32
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NX = 128
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NX = 128
            END IF
         END IF
      END IF
      ILAENV = NX
      RETURN
   80 CONTINUE
      ILAENV = 6
      RETURN
   90 CONTINUE
      ILAENV = 2
      RETURN
  100 CONTINUE
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
  110 CONTINUE
      ILAENV = 1
      RETURN
  120 CONTINUE
      ILAENV = 50
      RETURN
  130 CONTINUE
      ILAENV = 25
      RETURN
  140 CONTINUE
      ILAENV = 1
      IF( ILAENV.EQ.1 ) THEN
         ILAENV = IEEECK( 1, 0.0, 1.0 )
      END IF
      RETURN
  150 CONTINUE
      ILAENV = 1
      IF( ILAENV.EQ.1 ) THEN
         ILAENV = IEEECK( 0, 0.0, 1.0 )
      END IF
      RETURN
  160 CONTINUE
      ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
      RETURN
      END
      INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
      INTEGER            IHI, ILO, ISPEC, LWORK, N
      CHARACTER          NAME*( * ), OPTS*( * )
      INTEGER            INMIN, INWIN, INIBL, ISHFTS, IACC22
      PARAMETER          ( INMIN = 12, INWIN = 13, INIBL = 14,
     $                   ISHFTS = 15, IACC22 = 16 )
      INTEGER            NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
      PARAMETER          ( NMIN = 75, K22MIN = 14, KACMIN = 14,
     $                   NIBBLE = 14, KNWSWP = 500 )
      REAL               TWO
      PARAMETER          ( TWO = 2.0 )
      INTEGER            NH, NS
      INTRINSIC          LOG, MAX, MOD, NINT, REAL
      IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
     $    ( ISPEC.EQ.IACC22 ) ) THEN
         NH = IHI - ILO + 1
         NS = 2
         IF( NH.GE.30 )
     $      NS = 4
         IF( NH.GE.60 )
     $      NS = 10
         IF( NH.GE.150 )
     $      NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )
         IF( NH.GE.590 )
     $      NS = 64
         IF( NH.GE.3000 )
     $      NS = 128
         IF( NH.GE.6000 )
     $      NS = 256
         NS = MAX( 2, NS-MOD( NS, 2 ) )
      END IF
      IF( ISPEC.EQ.INMIN ) THEN
         IPARMQ = NMIN
      ELSE IF( ISPEC.EQ.INIBL ) THEN
         IPARMQ = NIBBLE
      ELSE IF( ISPEC.EQ.ISHFTS ) THEN
         IPARMQ = NS
      ELSE IF( ISPEC.EQ.INWIN ) THEN
         IF( NH.LE.KNWSWP ) THEN
            IPARMQ = NS
         ELSE
            IPARMQ = 3*NS / 2
         END IF
      ELSE IF( ISPEC.EQ.IACC22 ) THEN
         IPARMQ = 0
         IF( NS.GE.KACMIN )
     $      IPARMQ = 1
         IF( NS.GE.K22MIN )
     $      IPARMQ = 2
      ELSE
         IPARMQ = -1
      END IF
      END
      LOGICAL FUNCTION LSAME(CA,CB)
      CHARACTER CA,CB
      INTRINSIC ICHAR
      INTEGER INTA,INTB,ZCODE
      LSAME = CA .EQ. CB
      IF (LSAME) RETURN
      ZCODE = ICHAR('Z')
      INTA = ICHAR(CA)
      INTB = ICHAR(CB)
      IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN
          IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32
          IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32
      ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN
          IF (INTA.GE.129 .AND. INTA.LE.137 .OR.
     +        INTA.GE.145 .AND. INTA.LE.153 .OR.
     +        INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64
          IF (INTB.GE.129 .AND. INTB.LE.137 .OR.
     +        INTB.GE.145 .AND. INTB.LE.153 .OR.
     +        INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64
      ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN
          IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32
          IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32
      END IF
      LSAME = INTA .EQ. INTB
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
      CHARACTER*(*)      SRNAME
      INTEGER            INFO
      INTRINSIC          LEN_TRIM
      WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
      STOP
 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',
     $      'an illegal value' )
      END


      subroutine slrgen(j)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine generates solar radiation

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hru_rmx(:)  |MJ/m^2        |maximum possible radiation for the day in HRU
!!    j           |none          |HRU number
!!    i_mo        |none          |month being simulated
!!    pr_w(3,:,:) |none          |proportion of wet days in a month
!!    solarav(:,:)|MJ/m^2/day    |average daily solar radiation for the month
!!    subp(:)     |mm H2O        |precipitation for the day in HRU
!!    wgncur(3,:) |none          |parameter which predicts impact of precip on
!!                               |daily solar radiation
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hru_ra(:)   |MJ/m^2        |solar radiation for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    rav         |MJ/m^2        |modified monthly average solar radiation
!!    rx          |none          |variable to hold intermediate calculation
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer, intent (in) :: j

      real*8 :: rx, rav

      rav = 0.
      rav = solarav(i_mo,hru_sub(j)) /
     &                              (1. - 0.5 * pr_w(3,i_mo,hru_sub(j)))
      if (subp(j) > 0.0) rav = 0.5 * rav
      rx = 0.
      rx = hru_rmx(j) - rav
      hru_ra(j) = rav + wgncur(3,j) * rx / 4.
      if (hru_ra(j) <= 0.) hru_ra(j) = .05 * hru_rmx(j)

      return
      end