*     FB01VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, LMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, LMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDK, LDP, LDQ, LDR
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = LMAX, LDK = NMAX,
     $                   LDP = NMAX, LDQ = MMAX, LDR = LMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( LMAX*NMAX + 3*LMAX, NMAX*NMAX,
     $                                 MMAX*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, L, M, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), K(LDK,LMAX), P(LDP,NMAX),
     $                 Q(LDQ,MMAX), R(LDR,LMAX)
      INTEGER          IWORK(LMAX)
*     .. External Subroutines ..
      EXTERNAL         DCOPY, FB01VD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, L, TOL
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( P(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,M ), I = 1,M )
            IF ( L.LE.0 .OR. L.GT.LMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) L
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,L )
               READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,L ), I = 1,L )
*              Perform one iteration of the (Kalman) filter recursion.
               CALL FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC,
     $                      Q, LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK,
     $                      LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, N
                     CALL DCOPY( I-1, P(1,I), 1, P(I,1), LDP )
                     WRITE ( NOUT, FMT = 99994 ) ( P(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( K(I,J), J = 1,L )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99995 )
                  DO 60 I = 1, L
                     WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1,L )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FB01VD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from FB01VD = ',I3)
99997 FORMAT (' The state covariance matrix is ')
99996 FORMAT (/' The Kalman filter gain matrix is ')
99995 FORMAT (/' The square root of the covariance matrix of the innov',
     $          'ations is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' L is out of range.',/' P = ',I5)
      END


c=======================================================================
c
c     subroutine OPMVRFR
c
c     Optimization utility for ALLOCMVRFR
c
c-----------------------------------------------------------------------
      SUBROUTINE opmvrfr ( n, cov, rho, rfr, mu, neq, nin, ccst, bcst,
     &                     cinf, csup, cinfrfr, csuprfr,
     &                     iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : size of portfolio                               integer
c       cov    : covariance matrix (n*n)                          double
c       rho    : expected mean returns vector (n)                 double
c       rfr    : risk-free rate                                   double
c       mu     : performance target                               double
c       neq    : number of initial equality constraints          integer
c       nin    : number of initial inequality constraints        integer
c       ccst   : matrix of constraints (n*(neq + nin))            double
c       bcst   : vector of constraints (neq + nin)                double
c       cinf   : assets inferior limit (n)                        double
c       csup   : assets superior limit (n)                        double
c       cinfrfr: risk-free rate lower bound                       double
c       csuprfr: risk-free rate upper bound                       double
c
c     WORKSPACE
c       iwork  : 3*n + 2*nin + neq + 7                           integer
c       dwork  : n*(n+neq+nin+11)+2*neq+4*nin+12                  double

c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       info   : = 0 successful exit                             integer
c
c     CALL
c       QP      : quadratic solver (vectorized version)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION mu, rfr, cinfrfr, csuprfr
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*), wopt(*),
     &                 ccst(n,*), bcst(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, ntot, neqtot, nintot
      INTEGER piw, pdlin, pdw, pdb, pdc, pdlagr
      DOUBLE PRECISION ZERO, EPS
      PARAMETER (ZERO = 0.D0, EPS = 1.E-8)
c
c     external subroutines
      EXTERNAL qp
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw  = 1
c     piw  : pointer for QUAPRO ( 3*n + neq + 2*nin + 7 )
c
c     Total size of iwork array = 3*n + 2*nin + neq + 7
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdlin  = 1
c     pdlin  : pointer for linear part vector, so ( n ) more
      pdlagr = pdlin + ( n )
c     pdlagr : pointer for Lagrange multipliers ( n + neq + nin + 3 )
      pdb    = pdlagr + ( n + neq + nin + 3 )
c     pdbcs  : pointer for the constraints vector ( neq + nin + 3 )
      pdc    = pdb +  ( neq + nin + 3 )
c     pdccs  : pointer for the constraints matrix n*( neq + nin + 3 )
      pdw    = pdc + ( n*( neq + nin + 3 ) )
c     pdw    : pointer for QUAPRO  (n*n + 6*n + 2*nin + 6)
c
c     Total size of dwork array = n
c                               + n + neq + nin + 3
c                               +     neq + nin + 3
c                               + n*( neq + nin + 3 )
c                               + n*n + 6*n + 2*nin + 6
c
c     Total size of dwork array = n*(n + neq + nin + 11) + 2*neq  + 4*nin + 1é
c
c-----------------------------------------------------------------------
c
c     construction of the constraints matrix and vector and linear part
      ntot   = neq + nin  ! number total of input constraint
      neqtot = neq
      nintot = nin + 3
c
c     construction of the linear part
      CALL IVX (n, dwork(pdlin), ZERO)
c
c     case ncst <> 0 (neq=0, nin=0)
      IF (ntot .NE. 0) THEN
        CALL YV ( n*ntot, ccst, dwork(pdc) )  ! constraint matrix
        CALL YV ( ntot, bcst, dwork(pdb) )    ! constraint vector
      ENDIF
      DO i = 1,n
        dwork(pdc + ntot*n + i - 1)     =  rfr - rho(i)
        dwork(pdc + (ntot+1)*n + i - 1) =  1.0
        dwork(pdc + (ntot+2)*n + i - 1) = -1.0
      ENDDO
      dwork(pdb + ntot)     = rfr - mu
      dwork(pdb + ntot + 1) = 1.0 - cinfrfr + EPS
      dwork(pdb + ntot + 2) = csuprfr - 1.0 + EPS
c
c     quadratic solver
      CALL qp ( n, cov, dwork(pdlin), neqtot, nintot,
     &          dwork(pdc), dwork(pdb), cinf, csup,
     &          iwork(piw), dwork(pdw), dwork(pdlagr), wopt,
     &          info )
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     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 for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine approxplane(col,straight,xn,nopes)
!
!     calculate the equation of the planes through the
!     edges of a quadrilateral and parallel to the vector xn together
!     with a plane perpendicular to xn and through the center of gravity
!     of the four corner nodes of the quadrilateral
!     (so-called mean quadrilateral plane) with
!     (col(1,1),col(2,1),col(3,1)),(col(1,2),col(2,2),col(3,2)),
!     (col(1,3),col(2,3),col(3,3)),(col(1,4),col(2,4),col(3,4))
!     as vertices. The equation of the planes through the first edge
!     (connecting the first and the second node) is of the form
!     straight(1)*x+straight(2)*y+straight(3)*z+straight(4)=0, such that the
!     vector (straight(1),straight(2),straight(3)) points outwards (replace
!     (1) by (5),(9) and (13) for the second, third and fourth edge,
!     similar offset for (2),(3) and (4);
!     The equation of the mean quadrilateral plane is
!     straight(17)*x+straight(18)*y+straight(19)*z+straight(20)=0 such
!     that the quadrilateral is numbered clockwise when looking in the
!     direction of vector (straight(17),straight(18),straight(19)).
!
!     adapted for quadratic elements hex20, tet10
!     Author: Saskia Sitzmann
!
      implicit none
!
      integer i,j,k,nopes
!
      real*8 col(3,nopes),colmean(3),straight(36),ps(8,3),dd,xn(3)
!
!     sides of the quadrilateral
!
      do i=1,3
         do j=1,nopes-1
            ps(j,i)=col(i,j+1)-col(i,j)
         enddo
         ps(nopes,i)=col(i,1)-col(i,nopes)
      enddo
!
!     mean normal to the quadrilateral (given)
!
      do i=1,3
         straight(4*nopes+i)=xn(i)
      enddo
!
!     ps(j,:) x xn
!
      do j=1,nopes
         k=(j-1)*4
         straight(k+1)=ps(j,2)*xn(3)-ps(j,3)*xn(2)
         straight(k+2)=ps(j,3)*xn(1)-ps(j,1)*xn(3)
         straight(k+3)=ps(j,1)*xn(2)-ps(j,2)*xn(1)
         dd=dsqrt(straight(k+1)*straight(k+1)
     &        +straight(k+2)*straight(k+2)
     &        +straight(k+3)*straight(k+3))
         do i=1,3
            straight(k+i)=straight(k+i)/dd
         enddo
      enddo
!
!     determining the inhomogeneous terms
!
      do i=1,3
         colmean(i)=0.0
      enddo
      do j=1,nopes
         k=(j-1)*4
         straight(k+4)=-straight(k+1)*col(1,j)
     &        -straight(k+2)*col(2,j)
     &        -straight(k+3)*col(3,j)
         do i=1,3
            colmean(i)=colmean(i)+col(i,j)
         enddo
      enddo
      straight(4*nopes+4)=(-xn(1)*colmean(1)
     &     -xn(2)*colmean(2)
     &     -xn(3)*colmean(3))/nopes
!
      return
      end


module get_constants
implicit none

double precision :: ang2bohr, amu2au, au2wavenumber, time_au2s, &
                    speed_of_light, pi, freq_conv
!---------------------------------------------------------------------
parameter (ang2bohr = 1d0/0.529177249238d0)             ! GAMESS conversion factor
parameter (amu2au = 1822.888484995826d0)                ! GAMESS conversion factor
parameter (au2wavenumber = 219474.63068d0)
parameter (time_au2s = 2.418884326505d-17)
parameter (speed_of_light = 299792458)
parameter (pi = 3.141592653589793238462643383279502d0)
parameter (freq_conv = 2.0d0*pi*100.d0*speed_of_light*time_au2s)
end module get_constants


module nodal_stencil_apply_module

  use bl_constants_module
  use bl_types
  use multifab_module
  use bc_functions_module
  use impose_neumann_bcs_module
  use stencil_types_module

  implicit none

contains

  subroutine stencil_apply_1d_nodal(sg, dd, uu, mm, ng_u, ng_d, diagonalize)
    integer, intent(in) :: ng_u, ng_d
    real (kind = dp_t), intent(in   ) :: sg(   0:)
    real (kind = dp_t), intent(inout) :: dd(1-ng_d:)
    real (kind = dp_t), intent(inout) :: uu(1-ng_u:)
    integer           , intent(in   ) :: mm(    :)
    logical           , intent(in   ) :: diagonalize

    integer :: i,lo(1),nx

    nx = size(sg,dim=1) - 2

    dd = ZERO

    lo = 1
    call impose_neumann_bcs_1d(uu,mm,lo,ng_u)

    i = 1
    if (.not. bc_dirichlet(mm(i),1,0)) then
      dd(i) = sg(i) * (uu(i+1) - uu(i)) + sg(i-1) * (uu(i-1) - uu(i))
      if (diagonalize) dd(i) = -dd(i) / (sg(i)+sg(i-1))
    end if

    do i = 2,nx-1
      dd(i) = sg(i) * (uu(i+1) - uu(i)) + sg(i-1) * (uu(i-1) - uu(i))
      if (diagonalize) dd(i) = -dd(i) / (sg(i)+sg(i-1))
    end do

    i = nx
    if (.not. bc_dirichlet(mm(i),1,0)) then
      dd(i) = sg(i) * (uu(i+1) - uu(i)) + sg(i-1) * (uu(i-1) - uu(i))
      if (diagonalize) dd(i) = -dd(i) / (sg(i)+sg(i-1))
    end if

  end subroutine stencil_apply_1d_nodal

  subroutine stencil_apply_2d_nodal(sg, dd, uu, mm, ng_u, ng_d, stencil_type, diagonalize)
    integer, intent(in) :: ng_u, ng_d
    real (kind = dp_t), intent(inout) :: uu(1-ng_u:,1-ng_u:)
    real (kind = dp_t), intent(inout) :: dd(1-ng_d:,1-ng_d:)
    real (kind = dp_t), intent(in   ) :: sg(   0:,   0:)
    integer           , intent(in   ) :: mm(    :,    :)
    integer           , intent(in   ) :: stencil_type
    logical           , intent(in   ) :: diagonalize

    integer :: i,j,lo(2),nx,ny
    logical :: zeroit,iface,jface
    real (kind = dp_t) :: ss0

    lo = 1
    call impose_neumann_bcs_2d(uu,mm,lo,ng_u)

    nx = size(sg,dim=1) - 1
    ny = size(sg,dim=2) - 1

    if (stencil_type .eq. ND_CROSS_STENCIL) then

       do j = 1,ny
          jface = .false. ; if ( (j.eq.1).or.(j.eq.ny) ) jface = .true.
          do i = 1,nx
             iface = .false. ; if ( (i.eq.1).or.(i.eq.nx) ) iface = .true.

             zeroit = .false.

             if ( iface .or. jface ) then
                if (bc_dirichlet(mm(i,j),1,0)) zeroit = .true.
             end if

             if (zeroit) then
                dd(i,j) = ZERO
             else
                ss0 = -(sg(i-1,j-1)+sg(i,j-1)+sg(i-1,j)+sg(i,j))
                dd(i,j) = ss0 * uu(i,j) + &
                   HALF * ( (sg(i  ,j-1)+sg(i  ,j  )) * uu(i+1,j) + &
                            (sg(i-1,j-1)+sg(i-1,j  )) * uu(i-1,j) + &
                            (sg(i-1,j  )+sg(i  ,j  )) * uu(i,j+1) + &
                            (sg(i-1,j-1)+sg(i  ,j-1)) * uu(i,j-1) )
                if (diagonalize) then
                    dd(i,j) = dd(i,j) / ss0
                end if
             end if
          end do
       end do

    else if (stencil_type .eq. ND_DENSE_STENCIL) then

       do j = 1,ny
          jface = .false. ; if ( (j.eq.1).or.(j.eq.ny) ) jface = .true.
          do i = 1,nx
             iface = .false. ; if ( (i.eq.1).or.(i.eq.nx) ) iface = .true.

             zeroit = .false.

             if ( iface .or. jface ) then
                if (bc_dirichlet(mm(i,j),1,0)) zeroit = .true.
             end if

             if (zeroit) then
                dd(i,j) = ZERO
             else
                ss0 = -TWO * THIRD * (sg(i-1,j-1) + sg(i,j-1) + sg(i-1,j) + sg(i,j))
                dd(i,j) = ss0 * uu(i,j) + THIRD * ( &
                            sg(i-1,j-1) * uu(i-1,j-1) + &
                            sg(i  ,j-1) * uu(i+1,j-1) + &
                            sg(i-1,j  ) * uu(i-1,j+1) + &
                            sg(i  ,j  ) * uu(i+1,j+1) + &
                  HALF * ( (sg(i-1,j-1) + sg(i  ,j-1)) * uu(i,j-1) + &
                           (sg(i-1,j-1) + sg(i-1,j  )) * uu(i-1,j) + &
                           (sg(i  ,j-1) + sg(i  ,j  )) * uu(i+1,j) + &
                           (sg(i-1,j  ) + sg(i  ,j  )) * uu(i,j+1) ) )
                if (diagonalize) then
                    dd(i,j) = dd(i,j) / ss0
                end if
             end if
          end do
       end do

    else if (stencil_type .eq. ND_VATER_STENCIL) then

       do j = 1,ny
          jface = .false. ; if ( (j.eq.1).or.(j.eq.ny) ) jface = .true.
          do i = 1,nx
             iface = .false. ; if ( (i.eq.1).or.(i.eq.nx) ) iface = .true.

             zeroit = .false.

             if ( iface .or. jface ) then
                if (bc_dirichlet(mm(i,j),1,0)) zeroit = .true.
             end if

             if (zeroit) then
                dd(i,j) = ZERO
             else
                ss0 = -THREE4TH * (sg(i-1,j-1) + sg(i,j-1) + sg(i-1,j) + sg(i,j))
                dd(i,j) = ss0 * uu(i,j) + &
                FOURTH * ( &
                            sg(i-1,j-1) * uu(i-1,j-1) + &
                            sg(i  ,j-1) * uu(i+1,j-1) + &
                            sg(i-1,j  ) * uu(i-1,j+1) + &
                            sg(i  ,j  ) * uu(i+1,j+1) + &
                           (sg(i-1,j-1) + sg(i  ,j-1)) * uu(i,j-1) + &
                           (sg(i-1,j-1) + sg(i-1,j  )) * uu(i-1,j) + &
                           (sg(i  ,j-1) + sg(i  ,j  )) * uu(i+1,j) + &
                           (sg(i-1,j  ) + sg(i  ,j  )) * uu(i,j+1) )
                if (diagonalize) then
                    dd(i,j) = dd(i,j) / ss0
                end if
             end if
          end do
       end do

    else
       call bl_error("stencil_apply_2d_nodal: dont know this stencil_type")
    end if

  end subroutine stencil_apply_2d_nodal

  subroutine stencil_apply_3d_nodal(sg, dd, uu, mm, ng_u, ng_d, stencil_type, &
                                    uniform_dh, bottom_solver, diagonalize)
    integer           , intent(in   ) :: ng_u, ng_d
    real (kind = dp_t), intent(inout) :: uu(1-ng_u:,1-ng_u:,1-ng_u:)
    real (kind = dp_t), intent(inout) :: dd(1-ng_d:,1-ng_d:,1-ng_d:)
    real (kind = dp_t), intent(in   ) :: sg(   0:,   0:,   0:)
    integer           , intent(in   ) :: mm(    :,    :,    :)
    integer           , intent(in   ) :: stencil_type
    logical           , intent(in   ) :: uniform_dh, bottom_solver, diagonalize

    integer :: i,j,k,lo(3),nx,ny,nz
    logical :: jface,kface
    real (kind = dp_t) :: f0, fx, fy, fz, fxyz, f2y2zx, f2x2zy, f2x2yz, ss0

    lo = 1
    call impose_neumann_bcs_3d(uu,mm,lo,ng_u)

    nz = size(sg,dim=3) - 1
    ny = size(sg,dim=2) - 1
    nx = size(sg,dim=1) - 1

    if (stencil_type .eq. ND_CROSS_STENCIL) then

       !$OMP PARALLEL DO PRIVATE(i,j,k,jface,kface,ss0) IF(.not.bottom_solver)
       do k = 1,nz
          kface = .false. ; if ( (k.eq.1) .or. (k.eq.nz) ) kface = .true.

          do j = 1,ny
             jface = .false. ; if ( (j.eq.1) .or. (j.eq.ny) ) jface = .true.

             do i = 1,nx

                if ( (jface .or. kface .or. (i.eq.1) .or. (i.eq.nx)) .and. bc_dirichlet(mm(i,j,k),1,0) ) then
                   dd(i,j,k) = ZERO
                else
                   ss0 = -( sg(i-1,j-1,k-1) + sg(i-1,j  ,k-1) &
                           +sg(i  ,j-1,k-1) + sg(i  ,j  ,k-1) &
                           +sg(i-1,j-1,k  ) + sg(i-1,j  ,k  ) &
                           +sg(i  ,j-1,k  ) + sg(i  ,j  ,k  )) * THREE
                   dd(i,j,k) = ss0 * uu(i,j,k) + &
                     (sg(i-1,j-1,k-1) + sg(i-1,j-1,k  ) &
                     +sg(i-1,j  ,k-1) + sg(i-1,j  ,k  )) * uu(i-1,j  ,k  ) + &
                     (sg(i  ,j-1,k-1) + sg(i  ,j-1,k  ) &
                     +sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )) * uu(i+1,j  ,k  ) + &
                     (sg(i-1,j-1,k-1) + sg(i-1,j-1,k  ) &
                     +sg(i  ,j-1,k-1) + sg(i  ,j-1,k  )) * uu(i  ,j-1,k  ) + &
                     (sg(i-1,j  ,k-1) + sg(i-1,j  ,k  ) &
                     +sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )) * uu(i  ,j+1,k  ) + &
                     (sg(i-1,j-1,k-1) + sg(i-1,j  ,k-1) &
                     +sg(i  ,j-1,k-1) + sg(i  ,j  ,k-1)) * uu(i  ,j  ,k-1) + &
                     (sg(i-1,j-1,k  ) + sg(i-1,j  ,k  ) &
                     +sg(i  ,j-1,k  ) + sg(i  ,j  ,k  )) * uu(i  ,j  ,k+1)
                   if (diagonalize) then
                       dd(i,j,k) = dd(i,j,k) / ss0
                   end if
                end if
             end do
          end do
       end do
       !$OMP END PARALLEL DO

    else if (stencil_type .eq. ND_DENSE_STENCIL) then

       fx     = ONE/36._dp_t
       fy     = fx
       fz     = fx
       f0     = FOUR * (fx + fy + fz)
       fxyz   = (fx+fy+fz)
       f2y2zx = (TWO*fy+TWO*fz-fx)
       f2x2zy = (TWO*fx+TWO*fz-fy)
       f2x2yz = (TWO*fx+TWO*fy-fz)

       !$OMP PARALLEL DO PRIVATE(i,j,k,jface,kface,ss0) IF(.not.bottom_solver)
       do k = 1,nz
          kface = .false. ; if ( (k.eq.1) .or. (k.eq.nz) ) kface = .true.

          do j = 1,ny
             jface = .false. ; if ( (j.eq.1) .or. (j.eq.ny) ) jface = .true.

             do i = 1,nx

                if ( (jface .or. kface .or. (i.eq.1) .or. (i.eq.nx)) .and. bc_dirichlet(mm(i,j,k),1,0) ) then
                   dd(i,j,k) = ZERO
                else

                ss0 =  -( sg(i-1,j-1,k-1) + sg(i,j-1,k-1) &
                         +sg(i-1,j  ,k-1) + sg(i,j  ,k-1) &
                         +sg(i-1,j-1,k  ) + sg(i,j-1,k  ) &
                         +sg(i-1,j  ,k  ) + sg(i,j  ,k  ) ) * f0
                dd(i,j,k) = fxyz * ( &   ! Corners
                     sg(i-1,j-1,k-1) * uu(i-1,j-1,k-1) + sg(i  ,j-1,k-1) * uu(i+1,j-1,k-1) + &
                     sg(i-1,j  ,k-1) * uu(i-1,j+1,k-1) + sg(i  ,j  ,k-1) * uu(i+1,j+1,k-1) + &
                     sg(i-1,j-1,k  ) * uu(i-1,j-1,k+1) + sg(i  ,j-1,k  ) * uu(i+1,j-1,k+1) + &
                     sg(i-1,j  ,k  ) * uu(i-1,j+1,k+1) + sg(i  ,j  ,k  ) * uu(i+1,j+1,k+1)) &
                     + f2y2zx * ( & ! Edges in x-direction
                     (sg(i  ,j-1,k-1) + sg(i-1,j-1,k-1)) * uu(i  ,j-1,k-1) + &
                     (sg(i  ,j  ,k-1) + sg(i-1,j  ,k-1)) * uu(i  ,j+1,k-1) + &
                     (sg(i  ,j-1,k  ) + sg(i-1,j-1,k  )) * uu(i  ,j-1,k+1) + &
                     (sg(i  ,j  ,k  ) + sg(i-1,j  ,k  )) * uu(i  ,j+1,k+1)) &
                     + f2x2zy * ( & ! Edges in y-direction
                     (sg(i-1,j-1,k-1) + sg(i-1,j  ,k-1)) * uu(i-1,j  ,k-1) + &
                     (sg(i  ,j-1,k-1) + sg(i  ,j  ,k-1)) * uu(i+1,j  ,k-1) + &
                     (sg(i-1,j-1,k  ) + sg(i-1,j  ,k  )) * uu(i-1,j  ,k+1) + &
                     (sg(i  ,j-1,k  ) + sg(i  ,j  ,k  )) * uu(i+1,j  ,k+1)) &
                     + f2x2yz * ( & ! Edges in z-direction
                     (sg(i-1,j-1,k-1) + sg(i-1,j-1,k  )) * uu(i-1,j-1,k  ) + &
                     (sg(i  ,j-1,k-1) + sg(i  ,j-1,k  )) * uu(i+1,j-1,k  ) + &
                     (sg(i-1,j  ,k-1) + sg(i-1,j  ,k  )) * uu(i-1,j+1,k  ) + &
                     (sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )) * uu(i+1,j+1,k  )) &
                     + ss0 * uu(i,j,k)

                   if (.not. uniform_dh) then
                      !
                      ! Add faces (only non-zero for non-uniform dx)
                      !
                      dd(i,j,k) = dd(i,j,k) + &
                           ( (FOUR*fx-TWO*fy-TWO*fz)*(sg(i-1,j-1,k-1) + sg(i-1,j-1,k  ) &
                            +sg(i-1,j  ,k-1) + sg(i-1,j  ,k  )) ) * uu(i-1,j  ,k  ) + &
                           ( (FOUR*fx-TWO*fy-TWO*fz)*(sg(i  ,j-1,k-1) + sg(i  ,j-1,k  ) &
                            +sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )) ) * uu(i+1,j  ,k  ) + &
                           ( (FOUR*fy-TWO*fx-TWO*fz)*(sg(i-1,j-1,k-1) + sg(i-1,j-1,k  ) &
                            +sg(i  ,j-1,k-1) + sg(i  ,j-1,k  )) ) * uu(i  ,j-1,k  ) + &
                           ( (FOUR*fy-TWO*fx-TWO*fz)*(sg(i-1,j  ,k-1) + sg(i-1,j  ,k  ) &
                            +sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )) ) * uu(i  ,j+1,k  ) + &
                           ( (FOUR*fz-TWO*fx-TWO*fy)*(sg(i-1,j-1,k-1) + sg(i-1,j  ,k-1) &
                            +sg(i  ,j-1,k-1) + sg(i  ,j  ,k-1)) ) * uu(i  ,j  ,k-1) + &
                           ( (FOUR*fz-TWO*fx-TWO*fy)*(sg(i-1,j-1,k  ) + sg(i-1,j  ,k  ) &
                            +sg(i  ,j-1,k  ) + sg(i  ,j  ,k  )) ) * uu(i  ,j  ,k+1)
                   end if

                   ! This accounts for the fact that fac = 1/(4*dx*dx) to be compatible with
                   !      the cross stencil
                   if (diagonalize) then
                       dd(i,j,k) = dd(i,j,k) / ss0
                   else
                       dd(i,j,k) = FOUR * dd(i,j,k)
                   end if

                end if

             end do
          end do
       end do
       !$OMP END PARALLEL DO
    else if (stencil_type .eq. ND_VATER_STENCIL) then
       call bl_error("stencil_apply_3d_nodal: ND_VATER_STENCIL not implemented in 3-d")
    else
       call bl_error("stencil_apply_3d_nodal: dont know this stencil_type")
    end if

  end subroutine stencil_apply_3d_nodal

