      PROGRAM range
!
! This program finds the range of a charged partcile in a plasma, where the
! charged particle is created with threshold energy Ep.
!
! The subroutine rk4(y,t,dt,nit) advances y at time t by nit iterations, each
! of which has a constant time-step dt.
!
! nts = number of time steps
! nit = number of iterations per time step
!
      USE allocatablevars
      USE bpsvars
      USE physvars
      USE mathvars
        IMPLICIT NONE
        INTEGER NTSMAX
        PARAMETER (NTSMAX=5000)

        REAL    :: y, v, t, dt, tmax
        REAL    :: xt(0:NTSMAX), vt(0:NTSMAX), tt(0:NTSMAX)
        REAL    :: dedx_tot,  dedx_i,  dedx_e
        REAL    :: dedxc_tot, dedxc_i, dedxc_e
        REAL    :: dedxq_tot, dedxq_i, dedxq_e
        INTEGER :: j, nts, nit

        REAL    :: te, ti, ne, ep, mp, zp
        REAL    :: de, epp
        INTEGER :: nni, nn
!
! Range parameters
!
                     ! 3 keV: range.002.out
        tmax=1.0E-11 ! [s]
        nts=100
        nit=10
        nn =300
        dt=tmax/(nts*nit)
        te=3.        ! Electron temperature       [keV]
        ti=3.        ! Ion temperature            [keV]
        ne=1.E25     ! Electron number density    [cm^-3]
        ep=3540.     ! Projectile energy  [keV]
        mp=4*MPKEV   ! Projectile mass    [keV]
        zp=2.        ! Projectile charge  [e]
        OPEN(1, FILE='range.001.out')
        OPEN(2, FILE='dedx.001.out')

                     ! 30 keV: range.002.out
!!        tmax=0.6E-10 ! [s]
!!        nts=100
!!        nit=10
!!        nn =300
!!        dt=tmax/(nts*nit)
!!        te=30.       ! Electron temperature       [keV]
!!        ti=30.       ! Ion temperature            [keV]
!!        ne=1.E25     ! Electron number density    [cm^-3]
!!        ep=3540.     ! Projectile energy  [keV]
!!        mp=4*MPKEV   ! Projectile mass    [keV]
!!        zp=2.        ! Projectile charge  [e]
!!        OPEN(1, FILE='range.002.out')
!!        OPEN(2, FILE='dedx.002.out')

                     ! FF: range.003.out
!!        tmax=3.0E-11 ! [s]
!!        nts=100
!!        nit=10
!!        nn =300
!!        dt=tmax/(nts*nit)
!!        te=1.        ! Electron temperature       [keV]
!!        ti=1.        ! Ion temperature            [keV]
!!        ne=1.E23     ! Electron number density    [cm^-3]
!!        ep=185000./2.! Projectile energy  [keV]
!!        mp=120*MPKEV ! Projectile mass    [keV]
!!        zp=25.       ! Projectile charge  [e]
!!        OPEN(1, FILE='range.003.out')
!!        OPEN(2, FILE='dedx.003.out')

                     ! FF: range.003.out
!!        tmax=3.0E-11 ! [s]
!!        nts=100
!!        nit=10
!!        nn =300
!!        dt=tmax/(nts*nit)
!!        te=1.        ! Electron temperature       [keV]
!!        ti=1.        ! Ion temperature            [keV]
!!        ne=1.E23     ! Electron number density    [cm^-3]
!!        ep=185000./2.! Projectile energy  [keV]
!!        mp=120*MPKEV ! Projectile mass    [keV]
!!        zp=25.       ! Projectile charge  [e]
!!        OPEN(1, FILE='range.004.out')
!!        OPEN(2, FILE='dedx.004.out')

!
! DT plasma with alpha particle projectile
!
      CALL define_plasma(te,ti,ne,nni)
!!    CALL define_plasma_FF(te,ti,ne,nni)
!
! plot the regular and singular contributions
!
        CALL write_output(ep,mp,zp,te,ti,ne,nni,betab,zb,mb,nb)
!
! evolution
!
        WRITE(2,*) ne
        WRITE(2,*) te
        WRITE(2,*) ti
        WRITE(2,*) nn
        WRITE(2,*) ep, mp, zp
        de=ep/nn
        epp=0
        DO j=0,nn
           epp=j*de
           IF (epp .EQ. 0) epp=1.E-5
           CALL dedx_bps(nni, epp, zp, mp, betab, zb, mb, nb,   &
             dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, &
             dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]
           WRITE (6,'(I6,E17.8,6D22.13)') j, epp, dedx_tot, dedx_i, dedx_e
           WRITE (2,'(I6,E17.8,6D22.13)') j, epp, dedx_tot, dedx_i, dedx_e
        END DO
        CLOSE (2)
!
! initial conditions
!
        t=0                ! [s]
        y=0.               ! [cm]
        v=CC*SQRT(2*ep/mp) ! [cm/s]
        tt(0)=t
        xt(0)=y
        vt(0)=v
!
! evolution
!
        j=0
        ep=0.5*mp*(vt(j)/CC)**2
        CALL dedx_bps(nni, ep, zp, mp, betab, zb, mb, nb,   &
            dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, &
            dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]

        WRITE(1,*) ne
        WRITE(1,*) te
        WRITE(1,*) ti
        WRITE(1,*) tmax, nts, nit
        WRITE(1,*) ep, mp, zp
        WRITE (6,'(I6,E17.8,6D22.13)') j, tt(j), xt(j), vt(j), ep, dedx_tot, dedx_i, dedx_e
        WRITE (1,'(I6,E17.8,6D22.13)') j, tt(j), xt(j), vt(j), ep, dedx_tot, dedx_i, dedx_e
        DO j=1,nts
           CALL rk4(y,v,t,dt,nit,nni,zp,mp,dedx_tot,dedx_i,dedx_e)
           tt(j)=t
           xt(j)=y
           vt(j)=v
           ep   =0.5*mp*(vt(j)/CC)**2
           WRITE (6,'(I6,E17.8,6D22.13)') j, tt(j), xt(j), vt(j), ep, dedx_tot, dedx_i, dedx_e
           WRITE (1,'(I6,E17.8,6D22.13)') j, tt(j), xt(j), vt(j), ep, dedx_tot, dedx_i, dedx_e
        END DO
        CLOSE (1)
        END PROGRAM range

!
! SUBROUTINE rk4:
! Given the equation of motion
!
!   y'' = f(y,v,t)  ,
!
! this subroutine advances (y,v) at time t by nit iterations of
! length dt. The variable (y,v) and the time t are returned with
! their updated values.
!
      SUBROUTINE rk4(x, v, t, dt, nit, nni, zp, mp, dedx_tot, dedx_i, dedx_e)
      USE allocatablevars ! betab(1:nni+1), zb(1:nni+1), mb(1:nni+1), nb(1:nni+1)
      USE physvars
      IMPLICIT NONE
      REAL,    INTENT(INOUT) :: x, v, t
      REAL,    INTENT(INOUT) :: dt
      INTEGER, INTENT(IN)    :: nit
      INTEGER, INTENT(IN)    :: nni
      REAL,    INTENT(IN)    :: zp, mp
      REAL,    INTENT(OUT)   :: dedx_tot, dedx_i, dedx_e ! [MeV/micron]
      REAL    :: xx, vv, th, f
      REAL    :: xk1, xk2, xk3, xk4
      REAL    :: vk1, vk2, vk3, vk4
      REAL    :: dedxc_tot, dedxc_i, dedxc_e, dedxq_tot, dedxq_i, dedxq_e
      REAL    :: ep
      INTEGER :: it
      REAL, PARAMETER :: d6=0.1666666666666666666

      dedx_tot=0
      dedx_i  =0
      dedx_e  =0
      th=t+0.5*dt
      DO it=1,nit
!
! first intermediate step
!
         CALL force(v,f,nni,zp,mp)
         xk1=dt*v
         vk1=dt*f
         xx =x+0.5*xk1
         vv =v+0.5*vk1
!
! second intermediate step
!
         CALL force(vv,f,nni,zp,mp)
         xk2=dt*vv
         vk2=dt*f
         xx =x+0.5*xk2
         vv =v+0.5*vk2
!
! third intermediate step
!
         CALL force(vv,f,nni,zp,mp)
         xk3=dt*vv
         vk3=dt*f
         xx =x+xk3
         vv =v+vk3
!
! fourth intermediate step
!
         t=t+dt
         CALL force(v,f,nni,zp,mp)
         xk4=dt*v
         vk4=dt*f
!
         x = x + d6*(xk1 + 2*xk2 + 2*xk3 + xk4)
         v = v + d6*(vk1 + 2*vk2 + 2*vk3 + vk4)
      END DO
      ep = 0.5*mp*(v/CC)**2 ! [keV] projectile energy
      CALL dedx_bps(nni, ep, zp, mp, betab, zb, mb, nb,   &
        dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, &
        dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]
      END SUBROUTINE rk4
!
! SUBROUTINE force:
! Returns the force f(x,v,t,) for x''=f(x,v,t)
!
      SUBROUTINE force(v, f, nni, zp, mp)
      USE allocatablevars ! betab(1:nni+1), zb(1:nni+1), mb(1:nni+1), nb(1:nni+1)
      USE physvars
      IMPLICIT NONE
      REAL,    INTENT(IN) :: v
      REAL,    INTENT(OUT):: f
      INTEGER, INTENT(IN) :: nni
      REAL,    INTENT(IN) :: zp, mp
      REAL    :: ep
      REAL    :: dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, dedxc_e
      REAL    :: dedxq_tot, dedxq_i, dedxq_e
      REAL    :: KEV_TO_ERG=1.6022E-9
      REAL    :: f1, m1

      ep = 0.5*mp*(v/CC)**2  ! [keV] projectile energy
      CALL dedx_bps(nni, ep, zp, mp, betab, zb, mb, nb,   &
            dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, &
            dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]

      f   =-dedx_tot         ! [MeV/mircon] is a force]
      f   =f*1.E7            ! [keV/cm]
      f1  =f*KEV_TO_ERG      ! [erg]
      m1  =mp*KEV_TO_ERG/CC2 ! [g]
      f   =f1/m1             ! [dyne]
      END SUBROUTINE force

!
! SUBROUTINE define_plasma:
! Returns the plasma species arrays: betab, mb, nb, zb
! Allocates other plasma arrays
!
    SUBROUTINE define_plasma(te, ti, ne, nni)
    USE allocatablevars
    USE physvars
      IMPLICIT NONE
      REAL                                :: te     ! [keV]
      REAL                                :: ti     ! [keV]
      REAL                                :: ne     ! [cm^-3]
      INTEGER                             :: nni    ! number of ion species