end module nodal_stencil_apply_module


      subroutine rcombined(stress,dstrain, dtime, temp,
     & statev, nstatv, props, nprops)
!f2py real*8 intent(in,out) :: stress
!f2py real*8 intent(in) :: dstrain,dtime,temp
!f2py integer intent(hide),depend(statev) :: nstatv = len(statev)
!f2py real*8 intent(in,out),dimension(nstatv) :: statev
!f2py integer intent(hide),depend(props) :: nprops = len(props)
!f2py real*8 intent(in),dimension(nprops) :: props
!
      implicit real*8(a-h,o-z)
      dimension statev(nstatv),props(nprops),tempstatev(nstatv)
      parameter(zero=0.d0,one=1.d0,two=2.d0,newtonmax=10,toler=1.0d-8)
!
! elastic properties
      call shearmod(eg,enu,temp,props,nprops)
      eg2=two*eg
      emod = eg2*(one+enu)
!
! initialize temporary statevariable array
      do i =1,nstatv
        tempstatev(i) = statev(i)
      end do
      backstress = statev(1)
!
! calculate predictor stress
      stress=stress+emod*dstrain
      xitrial=dabs(stress-backstress)
!
! check yield condition
      call fcombined(sy,dsy,sb0,dsb,zero,dtime,temp,
     & statev,tempstatev,nstatv,props,nprops)
!
! determine if actively yielding
      residual = xitrial-sy
      if(residual.gt.toler)then
!
! direction of the plastic flow
        flow=(stress-backstress)/xitrial
!
! newton raphson return mapping
      cop=toler
      kount = 1
      do while((dabs(residual).gt.toler).and.(kount.lt.newtonmax))
        cop=dabs(cop+residual/(emod+dsy+dsb))
        deqpl = cop
        call fcombined(sy,dsy,sb,dsb,deqpl,dtime,temp,
     & statev,tempstatev,nstatv,props,nprops)
        residual=xitrial-emod*cop-sy-sb+sb0
      end do
!
! update stress solution
      backstress = backstress + (sb-sb0)*flow
      stress=flow*sy+backstress
      endif
!
! update state variables
      tempstatev(1) = backstress
      do k1=1,nstatv
        statev(k1) = tempstatev(k1)
      end do
      return
      end


      subroutine calculate_asa_ro3(n_spin_pola,rho1,rho2,
     &           i_vdif,r_mesh,jmt,rmt,iprpts,
     &           ro3,dz)
      implicit none

      integer jmt,i_vdif,iprpts,n_spin_pola
      integer i
      real*8 rmt
      real*8 rho1(iprpts),rho2(iprpts)
      real*8 rhojmt,rhojmt1,rhojmt2,drhot
      real*8 r_mesh(iprpts),rtmp(0:iprpts)
      real*8 ro3,dz

      rtmp(0)=0.d0
      do i=1,jmt+2
        rtmp(i)=sqrt(r_mesh(i))
      enddo

      rhojmt2=0.0
      call interp(rtmp(1),rho1(1),jmt,
     >   sqrt(rmt),rhojmt1,drhot,.false.)
      if(n_spin_pola.eq.2) then
        call interp(rtmp(1),rho2(1),jmt,
     >     sqrt(rmt),rhojmt2,drhot,.false.)
      end if
      rhojmt=rhojmt1+(n_spin_pola-1)*rhojmt2

      ro3 = 1.0d10
      dz = 0.0

      if(rhojmt.gt.1.d-10)
     >   ro3=(3.0*rmt*rmt/rhojmt)**(1.0/3.0)
      if(i_vdif.ne.0 .and. n_spin_pola.eq.2)
     >   dz =(rho1(jmt)-rho2(jmt))/rhojmt

      end subroutine


      subroutine swu(nowcrp)
c
c********************************************************************
c     note: subroutine to be modified according to plant growth     *
c           model input requirement                                 *
c********************************************************************
c
c     + + + PURPOSE + + +
c     Distributes potential plant evaporation through the root zone
c     and calculates actual plant water use based on soil water
c     availability.
c
c     Called from WATBAL
c     Author(s): Savabi
c     Reference in User Guide:
c
c     Changes:
c          1) Common blocks CLIM, PARAME, & UPDATE not used.
c             Dereferenced.
c          2) Parameter MXPOND not used.  Dereferenced.
c          3) Variable EP expanded to array EP(MXPLAN).
c
c     Version: This module originally recoded from WEPP version 91.38.
c     Date recoded: 08/19/91.
c     Version: This module updated from WEPP release version 91.50.
c     Date updated: 12/04/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pntype.inc'
      include 'pmxpln.inc'
      include 'pmxres.inc'
      include 'ptilty.inc'
      include 'pmxcrp.inc'
      include 'pmxtls.inc'
      include 'pmxtil.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer nowcrp
c
c     + + + ARGUMENT DEFINITIONS + + +
c     nowcrp - current crop
c
c     + + + COMMON BLOCKS + + +
c
      include 'cclim.inc'
c
      include 'ccrpout.inc'
c     modify: rtd
c
      include 'ccrpprm.inc'
c       read: itype
c
      include 'ccrpvr1.inc'
c     modify: pltol
c
      include 'cstruc.inc'
c       read: iplane
c
      include 'cwater.inc'
c       read: nsl,ub,ul(mxnsl,mxplane),solthk(mxnsl,mxplan),plaint(mxplan)
c     modify: ep(mxplan),ul4
c      write: watstr(mxplan),st(mxnsl,mxplan)
c
c     + + + LOCAL VARIABLES + + +
      real  gx, sum, u(mxnsl),ub, uob, xx
      integer k,ixx
c
c     + + + LOCAL DEFINITIONS + + +
c       sum   - potential (maximum possible) water uptake by plant
c               roots.
c       u     - actual water uptake by plant roots from each soil
c               layer, m.
c       xx    - total water uptake for this OFE.
c       ixx   - index of deepest soil layer containing roots.
c       gx    - depth of roots in the current layer.
c       ub    - a plant water use rate-depth parameter = 3.065
c               (See eq. 7.3.3)
c       uob   -  Since UB is a constant, "1 - exp(-UB)" is too;
c                ie, 0.953346.
c
c     + + + DATA INITIALIZATIONS + + +
      data uob /0.953346/, ub /3.065/
c
c     + + + END SPECIFICATIONS + + +
c
c      If the roots are all within the soil layers....
      if (rtd(iplane).lt.solthk(nsl(iplane),iplane)) then
c       Initialize U and find deepest soil layer (IXX) containing roots.
c       (Reverse order of loop to find SHALLOWEST layer >= root depth.)
        do 10 k = nsl(iplane), 1, -1
          u(k) = 0.
          if (rtd(iplane).le.solthk(k,iplane)) ixx = k
   10   continue
c
c     If the root depth is greater than the soil layers....
      else
        rtd(iplane) = solthk(nsl(iplane),iplane)
        ixx = nsl(iplane)
      end if
c
c     new adjustment of ep for intercepted rain by live plants(intpla)
c     plaint will evaporate first, reza 7/27/93
c
cd    Modified by S. Dun July 26,2003
      if (plaint(iplane).gt.0.0) then
cd      if (ep(iplane).gt.0.0) then
        ep(iplane) = ep(iplane) - plaint(iplane)
      if (ep(iplane).gt.0.0) pintlv(iplane) = 0.0
        if (ep(iplane).lt.0.0) then
        pintlv(iplane) = -ep(iplane)
        ep(iplane) = 0.0
      endif
      end if
cd    End modifying
c
c     If there is evapotranspiration....
      if (ep(iplane).gt.0.) then
        xx = 0.0
c
c       distribution of plant transpiration ep (m) in the root zone rtd (m)
c       (equations 7.3.3-4)
c
c       For all soil layers containing roots....
        do 20 k = 1, ixx
c
          if (k.lt.ixx) then
            gx = solthk(k,iplane)
          else
            gx = rtd(iplane)
          end if
c
c         (eq. 7.3.3)
          if (rtd(iplane).gt.0.0) then
            sum = (1.-exp(-ub*gx/rtd(iplane))) * ep(iplane) / uob
          else
            sum = ep(iplane) / uob
          end if
c
          u(k) = sum - xx
c
c         Determine tolerence to moisture stress for current crop;
c         ie, the fraction of UL that soil moisture reach before
c         moisture stress occurs, and water uptake is reduced.
          if (itype(nowcrp,iplane).gt.0) then
c           ---------- if no value is input for PLTOL; ie, PLTOL = 0, set PLTOL
c           to default value of 0.25.
            if (pltol(itype(nowcrp,iplane)).le.0.) then
              pltol(itype(nowcrp,iplane)) = 0.25
c           ---------- if value input for PLTOL is > 0.4, set it to 0.4.
            else if (pltol(itype(nowcrp,iplane)).gt.0.4) then
              pltol(itype(nowcrp,iplane)) = 0.4
c           ---------- if value input for PLTOL is < 0.1, set it to 0.1.
            else if (pltol(itype(nowcrp,iplane)).lt.0.1) then
              pltol(itype(nowcrp,iplane)) = 0.1
            end if
c
c           Determine the threshold for water stress (UL4).
            ul4 = pltol(itype(nowcrp,iplane)) * ul(k,iplane)
cd    Modified by S. Dun April 04,2003
cd          end if
cd    Move down one line.
c
c         --------- compute water uptake by plants, (not to exceed avail. moisture (ST))
            if (st(k,iplane).lt.ul4) u(k) = u(k) * st(k,iplane) / ul4
        end if
cd    End Modifying
          if (st(k,iplane).lt.u(k)) u(k) = st(k,iplane)
          if (u(k).lt.1e-10) u(k) = 0.0