!     REAL,    DIMENSION(:), ALLOCATABLE  :: betab  ! [1/keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: mb     ! [keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: nb     ! [cm^-3]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: zb     ! [e]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: gb, etab, mpb, mbpb

      nni=2  ! number of ion species

      ALLOCATE(betab(1:nni+1),zb(1:nni+1),mb(nni+1),nb(1:nni+1))   ! allocatablevars
      ALLOCATE(gb(1:nni+1),etab(1:nni+1),mpb(nni+1),mbpb(1:nni+1)) ! allocatablevars

      zb(1)=-1.    ! Species charges
      zb(2)=+1.    !
      zb(3)=+1.    !
      mb(1)=MEKEV  ! Species masses [keV]
      mb(2)=2*MPKEV!
      mb(3)=3*MPKEV!
!
! Construct density and temperature arrays
!
      nb(1)=1.                          ! ONLY FOR EQUIMOLAR DT
      nb(2:nni+1)=1./(zb(2:nni+1)*nni)  ! charge neutrality
      nb=nb*ne                          ! number density array [cm^-3]
      betab(1)=1./te                    ! inverse temp array   [keV^-1]
      betab(2:nni+1)=1./ti              !
    END SUBROUTINE define_plasma

!
! SUBROUTINE define_plasma:
! Returns the plasma species arrays: betab, mb, nb, zb
! Allocates other plasma arrays
!
    SUBROUTINE define_plasma_FF(te, ti, ne, nni)
    USE allocatablevars
    USE physvars
      IMPLICIT NONE
      REAL                                :: te     ! [keV]
      REAL                                :: ti     ! [keV]
      REAL                                :: ne     ! [cm^-3]
      INTEGER                             :: nni    ! number of ion species
!     REAL,    DIMENSION(:), ALLOCATABLE  :: betab  ! [1/keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: mb     ! [keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: nb     ! [cm^-3]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: zb     ! [e]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: gb, etab, mpb, mbpb

      nni=1  ! number of ion species

      ALLOCATE(betab(1:nni+1),zb(1:nni+1),mb(nni+1),nb(1:nni+1))   ! allocatablevars
      ALLOCATE(gb(1:nni+1),etab(1:nni+1),mpb(nni+1),mbpb(1:nni+1)) ! allocatablevars

      zb(1)=-1.      ! Species charges
      zb(2)=50.      !
      mb(1)=MEKEV    ! Species masses [keV]
      mb(2)=239*MPKEV!
!
! Construct density and temperature arrays
!
      nb(1)=1.                          ! ONLY FOR EQUIMOLAR DT
      nb(2:nni+1)=1./(zb(2:nni+1)*nni)  ! charge neutrality
      nb=nb*ne                          ! number density array [cm^-3]
      betab(1)=1./te                    ! inverse temp array   [keV^-1]
      betab(2:nni+1)=1./ti              !
    END SUBROUTINE define_plasma_FF

    SUBROUTINE write_output(ep, mp, zp, te, ti, ne, nni, betab, zb, mb, nb)
    USE physvars
      IMPLICIT NONE
      REAL,                        INTENT(IN) :: ep     ! [keV]
      REAL,                        INTENT(IN) :: mp     ! [keV]
      REAL,                        INTENT(IN) :: zp     ! [e]
      REAL,                        INTENT(IN) :: te     ! [keV]
      REAL,                        INTENT(IN) :: ti     ! [keV]
      REAL,                        INTENT(IN) :: ne     ! [cm^-3]
      INTEGER,                     INTENT(IN) :: nni    ! number of ion species
      REAL,    DIMENSION(1:nni+1), INTENT(IN) :: betab  ! [1/keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN) :: zb     ! [e]
      REAL,    DIMENSION(1:nni+1), INTENT(IN) :: mb     ! [keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN) :: nb     ! [cm^-3]

      REAL  :: etae, ge, gi, ze
      REAL,    DIMENSION(1:nni+1) :: gb

      REAL  :: vp
      REAL,    DIMENSION(1:nni+1) :: ab, etab
!
! write header
!
      WRITE(6,'(A)') '#'
      WRITE(6,'(A, 3X,A21)') '#','Projectile Parameters'
      WRITE(6,'(A, 4X,A13, X,D12.4)') '#','charge      :', zp
      WRITE(6,'(A, 4X,A13, X,D12.4)') '#','mass   [amu]:', mp/AMUKEV
      WRITE(6,'(A, 4X,A13, X,D12.4)') '#','mass   [keV]:', mp
      WRITE(6,'(A, 4X,A13, X,D12.4)') '#','energy [keV]:', ep
      WRITE(6,'(A)') '#'
      WRITE(6,'(A, 3X,A17)') '#','Plasma Parameters'
      WRITE(6,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
      WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
      WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
      WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
      WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb

      WRITE(1,'(A)') '#'
      WRITE(1,'(A)') '#'
      WRITE(1,'(A, 3X,A17)') '#','Plasma Parameters'
      WRITE(1,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
      WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
      WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
      WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
      WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb
      WRITE(1,'(A)') '#'
      WRITE(1,'(A)') '#'
      WRITE(1,'(A, 3X,A21)') '#','Projectile Parameters'
      WRITE(1,'(A, 4X,A13, X,D12.4)') '#','charge      :', zp
      WRITE(1,'(A, 4X,A13, X,D12.4)') '#','mass   [amu]:', mp/AMUKEV
      WRITE(1,'(A, 4X,A13, X,D12.4)') '#','mass   [keV]:', mp
      WRITE(1,'(A, 4X,A13, X,D12.4)') '#','energy [keV]:', ep

      WRITE(2,'(A)') '#'
      WRITE(2,'(A)') '#'
      WRITE(2,'(A, 3X,A17)') '#','Plasma Parameters'
      WRITE(2,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
      WRITE(2,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
      WRITE(2,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
      WRITE(2,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
      WRITE(2,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb
      WRITE(2,'(A)') '#'
      WRITE(2,'(A)') '#'
      WRITE(2,'(A, 3X,A21)') '#','Projectile Parameters'
      WRITE(2,'(A, 4X,A13, X,D12.4)') '#','charge      :', zp
      WRITE(2,'(A, 4X,A13, X,D12.4)') '#','mass   [amu]:', mp/AMUKEV
      WRITE(2,'(A, 4X,A13, X,D12.4)') '#','mass   [keV]:', mp
      WRITE(2,'(A, 4X,A13, X,D12.4)') '#','energy [keV]:', ep
!
! Print plasma parameters
!

      CALL param(nni, betab, nb, gb, ge, gi, etae, ze)
      WRITE(6,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
        '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
      WRITE(6,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5
      WRITE(1,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
        '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
      WRITE(1,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5
      WRITE(2,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
        '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
      WRITE(2,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5

      vp  = CC*SQRT(2*ep/mp)       ! [cm/s]
      ab  =0.5*betab*mb*vp*vp/CC2  ! [dimensionless] (1/2) betab(ib)*mb(ib)*vp2/CC2
      etab=ABS(zp*zb)*2.1870E8/vp  ! [dimensionless]

      WRITE(6,'(A7, 3D12.4)') '# ab  =', ab
      WRITE(6,'(A7, 3D12.4)') '# etab=', etab
      WRITE(1,'(A7, 3D12.4)') '# ab  =', ab
      WRITE(1,'(A7, 3D12.4)') '# etab=', etab
      WRITE(2,'(A7, 3D12.4)') '# ab  =', ab
      WRITE(2,'(A7, 3D12.4)') '# etab=', etab

!      WRITE(6,'(A)') "#"
!      WRITE(6,'(A5, 2X,A7, 5X,A5, 7X,A3, 9X,A3, 9X,A6, 6X,A4, 8X,A4, 8X,A6, 6X,A4, 8X,A4)') &
!        "#  iu", "ep[keV]", "a_tot", "a_e", "a_i", "ac_tot", "ac_e_lim", "ac_i", &
!        "aq_tot", "aq_e", "aq_i"
!      WRITE(1,'(A)') "#"
!      WRITE(1,'(A5, 2X,A7, 5X,A5, 7X,A3, 9X,A3, 9X,A6, 6X,A4, 8X,A4, 8X,A6, 6X,A4, 8X,A4)') &
!        "#  iu", "ep[keV]", "a_tot", "a_e", "a_i", "ac_tot", "ac_e", "ac_i", "aq_tot", "aq_e","aq_i"

    END SUBROUTINE write_output


*deck ptwt
      subroutine ptwt(abess,arc2,bbess,dfac,npi,l,lambu,ltot1,lmahi,
     &  lmbhi,alpha,ptpow,q2,rc,rka,rkb,prd,hpt,hwt,qsum)
c
c  compute type 2 radial integrals, scaled by exp(-arc2)/sqrt(pi),
c  using the points and weights method,
c  for lama=l to lmahi, lamb=l to lmbhi, n=lama+lamb-l-l
c
      implicit real*8 (a-h,o-z)
      parameter (a500=500.0d0, a50000=50000.0d0)
      dimension abess(*),bbess(*),dfac(*),hpt(*),hwt(*),ptpow(*),
     &  q2(lambu,*),qsum(ltot1,lambu,*)
c
      call wzero(lambu*lmahi,q2,1)
      if(arc2.gt.a50000) then
        npt=5
        idif=0
      else if(arc2.gt.a500) then
        npt=10
        idif=5
      else
        npt=20
        idif=15
      endif
      sqalp=sqrt(alpha)
      prd=prd/sqalp
      do 90 i=1,npt
        pt=rc+hpt(i+idif)/sqalp
        call ssibfn(lmahi-1,rka*pt,abess)
        call ssibfn(lmbhi-1,rkb*pt,bbess)
        if((npi+l+l-2).eq.0) then
          ptpow(1)=prd
        else
          ptpow(1)=prd*pt**(npi+l+l-2)
        endif
        do 70 n=2,ltot1
          ptpow(n)=(pt*pt)*ptpow(n-1)
   70   continue
        do 88 lama=l,lmahi
          do 86 lamb=l,lmbhi
            n=((1-l-l)+lama)+lamb
            q2(lamb,lama)=q2(lamb,lama)+(hwt(i+idif)*abess(lama))*
     1        bbess(lamb)*ptpow(n)
   86     continue
   88   continue
   90 continue
      fctr=rkb**(l-1)
      do 92 lamb=l,lmbhi
        bbess(lamb)=fctr/dfac(lamb+lamb+1)
        fctr=rkb*fctr
   92 continue
      fctr=rka**(l-1)
      do 96 lama=l,lmahi
        do 94 lamb=l,lmbhi
          n=((1-l-l)+lama)+lamb
          qsum(n,lamb,lama)=qsum(n,lamb,lama)+(fctr/dfac(lama+lama+1))*
     1      bbess(lamb)*q2(lamb,lama)
   94   continue
        fctr=rka*fctr
   96 continue
      return
      end


subroutine compute_se(parameters)
    use dimensions; use nrtype; use optimization; use structural_p2; use simulation_input
    implicit none
    real(SP),dimension(parameters_to_est)::parameters
    real(SP),dimension(moment_conditions,parameters_to_est)::J
    real(DP),dimension(parameters_to_est,parameters_to_est)::V,inv_v
    integer::p_l,ns,i_l,j_l
    real(SP)::obj_fct_original
    real(SP),dimension(moment_conditions,1)::mean
    real(SP),dimension(moment_conditions,samples_per_i)::matrix_s_new
    interface
        function SMM(parameters)
        use nrtype;use dimensions
        implicit none
        real(SP),dimension(parameters_to_est),intent(in)::parameters
        real(SP)::SMM
        end function
    end interface

    !Compute Jacobian
    call Jacobian(parameters,J)

    !Variance Covariance matrix of estimated parameters
    V=matmul(matmul(transpose(dble(J(1:real_moments,1:parameters_to_est))),dble(W_opt(1:real_moments,1:real_moments))) &
             ,dble(J(1:real_moments,1:parameters_to_est)))
    call inverse(V,inv_V,parameters_to_est)
    !If using the optimal weighting matrix
    V=(1.0d0+1.0d0/dble(samples_per_i))/dble(indv)*inv_V

    print*,'standard errors'
    do p_l=1,parameters_to_est
        se(p_l)=real(sqrt(V(p_l,p_l)))
        print*,se(p_l)
    end do

end subroutine


!==============================================================================!
  subroutine Calculate_Sgs_Wale(grid)
!------------------------------------------------------------------------------!
!  Compute SGS viscosity for 'LES' by using LES_WALE model.
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod, only: ONE_THIRD, TINY
  use Flow_Mod
  use Les_Mod
  use Grid_Mod
  use Work_Mod, only: sijd_sijd => r_cell_01,  &
                      shear2    => r_cell_02,  &
                      vort2     => r_cell_03
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer :: c
  real    :: s11,  s22,  s33,  s12,  s13,  s23,  s21,  s31,  s32
  real    :: s11d, s22d, s33d, s12d, s13d, s23d, s21d, s31d, s32d
  real    :: v11,  v22,  v33,  v12,  v13,  v23,  v21,  v31,  v32
!==============================================================================!

  !---------------!
  !               !
  !   SGS terms   !
  !               !
  !---------------!
  do c = 1, grid % n_cells
    s11 = u % x(c)
    s22 = v % y(c)
    s33 = w % z(c)
    s12 = 0.5*(v % x(c) + u % y(c))
    s13 = 0.5*(u % z(c) + w % x(c))
    s23 = 0.5*(v % y(c) + w % y(c))
    s21 = s12
    s31 = s13
    s32 = s23

    v11 = 0.0
    v22 = 0.0
    v33 = 0.0
    v12 = 0.5*(v % x(c) - u % y(c))
    v13 = 0.5*(u % z(c) - w % x(c))
    v23 = 0.5*(v % y(c) - w % y(c))
    v21 = -v12
    v31 = -v13
    v32 = -v23

    shear2(c) = 0.5 * shear(c) * shear(c)
    vort2(c)  = 0.5 * vort(c) * vort(c)

    s11d =  s11*s11 + s12*s12 + s13*s13   &
         - (v11*v11 + v12*v12 + v13*v13)  &
         - ONE_THIRD * (shear2(c) - vort2(c))

    s22d =  s12*s12 + s22*s22 + s23*s23   &
         - (v12*v12 + v22*v22 + v23*v23)  &
         - ONE_THIRD * (shear2(c) - vort2(c))

    s33d =  s13*s13 + s23*s23 + s33*s33   &
         - (v13*v13 + v23*v23 + v33*v33)  &
         - ONE_THIRD * (shear2(c) - vort2(c))

    s12d = s11*s12 + s12*s22 + s13*s32 + (v11*v12 + v12*v22 + v13*v32)
    s13d = s11*s13 + s12*s23 + s13*s33 + (v11*v13 + v12*v23 + v13*v33)
    s23d = s21*s13 + s22*s23 + s23*s33 + (v21*v13 + v22*v23 + v23*v33)

    s21d = s12d
    s31d = s13d
    s32d = s23d

    sijd_sijd(c) = s11d*s11d + s22d*s22d + s33d*s33d  &
                 + s12d*s12d + s13d*s13d + s23d*s23d

    wale_v(c) =  sqrt( abs (sijd_sijd(c)**3) )          &
              / (sqrt( abs (shear2(c)   **5) ) +        &
                 sqrt( sqrt(sijd_sijd(c)**6) ) + TINY)
  end do

  end subroutine


C FSTOEQ.F - Gateway function for the QR factorization of (block)
C            Toeplitz matrices and/or solving associated linear
C            least-squares systems using SLICOT routines MB02HD,
C            MB02ID, MB02JD, MB02JX, MB02KD.
C
C RELEASE 2.0 of SLICOT Basic Systems and Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C            [(Q,)R(,X,Y)] = fstoeq(task,TC,TR(,B,C))
C                  [(Q,)R] = fstoeq(task,TC,TR,tol)
C                [R(,X,Y)] = fstoeq(task,m,n,TCB,TRB(,B,C))
C                  [X(,Y)] = fstoeq(task,TC,TR,B(,C))
C                      [Y] = fstoeq(task,TC,TR,C)
C
C   task =  1 :        [R] = fstoeq( 1,TC,TR)
C                    [Q,R] = fstoeq( 1,TC,TR)
C   task =  2 :      [R,X] = fstoeq( 2,TC,TR,B)
C                  [Q,R,X] = fstoeq( 2,TC,TR,B)
C   task =  3 :      [R,Y] = fstoeq( 3,TC,TR,C)
C                  [Q,R,Y] = fstoeq( 3,TC,TR,C)
C   task =  4 :    [R,X,Y] = fstoeq( 4,TC,TR,B,C)
C                [Q,R,X,Y] = fstoeq( 4,TC,TR,B,C)
C   task =  5 :      [R,E] = fstoeq( 5,TC,TR,tol)
C                  [Q,R,E] = fstoeq( 5,TC,TR,tol)
C   task =  6 :        [R] = fstoeq( 6,m,n,TCB,TRB)
C   task =  7 :      [R,X] = fstoeq( 7,m,n,TCB,TRB,B)
C   task =  8 :      [R,Y] = fstoeq( 8,m,n,TCB,TRB,C)
C   task =  9 :    [R,X,Y] = fstoeq( 9,m,n,TCB,TRB,B,C)
C   task = 10 :        [X] = fstoeq(10,TC,TR,B)
C   task = 11 :        [Y] = fstoeq(11,TC,TR,C)
C   task = 12 :      [X,Y] = fstoeq(12,TC,TR,B,C)
C   task = 13 :        [X] = fstoeq(13,TC,TR,B)
C
C Purpose:
C   To compute an orthogonal-triangular/trapezoidal decomposition
C   (with partial column pivoting) of a (banded) block Toeplitz matrix.
C   If task <= 5 or task >= 10, the first block column of T is contained
C   in TC and has the dimension M*K-by-L and the first block row of T is
C   contained in TR and has the dimension K-by-N*L, while for task >= 6
C   and task <= 9 the leading nonzero blocks of the first block column
C   of T are contained in TCB which has the dimension (ML+1)*K-by-L
C   and the leading nonzero blocks of the first block row of T are
C   contained in TRB which has the dimesion K-by-(NU+1)*L.
C   If task = 13, the product of a block Toeplitz matrix T with a block
C   column vector C is computed.
C
C   task =  1: Compute R, the Cholesky factor of T'*T, i.e., R is lower
C              triangular, so that R*R' = T'*T. Optionally, a matrix Q
C              is computed so that Q'*Q = I and T = Q*R'.
C
C   task =  2: Compute R and the least-squares solution of T*X = B for a
C              given right hand side matrix B.
C
C   task =  3: Compute R and the minimum norm solution of T'*Y = C for a
C              given right hand side matrix C.
C
C   task =  4: Compute R, X and Y.
C
C   task =  5: Compute R, a low rank Cholesky factor of T'*T, i.e.,
C              R is lower triangular, so that R*R' = (T*E)'*(T*E)
C              for a permutation matrix E. Optionally, a matrix
C              Q is computed so that Q'*Q = I and T*E = Q*R'.
C
C   task =  6: Compute R, the Cholesky factor of T'*T, where T is a
C              banded block Toeplitz matrix.
C
C   task =  7: Compute R and the least-squares solution of T*X = B for a
C              banded block Toeplitz matrix T and given right hand side
C              matrix B.
C
C   task =  8: Compute R and the minimum norm solution of T'*Y = C for a
C              banded block Toeplitz matrix and given right hand side
C              matrix C.
C
C   task =  9: Compute R, X and Y for a banded block Toeplitz matrix.
C
C   task = 10: Compute the least-squares solution of T*X = B for a block
C              Toeplitz matrix T and a given right hand side matrix B.
C
C   task = 11: Compute the minimum norm solution of T'*Y = C for a given
C              right hand side matrix C.
C
C   task = 12: Compute X and Y.
C
C   task = 13: Compute the matrix-vector products X = T*B.
C
C Input parameters:
C   task  - integer option to determine the computation to perform as
C           described above.
C   TC    - real M*K-by-L matrix, containing the first block column of
C           the block Toeplitz matrix T with K-by-L blocks.
C   TR    - real K-by-N*L matrix, containing the first block row of the
C           block Toeplitz matrix T with K-by-L blocks. If the first
C           block of TR differs from the first block of TC a warning
C           will be displayed that the first block of TC will be used
C           as block diagonal element of the matrix T.
C   B     - real right hand side M*K-by-NCB (task < 13) / N*L-by-NCB
C           (task = 13) matrix.
C   C     - real right hand side N*L-by-NCC matrix.
C   tol   - real tolerance used to estimate the numerical rank of T.
C           (See Section METHOD of the SLICOT Library routine MB02JX,
C           argument TOL1.)
C   m     - integer containing the number of block rows of T.
C   n     - integer containing the number of block columns of T.
C   TCB   - real (ML+1)*K-by-L matrix, containing the leading nonzero
C           blocks of the first block column of the banded block
C           Toeplitz matrix T with K-by-L blocks.
C   TRB   - real K-by-(NU+1)*L matrix, containing the leading nonzero
C           blocks of the first block row of the banded block Toeplitz
C           matrix T with K-by-L blocks. If the first block of TRB
C           differs from the first block of TCB a warning will be
C           displayed that the first block of TCB will be used as block
C           diagonal element of the matrix T.
C
C Output parameters:
C
C   Q     - the M*K-by-RNK orthogonal factor satisfying T = Q*R' /
C           T*E = Q*R', where RNK is the numerical rank of T. Note that
C           if task<>5 then RNK = MIN(M*K,N*L).
C   R     - the N*L-by-RNK Cholesky factor of T'*T / (T*E)'*(T*E)
C           (task < 6),
C           the MIN(ML+NU+1,N)*L-by-MIN(M*K,N*L) matrix containing the
C           Cholesky factor of T'*T in banded storage format
C           (6 <= task <= 9).
C   X     - the N*L-by-NCB least-squares solution of T*X = B (task < 13),
C           the M*K-by-NCB matrix containing the matrix-vector products
C           T*B (task = 13).
C   Y     - the M*K-by-NCC minimum norm solution of T'*Y = C.
C   E     - MIN(M*K,N*L) vector recording the column pivoting performed.
C           If E(j) = k, then the j-th column of T*P was the k-th column
C           of T, where P is the permutation matrix.
C
C Comments:
C   1.    - If only least-squares/minimum norm solutions are desired
C           then task = 6..9 should be used for efficiency.
C   2.    - Note that for the computation of the least-squares/minimum
C           norm solution, a semi-normal equation approach is used which
C           does not yield numerically backward stable solutions.
C           Iterative refinement should be used if improved accuracy
C           is required.
C
C Contributor:
C   D. Kressner, TU Berlin, Aug. 2002.
C
C Revisions:
C   V. Sima, Research Institute for Informatics, Bucharest, Aug. 2002,
C   Apr. 2009, Dec. 2012.
C
C **********************************************************************
C
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C
C     .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C     .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mexEvalString, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsComplex, mxIsNumeric
C
C     .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         JOB
      INTEGER           INFO, K, L, LDB, LDC, LDQ, LDR, LDTC, LDTR,
     $                  LDWORK, LDX, LDY, M, ML, N, NU, RNK, S
C
C     .. Allocatable arrays ..
C     !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      INTEGER, ALLOCATABLE ::          JPVT(:)
      DOUBLE PRECISION, ALLOCATABLE :: B(:,:), C(:,:), DWORK(:), Q(:,:),
     $                                 R(:,:), TC(:,:), TR(:,:), X(:,:),
     $                                 Y(:,:)
C
C     .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      LOGICAL           BADK, BADL, GETX, GETY
      INTEGER           I, IP, IPB, IPC, J, LEN, MKNL, NB, NCB, NCC,
     $                  NCQ, NCR, NCTC, NCTR, NCX, NCY, NLM, NRB, NRC,
     $                  NRQ, NRR, NRTC, NRTR, NRX, NRY, POSX, PT, TASK
      DOUBLE PRECISION  TEMP, TOL1, TOL2
C
C     .. External Functions ..
      INTEGER           ILAENV
      EXTERNAL          ILAENV
C
C     .. External subroutines ..
      EXTERNAL          DGEMM, DLACPY, DLASET, DTBTRS, DTRSM, MB02HD,
     $                  MB02ID, MB02JD, MB02JX, MB02KD
C
C     ..Intrinsic functions..
      INTRINSIC         DBLE, INT, MAX, MIN, MOD
C
C     Check for proper number of arguments.
C
      IF ( NRHS.LT.3 ) THEN
         CALL mexErrMsgTxt
     $        ( 'FSTOEQ requires at least 3 input arguments' )
      ELSE IF ( NLHS.GT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'FSTOEQ requires at most 4 output arguments' )
      END IF
C
C     Check dimensions of input parameters and read/set scalar
C     parameters.
C
      IF ( mxGetM( PRHS(1) ).NE.1 .OR. mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'TASK must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'TASK must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), TEMP, 1 )
      TASK = TEMP
C
      IF ( TASK.LT.1 .OR. TASK.GT.13 ) THEN
         CALL mexErrMsgTxt
     $        ( 'The only admissible values of TASK are 1, 2, ..., 13.')
      END IF
C
      JOB = 'R'
      IF ( TASK.EQ.1 ) THEN
         IF ( NLHS.GT.1 )
     $      JOB = 'Q'
         NLM = 2
      ELSE IF ( TASK.EQ.2 ) THEN
         IF ( NLHS.GT.2 )
     $      JOB = 'Q'
         NLM = 3
      ELSE IF ( TASK.EQ.3 ) THEN
         IF ( NLHS.GT.2 )
     $      JOB = 'Q'
         NLM = 3
      ELSE IF ( TASK.EQ.4 ) THEN
         IF ( NLHS.GT.3 )
     $      JOB = 'Q'
         NLM = 4
      ELSE IF ( TASK.EQ.5 ) THEN
         IF ( NLHS.GT.2 )
     $      JOB = 'Q'
         NLM = 3
      ELSE IF ( TASK.EQ.6 ) THEN
         NLM = 1
      ELSE IF ( TASK.EQ.7 ) THEN
         NLM = 2
      ELSE IF ( TASK.EQ.8 ) THEN
         NLM = 2
      ELSE IF ( TASK.EQ.9 ) THEN
         NLM = 3
      ELSE IF ( TASK.EQ.10 ) THEN
         JOB = 'O'
         NLM = 1
      ELSE IF ( TASK.EQ.11 ) THEN
         JOB = 'U'
         NLM = 1
      ELSE IF ( TASK.EQ.12 ) THEN
         JOB = 'A'
         NLM = 2
      ELSE IF ( TASK.EQ.13 ) THEN
         NLM = 1
      END IF
C
      IF ( NLHS.GT.NLM ) THEN
         WRITE( TEXT, '('' FSTOEQ requires at most '',I4,
     $            '' output arguments'')' ) NLM
         CALL mexErrMsgTxt( TEXT )
      END IF
      IF ( TASK.EQ.1 .AND. NRHS.GT.3 ) THEN
         CALL mexErrMsgTxt
     $           ( 'FSTOEQ requires at most 3 input arguments' )
      ELSE IF ( ( TASK.EQ.2 .OR. TASK.EQ.3 .OR. TASK.EQ.5 .OR.
     $            TASK.EQ.10 .OR. TASK.EQ.11 .OR. TASK.EQ.13 ) .AND.
     $          NRHS.GT.4 ) THEN
         CALL mexErrMsgTxt
     $           ( 'FSTOEQ requires at most 4 input arguments' )
      ELSE IF ( ( TASK.EQ.4 .OR. TASK.EQ.6 .OR. TASK.EQ.12 ) .AND.
     $          NRHS.GT.5 ) THEN
         CALL mexErrMsgTxt
     $           ( 'FSTOEQ requires at most 5 input arguments' )
      ELSE IF ( ( TASK.EQ.7 .OR. TASK.EQ.8 ) .AND. NRHS.GT.6 ) THEN
         CALL mexErrMsgTxt
     $           ( 'FSTOEQ requires at most 6 input arguments' )
      END IF
C
      IF ( ( TASK.EQ.2 .OR. TASK.EQ.3 .OR. TASK.EQ.5 .OR. TASK.EQ.10
     $       .OR. TASK.EQ.11 .OR. TASK.EQ.13 ) .AND.
     $          NRHS.LT.4 ) THEN
         CALL mexErrMsgTxt
     $           ( 'FSTOEQ requires at least 4 input arguments' )
      ELSE IF ( ( TASK.EQ.4 .OR. TASK.EQ.6 .OR. TASK.EQ.12 ) .AND.
     $          NRHS.LT.5 ) THEN
         CALL mexErrMsgTxt
     $           ( 'FSTOEQ requires at least 5 input arguments' )
      ELSE IF ( ( TASK.EQ.7 .OR. TASK.EQ.8 ) .AND. NRHS.LT.6 ) THEN
         CALL mexErrMsgTxt
     $           ( 'FSTOEQ requires at least 6 input arguments' )
      ELSE IF ( TASK.EQ.9 .AND. NRHS.LT.7 ) THEN
         CALL mexErrMsgTxt
     $           ( 'FSTOEQ requires at least 7 input arguments' )
      END IF
C
C     Check integer leading parameters if applicable.
C
      IF ( TASK.GE.6 .AND. TASK.LE.9 ) THEN
         IF ( mxGetM( PRHS(2) ).NE.1 .OR. mxGetN( PRHS(2) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'M must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(2) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'M must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), TEMP, 1 )
         M = TEMP
         IF ( mxGetM( PRHS(3) ).NE.1 .OR. mxGetN( PRHS(3) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'N must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(3) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'N must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), TEMP, 1 )
         N = TEMP
         IP = 4
      ELSE
         IP = 2
      END IF
C
C     Check TC and TR.
C
      NRTC = mxGetM( PRHS(IP) )
      NCTC = mxGetN( PRHS(IP) )
      NRTR = mxGetM( PRHS(IP+1) )
      NCTR = mxGetN( PRHS(IP+1) )
      K = NRTR
      L = NCTC
      IF ( NRTC.LT.0 .OR. L.LT.0 ) THEN
         CALL mexErrMsgTxt( 'TC must be a matrix' )
      ELSE IF ( TASK.GE.6 .AND. TASK.LE.9 .AND. NRTC.EQ.0 ) THEN
         CALL mexErrMsgTxt( 'TC must have at least one row' )
      END IF
      IF ( NCTR.LT.0 .OR. K.LT.0 ) THEN
         CALL mexErrMsgTxt( 'TR must be a matrix' )
      ELSE IF ( TASK.GE.6 .AND. TASK.LE.9 .AND. NRTR.EQ.0 ) THEN
         CALL mexErrMsgTxt( 'TR must have at least one column' )
      END IF
      IF ( K.NE.0 ) THEN
         BADK = MOD( NRTC, K ).NE.0
      ELSE
         BADK = NRTC.NE.0
      END IF
      IF ( L.NE.0 ) THEN
         BADL = MOD( NCTR, L ).NE.0
      ELSE
         BADL = NCTR.NE.0
      END IF
      IF ( BADK .OR. BADL ) THEN
         CALL mexErrMsgTxt( 'Dimensions of TC and TR do not match' )
      END IF
C
      IF ( TASK.GE.6 .AND. TASK.LE.9 ) THEN
         ML = NRTC / K - 1
         IF ( ML.GE.M ) THEN
            CALL mexErrMsgTxt(
     $'The number of block rows of TC must not be greater than M' )
         ELSE IF ( ( ML + 1 )*K.LT.L ) THEN
            CALL mexErrMsgTxt(
     $'The number of columns in TC must not be greater than the number o
     $f nonzero rows' )
         END IF
         NU = NCTR / L - 1
         IF ( NU.GE.N ) THEN
            CALL mexErrMsgTxt(
     $'The number of block columns of TR must not be greater than N' )
         END IF
         IF ( ( M*K.LE.N*L.AND.( ( ML.LT.M - INT( ( M*K - 1 )/L ) - 1 )
     $        .OR.( ML.LT.M - INT( M*K/L ).AND.MOD( M*K, L ).LT.K ) ) )
     $        .OR.( M*K.GE.N*L .AND. ML*K.LT.N*( L - K ) )
     $        .OR.( M + NU )*L.LT.MIN( M*K, N*L ) ) THEN
            CALL mexErrMsgTxt(
     $'The first MIN(M*K,N*L) columns of T must have full rank.' )
         END IF
      ELSE
         IF ( K.NE.0 ) THEN
            M = NRTC / K
         ELSE
            M = NRTC
         END IF
         IF ( L.NE.0 ) THEN
            N = NCTR / L
         ELSE
            N = NCTR
         END IF
      END IF
C
C     Solving least-squares problems using seminormal equations is only
C     possible if T has full column rank, which induces M*K >= N*L.
C
      IF ( ( ( TASK.GE.2 .AND. TASK.LE.4 ) .OR.
     $       ( TASK.GE.7 .AND. TASK.LE.9 ) .OR.
     $       ( TASK.GE.10 .AND. TASK.LE.12 ) ) .AND. M*K.LT.N*L )
     $   CALL mexErrMsgTxt( 'T must have full column rank.' )
      IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'TC must be a real matrix' )
      ELSE IF ( mxIsNumeric( PRHS(IP+1) ).EQ.0 .OR.
     $          mxIsComplex( PRHS(IP+1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'TR must be a real matrix' )
      END IF
C
C     Check B.
C
      GETX = ( TASK.EQ.2 .OR. TASK.EQ.4 .OR. TASK.EQ.7 .OR. TASK.EQ.9
     $         .OR. TASK.EQ.10 .OR. TASK.EQ.12 .OR. TASK.EQ.13 )
      IF ( GETX ) THEN
         IF ( TASK.EQ.7 .OR. TASK.EQ.9 ) THEN
            IPB = 6
         ELSE
            IPB = 4
         END IF
         NRB = mxGetM( PRHS(IPB) )
         NCB = mxGetN( PRHS(IPB) )
         IF ( NRB.LT.0 .OR. NCB.LT.0 )
     $      CALL mexErrMsgTxt( 'B must be a matrix' )
         IF ( ( TASK.EQ.13.AND.NRB.NE.N*L ).OR.
     $        ( TASK.NE.13.AND.NRB.NE.M*K ) )
     $      CALL mexErrMsgTxt( 'Dimensions of T and B do not match.' )
         IF ( mxIsNumeric( PRHS(IPB) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IPB) ).EQ.1 )
     $      CALL mexErrMsgTxt( 'B must be a real matrix' )
      ELSE
         NRB = 0
         NCB = 0
      END IF
C
C     Check C.
C
      GETY = ( TASK.EQ.3 .OR. TASK.EQ.4 .OR. TASK.EQ.8 .OR. TASK.EQ.9
     $         .OR. TASK.EQ.11 .OR. TASK.EQ.12 )
      IF ( GETY ) THEN
         IPC = NRHS
         NRC = mxGetM( PRHS(IPC) )
         NCC = mxGetN( PRHS(IPC) )
         IF ( NRC.LT.0 .OR. NCC.LT.0 )
     $      CALL mexErrMsgTxt( 'C must be a matrix' )
         IF ( NRC.NE.N*L )
     $      CALL mexErrMsgTxt( 'Dimensions of T and C do not match.' )
         IF ( mxIsNumeric( PRHS(IPC) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IPC) ).EQ.1 )
     $      CALL mexErrMsgTxt( 'C must be a real matrix' )
      ELSE
         NRC = 0
         NCC = 0
      END IF
C
C     Check TOL.
C
      IF ( TASK.EQ.5 ) THEN
         IF ( mxGetM( PRHS(4) ).NE.1 .OR. mxGetN( PRHS(4) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'TOL must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(4) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'TOL must be a real scalar' )
         END IF
      END IF
C
C     Determine the lenghts of working arrays.
C
      LDTC = MAX( 1, NRTC )
      LDTR = MAX( 1, NRTR )
      LDB = MAX( 1, NRB )
      LDC = MAX( 1, NRC )
      NCR = 0
      NRR = 0
      LDR = 1
      NCQ = 0
      NRQ = 0
      LDQ = 1
      NCY = 0
      NRY = 0
      LDY = 1
      MKNL = MIN( M*K, N*L )
      IF ( TASK.LE.4 ) THEN
         NRR = N*L
         LDR = MAX( 1, NRR )
         NCR = MKNL
      END IF
      IF ( TASK.EQ.5 ) THEN
         NRR = N*L
         LDR = MAX( 1, NRR )
         NCR = N*L
      END IF
      IF ( TASK.GE.6 .AND. TASK.LE.9 ) THEN
         NRR = MIN( ML + NU + 1, N )*L
         LDR = MAX( 1, NRR )
         NCR = MKNL
      END IF
      IF ( TASK.LE.4 .AND. NLHS.GE.NRHS-1 ) THEN
         NRQ = M*K
         LDQ = MAX( 1, NRQ )
         NCQ = MKNL
      END IF
      IF ( TASK.EQ.5 .AND. NLHS.GE.NRHS-1 ) THEN
         NRQ = M*K
         LDQ = MAX( 1, NRQ )
         NCQ = N*L
      END IF
      IF ( GETX ) THEN
C
C        Create temporary array X to hold intermediate results.
C
         IF ( TASK.LE.12 ) THEN
            NRX = N*L
            LDX = MAX( 1, NRX )
            NCX = NCB
         ELSE IF ( TASK.EQ.13 ) THEN
            NRX = M*K
            LDX = MAX( 1, NRX )
            NCX = NCB
         END IF
      END IF
      IF ( GETY ) THEN
C
C        Create temporary array Y to hold intermediate results.
C
         IF ( TASK.LE.12 ) THEN
            NRY = M*K
            LDY = MAX( 1, NRY )
            NCY = NCC
         END IF
      END IF
C
C     Workspace requirements to enable blocked algorithms.
C
      IF ( TASK.LE.4 ) THEN
         NB = MIN( ILAENV( 1, 'DGELQF', ' ', MKNL + L, L, -1, -1 ), L )
         LDWORK = MAX( 1, ( MAX( M*K, N*L ) + L )*NB
     $                    + ( M*K + N*L )*( L + 2*K )
     $                    + 6*L + M*K + N*L )
      ELSE IF ( TASK.EQ.5 ) THEN
         LDWORK = MAX( 3, ( M*K + ( N - 1 )*L )*( L + 2*K ) + 9*L
     $                    + MAX( M*K, ( N - 1 )*L ) )
      ELSE IF ( TASK.GE.6 .AND. TASK.LE.9 ) THEN
         NB = MIN( ILAENV( 1, 'DGELQF', ' ', ( ML + NU + 1 )*L,
     $                                       L, -1, -1 ), L )
         LDWORK = 1 + MAX( ( ML + NU + 1 )*L*L + ( 2*NU + L )*L*K,
     $                     ( 2*( L + K ) + MAX( NB , 1 ) )*
     $                     ( ML + NU + 1 )*L + 6*L )
      ELSE IF ( TASK.GE.10 .AND. TASK.LE.12 ) THEN
         NB = MIN( ILAENV( 1, 'DGELQF', ' ', MKNL + L, L, -1, -1 ), L )
         LDWORK = ( MAX(M*K,N*L) + L )*NB + 2*N*L*( L + K )
     $            + ( 6 + N )*L + M*K*( L + 1 ) + N*L*MAX( NCB, NCC )
     $            + 1
      ELSE IF ( TASK.EQ.13 ) THEN
         LDWORK = MAX(1, 2*( K*L + K*NCB + L*NCB + 1 )*( M + N ) )
      END IF
C
C     Allocate variable dimension local arrays.
C     !Fortran 90/95
C
      ALLOCATE ( DWORK(LDWORK), TC(LDTC,NCTC), TR(LDTR,NCTR) )
      IF ( TASK.LE.9 )
     $   ALLOCATE ( R(LDR,NCR) )
      IF ( TASK.LE.5 )
     $   ALLOCATE ( Q(LDQ,NCQ) )
      IF ( GETX.OR.GETY )
     $   ALLOCATE ( B(LDB,NCB), C(LDC,NCC) )
      IF ( GETX )
     $   ALLOCATE ( X(LDX,NCX) )
      IF ( ( GETY .AND. TASK.LE.9 ) .OR.
     $     ( TASK.GE.10 .AND. TASK.LE.12 ) )
     $   ALLOCATE ( Y(LDY,NCY) )
      IF ( TASK.EQ.5 )
     $   ALLOCATE ( JPVT(MKNL) )
      CALL DLASET( 'All', NRR, NCR, ZERO, ZERO, R, LDR )
C
C     Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TC, NRTC*NCTC )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP+1) ), TR, NRTR*NCTR )
      IF ( GETX )
     $   CALL mxCopyPtrToReal8( mxGetPr( PRHS(IPB) ), B, NRB*NCB )
      IF ( GETY )
     $   CALL mxCopyPtrToReal8( mxGetPr( PRHS(IPC) ), C, NRC*NCC )
      IF ( TASK.EQ.5 )
     $   CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), TOL1, 1 )
C
C     Check whether the first blocks of TC and TR are equal.
C
      IF ( NRTC.GE.1 .AND. NCTR.GE.1 ) THEN
         DO 20  J = 1, L
            DO 10  I = 1, K
               IF ( TC(I,J).NE.TR(I,J) )
     $            GO TO 30
   10       CONTINUE
   20    CONTINUE
         GO TO 40
   30    CONTINUE
         I = mexEvalString('warning(
     $   ''Block column wins block diagonal conflict in TC/TR.'');');
   40    CONTINUE
      END IF
C
C     Do the actual computations.
C
      IF ( TASK.LE.4 ) THEN
         INFO = 0
         IF ( M*K.GT.0 .AND. N*L.GT.0 ) THEN
            S = ( MKNL + L - 1 ) / L
            CALL MB02JD( JOB, K, L, M, N, 0, S, TC, LDTC,
     $                   TR(1,MIN( NCTR, L+1 )), LDTR, Q, LDQ, R, LDR,
     $                   DWORK, LDWORK, INFO )
         END IF
         IF ( INFO.EQ.0 ) THEN
            IF ( GETX ) THEN
               CALL MB02KD( 'Column', 'Transpose', K, L, M, N, NCB, ONE,
     $                      ZERO, TC, LDTC, TR(1,MIN( NCTR, L+1 )),
     $                      LDTR, B, LDB, X, LDX, DWORK, LDWORK, INFO )
               CALL DTRSM( 'Left', 'Lower', 'No Transpose',
     $                     'NoUnitDiag', N*L, NCB, ONE, R, LDR, X, LDX )
               CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NoUnitDiag',
     $                     N*L, NCB, ONE, R, LDR, X, LDX )
            END IF
            IF ( GETY ) THEN
               CALL DTRSM( 'Left', 'Lower', 'No Transpose',
     $                     'NoUnitDiag', N*L, NCC, ONE, R, LDR, C, LDC )
               CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NoUnitDiag',
     $                      N*L, NCC, ONE, R, LDR, C, LDC )
               CALL MB02KD( 'Column', 'No Transpose', K, L, M, N, NCC,
     $                      ONE, ZERO, TC, LDTC, TR(1,MIN( NCTR, L+1 )),
     $                      LDTR, C, LDC, Y, LDY, DWORK, LDWORK, INFO )
            END IF
         END IF
      ELSE IF ( TASK.EQ.5 ) THEN
         TOL2 = -1.0D0
         CALL MB02JX( JOB, K, L, M, N, TC, LDTC, TR(1,MIN( NCTR, L+1 )),
     $                LDTR, RNK, Q, LDQ, R, LDR, JPVT, TOL1, TOL2,
     $                DWORK, LDWORK, INFO )
      ELSE IF ( TASK.GE.6 .AND. TASK.LE.9 ) THEN
         S = ( MKNL + L - 1 ) / L
         CALL MB02HD( 'No Structure', K, L, M, ML, N, NU, 0, S, TC,
     $                LDTC, TR(1,MIN( NCTR, L+1 )), LDTR, R, LDR, DWORK,
     $                LDWORK, INFO )
         IF ( INFO.EQ.0 ) THEN
            IF ( GETX.OR.GETY ) THEN
C
C              Put a flipped copy of TC in DWORK.
C
               PT = ML*K + 1
               DO 50  I = 1, ( ML + 1 )*K*L, K*L
                  CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I),
     $                         K )
                  PT = PT - K
   50          CONTINUE
            END IF
            IF ( GETX .AND. NCB.GT.0 ) THEN
C
C              Overwrite X with T'*B.
C
               PT = ML*K*L + 1
               LEN = NU*L
               CALL DLASET( 'All', N*L, NCB, ZERO, ZERO, X, LDX )
               DO 60  I = 1, M
                  POSX = MAX(1,(I-ML-1)*L+1)
                  IF ( POSX.LE.N*L ) THEN
                     CALL DGEMM( 'Transpose', 'No Transpose',
     $                           MIN( MIN(I,ML+1)*L, N*L-POSX+1 ), NCB,
     $                           K, ONE, DWORK(PT), K, B((I-1)*K + 1,1),
     $                           LDB, ONE, X(POSX,1), LDX )
                  END IF
                  IF ( LEN.GT.0 ) THEN
                     CALL DGEMM( 'Transpose', 'No Transpose', LEN, NCB,
     $                           K, ONE, TR(1,L+1), LDTR,
     $                           B((I-1)*K + 1,1), LDB, ONE, X(I*L+1,1),
     $                           LDX )
                  END IF
                  IF ( PT.GT.1 )
     $               PT = PT - K*L
                  IF ( I.GE.N-NU )
     $               LEN = LEN - L
   60          CONTINUE
               CALL DTBTRS( 'Lower', 'No Transpose', 'NoUnitDiag', N*L,
     $                      MIN( ML + NU + 1, N )*L - 1, NCB, R, LDR, X,
     $                      LDX, INFO )
               CALL DTBTRS( 'Lower', 'Transpose', 'NoUnitDiag', N*L,
     $                      MIN( ML + NU + 1, N )*L - 1, NCB, R, LDR, X,
     $                      LDX, INFO )
            END IF
C
            IF ( GETY .AND. NCC.GT.0 ) THEN
               CALL DTBTRS( 'Lower', 'No Transpose', 'NoUnitDiag', N*L,
     $                      MIN( ML + NU + 1, N )*L - 1, NCC, R, LDR, C,
     $                      LDC, INFO )
               CALL DTBTRS( 'Lower', 'Transpose', 'NoUnitDiag', N*L,
     $                      MIN( ML + NU + 1, N )*L - 1, NCC, R, LDR, C,
     $                      LDC, INFO )
C
C              Overwrite Y with T*C.
C
               PT = ML*K*L + 1
               LEN = NU*L
               CALL DLASET( 'All', M*K, NCC, ZERO, ZERO, Y, LDY )
               DO 70  I = 1, M
                  POSX = MAX(1,(I-ML-1)*L+1)
                  IF ( POSX.LE.N*L ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', K, NCC,
     $                           MIN( MIN(I,ML+1)*L, N*L-POSX+1 ), ONE,
     $                           DWORK(PT), K, C(POSX,1), LDC,
     $                           ONE, Y((I-1)*K + 1,1), LDY )
                  END IF
                  IF ( LEN.GT.0 ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', K, NCC,
     $                           LEN, ONE, TR(1,L+1), LDTR, C(I*L+1,1),
     $                           LDC, ONE, Y((I-1)*K + 1,1), LDY )
                  END IF
                  IF ( PT.GT.1 )
     $               PT = PT - K*L
                  IF ( I.GE.N-NU )
     $               LEN = LEN - L
   70          CONTINUE
            END IF
         END IF
      ELSE IF ( TASK.GE.10 .AND. TASK.LE.12 ) THEN
         IF ( GETY )
     $      CALL DLACPY( 'All', NRC, NCC, C, LDC, Y, LDY )
         CALL MB02ID( JOB, K, L, M, N, NCB, NCC, TC, LDTC,
     $                TR(1,MIN( NCTR, L+1 )), LDTR, B, LDB, Y, LDY,
     $                DWORK, LDWORK, INFO )
         IF ( INFO.EQ.0 ) THEN
            IF ( GETX )
     $         CALL DLACPY( 'All', NRX, NCX, B, LDB, X, LDX )
         END IF
      ELSE IF ( TASK.EQ.13 ) THEN
         CALL MB02KD( 'Column', 'No Transpose', K, L, M, N, NCB, ONE,
     $                ZERO, TC, LDTC, TR(1,MIN( NCTR, L+1 )), LDTR, B,
     $                LDB, X, LDX, DWORK, LDWORK, INFO )
      END IF
C
C     Copy output to MATLAB workspace.
C
      IP = 1
      IF ( INFO.EQ.0 ) THEN
         IF ( TASK.LE.4 .AND. NLHS.GE.NRHS-1 ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( NRQ, NCQ, 0 )
            CALL mxCopyReal8ToPtr( Q, mxGetPr( PLHS(IP) ), NRQ*NCQ )
            IP = IP + 1
         END IF
         IF ( TASK.EQ.5 .AND. NLHS.GE.NRHS-1 ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( NRQ, RNK, 0 )
            CALL mxCopyReal8ToPtr( Q, mxGetPr( PLHS(IP) ), NRQ*RNK )
            IP = IP + 1
         END IF
         IF ( TASK.LE.9 .AND. TASK.NE.5 ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( NRR, NCR, 0 )
            IF ( MIN( NRR, NCR-1 ).GE.1 .AND. TASK.LE.4 ) THEN
               CALL DLASET( 'Upper part', NRR-1, NCR-1, ZERO, ZERO,
     $                      R(1,2), LDR )
            END IF
            CALL mxCopyReal8ToPtr( R, mxGetPr( PLHS(IP) ), NRR*NCR )
            IP = IP + 1
         END IF
         IF ( TASK.EQ.5 ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( NRR, RNK, 0 )
            CALL mxCopyReal8ToPtr( R, mxGetPr( PLHS(IP) ), NRR*RNK )
            IP = IP + 1
         END IF
         IF ( GETX .AND. NLHS.GE.IP ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( NRX, NCX, 0 )
            CALL mxCopyReal8ToPtr( X, mxGetPr( PLHS(IP) ), NRX*NCX )
            IP = IP + 1
         END IF
         IF ( GETY .AND. NLHS.GE.IP ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( NRY, NCY, 0 )
            CALL mxCopyReal8ToPtr( Y, mxGetPr( PLHS(IP) ), NRY*NCY )
            IP = IP + 1
         END IF
         IF ( TASK.EQ.5 .AND. NLHS.GE.IP ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( 1, MKNL, 0 )
            DO 80 I = 1, MKNL
               DWORK(I) = DBLE( JPVT(I) )
   80       CONTINUE
            CALL mxCopyReal8ToPtr( DWORK, mxGetPr( PLHS(IP) ), MKNL )
            IP = IP + 1
         END IF
      END IF
C
C     Deallocate local arrays.
C     !Fortran 90/95
C
      DEALLOCATE( DWORK, TC, TR )
      IF ( TASK.LE.9 )
     $   DEALLOCATE( R )
      IF ( TASK.LE.5 )
     $   DEALLOCATE( Q )
      IF ( GETX.OR.GETY )
     $   DEALLOCATE( B, C )
      IF ( GETX )
     $   DEALLOCATE( X )
      IF ( ( GETY .AND. TASK.LE.9 ) .OR.
     $     ( TASK.GE.10 .AND. TASK.LE.12 ) )
     $   DEALLOCATE( Y )
      IF ( TASK.EQ.5 )
     $   DEALLOCATE( JPVT )
C
C     Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
         IF ( TASK.LE.4 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM MB02JD'')' )
     $             INFO
         ELSE IF ( TASK.LE.5 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM MB02JX'')' )
     $             INFO
         ELSE IF ( TASK.LE.9 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM MB02HD'')' )
     $             INFO
         ELSE IF ( TASK.LE.12 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM MB02ID'')' )
     $             INFO
         ELSE IF ( TASK.EQ.13 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM MB02KD'')' )
     $             INFO
         END IF
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of FSTOEQ ***
      END


      SUBROUTINE FITPAR (MSGTXT, CHWRAT, PHWRAT, LINSIZ)

C  FITPAR calculates a reasonably good line size (number of characters)
C  for fitting MSGTXT into a rectangular area.

C  Input parameters:
C    MSGTXT : Text to be fit
C    CHWRAT : Desired height/width ratio of each character
C    PHWRAT : Height/width ratio of area to hold paragraph
C  Output parameters:
C    LINSIZ : Number of characters per line

C  let:
C    #chars = #lines * chars-per-line
C    char-height = phwrat/#lines
C    char-width  = 1/chars-per-line
C    char-height/char-width = CHWRAT
C  then
C    chars-per-line = sqrt(CHWRAT*#chars / phwrat)

      INTEGER    LINSIZ, LENMSG, ITRIM, MINLIN, ERR, NUMLIN,LINPOS(300)
      INTEGER    SIZSAV

      REAL       CHWRAT, PHWRAT, CHHT1,CHHT2, LOGHW

      CHARACTER  MSGTXT*(*)

      LENMSG = ITRIM(MSGTXT)
C  3 is fudge factor, because there won't be perfect packing.
      LINSIZ = SQRT(CHWRAT*LENMSG/PHWRAT) + 3
C  15 is minimum tolerable line-length
      MINLIN = 15
      LINSIZ = MAX (MINLIN,LINSIZ)
C  Generate line-breaks for LINSIZ:
      CALL LINBRK (MSGTXT, LINSIZ, ERR, NUMLIN, LINPOS)
C  get resulting character height
      CALL SCAPAR (LINSIZ,CHWRAT,PHWRAT,NUMLIN,LINPOS, CHHT1,LOGHW)

C  alter LINSIZ for attempted better fit
      SIZSAV = LINSIZ
      IF (LOGHW .GT. PHWRAT .AND. NUMLIN .EQ. 2) THEN
C  2-line message is too tall ... force to 1 line
         LINSIZ = LENMSG
      ELSE
C  try to converge on proper height/width ratio for paragraph
         LINSIZ = LINSIZ * LOGHW / PHWRAT
      ENDIF

      LINSIZ = MAX (MINLIN,LINSIZ)
C  Generate line-breaks for 2nd LINSIZ:
      CALL LINBRK (MSGTXT, LINSIZ, ERR, NUMLIN, LINPOS)
C  get 2nd resulting character height
      CALL SCAPAR (LINSIZ,CHWRAT,PHWRAT,NUMLIN,LINPOS, CHHT2,LOGHW)

C  If 2nd attempt generated smaller characters, re-set to 1st,
C  otherwise leave LINSIZ as is.
      IF (CHHT1 .GT. CHHT2) LINSIZ = SIZSAV

      END


MODULE A

  USE precise, ONLY : defaultp
  USE io
  USE fourthconst
  USE fifthpanel

!! variable declarations

  IMPLICIT NONE    ! makes sure the compiler complains about
                   ! undeclared variables
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp

CONTAINS

  FUNCTION hsinfluence( fieldpoint, center, area, coordsys, cornerslocal) RESULT (vel)
    !
    ! Function to compute the del dot phi
    ! It will return a 3D velocity vector
    ! Equivlent to the far approximation
    ! of the velocity induced by a panel
    ! source q on a point p.

    !Note: area is not used!

    INTEGER :: i,j,k
    REAL(wp), DIMENSION(3) :: vel
    REAL(wp), DIMENSION(3) :: dphi           ! Page 3 of the notes
    REAL(wp), DIMENSION(3) :: fieldpoint
    REAL(wp), DIMENSION(3) :: center
    REAL(wp) :: area
    REAL(wp), DIMENSION(3,3) :: coordsys     ! local coordinate system
    REAL(wp), DIMENSION(2,4) :: cornerslocal ! quad corners in local coordinate system
    REAL(wp), DIMENSION(3) :: plocal         ! fieldpoint "p" in local coordinate system
    REAL(wp), DIMENSION(3) :: vellocal

    REAL(wp), DIMENSION(4) :: d,e,h,m,r
    real(wp) :: zero

    integer, dimension(4) :: ip1 = (/ 2, 3, 4, 1 /)

    ! transfer point p into the local coordinate system:
    plocal = MATMUL((TRANSPOSE(coordsys)),fieldpoint-center)

    !write(6,*) 'center', center
    !write(6,*) 'plocal', plocal
    zero=0.

    dphi=zero

    Do, k=1,4

       !write(6,*)'cornerslocal', cornerslocal(:,k)
       d(k) = sqrt((cornerslocal(1,ip1(k))-cornerslocal(1,k))**2.+(cornerslocal(2,ip1(k))-cornerslocal(2,k))**2.)
       e(k) = (plocal(1)-cornerslocal(1,k))**2. + plocal(3)**2.
       h(k) = ((plocal(1)-cornerslocal(1,k))*(plocal(2)-cornerslocal(2,k)))
       m(k) = (((cornerslocal(2,ip1(k)))-(cornerslocal(2,k))) /(cornerslocal(1,ip1(k))-(cornerslocal(1,k))))
       r(k) = sqrt(((plocal(1))-(cornerslocal(1,k)))**2.+((plocal(2))-(cornerslocal(2,k)))**2.+(plocal(3))**2.)

       !write(6,*) 'd(k)', d(k)
       !write(6,*) 'e(k)', e(k)
       !write(6,*) 'h(k)', h(k)
       !write(6,*) 'm(k)', m(k)
       !write(6,*) 'r(k)', r(k)

     end do

     dphi(:)=0.

     do, k=1,4

       !If (abs(d(k))> 0.000001) then
       If (abs(d(k))> 0.000000001) then

          dphi(1) = dphi(1)+((((cornerslocal(2,ip1(k)))-(cornerslocal(2,k)))/d(k))*log((r(k)+r(ip1(k))-d(k))/(r(k)+r(ip1(k))+d(k))))

          dphi(2) = dphi(2)-(cornerslocal(1,ip1(k))-(cornerslocal(1,k)))/d(k)*log((r(k)+r(ip1(k))-d(k))/(r(k)+r(ip1(k))+d(k)))

          dphi(3) = dphi(3)+(atan((m(k)*e(k)-h(k))/(plocal(3)*r(k)))- atan((m(k)*e(ip1(k))-h(ip1(k)))/(plocal(3)*r(ip1(k)))))

          !write(6,*) 'k', k

       End if

    End do
    dphi(1)=-1./(4.*pi)*dphi(1)
    dphi(2)=-1./(4.*pi)*dphi(2)
    dphi(3)=-1./(4.*pi)*dphi(3)

    !write(6,*) 'dphi(1)', dphi(1)
    !write(6,*) 'dphi(2)', dphi(2)
    !write(6,*) 'dphi(3)', dphi(3)

    vellocal=(/ dphi(1),dphi(2),dphi(3) /)
    !write(6,*) 'vellocal'
    !write(6,'(3D16.8)')  vellocal

     vel=MATMUL(coordsys,vellocal)
     !if ( (sum(vel(:)**2)) > 9999.) then
     !   vel = (/0.,0.,0./)
     !end if

     !write(6,*) 'vel'
     !write (6,'(3D16.8)') vel
     !write(6,*) ''

   END FUNCTION hsinfluence

!!
!!*****************************************************************************************************************************************
!!

  FUNCTION phixxinfluenceOLD( fieldpoint, center, area, coordsys, cornerslocal) RESULT (hessglobal)
    !
    ! Function to compute the (del outer del) dot phi
    ! It will return a 3D velocity vector
    ! Equivlent to the far approximation
    ! of the velocity induced by a panel
    ! source q on a point p.
    INTEGER :: i,j,k
    REAL(wp), DIMENSION(3)   :: vel
    REAL(wp), DIMENSION(3,3) :: ddphi           ! Page 4 of the notes
    REAL(wp), DIMENSION(3,3) :: hessglobal
    REAL(wp), DIMENSION(3)   :: fieldpoint
    REAL(wp), DIMENSION(3)   :: center
    REAL(wp)                 :: area, Laplace
    REAL(wp), DIMENSION(3,3) :: coordsys        ! local coordinate system
    REAL(wp), DIMENSION(2,4) :: cornerslocal    ! quad corners in local coordinate system
    REAL(wp), DIMENSION(3)   :: plocal          ! fieldpoint "p" in local coordinate system
    REAL(wp), DIMENSION(3)   :: vellocal
    REAL(wp) :: zero
    REAL(wp), DIMENSION(4)   :: d,e,h,m,r

    integer, dimension(4)    :: ip1 = (/ 2, 3, 4, 1 /)

    plocal = MATMUL((TRANSPOSE(coordsys)),fieldpoint-center)

    zero = 0.

    Do, k=1,4

       !write(6,*)'cornerslocal', cornerslocal(:,k)
       d(k) = sqrt((cornerslocal(1,ip1(k))-cornerslocal(1,k))**2.+(cornerslocal(2,ip1(k))-cornerslocal(2,k))**2.)
       e(k) = (plocal(1)-cornerslocal(1,k))**2. + plocal(3)**2.
       h(k) = ((plocal(1)-cornerslocal(1,k))*(plocal(2)-cornerslocal(2,k)))
       m(k) = (((cornerslocal(2,ip1(k)))-(cornerslocal(2,k))) /(cornerslocal(1,ip1(k))-(cornerslocal(1,k))))
       r(k) = sqrt(((plocal(1))-(cornerslocal(1,k)))**2.+((plocal(2))-(cornerslocal(2,k)))**2.+(plocal(3))**2.)

     end do

     ddphi=zero

     do, k=1,4

       !If (abs(d(k))> 0.000001) then
        If (abs(d(k))> 0.000000001) then

          ddphi(1,1) =ddphi(1,1) + ((2.*(cornerslocal(2,ip1(k)) - cornerslocal(2,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2))  *&
               ((plocal(1)-cornerslocal(1,k))/r(k)+(plocal(1)-cornerslocal(1,ip1(k)))/r(ip1(K)) ))

          ddphi(1,2) =ddphi(1,2)+ ((-2.*(cornerslocal(1,ip1(k)) - cornerslocal(1,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2)) *&
               ((plocal(1)-cornerslocal(1,k))/r(k)+(plocal(1)-cornerslocal(1,ip1(k)))/r(ip1(K)) ))

          ddphi(1,3) =ddphi(1,3)+(( plocal(3) * (cornerslocal(2,ip1(k)) - cornerslocal(2,k)) * (r(k) + r(ip1(k))))  /&
               ((r(k)*r(ip1(k)))* ( r(k)*r(ip1(k)) + ((plocal(1)-cornerslocal(1,k))*(plocal(1)-cornerslocal(1,ip1(K)))) &
               +((plocal(2)-cornerslocal(2,k))*(plocal(2)-cornerslocal(2,ip1(k))))  + (plocal(3)**2.)    )))

          ddphi(2,1) = ddphi(2,1)+((2.*(cornerslocal(2,ip1(k)) - cornerslocal(2,k))/( (r(k)+r(ip1(K)))**2. - d(k)**2.)) *&
               ((plocal(2)-cornerslocal(2,k))/r(k)+(plocal(2)-cornerslocal(2,ip1(k)))/r(ip1(K)) ))

          ddphi(2,2) =ddphi(2,2)+((-2.*(cornerslocal(1,ip1(k)) - cornerslocal(1,k))/( (r(k)+r(ip1(K)))**2. - d(k)**2.)) *&
               ((plocal(2)-cornerslocal(2,k))/r(k)+(plocal(2)-cornerslocal(2,ip1(k)))/r(ip1(K)) ))

          ddphi(2,3) =ddphi(2,3)+  ( ((-plocal(3) * (cornerslocal(1,ip1(k)) - cornerslocal(1,k))) * (r(k) + r(ip1(k))))  /&
               ((r(k)*r(ip1(k)))* ( r(k)*r(ip1(k)) + ((plocal(1)-cornerslocal(1,k))*(plocal(1)-cornerslocal(1,ip1(K)))) &
               +((plocal(2)-cornerslocal(2,k))*(plocal(2)-cornerslocal(2,ip1(k))))  + (plocal(3)**2.)    )))

          ddphi(3,1) = ddphi(3,1) + ( 2.*(cornerslocal(2,ip1(k))-cornerslocal(2,k))*( (plocal(3)/r(k))+(plocal(3)/r(ip1(k))) )&
               /( ((r(k)+r(ip1(k)) )**2.) - (d(k)**2.)) )

          ddphi(3,2) =ddphi(3,2) + (-2.*(cornerslocal(1,ip1(k)) - cornerslocal(1,k)) *(( plocal(3)/r(k)) + (plocal(3)/r(ip1(k))) )/&
               ( ((r(k)+r(ip1(K)))**2.) - (d(k)**2.) )   )

          ddphi(3,3) =ddphi(3,3) +   ((  ((plocal(1)-cornerslocal(1,k)) * (plocal(2)-cornerslocal(2,ip1(k))) &
               - ((plocal(1)-cornerslocal(1,ip1(k)))*(plocal(2)-cornerslocal(2,k))))  * (r(k)+r(ip1(k))))  &
               / ((r(k)*r(ip1(k)))* ( r(k)*r(ip1(k)) + ((plocal(1)-cornerslocal(1,k))*(plocal(1)-cornerslocal(1,ip1(K)))) &
               +((plocal(2)-cornerslocal(2,k))*(plocal(2)-cornerslocal(2,ip1(k))))  + (plocal(3)**2.)    )) )

          !ddphi(1,1) =ddphi(1,1) + ((2.*(cornerslocal(2,ip1(k)) - cornerslocal(2,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2))  *&
          !     ((plocal(1)-cornerslocal(1,k))/r(k)+(plocal(1)-cornerslocal(1,ip1(k)))/r(ip1(K)) ))

          !ddphi(1,2) =ddphi(1,2)+ ((-2.*(cornerslocal(1,ip1(k)) - cornerslocal(1,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2)) *&
          !     ((plocal(1)-cornerslocal(1,k))/r(k)+(plocal(1)-cornerslocal(1,ip1(k)))/r(ip1(K)) ))

          !ddphi(1,3) =ddphi(1,3)+(( plocal(3) * (cornerslocal(2,ip1(k)) - cornerslocal(2,k)) * (r(k) + r(ip1(k))))  /&
          !     ((r(k)*r(ip1(k)))* ( r(k)*r(ip1(k)) + ((plocal(1)-cornerslocal(1,k))*(plocal(1)-cornerslocal(1,ip1(K)))) &
          !     +((plocal(2)-cornerslocal(2,k))*(plocal(2)-cornerslocal(2,ip1(k))))  + (plocal(3)**2)    )))

       End if

    End do

    ddphi = -1./(4.*pi) * ddphi

    hessglobal = Matmul(Matmul(coordsys,ddphi),Transpose(coordsys))

!!$    write(6,*) ''
!!$    write(6,*) 'The Hessian'
!!$    write(6,*) ddphi(1,1), ddphi(1,2), ddphi(1,3)
!!$    write(6,*) ddphi(2,1), ddphi(2,2), ddphi(2,3)
!!$    write(6,*) ddphi(3,1), ddphi(3,2), ddphi(3,3)

!!$    write(6,*) ''
!!$    Laplace = ddphi(1,1)+ddphi(2,2)+ddphi(3,3)
!!$    write(6,*) 'The Laplacian is...'
!!$    write(6,*) Laplace

!!$    write(6,*) ''
!!$    write(6,*) 'Check the Hessian'
!!$    write(6,*) ddphi(1,2), ddphi(2,1)
!!$    write(6,*) ddphi(1,3), ddphi(3,1)
!!$    write(6,*) ddphi(2,3), ddphi(3,2)

    !vellocal=(/ dphi(1),dphi(2),dphi(3) /)
    !write(6,*) 'vellocal'
    !write(6,'(3D16.8)')  vellocal

     !vel=MATMUL(coordsys,vellocal)
     !if ( (sum(vel(:)**2)) > 9999.) then
     !   vel = (/0.,0.,0./)
     !end if

     !write(6,*) 'vel'
     !write (6,'(3D16.8)') vel
     !write(6,*) ''

   END FUNCTION phixxinfluenceOLD

   FUNCTION phixxinfluence (point, center, area, coordsys, qlocal) result (hessmatrix)

     implicit none
     ! fuildpoint, center of panel, result
       real(8),dimension(3) :: point, center, Plocal
     ! matrix T with voectors i, j, k for panel
       real(8),dimension(3,3) :: coordsys
     ! panel comes in local coordinates
       real(8),dimension(2,4) :: qlocal
     ! the x and y value
       real(8) :: area
       real(8), dimension (4) :: corner_x ! the x component of each corner
       real(8), dimension (4) :: corner_y ! the y component of each corner
     ! pi
       real(8), parameter :: pi= 4.d0*datan(1.d0)
     ! name k+1
       integer, dimension(4), parameter :: kp1 = (/ 2, 3, 4, 1 /)
       integer :: k
       real(8), dimension (4) :: d ! length of panel side k between point q_k and q_k+1
       real(8), dimension (4) :: m ! ratios of y and x coordinate difference of panel corners (local coordinates)
       real(8), dimension (4) :: r ! distance from field point to the 4 corners
       real(8), dimension (4) :: e
       real(8), dimension (4) :: h
       real(8), dimension (4) :: rho
       real(8), dimension (4) :: lambda
       real(8) :: phi_xx, phi_yx, phi_zx, phi_xy
       real(8) :: phi_yy, phi_zy, phi_xz, phi_yz, phi_zz
       real(8), dimension (3,3) :: hesslocal ! hessian matrix in local coordinate
       real(8), dimension (3,3) :: hessmatrix !hessian matrix in global coordinate

     ! Transfer the point P into the local coordinate system
       Plocal = matmul( transpose( coordsys), point-center)

      ! x value
      corner_x= qlocal(1,:)
      ! y value
      corner_y= qlocal(2,:)

      ! the length of panel side k between point q(k) and q(k+1)
      do k = 1,4
         d(k) = dsqrt((corner_x(kp1(k))-corner_x(k))**2 &
                + (corner_y(kp1(k))-corner_y(k))**2)

         ! ratio of y and x coordinate differences of panel corners
         if (d(k)==0) then
              m(k)= 0
         else
              m(k) = (corner_y(kp1(k))-corner_y(k)) &
                      & / (corner_x(kp1(k))-corner_x(k))
         end if
      end do

      do k = 1,4
         ! distance of field points form corner k
         ! x is Plocal(1)
         ! y is Plocal(2)
         ! z is Plocal(3)
         r(k)   = dsqrt( (Plocal(1)-corner_x(k))**2 &
                   & + (Plocal(2)-corner_y(k))**2 &
                   & + Plocal(3)**2)
         e(k)   = (Plocal(1)-corner_x(k))**2 + (Plocal(3))**2
         h(k)   = (Plocal(1)-corner_x(k)) * (Plocal(2)-corner_y(k))
      end do

      do k = 1,4
        rho(k) = r(k)*r(kp1(k)) + &
               & (Plocal(1)-corner_x(k))*(Plocal(1)- corner_x(kp1(k)))&
               & + (Plocal(2)-corner_y(k))*(Plocal(2)-corner_y(kp1(k)))&
               & + Plocal(3)**2
       lambda(k) = ((Plocal(1)-corner_x(k))*(Plocal(2)-corner_y(kp1(k)))&
                & - (Plocal(1) - corner_x(kp1(k)))*(Plocal(2)-corner_y(k)))
      end do

      ! the starting value of the second order dericatives
       phi_xx = 0.
       phi_xy = 0.
       phi_xz = 0.
       phi_yx = 0.
       phi_yy = 0.
       phi_yz = 0.
       phi_zx = 0.
       phi_zy = 0.
       phi_zz = 0.

       do k = 1,4
         phi_xx = phi_xx + 2*(corner_y(kp1(k))-corner_y(k)) / &
                & ((r(k)+r(kp1(k)))**2-d(k)**2)      &
                & *((Plocal(1)-corner_x(k))/r(k) +   &
                & (Plocal(1)-corner_x(kp1(k)))/r(kp1(k)))
       end do
       phi_xx = -1./(4.*pi)*phi_xx

       do k= 1,4
         phi_yx = phi_yx + (-2)*(corner_x(kp1(k))-corner_x(k)) &
                & / ((r(k)+r(kp1(k)))**2-d(k)**2)   &
                & *((Plocal(1)-corner_x(k))/r(k)    &
                & + (Plocal(1)-corner_x(kp1(k)))/r(kp1(k)))
       end do
       phi_yx = -1./(4.*pi)*phi_yx

       do k = 1,4
         phi_zx = phi_zx + Plocal(3)*(corner_y(kp1(k))-corner_y(k))&
               & *(r(k)+r(kp1(k)))/(r(k)*r(kp1(k))) / rho(k)
       end do
       phi_zx = -1./(4.*pi)*phi_zx

       do k = 1,4
         phi_xy = phi_xy + 2*(corner_y(kp1(k))-corner_y(k)) &
                & /( (r(k)+r(kp1(k)))**2-d(k)**2 )          &
                & *( (Plocal(2)-corner_y(k))/r(k) &
                & +(Plocal(2)-corner_y(kp1(k)))/r(kp1(k)) )
       end do
       phi_xy = -1./(4.*pi)*phi_xy

       do k = 1,4
         phi_yy = phi_yy + (-2*(corner_x(kp1(k))-corner_x(k))) &
                & /( (r(k)+r(kp1(k)))**2-d(k)**2 )             &
                & *( (Plocal(2)-corner_y(k))/r(k)              &
                & + (Plocal(2)-corner_y(kp1(k)))/r(kp1(k)) )
       end do
       phi_yy = -1./(4.*pi)*phi_yy

       do k = 1,4
         phi_zy = phi_zy - Plocal(3)*(corner_x(kp1(k))-corner_x(k)) &
                & *(r(k)+r(kp1(k)))/(r(k)*r(kp1(k))) / rho(k)
       end do
       phi_zy = -1./(4.*pi)*phi_zy

       do k = 1,4
         phi_xz = phi_xz + 2*(corner_y(kp1(k))-corner_y(k)) &
                & /( (r(k)+r(kp1(k)))**2-d(k)**2 )          &
                & *( Plocal(3)/r(k) + Plocal(3)/r(kp1(k)) )
       end do
       phi_xz = -1./(4.*pi)*phi_xz

       do k = 1,4
         phi_yz = phi_yz - 2*(corner_x(kp1(k))-corner_x(k)) &
                & /( (r(k)+r(kp1(k)))**2-d(k)**2 )          &
                & *( Plocal(3)/r(k)+Plocal(3)/r(kp1(k)) )
       end do
       phi_yz = -1./(4.*pi)*phi_yz

       do k = 1,4
         phi_zz = phi_zz+lambda(k)*(r(k)+r(kp1(k))) &
                & /(r(k)*r(kp1(k))*rho(k))
       end do
       phi_zz = -1./(4.*pi)*phi_zz

       hesslocal(1,1) = phi_xx
       hesslocal(1,2) = phi_xy
       hesslocal(1,3) = phi_xz
       hesslocal(2,1) = phi_yx
       hesslocal(2,2) = phi_yy
       hesslocal(2,3) = phi_yz
       hesslocal(3,1) = phi_zx
       hesslocal(3,2) = phi_zy
       hesslocal(3,3) = phi_zz

       hessmatrix = matmul(coordsys,hesslocal)
       hessmatrix = matmul(hessmatrix,transpose(coordsys))

       ! return to caller
       return

  END FUNCTION phixxinfluence

END MODULE A


      subroutine wshscs(peaksu,ieltmp,nh,qpmax)
c
c     + + + PURPOSE + + +
c
c     SR WSHSCS calculates SCS Triangular Hydrographs when
c     surface flows from hillslopes, channels and impoundments
c     merge onto a channel or into an impoundment. The hydrographs
c     are then superimposed to find a single peak runoff rate.
c
c     Called from: SR WSHPEK
c     Author(s): Ascough II
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
      include 'pmxelm.inc'
      include 'pmxhil.inc'
      include 'pmxpln.inc'
      include 'pmxprt.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real peaksu(3), qpmax
      integer ieltmp(3), nh
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     peaksu -
c     qpmax  -
c     ieltmp -
c     nh     -
c
c     + + + COMMON BLOCKS + + +
c
      include 'chydrol.inc'
      include 'cstore.inc'
c
c     + + + LOCAL VARIABLES + + +
c
      real delta1, delta2, h(3,1440), hcomp(1440), htot, tend(3),
     1    timeb(3), timep(3), tmax
      integer i, j, k, ntime
c
c     + + + LOCAL DEFINITIONS + + +
c
c     delta1 -
c     delta2 -
c     h(10,1440)  -
c     hcomp(1440) -
c     htot -
c     tend(10)    -
c     timeb(10)   -
c     timep(10)   -
c     tmax        -
c     i -
c     j -
c     k -
c     ntime -
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      tmax = 0.0
c
      do 10 i = 1, nh
c
c       calculate the base time (mins) for the SCS Triangular
c       Hydrographs
c
c       WEPP Units   --> Area (m^2), Runoff (m), Peak Runoff (m^3/s)
c       SCS TH units --> Area (km^2), Runoff (mm), Peak Runoff (m^3/s),
c       (33.333 = 12.4844 * 2.67 from SCS TH Equation)
c
        timeb(i) = (33.333*(wsarea(ieltmp(i))/1.0e6)*(
     1      rofave(ieltmp(i))*1.0e3)) / peaksu(i)
c
        if (timeb(i).gt.tmax) tmax = timeb(i)
c
c       calculate the time to peak (mins)
c
        timep(i) = timeb(i) / 2.67
c
        tend(i) = timeb(i)
c
   10 continue
c
c     if tmax is greater than one day then limit the hydrograph
c     calculations
c
      if (tmax.gt.1440.0) tmax = 1440.0
      ntime = int(tmax)
c
c     calculate time-discharge relationship for each hydrograph
c
      do 30 j = 1, ntime
        do 20 i = 1, nh
          h(i,j) = 0.0
   20   continue
        hcomp(j) = 0.0
   30 continue
c
      do 50 i = 1, nh
c
        delta1 = peaksu(i) / timep(i)
        delta2 = peaksu(i) / (timeb(i)-timep(i))
c
        k = 0
c
        do 40 j = 1, ntime
c
          if (float(j).gt.tend(i)) then
            h(i,j) = 0.0
            go to 40
          end if
c
          if (float(j).lt.timep(i)) then
            if (j.eq.1) h(i,j) = delta1
            if (j.gt.1) h(i,j) = h(i,j-1) + delta1
          else
            if (k.eq.0) then
              h(i,j) = peaksu(i)
              k = 1
            else
              h(i,j) = h(i,j-1) - delta2
            end if
          end if
c
          if (h(i,j).lt.0.0) h(i,j) = 0.0
c
   40   continue
   50 continue
c
      qpmax = 0.0
c
      do 70 i = 1, ntime
        htot = 0.0
        do 60 j = 1, nh
          htot = htot + h(j,i)
   60   continue
        hcomp(i) = htot
        if (hcomp(i).gt.qpmax) qpmax = hcomp(i)
   70 continue
c
      return
      end


      subroutine pgaussj(a,n,np,b,m,mp)
      implicit real*8 (a-h,o-z)
      parameter (nmax=20)
      dimension a(np,np),b(np,mp),ipiv(nmax),indxr(nmax),indxc(nmax)
c     begin initialize for preventing compiler warning
      irow=0
      icol=0
c     end   initialize for preventing compiler warning
      do 11 j=1,n
        ipiv(j)=0
11    continue
      do 22 i=1,n
        big=0d0
        do 13 j=1,n
          if(ipiv(j).ne.1) then
            do 12 k=1,n
              if(ipiv(k).eq.0) then
                if(abs(a(j,k)).ge.big) then
                  big=abs(a(j,k))
                  irow=j
                  icol=k
                endif
              elseif(ipiv(k).gt.1) then
                print *,'Singular matrix (PGAUSSJ)'
                return
              endif
12          continue
          endif
13      continue
        ipiv(icol)=ipiv(icol)+1
        if(irow.ne.icol) then
          do 14 l=1,n
            dum=a(irow,l)
            a(irow,l)=a(icol,l)
            a(icol,l)=dum
14        continue
          do 15 l=1,m
            dum=b(irow,l)
            b(irow,l)=b(icol,l)
            b(icol,l)=dum
15        continue
        endif
        indxr(i)=irow
        indxc(i)=icol
        if(a(icol,icol).eq.0d0) then
          print *,'Singular matrix (PGAUSSJ)'
          return
        endif
        pivinv=1d0/a(icol,icol)
        a(icol,icol)=1d0
        do 16 l=1,n
          a(icol,l)=a(icol,l)*pivinv
16      continue
        do 17 l=1,m
          b(icol,l)=b(icol,l)*pivinv
17      continue
        do 21 ll=1,n
          if(ll.ne.icol) then
            dum=a(ll,icol)
            a(ll,icol)=0d0
            do 18 l=1,n
              a(ll,l)=a(ll,l)-a(icol,l)*dum
18          continue
            do 19 l=1,m
              b(ll,l)=b(ll,l)-b(icol,l)*dum
19          continue
          endif
21      continue
22    continue
      do 24 l=n,1,-1
        if(indxr(l).ne.indxc(l)) then
          do 23 k=1,n
            dum=a(k,indxr(l))
            a(k,indxr(l))=a(k,indxc(l))
            a(k,indxc(l))=dum
23        continue
        endif
24    continue
      return
      end


module worker_module
use iso_fortran_env, only: real64

contains

  subroutine where_all(a,b,c)
    implicit none
    real(real64), allocatable :: a(:), b(:),c(:)

    where(a >= b)
       c = (a - 10.0) * b
    end where

  end subroutine where_all

  subroutine if_then_all(a,b,c)
    implicit none
    real(real64), allocatable :: a(:), b(:),c(:)
    integer :: n,i

    n = size(a,1)

    do i = 1, n
       if(a(i) > b(i)) then
          c(i) = (a(i) - 10.0) * b(i)
       end if
    end do

  end subroutine if_then_all

  subroutine where_sqrt(a,b,c)
    implicit none
    real(real64), allocatable :: a(:), b(:), c(:)

    where(a >= b)
       c = sqrt(a)
    elsewhere
       c = 0.0
    end where

  end subroutine where_sqrt

end module worker_module


      SUBROUTINE MDIAN1(X,N,XMED)
      DIMENSION X(N)
      CALL SORT(N,X)
      N2=N/2
      IF(2*N2.EQ.N)THEN
        XMED=0.5*(X(N2)+X(N2+1))
      ELSE
        XMED=X(N2+1)
      ENDIF
      RETURN
      END


! -----------------------------------------------------------------
! Programmer(s): Cody J. Balos @ LLNL
! -----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2019, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! -----------------------------------------------------------------
! This file tests the Fortran 2003 interface to the SUNDIALS
! sparse SUNMatrix implementation.
! -----------------------------------------------------------------

program main

  !======== Inclusions ==========
  use, intrinsic :: iso_c_binding
  use fsunmatrix_sparse_mod
  use fsunmatrix_dense_mod
  use fsunmatrix_band_mod
  use fnvector_serial_mod

  !======== Declarations ========
  implicit none

  ! constants
  real(c_double) :: ZERO = 0.d0
  real(c_double) :: ONE  = 1.d0

  ! local variables
  integer(c_int)  :: fails = 0    ! number of test fails
  integer(c_int)  :: typ          ! type of Sparse matrix
  integer(c_long) :: N            ! dimensions of SUNMatrix
  integer(c_long) :: uband, lband ! bandwidth of band SUNMatrix
  type(c_ptr)     :: A, B         ! Sparse SUNMatrix
  type(c_ptr)     :: D, E         ! Dense and Banded SUNMatrix
  type(c_ptr)     :: x, y         ! NVectors
  type(c_ptr)     :: matdata      ! Matrix data pointer
  integer(c_long) :: lenrw, leniw ! matrix real and int work space size
  integer(c_long) :: val

  N = 100
  uband = 0
  lband = 0

  x = FN_VNew_Serial(N)
  y = FN_VNew_Serial(N)

  D = FSUNDenseMatrix(N, N)
  E = FSUNBandMatrix(N, uband, lband, uband)

  !======= Introduction =========
  print *,'Sparse matrix Fortran 2003 interface test'

  !===== Calls to interface =====

  ! constructors
  A = FSUNSparseMatrix(N, N, N, CSC_MAT)
  if (.not. c_associated(A)) then
    print *,'>>> FAILED - ERROR in FSUNSparseMatrix; halting'
    stop 1
  end if
  call FSUNMatDestroy_Sparse(A)

  A = FSUNSparseFromDenseMatrix(D, ZERO, CSR_MAT)
  if (.not. c_associated(A)) then
    print *,'>>> FAILED - ERROR in FSUNSparseFromDenseMatrix; halting'
    stop 1
  end if
  call FSUNMatDestroy_Sparse(A)

  A = FSUNSparseFromBandMatrix(E, ZERO, CSC_MAT)
  if (.not. c_associated(A)) then
    print *,'>>> FAILED - ERROR in FSUNSparseFromBandMatrix; halting'
    stop 1
  end if

  ! misc. matrix functions
  val = FSUNSparseMatrix_Rows(A)
  val = FSUNSparseMatrix_Columns(A)
  val = FSUNSparseMatrix_NNZ(A)
  val = FSUNSparseMatrix_NP(A)
  typ = FSUNSparseMatrix_SparseType(A)
  matdata = FSUNSparseMatrix_Data(A)
  matdata = FSUNSparseMatrix_IndexValues(A)
  matdata = FSUNSparseMatrix_IndexPointers(A)
  fails = fails + FSUNSparseMatrix_Realloc(A)
  fails = fails + FSUNSparseMatrix_Reallocate(A, N)

  ! matrix operations
  B = FSUNMatClone_Sparse(A)
  if (.not. c_associated(B)) then
    print *,'>>> FAILED - ERROR in FSUNMatClone_Sparse; halting'
    stop 1
  end if
  val = FSUNMatGetID_Sparse(A)
  fails = fails + FSUNMatZero_Sparse(A)
  fails = fails + FSUNMatCopy_Sparse(A,B)
  fails = fails + FSUNMatScaleAdd_Sparse(ONE, A, B)
  fails = fails + FSUNMatScaleAddI_Sparse(ONE, A)
  fails = fails + FSUNMatMatvec_Sparse(A, x, y)
  fails = fails + FSUNMatSpace_Sparse(A, lenrw, leniw)

  ! destructor
  call FSUNMatDestroy_Sparse(A)

  !======= Cleanup ===========
  call FSUNMatDestroy_Sparse(B)
  call FSUNMatDestroy_Dense(D)
  call FSUNMatDestroy_Band(E)
  call FN_VDestroy_Serial(x)
  call FN_VDestroy_Serial(y)

  if (fails == 0) then
    print *,'    SUCCESS - all tests passed'
  else
    print *,'    FAILURE - ', fails, ' tests failed'
    stop 1
  end if

end program main


program fibonacci
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    character(len=80) :: buffer
    integer :: n

      if (command_argument_count() > 0) then
          call get_command_argument(1, buffer)
          read (buffer, fmt='(I10)') n
      else
          write (unit=error_unit, fmt='(A)') &
              '### error: no argument to command'
          stop 1
      end if
      print '(I20)', fib(n)

    contains

        recursive function fib(n) result(f)
            implicit none
            integer, intent(in) :: n
            integer :: f
            f = fib(n - 1) + fib(n - 2)
        end function fib

end program fibonacci


      double complex function ALslcggpppp(e1,p2,p3,e4,za,zb,zab,zba)
      implicit none
C-----Authors: John Campbell and Keith Ellis, November 2011
C---- arXiv:1101.5947 [hep-ph], Eq. (92)
      include 'constants.f'
      include 'masses.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'zabprods_decl.f'
      include 'epinv.f'
      include 'scale.f'
      double precision mt2,xlog,beta
      double complex BSYA0qedpppp,BSYALslggpppp,Vslc,lnrat
      integer e1,p2,p3,e4

      mt2=mt**2
      beta=sqrt(1d0-4d0*mt2/s(p2,p3))
      xlog=log((1d0-beta)/(1d0+beta))/beta
      Vslc=dcmplx(epinv)*
     & (+s(1,p2)/s(p2,p3)*(lnrat(musq,-s(1,p2))+lnrat(mt2,-s(1,p2)))
     &  +s(1,p3)/s(p2,p3)*(lnrat(musq,-s(1,p3))+lnrat(mt2,-s(1,p3)))
     & +lnrat(musq,-s(p2,p3))+(1d0-2d0*mt2/s(p2,p3))*xlog)

      ALslcggpppp=Vslc*BSYA0qedpppp(e1,p2,p3,e4,za,zb,zab,zba)
     &                +BSYALslggpppp(e1,p2,p3,e4,za,zb,zab,zba)
      return
      end


      subroutine gen3b(r,p,wt3,*)
c----generate 3 dimensional phase space weight and vectors p(7,4)
c----           p1+p2+p3+p4+p5=0
c----and x1 and x2 given seven random numbers
c----p(6,i) and p(7,i) are set equal to zero
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'phasemin.f'
      include 'x1x2.f'
      include 'energy.f'
      integer nu
      double precision r(mxdim),wt3
      double precision p(mxpart,4),
     . p1(4),p2(4),p3(4),p4(4),p5(4),p6(4),p7(4)
      double precision pswt,xjac,tau,y

      wt3=0d0
      p(:,:)=0d0
      tau=exp(log(taumin)*r(4))
      y=0.5d0*log(tau)*(1d0-2d0*r(5))
      xjac=log(taumin)*tau*log(tau)

      xx(1)=sqrt(tau)*exp(+y)
      xx(2)=sqrt(tau)*exp(-y)

c---if x's out of normal range alternative return
      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)) return 1

      p1(4)=-xx(1)*sqrts*half
      p1(1)=zip
      p1(2)=zip
      p1(3)=-xx(1)*sqrts*half

      p2(4)=-xx(2)*sqrts*half
      p2(1)=zip
      p2(2)=zip
      p2(3)=+xx(2)*sqrts*half

      call phase3(r(1),r(2),r(3),r(6),r(7),p1,p2,p3,p4,p5,p6,p7,pswt)

      do nu=1,4
      p(1,nu)=p1(nu)
      p(2,nu)=p2(nu)
      p(3,nu)=p3(nu)
      p(4,nu)=p4(nu)
      p(5,nu)=p5(nu)
      p(6,nu)=p6(nu)
      p(7,nu)=p7(nu)
      enddo

      wt3=xjac*pswt
      if(wt3 .eq. 0d0) then
      p(:,:)=0d0
      return 1
      endif

      return
      end


      SUBROUTINE JACOBS (ELID,SHP,DSHP,GPTH,BGPDT,GPNORM,JACOB)
C
C     THIS SUBROUTINE CALCULATES JACOBIAN AT EACH GIVEN INTEGRATION
C     POINT FOR QUAD4 POTVIN TYPE ELEMENTS.
C
C     SINGLE PRECISION VERSION
C
      LOGICAL         BADJ
      INTEGER         INDEX(3,3),ELID,NOGO,NOUT
      REAL            BGPDT(4,1),GPNORM(4,1)
      REAL            SHP(1),DSHP(1),GPTH(1),PSITRN(9),JACOB(3,3),
     1                TGRID(3,8),SK(3),TK(3),ENK(3),V1(3),V2(3),V3(3),
     2                VAL,HZTA,THICK ,DETJ,DUM(3),EPS
      COMMON /Q4DT  / DETJ,HZTA,PSITRN,NNODE,BADJ,N1
      COMMON /SYSTEM/ IBUF,NOUT,NOGO
C
      EQUIVALENCE     (PSITRN(1),V1(1))
      EQUIVALENCE     (PSITRN(4),V2(1))
      EQUIVALENCE     (PSITRN(7),V3(1))
C
      DATA   EPS    / 1.0E-15 /
C
C     INITIALIZE BADJ LOGICAL
C
      BADJ=.FALSE.
C
C     COMPUTE THE JACOBIAN AT THIS GAUSS POINT,
C     ITS INVERSE AND ITS DETERMINANT.
C
      DO 150 I=1,NNODE
      THICK=GPTH(I)
      TGRID(1,I)=BGPDT(2,I)+HZTA*THICK*GPNORM(2,I)
      TGRID(2,I)=BGPDT(3,I)+HZTA*THICK*GPNORM(3,I)
  150 TGRID(3,I)=BGPDT(4,I)+HZTA*THICK*GPNORM(4,I)
      DO 200 I=1,2
      IPOINT=N1*(I-1)
      DO 200 J=1,3
      JACOB(I,J)=0.0
      DO 200 K=1,NNODE
      JACOB(I,J)=JACOB(I,J)+DSHP(K+IPOINT)*TGRID(J,K)
  200 CONTINUE
      DO 250 J=1,3
      JACOB(3,J)=0.0
      DO 250 K=1,NNODE
      JTEMP=J+1
      JACOB(3,J)=JACOB(3,J)+0.5*GPTH(K)*GPNORM(JTEMP,K)*SHP(K)
  250 CONTINUE
C
C     SAVE THE S,T, AND N VECTORS FOR CALCULATING PSI LATER.
C
      DO 300 I=1,3
      IF (ABS(JACOB(1,I)) .LE. EPS) JACOB(1,I)=0.0
      SK(I)=JACOB(1,I)
      IF (ABS(JACOB(2,I)) .LE. EPS) JACOB(2,I)=0.0
      TK(I)=JACOB(2,I)
      IF (ABS(JACOB(3,I)) .LE. EPS) JACOB(3,I)=0.0
      ENK(I)=JACOB(3,I)
  300 CONTINUE
C
C     THE INVERSE OF THE JACOBIAN WILL BE STORED IN
C     JACOB AFTER THE SUBROUTINE INVERS HAS EXECUTED.
C
      CALL INVERS (3,JACOB,3,DUM,0,DETJ,ISING,INDEX)
      IF (ISING.EQ.1 .AND. DETJ.GT.0.0) GO TO 350
      WRITE (NOUT,550) ELID
      NOGO=1
      BADJ=.TRUE.
      GO TO 500
  350 CALL SAXB (SK,TK,V3)
      VAL=SQRT(V3(1)*V3(1)+V3(2)*V3(2)+V3(3)*V3(3))
      V3(1)=V3(1)/VAL
      V3(2)=V3(2)/VAL
      V3(3)=V3(3)/VAL
C
C     CROSS ELEMENT Y DIRECTION WITH UNIT VECTOR V3 IN ORDER
C     TO BE CONSISTENT WITH THE ELEMENT COORDINATE SYSTEM.
C
C     NOTE - THIS IS IMPORTANT FOR THE DIRECTIONAL REDUCED
C            INTEGRATION CASES.
C
C
C
      V2(1)=0.0
      V2(2)=1.0
      V2(3)=0.0
C
      CALL SAXB (V2,V3,V1)
      VAL=SQRT(V1(1)*V1(1)+V1(2)*V1(2)+V1(3)*V1(3))
      V1(1)=V1(1)/VAL
      V1(2)=V1(2)/VAL
      V1(3)=V1(3)/VAL
      CALL SAXB (V3,V1,V2)
C
C     REMEMBER THAT V1(1) IS EQUIVALENCED TO PSITRN(1), AND SO ON.
C
C     ELIMINATE SMALL NUMBERS
C
      DO 400 I = 1,3
      IF (ABS(V1(I)) .LE. EPS) V1(I)=0.0
      IF (ABS(V2(I)) .LE. EPS) V2(I)=0.0
      IF (ABS(V3(I)) .LE. EPS) V3(I)=0.0
  400 CONTINUE
C
  500 CONTINUE
      RETURN
C
  550 FORMAT ('0*** USER FATAL ERROR, ELEMENT ID =',I10,
     1        '  HAS BAD OR REVERSE GEOMETRY')
      END


!######################################################################
!# MODULE: subprogramr0
!#
!# AUTHORS:
!#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca>,
!#         Waleed Almutiry <wkmtierie@qu.edu.sa>, and
!#         Rob Deardon <robert.deardon@ucalgary.ca>
!#
!# DESCRIPTION:
!#
!#     Calculates the basic reproduction number for the specified SIR model and data
!#
!#
!#     This program is free software; you can redistribute it and/or
!#     modify it under the terms of the GNU General Public License,
!#     version 2, as published by the Free Software Foundation.
!#
!#     This program is distributed in the hope that it will be useful,
!#     but without any warranty; without even the implied warranty of
!#     merchantability or fitness for a particular purpose. See the GNU
!#     General Public License, version 2, for more details.
!#
!#     A copy of the GNU General Public License, version 2, is available
!#     at http://www.r-project.org/Licenses/GPL-2
!#
!# Part of the R/EpiILM package
!# Contains:
!#            rxysir   ..................... subroutine
!#            rconsir  ..................... subroutine
!######################################################################

    module  subprogramr0
    use, intrinsic :: iso_c_binding
    implicit none
    public :: rxysir,rconsir

    contains

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

    subroutine rxysir (n, tmax, ns, nt, ni, suspar, transpar, beta, spark, &
                      & covmatsus, covmattrans, lambda, x, y, sim, &
                      & val, countinf)  bind(C, name="rxysir_")
    !Calculates the basic reproduction number under the spatial model

    external seedin
    external seedout
    external randomnumber

    integer (C_INT), intent(in)  :: n, tmax, ns, ni, nt, sim
    integer (C_INT), intent(in) :: lambda(n)                  !infperiod

    real (C_DOUBLE), intent(in) :: suspar(ns), transpar(nt), beta(ni), spark !parameters
    real (C_DOUBLE), intent(in) :: covmatsus(n,ns), covmattrans(n,nt)        !susceptibility covariate
    real (C_DOUBLE), intent(in) :: x(n), y(n)                 !locations

    real (C_DOUBLE), intent(inout) :: val                     !result
    integer (C_INT), intent(out)   :: countinf(sim)           !result

    integer (C_INT) :: i, j, t, tau(n), A
    real (C_DOUBLE) :: u, dx, p
    real (C_DOUBLE) :: Somega(n), Tomega(n)

    !initialzing random seed
    call seedin()

    !Calculate the distance matrix
!    do i = 1,n
!        do j = i,n
!            eu(i,j) = sqrt(((x(i)-x(j))**2)+((y(i)-y(j))**2))
!            eu(j,i) = eu(i,j)
!        end do
!    end do

    Somega = matmul(covmatsus, suspar) !susceptibility function
    Tomega = matmul(covmattrans, transpar) !transmissibility function

    do j = 1,sim  !simulation starts here

    call randomnumber(u)
    A = int(u * n) + 1  !random initialization for first infection
    do i = 1,n
        tau(i) = 0
    end do
    tau(A) = 1

    !Calculate the initial probability of susceptible being exposed and update tau
    do t = 1,tmax
        do i = 1,n
          dx = 0.0_c_double
          if (tau(i)==0) then
              if ((tau(A) .LE. t) .and. ((tau(A)+lambda(A)) .GT. t)) then
                dx = (sqrt(((x(i)-x(A))**2)+((y(i)-y(A))**2))**(-beta(ni)))*Tomega(A)
!                dx = (eu(i,A)**(-beta(ni)))*Tomega(A)
                p = 1.0_c_double - exp(-((Somega(i)*dx)+spark))
                call randomnumber(u)
                if (p .GT. u) then
                  tau(i) = t + 1  !time at which individual become infected/infectious
                end if
              end if
          end if
        end do
    end do

    countinf(j) = 0
    do i = 1,n
    if (tau(i) .NE. 0) then
        countinf(j) = countinf(j) + 1
    end if
    end do

    countinf(j) = countinf(j)-1

    end do ! simulation ends

    val = sum(countinf)/dble(sim) !result

    call seedout()
    end subroutine rxysir

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

    subroutine rconsir(n, tmax, ns, nt, ni, lambda, suspar, transpar, beta, &
                       & spark, covmatsus, covmattrans,network, sim, &
                       & val, countinf) bind(C, name="rconsir_")
    !Calculates the basic reproduction number under the contact network model

    external seedin
    external seedout
    external randomnumber

    integer (C_INT),intent(in)  :: n, tmax, ns, nt, ni, sim
    integer (C_INT),intent(in)  :: lambda(n)                   !infperiod
    real (C_DOUBLE), intent(in) :: suspar(ns), transpar(nt), beta(ni), spark  !parameter
    real (C_DOUBLE), intent(in) :: network(n, n, ni)           !contact network
    real (C_DOUBLE), intent(in) :: covmatsus(n, ns), covmattrans(n, nt)      !susceptibility covariates

    real (C_DOUBLE), intent(inout) :: val                      !result
    integer (C_INT),intent(out)    :: countinf(sim)            !result

    integer (C_INT) :: i, j, t, k, tau(n), A
    real (C_DOUBLE) :: u, dx, p, Somega(n), Tomega(n)

    !initialzing random seed
    call seedin()

    Somega = matmul(covmatsus,suspar) !susceptibility function
    Tomega = matmul(covmattrans,transpar) !transmissibility function

    do j = 1, sim  !simulation starts

    call randomnumber(u)
    A = int(u * n) + 1 !random initialization for first infection
    do i = 1, n
        tau(i) = 0
    end do
    tau(A) = 1
    !Calculate the initial probability of susceptible being exposed and update tau
    do t = 1, tmax
        do i = 1, n
          dx = 0.0_c_double
          if (tau(i)==0) then
             if ((tau(A) .LE. t) .and. ((tau(A) + lambda(A)) .GT. t)) then
                do k = 1, ni
                  dx = dx + ((beta(k) * network(i, A, k))*Tomega(A))
                end do
                p = 1.0_c_double - (exp(-((Somega(i) * dx) + spark)))
                call randomnumber(u)
                if (p .GT. u) then
                  tau(i) = t + 1
                end if
             end if
          end if
        end do
    end do

    countinf(j) = 0
    do i = 1, n
    if (tau(i) .NE. 0) then
      countinf(j) = countinf(j) + 1
    end if
    end do

    countinf(j) = countinf(j) - 1

    end do ! simulation ends

    val = sum(countinf)/dble(sim) !result

    call seedout()
    end subroutine rconsir

    end module subprogramr0