c
c         -------- reduce water content of soil layer to reflect plant uptake.
          st(k,iplane) = st(k,iplane) - u(k)
          if (st(k,iplane).lt.1e-10) st(k,iplane) = 0.00
c
          xx = xx + u(k)
c
   20   continue
c
c       Calculate water stress factor (0-1); ie, ratio of actual uptake
c       to potential uptake.
        watstr(iplane) = xx / ep(iplane)
c       ------ set evapotranspiration = actual water uptake.
        ep(iplane) = xx
c
c     If there is no evapotranspiration....
      else
        watstr(iplane) = 1.0
      end if
c
c     7/27/93 daily actual plant transpiration was reduced before
c     by the amount of plaint, m,  so must add it back on -  reza
c
      ep(iplane) = ep(iplane) + plaint(iplane)
cd    Modified By S. Dun July 26, 2003
      if(pintlv(iplane).gt.0.0) then
        ep(iplane) = ep(iplane) - pintlv(iplane)
      else
        pintlv(iplane) = 0.0
      endif
cd    End modifying
c
c     8/16/93 - need to reset value of plaint to 0.0 so it does not
c     cause errors in following day when there is no rainfall - reza
c
c      plaint(iplane) = 0.0
c
      return
      end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mncoco : concon test program                       cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(16),y(16),w(16),v(16),sx(16),s2(16),t(20),c(20),wrk(550),
     * s(3)
      integer iwrk(450)
      logical bind(20)
      integer i,ier,iopt,is,j,j3,kwrk,lwrk,m,maxbin,maxtr,n,nest,n4,n6
      real sq
c  the absciss values of the data points.
      data x(1),x(2),x(3),x(4),x(5),x(6),x(7),x(8),x(9),x(10),x(11),
     * x(12),x(13),x(14),x(15),x(16)/0.1,0.3,0.5,0.7,0.9,1.25,1.75,
     * 2.25,2.75,3.5,4.5,5.5,6.5,7.5,8.5,9.5/
c  the ordinate values of the data points.
      data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11),
     * y(12),y(13),y(14),y(15),y(16)/0.124,0.234,0.256,0.277,0.278,
     * 0.291,0.308,0.311,0.315,0.322,0.317,0.326,0.323,0.321,0.322,
     * 0.328/
c  m denotes the number of data points.
      m = 16
c  we set up the weights of the data points.
      do 10 i=1,m
         w(i) = 1.
  10  continue
      w(1) = 10.
      w(2) = 3.
      w(16) = 10.
c  we will determine concave approximations
      do 20 i=1,m
         v(i) = 1.
  20  continue
c  we set up the dimension information.
      nest = 20
      maxtr = 100
      maxbin = 10
      lwrk = 550
      kwrk = 450
c  we set up the different s-values.
      s(1) = 0.2
      s(2) = 0.04
      s(3) = 0.0002
c  initialization.
      iopt = 0
c  loop for the different spline approximations
      do 300 is=1,3
c  we determine the concave spline approximation.
         call concon(iopt,m,x,y,w,v,s(is),nest,maxtr,maxbin,n,t,c,sq,sx,
     *     bind,wrk,lwrk,iwrk,kwrk,ier)
c  printing of the results.
         write(6,900) s(is),ier
         write(6,905) sq
         write(6,910) n
         write(6,915)
         write(6,920) (t(i),i=1,n)
         write(6,925)
         n6 = n-6
         do 100 j=1,n6
            j3 = j+3
            if(bind(j)) write(6,930) t(j3)
 100     continue
         write(6,935)
         n4 = n-4
         write(6,940) (c(i),i=1,n4)
c  we evaluate the second order derivative of the spline.
         call splder(t,n,c,3,2,x,s2,m,wrk,ier)
         write(6,945)
         do 200 i=1,m
            write(6,950) i,x(i),y(i),sx(i),s2(i)
 200     continue
c  iopt=1 from the second call on.
         iopt = 1
 300  continue
      stop
c  format statements
 900  format(48h0upper limit for the sum of squared residuals s=,
     * e8.1,5x,15herror flag ier=,i2)
 905  format(1x,28hsum of squared residuals sq=,e10.3)
 910  format(1x,24htotal number of knots n=,i2)
 915  format(1x,21hposition of the knots)
 920  format(5x,8f7.2)
 925  format(1x,24hthe knots where s''(x)=0)
 930  format(5x,f7.2)
 935  format(1x,21hb-spline coefficients)
 940  format(5x,4f12.6)
 945  format(3h0 i,5x,4hx(i),6x,4hy(i),4x,7hs(x(i)),4x,9hs''(x(i)))
 950  format(1x,i2,5x,f4.2,5x,f5.3,5x,f5.3,5x,f8.4)
      end


C SYSTRA.F - Gateway function for computing system transformations
C            with scaling, block diagonal decomposition, or Schur form
C            reduction of the state matrix, using the SLICOT routines
C            TB01ID, TB01KD, TB01LD, and TB01WD.
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   [A,B,C(,num,ev,U)] = systra(task,A,B,C(,job,par))
C   [A,B,C(,num,ev,U)] = systra(task,A,B,C(,flag,par))
C
C   task = 1 :        [A,B,C,U] = systra(1,A,B,C,job,par)
C   task = 2 :     [A,B,C,ev,U] = systra(2,A,B,C)
C   task = 3 : [A,B,C,num,ev,U] = systra(3,A,B,C,flag,par)
C   task = 4 : [A,B,C,num,ev,U] = systra(4,A,B,C,flag,par)
C
C Purpose:
C   To apply a specified similarity transformation to a given system
C              [ A  B ]
C   matrix S = [      ]. The possible transformations are:
C              [ C  0 ]
C
C task = 1                                            [ D  0 ]
C   Do balance on the matrix S with a diagonal matrix [      ];
C                                                     [ 0  I ]
C task = 2
C   Reduce A to Schur form using an orthogonal matrix U, and transform
C   B and C accordingly,
C                                [* . . . * |* . *]--
C                                [  .     . |.   .] |
C  [ U'| 0 ][ A | B ][ U | 0 ]   [    .   . |.   .] N
C  [---|---][---|---][---|---] = [      . . |.   .] |  ;      (1)
C  [ 0 | I ][ C | 0 ][ 0 | I ]   [        * |* . *]--
C                                [----------|-----]
C                                [* . . . * |     ]-|-
C                                [.       . |  0  ] P
C                                [* . . . * |     ]-|-
C                                 |-- N --|  |-M-|
C task = 3
C   Reduce A to real Schur form with eigenvalues in required order, by
C   using an orthogonal matrix U, and transform B and C accordingly,
C
C                               |--[* . * * . * |* . *]--
C                              num [  . . .   . |* . *] |
C                               |--[    * * . * |.   .] |
C  [ U'| 0 ][ A | B ][ U | 0 ]     [      * . * |.   .] N
C  [---|---][---|---][---|---] =   [        . . |.   .] |  ;   (2)
C  [ 0 | I ][ C | 0 ][ 0 | I ]     [          * |* . *]--
C                                  [------------|-----]
C                                  [* . . . . * |     ]-|-
C                                  [.         . |  0  ] P
C                                  [* . . . . * |     ]-|-
C                                   |--- N ---|  |-M-|
C task = 4
C  Reduce A to a block diagonal form with eigenvalues in required order,
C  using a nonsingular real matrix U, and transform B and C accordingly,
C
C                                 |--[* . *       |* . *]--
C                                num [  . .       |* . *] |
C     -1                          |--[    *       |.   .] |
C  [ U  | 0 ][ A | B ][ U | 0 ]      [      * . * |.   .] N
C  [----|---][---|---][---|---] =    [        . . |.   .] | .   (3)
C  [ 0  | I ][ C | 0 ][ 0 | I ]      [          * |* . *]--
C                                    [------------|-----]
C                                    [* . . . . * |     ]-|-
C                                    [.         . |  0  ] P
C                                    [* . . . . * |     ]-|-
C                                     |--- N ---|  |-M-|
C
C Input parameters:
C   task  - integer option to indicate which transformation is needed:
C           = 1 : do balancing;
C           = 2 : compute the transformation (1);
C           = 3 : compute the transformation (2);
C           = 4 : compute the transformation (3).
C   A     - real N-by-N state matrix.
C   B     - real N-by-M input matrix.
C   C     - real P-by-N output matrix.
C   job   - (for task = 1 only: optional) integer option parameter:
C           job = 1  : balancing involves the matrix A only.
C           job = 2  : balancing involves the matrices A and B.
C           job = 3  : balancing involves the matrices A and C.
C           otherwise, balancing involves all matrices A, B, and C.
C           default:  job = 0;
C   flag  - (optional) integer vector containing options.
C           task = 1, 2 : flag is not used.
C           task = 3, 4 : flag is a vector of length 2
C              flag(1) = 0 : the system is continuous-time (default),
C                            otherwise, the system is discrete-time.
C              flag(2) = 0 : reorder the stable eigenvalues of A on the
C                            top left diagonal block (default),
C                            otherwise, reorder the unstable eigenvalues
C                            on the top left diagonal block.
C   par   - (optional) real parameter specifying the following values:
C           task = 1    : the maximum allowed reduction in the 1-norm of
C                         S if zero rows or columns are encountered;
C                         default:  par = 10;
C           task = 2    : not used.
C           task = 3, 4 : the stability or instability boundary for the
C                         eigenvalues of A of interest. For the
C                         discrete-time case, par >= 0 represents the
C                         boundary value for the moduli of eigenvalues.
C             default:    -sqrt(epsilon_machine) for continuous-time;
C                      1.0-sqrt(epsilon_machine) for discrete-time.
C
C Output parameters:
C   A     - transformed state matrix.
C   B     - transformed input matrix.
C   C     - transformed output matrix.
C   num   - (optional) integer counting for the number of the required
C           eigenvalues, or, equivalently, the size of the diagonal
C           block containing the required eigenvalues. If task = 1, 2,
C           num is not available.
C   ev    - (optional) complex vector of length N, containing the
C           eigenvalues of A, possibly in the required order.
C           When task = 1, ev is not available.
C   U     - (optional) nonsingular matrix which performs the
C           transformations.
C           task = 1    : U is N-by-1 storing the diagonal elements
C                         of D.
C           task = 2, 3 : U is orthogonal.
C           task = 4    : U is nonsingular.
C
C Contributor:
C   H. Xu, TU Chemnitz, FR Germany, Dec. 1998
C
C Revisions:
C   V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Apr. 2009,
C   Dec. 2012.
C
C **********************************************************************
C
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         DICO, JOB, STDOM
      INTEGER           INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, P
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      DOUBLE PRECISION, ALLOCATABLE :: A(:,:), B(:,:), C(:,:), DWORK(:),
     $                                 U(:,:), V(:), WR(:), WI(:)
      COMPLEX*16,       ALLOCATABLE :: EV(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      INTEGER           FLAG(2), I, IJOB, IP, ISIZE, NUM, TASK
      DOUBLE PRECISION  FLAGR(2), PAR, RNUM, TEMP
C
C .. External functions ..
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH
C
C .. External subroutines ..
      EXTERNAL          TB01ID, TB01KD, TB01LD, TB01WD
C
C ..Intrinsic functions..
      INTRINSIC         DCMPLX, MAX, SQRT
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'SYSTRA requires at least 4 input arguments' )
      ELSE IF ( NLHS.GT.6 ) THEN
         CALL mexErrMsgTxt
     $        ( 'SYSTRA requires at most 6 output arguments' )
      END IF
C
C Check dimensions of input parameters and read/set scalar parameters.
C
C   task
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
      IF ( TASK.LT.1 .OR. TASK.GT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'TASK has 1 ... 4 the only admissible values' )
      END IF
C
C   A(NxN), B(NxM), C(PxN)
C
      N = mxGetM( PRHS(2) )
      M = mxGetN( PRHS(3) )
      P = mxGetM( PRHS(4) )
C
      IF ( mxGetN( PRHS(2) ).NE.N ) THEN
         CALL mexErrMsgTxt( 'A must be a square matrix' )
      END IF
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a real matrix' )
      END IF
C
      IF ( mxGetM( PRHS(3) ).NE.N ) THEN
         CALL mexErrMsgTxt
     $        ( 'B must have the same row dimension as A' )
      END IF
      IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'B must be a real matrix' )
      END IF
C
      IF ( mxGetN( PRHS(4) ).NE.N ) THEN
         CALL mexErrMsgTxt
     $        ( 'C must have the same column dimension as A' )
      END IF
      IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(4) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'C must be a real matrix' )
      END IF
C
      FLAG(1) = 0
      IF ( TASK.EQ.1 ) THEN
         IJOB = 0
         PAR  = ZERO
      ELSE IF ( TASK.GE.3 ) THEN
         FLAG(2) = 0
         PAR = -SQRT( DLAMCH( 'Epsilon' ) )
      END IF
      IF ( NRHS.GE.5 ) THEN
         ISIZE = mxGetM( PRHS(5) ) * mxGetN( PRHS(5) )
         IF ( TASK.EQ.1 ) THEN
C
C   job
C
            IF ( ISIZE.GT.1 )
     $         CALL mexErrMsgTxt( 'JOB must be a scalar' )
            IF ( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(5) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'JOB must be an integer scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), TEMP, ISIZE )
            IF ( ISIZE.GT.0 ) IJOB = TEMP
         ELSE IF ( TASK.GE.3 ) THEN
C
C   flag
C
            IF ( ISIZE.GT.2 )
     $         CALL mexErrMsgTxt
     $              ( 'FLAG must be a vector with at most 2 elements' )
            IF ( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(5) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'FLAG must be an integer vector' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), FLAGR, ISIZE )
            IF ( ISIZE.GT.0 ) FLAG(1) = FLAGR(1)
            IF ( ISIZE.GT.1 ) FLAG(2) = FLAGR(2)
            IF ( FLAG(1).NE.0 )
     $         PAR = ONE + PAR
         END IF
C
         IF ( NRHS.GE.6 ) THEN
            IF ( TASK.NE.2 ) THEN
               ISIZE = mxGetM( PRHS(6) ) * mxGetN( PRHS(6) )
C
C   par
C
               IF ( ISIZE.GT.1 )
     $            CALL mexErrMsgTxt( 'PAR must be a scalar' )
               IF ( mxIsNumeric( PRHS(6) ).EQ.0 .OR.
     $              mxIsComplex( PRHS(6) ).EQ.1 ) THEN
                  CALL mexErrMsgTxt( 'PAR must be a real scalar' )
               END IF
               CALL mxCopyPtrToReal8( mxGetPr( PRHS(6) ), TEMP, ISIZE )
               IF ( ISIZE.GT.0 ) PAR = TEMP
            END IF
         END IF
      END IF
C
C Determine the lenghts of working arrays.
C Use a larger value for LDWORK for enabling calls of block algorithms
C in DGEES. LDWORK >= N*MAX( 3, M, P ) will allow to use BLAS 3.
C
      LDWORK = MAX( 1, 3*N )
C
      LDA = MAX( 1, N )
      LDB = LDA
      LDC = MAX( 1, P )
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE( A( LDA, N ), B( LDB, M ), C( LDC, N ) )
C
      IF ( TASK.EQ.1 ) THEN
         ALLOCATE( V( N ) )
      ELSE
         LDU = LDA
         ALLOCATE( U( LDU, N ), WR( N ), WI( N ), DWORK( LDWORK ) )
         ALLOCATE( EV( N ) )
      END IF
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), A, N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), B, N*M )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), C, P*N )
C
C Do the actual computations.
C
      IF ( TASK.EQ.1 ) THEN
         IF ( IJOB.EQ.1 ) THEN
            JOB = 'N'
         ELSE IF ( IJOB.EQ.2 ) THEN
            JOB = 'B'
         ELSE IF ( IJOB.EQ.3 ) THEN
            JOB = 'C'
         ELSE
            JOB = 'A'
         END IF
         CALL TB01ID( JOB, N, M, P, PAR, A, LDA, B, LDB, C, LDC, V,
     $                INFO )
      ELSE IF ( TASK.EQ.2 ) THEN
         CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, WR, WI,
     $                DWORK, LDWORK, INFO )
      ELSE
         IF ( FLAG(1).EQ.0 ) THEN
            DICO = 'C'
         ELSE
            DICO = 'D'
         END IF
         IF ( FLAG(2).EQ.0 ) THEN
            STDOM = 'S'
         ELSE
            STDOM = 'U'
         END IF
C
         IF ( TASK.EQ.3 ) THEN
            CALL TB01LD( DICO, STDOM, 'G', N, M, P, PAR, A, LDA, B, LDB,
     $                   C, LDC, NUM, U, LDU, WR, WI, DWORK, LDWORK,
     $                   INFO )
         ELSE
            CALL TB01KD( DICO, STDOM, 'G', N, M, P, PAR, A, LDA, B, LDB,
     $                   C, LDC, NUM, U, LDU, WR, WI, DWORK, LDWORK,
     $                   INFO )
         END IF
      END IF
C
C Copy output to MATLAB workspace.
C
      IF ( INFO.EQ.0 ) THEN
         IF ( NLHS.GE.1 ) THEN
            PLHS(1) = mxCreateDoubleMatrix( N, N, 0 )
            CALL mxCopyReal8ToPtr( A, mxGetPr( PLHS(1) ), N*N )
         END IF
         IF ( NLHS.GE.2 ) THEN
            PLHS(2) = mxCreateDoubleMatrix( N, M, 0 )
            CALL mxCopyReal8ToPtr( B, mxGetPr( PLHS(2) ), N*M )
         END IF
         IF ( NLHS.GE.3 ) THEN
            PLHS(3) = mxCreateDoubleMatrix( P, N, 0 )
            CALL mxCopyReal8ToPtr( C, mxGetPr( PLHS(3) ), P*N )
         END IF
         IF ( NLHS.GE.4 ) THEN
            IP = 4
            IF ( TASK.EQ.1 ) THEN
               PLHS(4) = mxCreateDoubleMatrix( N, 1, 0 )
               CALL mxCopyReal8ToPtr( V, mxGetPr( PLHS(4) ), N )
            ELSE IF ( TASK.GE.3 ) THEN
               PLHS(4) = mxCreateDoubleMatrix( 1, 1, 0 )
               RNUM = NUM
               CALL mxCopyReal8ToPtr( RNUM, mxGetPr( PLHS(4) ), 1 )
               IP = IP + 1
            END IF
            IF ( TASK.GE.2 ) THEN
               IF ( NLHS.GE.IP ) THEN
                  DO 10 I = 1, N
                     EV(I) = DCMPLX( WR(I), WI(I) )
   10             CONTINUE
                  PLHS(IP) = mxCreateDoubleMatrix( N, 1, 1 )
                  CALL mxCopyComplex16ToPtr( EV, mxGetPr( PLHS(IP) ),
     $                                       mxGetPi( PLHS(IP) ), N )
                  IP = IP + 1
                  IF ( NLHS.GE.IP ) THEN
                     PLHS(IP) = mxCreateDoubleMatrix( N, N, 0 )
                     CALL mxCopyReal8ToPtr( U, mxGetPr( PLHS(IP) ),
     $                                      N*N )
                  END IF
               END IF
            END IF
         END IF
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
      IF ( TASK.EQ.1 ) THEN
         DEALLOCATE( A, B, C, V )
      ELSE
         DEALLOCATE( A, B, C, U, WR, WI, EV, DWORK )
      END IF
C
C Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
         IF ( TASK.EQ.1 ) THEN
            WRITE( TEXT,'('' INFO = '',I4,'' ON EXIT FROM TB01ID'')' )
     $         INFO
         ELSE IF ( TASK.EQ.2 ) THEN
            WRITE( TEXT,'('' INFO = '',I4,'' ON EXIT FROM TB01WD'')' )
     $         INFO
         ELSE IF ( TASK.EQ.3 ) THEN
            WRITE( TEXT,'('' INFO = '',I4,'' ON EXIT FROM TB01LD'')' )
     $         INFO
         ELSE
            WRITE( TEXT,'('' INFO = '',I4,'' ON EXIT FROM TB01KD'')' )
     $         INFO
         END IF
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C
C *** Last line of SYSTRA ***
      END


module types
implicit none
integer, parameter      :: dp = selected_real_kind(P=15)
end module types

!--------------------------------------------------------------------------------
!       About this code
!--------------------------------------------------------------------------------
!
! This code computes Mie's light scattering solution by using the Debye series,
! instead of Lorenz-Mie series.
! The basic structure of this code follows the BHMIE code by B.T.Draine:
!  https://www.astro.princeton.edu/~draine/scattering.html
! but it was modified to improve its accuracy and convergence by RT.
!
! The Debye series can "exactly" decompose the Lorenz-Mie series into
! various scattering components, such as diffraction, reflection, and
! refraction (including (np+1) internal refraction).
! See also Appendix A in Tazaki et al. (2021) for more detail.
!
! In this code, I adopted the algorithm developed by
!        Shen & Wang (2010, ApOpt, 49, 2422),
! where they developed a stable algorithm for computing highly absorbing
! sphere as well as non-absorbing sphere.
!
!                                                  Ryo Tazaki (2020/June/19)
!
!--------------------------------------------------------------------------------
!       Input parameters
!--------------------------------------------------------------------------------
!
! x               : size parameter of a sphere
! refrel          : complex refractive index
! nang            : number of scattering angles from 0 to 90 deg.
! ical            : switch for the Debye series calculation
!                   ical = 0 : Series are summed upto the infinite term.
!                              Returned S1p, S2p contains values for 0 ~ np terms.
!                   ical = 1 : Series are terminated at np.
!                              Returned S1p,S2p contains values for 0 ~ np terms.
! np              : Terms to be computed in the debye series terms (np >= 0).
!                       np=0 : Fraunhofer diffraction and reflected light.
!                       np=1 : Secondary refracted light
!                       np=2 : Tertially refracted light (one internal reflection)
!                         ...
!
!--------------------------------------------------------------------------------
!       Output parameters
!--------------------------------------------------------------------------------
!
! S1(2*nang-1),   : Mie scattering amplitude at each scattering angles
! S2(2*nang-1)
! S1p(p,2*nang-1) : Mie scattering amplitude of p-th order scattered wave
! S2p(p,2*nang-1)   at each scattering angles. For example, p=0 contains
!                   the amplitude of Fraunhofer diffraction + surface
!                   reflected light, p=1 does that of twice refracted light.
! Qext,Qsca,Qback : Extinction, scattering, back scattering efficiency
! gsca            : Asymmetry parameter
!
!--------------------------------------------------------------------------------
subroutine debye_series_rt(x,refrel,nang,ical,np,S1,S2,S1p,S2p,Qext,Qsca,Qback,gsca)
use types
implicit none

!--------------------------------------------------------------------------------
!       Input variables
!--------------------------------------------------------------------------------
real(kind=dp)                               :: x       ! size parameter
complex(kind=dp)                            :: refrel  ! refractive index
integer                                     :: nang    ! number of angle mesh
integer                                     :: ical    ! Series termination switch
integer                                     :: np      ! Number of partial waves

!--------------------------------------------------------------------------------
!       Output variables
!--------------------------------------------------------------------------------

complex(kind=dp),dimension(1:2*nang-1)      :: S1,S2   ! Mie scattering amplitude
complex(kind=dp),dimension(0:np,1:2*nang-1) :: S1p,S2p ! Partial wave sca. amplitude
real(kind=dp)                               :: qext    ! Qext
real(kind=dp)                               :: qsca    ! Qsca
real(kind=dp)                               :: gsca    ! <cos>
real(kind=dp)                               :: qback   ! Qback

!--------------------------------------------------------------------------------
!       Local variables
!--------------------------------------------------------------------------------
complex(kind=dp),parameter:: ivec=cmplx(0.0_dp,1.0_dp)
real(kind=dp),parameter   :: floorval=1.0e-30_dp
integer::j,jj,n,nn,nstop,nmx,ip,iq
real(kind=dp)::nu,d1x_ini
real(kind=dp)::xstop,ymod,en,fn,p,fnq_diff,dang,pii,theta
real(kind=dp)::realpart,imagpart
real(kind=dp),allocatable,dimension(:)::ajx
real(kind=dp),dimension(1:nang)::amu,pi0,pi1,pi,tau
complex(kind=dp)::y,d1y_ini,xi1,xi,dpcx
complex(kind=dp)::An13yy,An31yy,u0,u11,u31,u13,u33,Tn,R212n,R121n,umR212n,umR121n
complex(kind=dp)::an,bn,an1,bn1,fnq(2),fnqp(2,0:np),alpha(2),beta(2),R121n_power
complex(kind=dp),allocatable,dimension(:)::An13xx,lnAn13yy,w31,ajy
complex(kind=dp),allocatable,dimension(:,:)::d1,d3
realpart(dpcx)=(dble(dpcx))
imagpart(dpcx)=(dimag(dpcx))

! some checks...
y     = refrel*x
ymod  = abs(y)
xstop = x + 4.05_dp * x ** (1.0/3.0) + 2.0_dp
nstop = nint(xstop)
nmx   = nint(max(xstop,ymod)) + 15

! check numbers of ray-expansion:
if(np .lt. 0) then
        print *, 'error : negative np is detected.'
        print *, '        np should be positive. STOP!'
        stop
endif

! check calculation model:
if(ical .ne. 0 .and. ical .ne. 1) then
        print *, 'error: incorrect calculation mode: ical = ',ical
        print *, '       ical should be either 0 or 1. STOP!'
        stop
endif

! check refractive index
if(real(refrel) .lt. 1.0_dp) then
        print *, 'Now, the real part of the refractive index is ',real(refrel)
        print *, ', which is less than unity. In this case, this code cannot'
        print *, 'correctly decompose reflection/refraction components, although'
        print *, 'infinite series sum may be correctly calculated.'
        print *, 'Safety stop!'
        stop
endif

!*** require nang.ge.1 in order to calculate scattering intensities
pii  = 4.0_dp*atan(1.0_dp)
dang = 0.0_dp
if(nang.gt.1)dang=0.5_dp*pii/real(nang-1,kind=dp)
do j=1,nang
        theta=real(j-1,kind=dp)*dang
        amu(j)=cos(theta)
enddo
do j=1,nang
        pi0(j)=0.0_dp
        pi1(j)=1.0_dp
enddo
nn=2*nang-1
do j=1,nn
        S1(j)=cmplx(0.0_dp,0.0_dp)
        S2(j)=cmplx(0.0_dp,0.0_dp)
        do ip=0,np
                S1p(ip,j)=cmplx(0.0_dp,0.0_dp)
                S2p(ip,j)=cmplx(0.0_dp,0.0_dp)
        enddo
enddo

!----------------------------------------------------------------------
! The Lentz's continued fraction method
! Reference: W. J. Lentz, Appl. Opt. 15. 668. (1976)
!
! Finding initial value of the logarithmic derivative "d" at
! the starting order of downward recurrence (n=nmx).
!----------------------------------------------------------------------
allocate(An13xx(0:nmx),lnAn13yy(0:nmx),d1(2,0:nmx),&
        d3(2,0:nmx),w31(0:nmx),ajx(1:nmx),ajy(1:nmx))

d1      = cmplx(0.0_dp,0.0_dp)
d3      = cmplx(0.0_dp,0.0_dp)
An13xx  = cmplx(0.0_dp,0.0_dp)
lnAn13yy= cmplx(0.0_dp,0.0_dp)

! Equation (5) in Lentz (1976):
nu = real(nmx,kind=dp)+0.5_dp
ajx(1) = 2.0_dp * nu / x
ajy(1) = 2.0_dp * nu / y
do j=2,nmx
        ajx(j) = (-1.0_dp) ** (j-1) * 2.0_dp*(nu+real(j-1,kind=dp)) / x
        ajy(j) = (-1.0_dp) ** (j-1) * 2.0_dp*(nu+real(j-1,kind=dp)) / y
enddo
d1x_ini = ajx(nmx)
d1y_ini = ajy(nmx)
do j=1,nmx-1
        d1x_ini = ajx(nmx-j) + 1.0_dp / d1x_ini
        d1y_ini = ajy(nmx-j) + 1.0_dp / d1y_ini
enddo
! Equation (3) in Lentz (1976):
d1(1,nmx)=-real(nmx,kind=dp)/x+d1x_ini
d1(2,nmx)=-real(nmx,kind=dp)/y+d1y_ini
! Usual downward recurrence:
do n=1,nmx
        en=real(nmx-n+1,kind=dp)
        d1(1,nmx-n) = (en/x) - (1.0_dp/(d1(1,nmx-n+1) + en/x))
        d1(2,nmx-n) = (en/y) - (1.0_dp/(d1(2,nmx-n+1) + en/y))
enddo
!calculate D(3)_n(x,or,mx) by upward recurrence.
d3(1,0)=ivec
d3(2,0)=ivec
w31 = cmplx(0.0_dp,0.0_dp)
w31(0) = -1.0/tan(y)+ivec
do n=1,nmx
        en=real(n,kind=dp)
        d3(1,n) = -(en/x) + (1.0_dp/(en/x - d3(1,n-1)))
        w31(n) = w31(n-1)/((d3(2,n-1)-en/y)*(d1(2,n-1)-en/y))
        d3(2,n) = d1(2,n) + w31(n)
enddo
!calculate A(13)_n(x) by upward recurrence.
An13xx(0)=2.0_dp/(1.0_dp-ivec/tan(x))
do n=1,nmx
        en = real(n,kind=dp)
        An13xx(n) = An13xx(n-1)*(d1(1,n-1)-en/x)/(d3(1,n-1)-en/x)
enddo
!calculate lnA(13)_n(y) by upward recurrence.
lnAn13yy(0)=2.0_dp*aimag(y)+log(exp(-2.0_dp*aimag(y))-exp(-ivec*2.0_dp*real(y)))
do n=1,nmx
        en = real(n,kind=dp)
        lnAn13yy(n) = lnAn13yy(n-1)+log((d1(2,n-1)-en/y)/(d3(2,n-1)-en/y))
enddo

fnq_diff = 0.5_dp       ! Fraunhofer diffraction
alpha(1) = refrel
alpha(2) = 1.0_dp
beta(1)  = 1.0_dp
beta(2)  = refrel
qsca     = 0.0_dp
gsca     = 0.0_dp
p        =-1.0_dp

!
! Start series summation.
!
! Comments on the termination order:
! Here, the series sum is truncated at the order 'nmx' rather than 'nstop'.
! This is because nstop is not enough to attain convergence for high order
! scattered waves (large p).
! The Debye series code written by P. Laven:
!       http://www.philiplaven.com/mieplot.htm
! seems to adopt nstop as the termination order, leading to
! the unconverged results for high order of p.
!
do n=1,nmx

        en = real(n,kind=dp)
        fn = (2.0_dp*en+1.0_dp)/(en*(en+1.0_dp))

        !*** store previous values of an and bn for use
        !    in computation of g=<cos(theta)>
        if(n.gt.1)then
                an1=an
                bn1=bn
        endif

        !initialize
        fnq  = cmplx(0.0_dp,0.0_dp)
        fnqp = cmplx(0.0_dp,0.0_dp)

        do iq=1,2

                ! Shen & Wang (2010b) updated algorithm.
                u0 = (d1(1,n)-d3(1,n))*(d1(2,n)-d3(2,n))
                u11 = alpha(iq) * d1(1,n) - beta(iq) * d1(2,n)
                u31 = alpha(iq) * d3(1,n) - beta(iq) * d1(2,n)
                u13 = alpha(iq) * d1(1,n) - beta(iq) * d3(2,n)
                u33 = alpha(iq) * d3(1,n) - beta(iq) * d3(2,n)

                ! z=|z|e^{i*theta}: complex
                ! --> ln(z) = ln|z| + i * theta
                !     ln|z| = Re(ln(z))
                if(real(lnAn13yy(n)) .lt. 0.0_dp .or. aimag(refrel) .eq. 0.0_dp) then
                        An13yy = exp(lnAn13yy(n))
                        Tn = refrel * An13xx(n) * An13yy * u0
                        Tn = Tn / (u33-An13yy*u31)**2.0_dp
                        umR212n=An13xx(n)*(u13-An13yy*u11)/&
                                (u33-An13yy*u31)
                        umR121n=-An13yy*u31/(u33-An13yy*u31)
                        R212n=1.0_dp-An13xx(n)*(u13-An13yy*u11)/&
                                (u33-An13yy*u31)
                        R121n=1.0_dp+An13yy*u31/(u33-An13yy*u31)
                else
                        An31yy = exp(-lnAn13yy(n))
                        Tn = refrel*An13xx(n)*An31yy*u0
                        Tn = Tn / (An31yy*u33-u31)**2.0_dp
                        umR212n = An13xx(n)*(An31yy*u13-u11)/&
                                (An31yy*u33-u31)
                        umR121n = -u31/(An31yy*u33-u31)
                        R212n = 1.0_dp-An13xx(n)*(An31yy*u13-u11)/&
                                (An31yy*u33-u31)
                        R121n = 1.0_dp+u31/(An31yy*u33-u31)
                endif

                ! In this code, p=0 is defined such that
                ! diffraction + Fresnel reflection
                fnqp(iq,0)  = fnq_diff * umR212n

                ! For an optically thick grain, R121n^{ip-1} or fnqp
                ! often causes underflows, so it is safe to set
                ! some floor values for them.
                R121n_power = cmplx(1.0_dp,0.0_dp)
                do ip=1,np
                fnqp(iq,ip) = - 0.5_dp * Tn * R121n_power
                R121n_power = R121n_power * R121n
                if(abs(fnqp(iq,ip)) .le. floorval) fnqp(iq,ip) = cmplx(0.0_dp,0.0_dp)
                if(abs(R121n_power) .le. floorval) exit
                enddo

                if(ical .eq. 0) then
                        fnq(iq) = fnq_diff * (umR212n - Tn / umR121n)
                elseif(ical .eq. 1) then
                        do ip=0,np
                        fnq(iq) = fnq(iq) + fnqp(iq,ip)
                        enddo
                endif
        enddo

        an = fnq(1)
        bn = fnq(2)

        !*** augment sums for qsca and g=<cos(theta)>
        qsca=qsca+(2.0_dp*en+1.0_dp)*(abs(an)**2.0+abs(bn)**2.0)
        gsca=gsca+((2.0_dp*en+1.0_dp)/(en*(en+1.0_dp)))*&
        &        (realpart(an)*realpart(bn)+imagpart(an)*imagpart(bn))
        if(n.gt.1)then
            gsca=gsca+((en-1.0_dp)*(en+1.0_dp)/en)*&
        &      (realpart(an1)*realpart(an)+imagpart(an1)*imagpart(an)+&
        &      realpart(bn1)*realpart(bn)+imagpart(bn1)*imagpart(bn))
        endif

        !c*** now calculate scattering intensity pattern
        !    first do angles from 0 to 90
        do j=1,nang
                jj=2*nang-j
                pi(j)=pi1(j)
                tau(j)=en*amu(j)*pi(j)-(en+1.0_dp)*pi0(j)
                S1(j)=S1(j)+fn*(an*pi(j)+bn*tau(j))
                S2(j)=S2(j)+fn*(an*tau(j)+bn*pi(j))
                !
                if(ical .ge. 0) then
                        do ip=0,np
                                S1p(ip,j) = S1p(ip,j) + fn*(fnqp(1,ip)*pi(j)+fnqp(2,ip)*tau(j))
                                S2p(ip,j) = S2p(ip,j) + fn*(fnqp(1,ip)*tau(j)+fnqp(2,ip)*pi(j))
                        enddo
                endif
        enddo

        !*** now do angles greater than 90 using pi and tau from
        !    angles less than 90.
        !    p=1 for n=1,3,...; p=-1 for n=2,4,...
        p=-p
        do j=1,nang-1
                jj=2*nang-j
                S1(jj)=S1(jj)+fn*p*(an*pi(j)-bn*tau(j))
                S2(jj)=S2(jj)+fn*p*(bn*pi(j)-an*tau(j))
                !
                if(ical .ge. 0) then
                do ip=0,np
                S1p(ip,jj) = S1p(ip,jj) + fn*p*(fnqp(1,ip)*pi(j)-fnqp(2,ip)*tau(j))
                S2p(ip,jj) = S2p(ip,jj) + fn*p*(fnqp(2,ip)*pi(j)-fnqp(1,ip)*tau(j))
                enddo
                endif
        enddo

        !*** compute pi_n for next value of n
        !    for each angle j, compute pi_n+1
        !    from pi = pi_n , pi0 = pi_n-1
        do j=1,nang
                pi1(j)=((2.0_dp*en+1.0_dp)*amu(j)*pi(j)-(en+1.0_dp)*pi0(j))/en
                pi0(j)=pi(j)
        enddo
enddo

!*** have summed sufficient terms.
!    now compute qsca,qext,qback,and gsca
gsca=2.0_dp*gsca/qsca
qsca=(2.0_dp/(x*x))*qsca
qext=(4.0_dp/(x*x))*realpart(S1(1))
qback=(4.0_dp*(ABS(S1(2*NANG-1))/x)**2.0_dp)

deallocate(An13xx,lnAn13yy,d1,d3,w31,ajx,ajy)

return
end subroutine debye_series_rt


!> \brief \b SCNRM2
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       REAL FUNCTION SCNRM2(N,X,INCX)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       COMPLEX X(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SCNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!>    SCNRM2 := sqrt( x**H*x )
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is COMPLEX array, dimension (N)
!>         complex vector with N elements
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER, storage spacing between elements of X
!>          If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!>          If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!>          If INCX = 0, x isn't a vector so there is no need to call
!>          this subroutine.  If you call it anyway, it will count x(1)
!>          in the vector norm N times.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date August 2016
!
!> \ingroup single_blas_level1
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!>
!  =====================================================================
function SCNRM2( n, x, incx )
   integer, parameter :: wp = kind(1.e0)
   real(wp) :: SCNRM2
!
!  -- Reference BLAS level1 routine (version 3.9.1) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     March 2021
!
!  .. Constants ..
   real(wp), parameter :: zero = 0.0_wp
   real(wp), parameter :: one  = 1.0_wp
   real(wp), parameter :: maxN = huge(0.0_wp)
!  ..
!  .. Blue's ccaling constants ..
   real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( &
       (minexponent(0._wp) - 1) * 0.5_wp)
   real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( &
       (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)
   real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( &
       (minexponent(0._wp) - 1) * 0.5_wp))
   real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( &
       (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp))
!  ..
!  .. Scalar Arguments ..
   integer :: incx, n
!  ..
!  .. Array Arguments ..
   complex(wp) :: x(*)
!  ..
!  .. Local Scalars ..
   integer :: i, ix
   logical :: notbig
   real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
!
!  Quick return if possible
!
   SCNRM2 = zero
   if( n <= 0 ) return
!
   scl = one
   sumsq = zero
!
!  Compute the sum of squares in 3 accumulators:
!     abig -- sums of squares scaled down to avoid overflow
!     asml -- sums of squares scaled up to avoid underflow
!     amed -- sums of squares that do not require scaling
!  The thresholds and multipliers are
!     tbig -- values bigger than this are scaled down by sbig
!     tsml -- values smaller than this are scaled up by ssml
!
   notbig = .true.
   asml = zero
   amed = zero
   abig = zero
   ix = 1
   if( incx < 0 ) ix = 1 - (n-1)*incx
   do i = 1, n
      ax = abs(real(x(ix)))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ax = abs(aimag(x(ix)))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ix = ix + incx
   end do
!
!  Combine abig and amed or amed and asml if more than one
!  accumulator was used.
!
   if (abig > zero) then
!
!     Combine abig and amed if abig > 0.
!
      if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
         abig = abig + (amed*sbig)*sbig
      end if
      scl = one / sbig
      sumsq = abig
   else if (asml > zero) then
!
!     Combine amed and asml if asml > 0.
!
      if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
         amed = sqrt(amed)
         asml = sqrt(asml) / ssml
         if (asml > amed) then
            ymin = amed
            ymax = asml
         else
            ymin = asml
            ymax = amed
         end if
         scl = one
         sumsq = ymax**2*( one + (ymin/ymax)**2 )
      else
         scl = one / ssml
         sumsq = asml
      end if
   else
!
!     Otherwise all values are mid-range
!
      scl = one
      sumsq = amed
   end if
   SCNRM2 = scl*sqrt( sumsq )
   return
end function

!> \brief \b SNRM2
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       REAL FUNCTION SNRM2(N,X,INCX)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       REAL X(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!>    SNRM2 := sqrt( x'*x ).
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER, storage spacing between elements of X
!>          If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!>          If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!>          If INCX = 0, x isn't a vector so there is no need to call
!>          this subroutine.  If you call it anyway, it will count x(1)
!>          in the vector norm N times.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date August 2016
!
!> \ingroup single_blas_level1
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!>
!  =====================================================================
function SNRM2( n, x, incx )
   integer, parameter :: wp = kind(1.e0)
   real(wp) :: SNRM2
!
!  -- Reference BLAS level1 routine (version 3.9.1) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     March 2021
!
!  .. Constants ..
   real(wp), parameter :: zero = 0.0_wp
   real(wp), parameter :: one  = 1.0_wp
   real(wp), parameter :: maxN = huge(0.0_wp)
!  ..
!  .. Blue's ccaling constants ..
   real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( &
       (minexponent(0._wp) - 1) * 0.5_wp)
   real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( &
       (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)
   real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( &
       (minexponent(0._wp) - 1) * 0.5_wp))
   real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( &
       (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp))
!  ..
!  .. Scalar Arguments ..
   integer :: incx, n
!  ..
!  .. Array Arguments ..
   real(wp) :: x(*)
!  ..
!  .. Local Scalars ..
   integer :: i, ix
   logical :: notbig
   real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
!
!  Quick return if possible
!
   SNRM2 = zero
   if( n <= 0 ) return
!
   scl = one
   sumsq = zero
!
!  Compute the sum of squares in 3 accumulators:
!     abig -- sums of squares scaled down to avoid overflow
!     asml -- sums of squares scaled up to avoid underflow
!     amed -- sums of squares that do not require scaling
!  The thresholds and multipliers are
!     tbig -- values bigger than this are scaled down by sbig
!     tsml -- values smaller than this are scaled up by ssml
!
   notbig = .true.
   asml = zero
   amed = zero
   abig = zero
   ix = 1
   if( incx < 0 ) ix = 1 - (n-1)*incx
   do i = 1, n
      ax = abs(x(ix))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ix = ix + incx
   end do
!
!  Combine abig and amed or amed and asml if more than one
!  accumulator was used.
!
   if (abig > zero) then
!
!     Combine abig and amed if abig > 0.
!
      if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
         abig = abig + (amed*sbig)*sbig
      end if
      scl = one / sbig
      sumsq = abig
   else if (asml > zero) then
!
!     Combine amed and asml if asml > 0.
!
      if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
         amed = sqrt(amed)
         asml = sqrt(asml) / ssml
         if (asml > amed) then
            ymin = amed
            ymax = asml
         else
            ymin = asml
            ymax = amed
         end if
         scl = one
         sumsq = ymax**2*( one + (ymin/ymax)**2 )
      else
         scl = one / ssml
         sumsq = asml
      end if
   else
!
!     Otherwise all values are mid-range
!
      scl = one
      sumsq = amed
   end if
   SNRM2 = scl*sqrt( sumsq )
   return
end function

!> \brief \b SROTG
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!  SROTG constructs a plane rotation
!     [  c  s ] [ a ] = [ r ]
!     [ -s  c ] [ b ]   [ 0 ]
!  satisfying c**2 + s**2 = 1.
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> The computation uses the formulas
!>    sigma = sgn(a)    if |a| >  |b|
!>          = sgn(b)    if |b| >= |a|
!>    r = sigma*sqrt( a**2 + b**2 )
!>    c = 1; s = 0      if r = 0
!>    c = a/r; s = b/r  if r != 0
!> The subroutine also computes
!>    z = s    if |a| > |b|,
!>      = 1/c  if |b| >= |a| and c != 0
!>      = 1    if c = 0
!> This allows c and s to be reconstructed from z as follows:
!>    If z = 1, set c = 0, s = 1.
!>    If |z| < 1, set c = sqrt(1 - z**2) and s = z.
!>    If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2).
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in,out] A
!> \verbatim
!>          A is REAL
!>          On entry, the scalar a.
!>          On exit, the scalar r.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL
!>          On entry, the scalar b.
!>          On exit, the scalar z.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is REAL
!>          The scalar c.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is REAL
!>          The scalar s.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
!  =====================================================================
subroutine SROTG( a, b, c, s )
   integer, parameter :: wp = kind(1.e0)
!
!  -- Reference BLAS level1 routine --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
!  .. Constants ..
   real(wp), parameter :: zero = 0.0_wp
   real(wp), parameter :: one  = 1.0_wp
!  ..
!  .. Scaling constants ..
   real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( &
      minexponent(0._wp)-1, &
      1-maxexponent(0._wp) &
   )
   real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( &
      1-minexponent(0._wp), &
      maxexponent(0._wp)-1 &
   )
!  ..
!  .. Scalar Arguments ..
   real(wp) :: a, b, c, s
!  ..
!  .. Local Scalars ..
   real(wp) :: anorm, bnorm, scl, sigma, r, z
!  ..
   anorm = abs(a)
   bnorm = abs(b)
   if( bnorm == zero ) then
      c = one
      s = zero
      b = zero
   else if( anorm == zero ) then
      c = zero
      s = one
      a = b
      b = one
   else
      scl = min( safmax, max( safmin, anorm, bnorm ) )
      if( anorm > bnorm ) then
         sigma = sign(one,a)
      else
         sigma = sign(one,b)
      end if
      r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) )
      c = a/r
      s = b/r
      if( anorm > bnorm ) then
         z = s
      else if( c /= zero ) then
         z = one/c
      else
         z = one
      end if
      a = r
      b = z
   end if
   return
end subroutine

!> \brief \b SLARTG generates a plane rotation with real cosine and real sine.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLARTG( F, G, C, S, R )
!
!       .. Scalar Arguments ..
!       REAL(wp)          C, F, G, R, S
!       ..
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLARTG generates a plane rotation so that
!>
!>    [  C  S  ]  .  [ F ]  =  [ R ]
!>    [ -S  C  ]     [ G ]     [ 0 ]
!>
!> where C**2 + S**2 = 1.
!>
!> The mathematical formulas used for C and S are
!>    R = sign(F) * sqrt(F**2 + G**2)
!>    C = F / R
!>    S = G / R
!> Hence C >= 0. The algorithm used to compute these quantities
!> incorporates scaling to avoid overflow or underflow in computing the
!> square root of the sum of squares.
!>
!> This version is discontinuous in R at F = 0 but it returns the same
!> C and S as SLARTG for complex inputs (F,0) and (G,0).
!>
!> This is a more accurate version of the BLAS1 routine SROTG,
!> with the following other differences:
!>    F and G are unchanged on return.
!>    If G=0, then C=1 and S=0.
!>    If F=0 and (G .ne. 0), then C=0 and S=sign(1,G) without doing any
!>       floating point operations (saves work in SBDSQR when
!>       there are zeros on the diagonal).
!>
!> If F exceeds G in magnitude, C will be positive.
!>
!> Below, wp=>sp stands for single precision from LA_CONSTANTS module.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] F
!> \verbatim
!>          F is REAL(wp)
!>          The first component of vector to be rotated.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!>          G is REAL(wp)
!>          The second component of vector to be rotated.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is REAL(wp)
!>          The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is REAL(wp)
!>          The sine of the rotation.
!> \endverbatim
!>
!> \param[out] R
!> \verbatim
!>          R is REAL(wp)
!>          The nonzero component of the rotated vector.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date July 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
subroutine SLARTG( f, g, c, s, r )
   use LA_CONSTANTS, &
   only: wp=>sp, zero=>szero, half=>shalf, one=>sone, &
         rtmin=>srtmin, rtmax=>srtmax, safmin=>ssafmin, safmax=>ssafmax
!
!  -- LAPACK auxiliary routine (version 3.10.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     February 2021
!
!  .. Scalar Arguments ..
   real(wp) :: c, f, g, r, s
!  ..
!  .. Local Scalars ..
   real(wp) :: d, f1, fs, g1, gs, p, u, uu
!  ..
!  .. Intrinsic Functions ..
   intrinsic :: abs, sign, sqrt
!  ..
!  .. Executable Statements ..
!
   f1 = abs( f )
   g1 = abs( g )
   if( g == zero ) then
      c = one
      s = zero
      r = f
   else if( f == zero ) then
      c = zero
      s = sign( one, g )
      r = g1
   else if( f1 > rtmin .and. f1 < rtmax .and. &
            g1 > rtmin .and. g1 < rtmax ) then
      d = sqrt( f*f + g*g )
      p = one / d
      c = f1*p
      s = g*sign( p, f )
      r = sign( d, f )
   else
      u = min( safmax, max( safmin, f1, g1 ) )
      uu = one / u
      fs = f*uu
      gs = g*uu
      d = sqrt( fs*fs + gs*gs )
      p = one / d
      c = abs( fs )*p
      s = gs*sign( p, f )
      r = sign( d, f )*u
   end if
   return
end subroutine

!> \brief \b SLASSQ updates a sum of squares represented in scaled form.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLASSQ + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )
!
!       .. Scalar Arguments ..
!       INTEGER            INCX, N
!       REAL               SCALE, SUMSQ
!       ..
!       .. Array Arguments ..
!       REAL               X( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLASSQ  returns the values  scl  and  smsq  such that
!>
!>    ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
!>
!> where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
!> assumed to be non-negative and  scl  returns the value
!>
!>    scl = max( scale, abs( x( i ) ) ).
!>
!> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively.
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of elements to be used from the vector x.
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is REAL array, dimension (1+(N-1)*abs(INCX))
!>          The vector for which a scaled sum of squares is computed.
!>             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>          The increment between successive values of the vector x.
!>          If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!>          If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!>          If INCX = 0, x isn't a vector so there is no need to call
!>          this subroutine.  If you call it anyway, it will count x(1)
!>          in the vector norm N times.
!> \endverbatim
!>
!> \param[in,out] SCALE
!> \verbatim
!>          SCALE is REAL
!>          On entry, the value  scale  in the equation above.
!>          On exit, SCALE is overwritten with  scl , the scaling factor
!>          for the sum of squares.
!> \endverbatim
!>
!> \param[in,out] SUMSQ
!> \verbatim
!>          SUMSQ is REAL
!>          On entry, the value  sumsq  in the equation above.
!>          On exit, SUMSQ is overwritten with  smsq , the basic sum of
!>          squares from which  scl  has been factored out.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!> Nick Papior, Technical University of Denmark, DK
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!
!> \ingroup OTHERauxiliary
!
!  =====================================================================
subroutine SLASSQ( n, x, incx, scl, sumsq )
   use LA_CONSTANTS, &
      only: wp=>sp, zero=>szero, one=>sone, &
            sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml
   use LA_XISNAN
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
!  .. Scalar Arguments ..
   integer :: incx, n
   real(wp) :: scl, sumsq
!  ..
!  .. Array Arguments ..
   real(wp) :: x(*)
!  ..
!  .. Local Scalars ..
   integer :: i, ix
   logical :: notbig
   real(wp) :: abig, amed, asml, ax, ymax, ymin
!  ..
!
!  Quick return if possible
!
   if( LA_ISNAN(scl) .or. LA_ISNAN(sumsq) ) return
   if( sumsq == zero ) scl = one
   if( scl == zero ) then
      scl = one
      sumsq = zero
   end if
   if (n <= 0) then
      return
   end if
!
!  Compute the sum of squares in 3 accumulators:
!     abig -- sums of squares scaled down to avoid overflow
!     asml -- sums of squares scaled up to avoid underflow
!     amed -- sums of squares that do not require scaling
!  The thresholds and multipliers are
!     tbig -- values bigger than this are scaled down by sbig
!     tsml -- values smaller than this are scaled up by ssml
!
   notbig = .true.
   asml = zero
   amed = zero
   abig = zero
   ix = 1
   if( incx < 0 ) ix = 1 - (n-1)*incx
   do i = 1, n
      ax = abs(x(ix))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ix = ix + incx
   end do
!
!  Put the existing sum of squares into one of the accumulators
!
   if( sumsq > zero ) then
      ax = scl*sqrt( sumsq )
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
   end if
!
!  Combine abig and amed or amed and asml if more than one
!  accumulator was used.
!
   if (abig > zero) then
!
!     Combine abig and amed if abig > 0.
!
      if (amed > zero .or. LA_ISNAN(amed)) then
         abig = abig + (amed*sbig)*sbig
      end if
      scl = one / sbig
      sumsq = abig
   else if (asml > zero) then
!
!     Combine amed and asml if asml > 0.
!
      if (amed > zero .or. LA_ISNAN(amed)) then
         amed = sqrt(amed)
         asml = sqrt(asml) / ssml
         if (asml > amed) then
            ymin = amed
            ymax = asml
         else
            ymin = asml
            ymax = amed
         end if
         scl = one
         sumsq = ymax**2*( one + (ymin/ymax)**2 )
      else
         scl = one / ssml
         sumsq = asml
      end if
   else
!
!     Otherwise all values are mid-range or zero
!
      scl = one
      sumsq = amed
   end if
   return
end subroutine


program elasticAcuatorLine
    use structural
    use parameters
    real :: time = 0.0
    real,dimension(2) :: F_a, g
    integer :: j
    integer :: counter = 1
    real,dimension(N+2,2,2) :: EI
    real,dimension(N+2) :: r_location,rho
    real, dimension(N+2,2) :: V_new, V_old, S_new, S_old, M_new, M_old, q_new, q_old
    ! result
    real, dimension(T/t_count+1,N+2,2) :: q_result,M_result

    ! Main program

    call bladeConfig(EI,r_location,rho)
    call bladeInit(V_new,M_new,S_new,q_new,V_old,M_old,S_old,q_old)

    do j = 1, T
        g(1) = 0.0!
        g(2) = -9.8*cos(0-omega*time)

        F_a(1) = 0.0
        F_a(2) = 0.0!-100.0

        call bladeSolve(V_new,M_new,S_new,q_new,V_old,M_old,S_old,q_old,&
                            rho,EI,r_location,g,F_a,delta_t,delta_r)
        ! Upload data to new time-step:
        V_old = V_new
        M_old = M_new
        q_old = q_new
        ! Time control:
        time = delta_t*(j-1)

        if (mod(j,t_count) == 0) then
            q_result(counter,:,:) = q_new
            M_result(counter,:,:) = M_new
            print *, time,M_result(counter,2,2)
            counter = counter + 1
        end if
    end do

    ! Output
    call bladeOutput(q_result,M_result,V_new,M_new,S_new,q_new)

end program elasticAcuatorLine


!
!     -------------------------------------------------------------
!      N I N E L S
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
!                                                                  *
!     |  J1/2  J2/2  J3/2 |                                        *
!     |  L1/2  L2/2  L3/2 |                                        *
!     |  K1/2  K2/2  K3/2 |                                        *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius, LITHUANIA                              January 1997 *
!
      SUBROUTINE NINELS(J1, J2, J3, L1, L2, L3, K1, K2, K3, I, IN, A)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:09:06  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      USE nine0_I
      USE nine_I
      USE nine11_I
      USE nine12_I
      USE nine13_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J1
      INTEGER  :: J2
      INTEGER  :: J3
      INTEGER  :: L1
      INTEGER  :: L2
      INTEGER  :: L3
      INTEGER  :: K1
      INTEGER  :: K2
      INTEGER  :: K3
      INTEGER  :: I
      INTEGER  :: IN
      REAL(DOUBLE)  :: A
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
!-----------------------------------------------
      A = ZERO
      IF (I == 1) THEN
         IN = 0
         IF (ITTK(J1,J2,J3) == 0) RETURN
         IF (ITTK(L1,L2,L3) == 0) RETURN
         IF (ITTK(K1,K2,K3) == 0) RETURN
         IF (ITTK(J1,L1,K1) == 0) RETURN
         IF (ITTK(J2,L2,K2) == 0) RETURN
         IF (ITTK(J3,L3,K3) == 0) RETURN
         IN = 1
         RETURN
      ENDIF
      IN = 1
      IF (J1*J2*J3*L1*L2*L3*K1*K2*K3 == 0) THEN
         CALL NINE0 (J1, J2, J3, L1, L2, L3, K1, K2, K3, A)
      ELSE IF (K3 /= 2) THEN
         CALL NINE (J1, J2, J3, L1, L2, L3, K1, K2, K3, I, IN, A)
      ELSE IF (J3 == L3) THEN
         IF (K1 == K2) THEN
!
!    Case  J3 = L3           and   K1 = K2
!
            CALL NINE11 (J1, J2, J3, L1, L2, K1, A)
         ELSE IF (K1 - 2 == K2) THEN
!
!    Case  J3 = L3           and   K1/2 + 1 = K2/2
!
            CALL NINE12 (J1, J2, J3, L1, L2, K1, A)
         ELSE IF (K1 + 2 == K2) THEN
!
!    Case  J3 = L3           and   K1/2 = K2/2 + 1
!
            CALL NINE12 (J2, J1, J3, L2, L1, K2, A)
            IF (MOD(J1 + J2 + J3 + L1 + L2 + L3 + K1 + K2 + K3,4) /= 0) A = -A
         ELSE
            CALL NINE (J1, J2, J3, L1, L2, L3, K1, K2, K3, I, IN, A)
         ENDIF
      ELSE IF (J3 - 2 == L3) THEN
         IF (K1 == K2) THEN
!
!    Case  J3/2 + 1 = L3/2   and   K1 = K2
!
            CALL NINE12 (J1, L1, K1, J2, L2, J3, A)
         ELSE IF (K1 - 2 == K2) THEN
!
!    Case  J3/2 + 1 = L3/2   and   K1/2 + 1 = K2/2
!
            CALL NINE13 (J1, J2, J3, L1, L2, K1, A)
         ELSE IF (K1 + 2 == K2) THEN
!
!    Case  J3/2 + 1 = L3/2   and   K1/2 - 1 = K2/2
!
            CALL NINE13 (J2, J1, J3, L2, L1, K2, A)
            IF (MOD(J1 + J2 + J3 + L1 + L2 + L3 + K1 + K2 + K3,4) /= 0) A = -A
         ELSE
            CALL NINE (J1, J2, J3, L1, L2, L3, K1, K2, K3, I, IN, A)
         ENDIF
      ELSE IF (J3 + 2 == L3) THEN
         IF (K1 == K2) THEN
!
!    Case  J3/2 = L3/2 + 1   and   K1 = K2
!
            CALL NINE12 (L1, J1, K1, L2, J2, L3, A)
            IF (MOD(J1 + J2 + J3 + L1 + L2 + L3 + K1 + K2 + K3,4) /= 0) A = -A
         ELSE IF (K1 - 2 == K2) THEN
!
!    Case  J3/2 = L3/2 + 1   and   K1/2 - 1 = K2/2
!
            CALL NINE13 (L1, L2, L3, J1, J2, K1, A)
            IF (MOD(J1 + J2 + J3 + L1 + L2 + L3 + K1 + K2 + K3,4) /= 0) A = -A
         ELSE IF (K1 + 2 == K2) THEN
!
!    Case  J3/2 = L3/2 + 1   and   K1/2 - 1 = K2/2
!
            CALL NINE13 (L2, L1, L3, J2, J1, K2, A)
         ELSE
            CALL NINE (J1, J2, J3, L1, L2, L3, K1, K2, K3, I, IN, A)
         ENDIF
      ELSE
         CALL NINE (J1, J2, J3, L1, L2, L3, K1, K2, K3, I, IN, A)
      ENDIF
      RETURN
      END SUBROUTINE NINELS