!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
! TYPE  : MODULE
! NAME  : FermionOperators
! OBJECT: TYPE(FermOper)
! USED  :
! DATE  : 2017-12-06
! AUTHOR: hengyueli@gmail.com
!--------------
! Open-Source : No
!------------------
! DESCRIPTION:
!              offer the operation on fermion spin 1/2 system. THe maxmuer size of the system may be L=18.
!            This size is determined by the max size subspace  L = ( C_N^(N/2) ) ^ 2
!              The fermion states are saved in integer*8 of the form (spinup,spindown).
!             for a system of size L = Ns , the index is from 0 to Ns-1
!             spin = 0 for up and 1 for down
!
!
! STANDARD:
!           [sub] Initialization (see "avalable sets" for details)
!
!            after the type is initiated, type(FermOper)::o for instance, use it as :
!            call o%act(BasisIn,BasisOut,sign_) (  see that in "avalable others"  )
!  ╔═════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════╗
!  ║  optid = -1:                                                                                ║
!  ║              always returen unavalabel state   ( output = -1)                                                                   ║
!  ║  optid = 0 :                                                                                ║
!  ║              do nothing                                                                                ║
!  ║  optid = 1 : c_{i,spin}                                                                                ║
!  ║              i=para(1) ; spin=para(2)                                                                                ║
!  ║                                                                                ║
!  ║  optid = 2 : c^+_{i,spin}                                                                                ║
!  ║              i=para(1) ; spin=para(2)                                                                                ║
!  ║                                                                                ║
!  ║  optid = 3 : c^+_{i,sini} * c_{j,spinj}                                                                                ║
!  ║              i=para(1) ; spini=para(2) ; j=para(3) ; spinj=para(4)                                                              ║
!  ║                                                                                ║
!  ║  optid = 4 : c_{i,sini} * c_{j,spinj}                                                                                ║
!  ║              i=para(1) ; spini=para(2) ; j=para(3) ; spinj=para(4)                                                              ║
!  ║                                                                                ║
!  ║  optid = 5 : c^+_{i,sini} * c^+_{j,spinj}                                                                                ║
!  ║              i=para(1) ; spini=para(2) ; j=para(3) ; spinj=para(4)                                                              ║
!  ║                                                                                ║
!  ║  optid = 6 : c^+_{i,sini} * c_{j,spinj} * c^+_{k,sini} * c_{l,spinj}                                                            ║
!  ║              i=para(1) ; spini=para(2) ; j=para(3) ; spinj=para(4) ; k=para(5) ; spink=para(6) ; l=para(7) ; spinl=para(8) ;    ║
!  ║                                                                                ║
!  ║  optid = 7 : c^+_{i,sini} * c^+_{j,spinj} * c_{k,sini} * c_{l,spinj}                                                            ║
!  ║              i=para(1) ; spini=para(2) ; j=para(3) ; spinj=para(4) ; k=para(5) ; spink=para(6) ; l=para(7) ; spinl=para(8) ;    ║
!  ║                                                                                ║
!  ║  optid = 8 : n_{i,spini} * n_{j,spinj}                                                                                ║
!  ║              i=para(1) ; spini=para(2) ; j=para(3) ; spinj=para(4)                                                              ║
!  ║                                                                                ║
!  ║  optid = 9 : n_{i,spini}                                                                                ║
!  ║              i=para(1) ; spini=para(2)                                                                                ║
!  ╚═════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════╝
!  usually for para(i), odd i=2n+1 represent site index and even i=2n represent spin
!
! USING LIST:
!
!
!
! avalable sets:
!                  [sub] Initialization(ns,optid,para,print_)
!                        integer::ns  !size of the system
!                        integer::optid  !chose operators
!                        integer::para(8)!information for operators
!                        integer::print_  ! where to print, default is 6
!                  [sub] UnInitialization()
!
! avalable gets:
!
!                  [fun] get_para()
!                        integer::get_para(8)
!
!                  [fun] get_optid()
!                        integer::get_optid
! avalable IS  :
!                  [fun] IsInitiated()
!
! avalable others:
!                  [sub] self%act(Bin,Bout,sign)
!                        integer*8::Bin,Bout
!                        integer::sign
!                       Bin is the input basis, Bout is the output basis, sign= 1 / -1 is the correpsonding sign.
!
!
!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

module FermionOperators
     implicit none

    type FermOper
         private
         logical                          :: Initialized=.false.
         integer                          :: ns                       !total correlated sites in the system.
         integer                          :: para(8) !operator informations.
         integer                          :: optid
         integer                          :: print=6
         procedure(action),pointer,nopass :: opt => null()
         !--------------------------------------------------------
         ! internal use,to simplify para(8)
         ! para(8) will not do not directly inputted input subs, while Bsite(8) do.
         integer                          :: Bsite(4)
         !  the following two (opttemp1,opttemp2) are for bulting two particle operators.
         procedure(action),pointer,nopass :: opttemp1 => null() !
         procedure(action),pointer,nopass :: opttemp2 => null()
         integer                          :: Bsite2(4) ! cccc use
    contains
         !---------------------------------init,final
         procedure,pass::Initialization
         procedure,pass::UnInitialization
         final         ::Finalization

         procedure,pass::act
        !  procedure,pass::IsTheSameOperator
        !  procedure,pass::get_symmetry
         procedure,pass::get_para
         procedure,pass::get_optid
         procedure,pass::IsInitiated

         procedure::CheckTwoTheSame
         generic  :: operator(.eq.) => CheckTwoTheSame
    end type

    !--------------------------------------------------------------------------
    abstract interface
       subroutine  action(self,Bsite,basisin,basisout,sign_) ! para is saved in self
          import FermOper
          implicit none
          class(FermOper),intent(inout)::self
          integer   ,intent(in)::Bsite(4)
          integer*8,intent(in) ::basisin
          integer*8,intent(out)::basisout
          integer,intent(out)  ::sign_
       end subroutine action
    end interface
   !----------------------------------------------------------------------------

    private:: Initialization,UnInitialization,Finalization,act

    private:: select_operator

    !---------------------optid = -1
    private:: Forbi
    !---------------------optid = 0
    private:: DoNothing
    !---------------------optid = 1
    private:: SingleC
    !---------------------optid = 2
    private:: SingleCdagger
    !---------------------optid = 3
    private:: CPC_I_ne_J
    !---------------------optid = 4
    private:: CC_I_gt_J   , CC_I_lt_J
    !---------------------optid = 5
    private:: CpCp_I_gt_J , CpCp_I_lt_J
    !---------------------optid = 8
    private:: nn
    !---------------------optid = 9
    private:: particleN
    !---------------------optid = 6,7
    private:: cccc

    private::Check_Sign,get_optid

    private::checksite,checkspin

    private::IsInitiated,CheckTwoTheSame
  contains

    subroutine Initialization(self,ns,optid,para,print_)
      implicit none
      class(FermOper),intent(inout)::self
      integer,intent(in)::ns
      integer::optid
      integer,intent(in)::para(8)
      integer,optional::print_
      !----------------------------------------------------------
      call UnInitialization(self)
      !---------------------------
      self%Initialized = .true.
      self%ns          =  ns
      self%para        =  para
      self%optid       =  optid
      !------
      if (present(print_)) self%print = print_
      !------------------ select operator -----------
      call select_operator(self%ns,self%optid,self%para,self%Bsite,self%Bsite2&
                          ,self%opt,self%opttemp1,self%opttemp2,self%print)
      !----------------------------------------------
    endsubroutine

    subroutine UnInitialization(self)
      implicit none
      class(FermOper),intent(inout)::self
      !----------------------------------------------------------
      if (self%Initialized)then
        self%opt => null()
        self%Initialized = .false.
      endif
    endsubroutine

    impure elemental subroutine Finalization(self)
      implicit none
      type(FermOper),intent(inout)::self
      !----------------------------------------------------------
      call UnInitialization(self)
    endsubroutine

    recursive subroutine select_operator(ns,optid,para,Bsite,Bsite2,opt,opt1,opt2,print)
      implicit none
      integer,intent(in)::ns,optid,para(8)
      integer,intent(inout)::Bsite(4),Bsite2(4)
      procedure(action),pointer::opt,opt1,opt2
      integer,intent(in)::print
      !----------------------------------------------------------
      integer::optidcc1,optidcc2,para1(8),para2(8)
      !----------------  setting  bsite -------------------------
      Bsite(1) = para(2) * ns + para(1)
      Bsite(2) = para(4) * ns + para(3)
      Bsite(3) = min(Bsite(1) , Bsite(2)) + 1 !Bsite3: starting checking point
      Bsite(4) = abs(Bsite(1) - Bsite(2)) - 2 ! Bsite4: checking length
      !----------------------------------------------------------
      !----------------  selection  ------------------------------
      select case(optid)
      case(-1)!===========   optid = -1  ================================================
        opt => Forbi
      case(0)!===========    optid = 0   ================================================
        opt => DoNothing
      case(1)!===========    optid = 1   ================================================
        call checksite(ns,para(1))
        call checkspin(   para(2))
        opt => SingleC
      case(2)!===========    optid = 2   ================================================
        call checksite(ns,para(1))
        call checkspin(   para(2))
        opt => SingleCdagger
      case(3)!===========    optid = 3   ================================================
        call checksite(ns,para(1))  ; call checksite(ns,para(3))
        call checkspin(   para(2))  ; call checkspin(   para(4))
        if     (Bsite(1).ne.Bsite(2)) then
          opt => CPC_I_ne_J
        else
          opt => particleN
        endif
      case(4)!===========    optid = 4   ================================================
        if (Bsite(1).gt.Bsite(2))then
          opt => CC_I_gt_J
        elseif (Bsite(1).lt.Bsite(2))then
          opt => CC_I_lt_J
        else
          opt => Forbi
        endif
      case(5)!===========    optid = 5   ================================================
        if (Bsite(1).gt.Bsite(2))then
          opt => CpCp_I_gt_J
        elseif (Bsite(1).lt.Bsite(2))then
          opt => CpCp_I_lt_J
        else
          opt => Forbi
        endif
      case(6,7)!===========  optid = 6,7  ================================================
        if (optid.eq.6)then
          optidcc1 = 3  ;  optidcc2 = 3
        else
          optidcc1 = 5  ;  optidcc2 = 4
        endif
        para1(1:4) = para(1:4)  ;para2(1:4) = para(5:8)
        call select_operator(ns,optidcc1,para1,Bsite,Bsite2,opt1,opt,opt2,print)
        call select_operator(ns,optidcc2,para2,Bsite2,Bsite,opt2,opt,opt1,print)
        opt => cccc
      case(8)!===========    optid = 8   ================================================
        opt => nn
      case(9)!===========    optid = 9   ================================================
        opt => particleN
      case default
        write(print,*)"ERROR: Unknow optid input @ FermionOperators";stop
      endselect
    endsubroutine

    subroutine act(self,BasisIn,BasisOut,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer*8,intent(in)::BasisIn
      integer*8,intent(out)::BasisOut
      integer,intent(out)::sign_
      !------------------------------------
      call self%opt(self,self%Bsite,BasisIn,BasisOut,sign_)
    endsubroutine

    !===========================================================================
    !  selected operators

    subroutine cccc(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      integer::sign__
      integer*8::stemp
      call self%opttemp2(self,self%Bsite2,basisin,basisout,sign__)
      if (basisout.ne.-1_8)then
         stemp = basisout
         call self%opttemp1(self,self%Bsite,stemp,basisout,sign_)
         sign_ = sign_ * sign__
      endif
    endsubroutine cccc

    subroutine Forbi(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      basisout = -1_8
      sign_    = 0
    endsubroutine Forbi

    subroutine DoNothing(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      sign_    = 1_8
      basisout = basisin
    endsubroutine DoNothing

    ! the first position is started from 0
    ! check from pos to pos+len
    integer function Check_Sign(basis,pos,len)
        implicit none
        integer*8,intent(in)::basis
        integer,intent(in)::pos,len
        !-----------------------
        integer::jc
        Check_Sign = 1
        do jc = 0,len
           if (btest(basis,pos+jc)) Check_Sign=-Check_Sign
        enddo
    endfunction Check_Sign

    ! c_{i,spin}
    subroutine SingleC(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if (btest(basisin,Bsite(1)))then
         basisout = IBCLR(basisin,Bsite(1))
         sign_    = Check_Sign(basisin,0,Bsite(1)-1)
      else
         basisout = -1_8
      endif
    endsubroutine SingleC

    ! c^+_{i,spin}
    subroutine SingleCdagger(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if (.not.btest(basisin,Bsite(1)))then
         basisout = IBSET(basisin,Bsite(1))
         sign_    = Check_Sign(basisin,0,Bsite(1)-1)
      else
         basisout = -1_8
      endif
    endsubroutine SingleCdagger

    ! c^+_{i,spin}c_{j,spinj} where i .NE. j
    subroutine CPC_I_ne_J(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if ( btest(basisin,Bsite(2)) .and. (.not.btest(basisin,Bsite(1))) )then
         basisout = IBSET(basisin ,Bsite(1))
         basisout = IBCLR(basisout,Bsite(2))
         sign_    = Check_Sign(basisin,Bsite(3),Bsite(4))
      else
         basisout = -1_8
      endif
    endsubroutine CPC_I_ne_J

    ! c_{i,spin}c_{j,spinj} where i .lt. j
    subroutine CC_I_lt_J(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if ( btest(basisin,Bsite(2)) .and. btest(basisin,Bsite(1)) )then
         basisout = IBCLR(basisin ,Bsite(1))
         basisout = IBCLR(basisout,Bsite(2))
         sign_    = -Check_Sign(basisin,Bsite(3),Bsite(4))
      else
         basisout = -1_8
      endif
    endsubroutine CC_I_lt_J

    ! c_{i,spin}c_{j,spinj} where i .gt. j
    subroutine CC_I_gt_J(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if ( btest(basisin,Bsite(2)) .and. btest(basisin,Bsite(1)) )then
         basisout = IBCLR(basisin ,Bsite(1))
         basisout = IBCLR(basisout,Bsite(2))
         sign_    = Check_Sign(basisin,Bsite(3),Bsite(4))
      else
         basisout = -1_8
      endif
    endsubroutine CC_I_gt_J

    ! c^+_{i,spin}c^+_{j,spinj} where i .lt. j
    subroutine CpCp_I_lt_J(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if ( (.not.btest(basisin,Bsite(2))) .and. (.not.btest(basisin,Bsite(1))) )then
         basisout = IBSET(basisin ,Bsite(1))
         basisout = IBSET(basisout,Bsite(2))
         sign_    = Check_Sign(basisin,Bsite(3),Bsite(4))
      else
         basisout = -1_8
      endif
    endsubroutine CpCp_I_lt_J

    ! c^+_{i,spin}c^+_{j,spinj} where i .gt. j
    subroutine CpCp_I_gt_J(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if ( (.not.btest(basisin,Bsite(2))) .and. (.not.btest(basisin,Bsite(1))) )then
         basisout = IBSET(basisin ,Bsite(1))
         basisout = IBSET(basisout,Bsite(2))
         sign_    = -Check_Sign(basisin,Bsite(3),Bsite(4))
      else
         basisout = -1_8
      endif
    endsubroutine CpCp_I_gt_J

    ! N{i,spin}
    subroutine nn(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if ( BTEST(basisin,Bsite(1)) .and. BTEST(basisin,Bsite(2)) ) then
        basisout = basisin
        sign_    = 1_8
      else
        basisout = -1_8
      endif
    endsubroutine nn

    ! N{i,spin}
    subroutine particleN(self,Bsite,basisin,basisout,sign_)
      implicit none
      class(FermOper),intent(inout)::self
      integer   ,intent(in)::Bsite(4)
      integer*8,intent(in) ::basisin
      integer*8,intent(out)::basisout
      integer,intent(out)  ::sign_
      !------------------------------------------
      if ( BTEST(basisin,Bsite(1)) ) then
        basisout = basisin
        sign_    = 1_8
      else
        basisout = -1_8
      endif
    endsubroutine particleN

    integer function get_optid(self)
      implicit none
      class(FermOper),intent(inout)::self
      !----------------------------------------
      get_optid = self%optid
    endfunction

    function  get_para(self) result(r)
      implicit none
      class(FermOper),intent(inout)::self
      integer::r(8)
      !----------------------------------------
      r = self%para
    endfunction

    logical function IsInitiated(self)
      implicit none
      class(FermOper),intent(inout)::self
      !----------------------------------------
      IsInitiated = self%Initialized
    endfunction

    impure elemental subroutine checksite(ns,c)!,
      implicit none
      integer,intent(in)::ns
      integer,intent(in)::c
      !----------------------------------------
      if ((c.ge.0) .and.  (c.le.ns)  )then
      else
         write(*,*)"In definition of operator, site out of rang."
         write(*,*)"Found site=",c
         stop
      endif
    endsubroutine

    impure elemental subroutine checkspin(c)!,checkspin
      implicit none
      integer,intent(in)::c
      !----------------------------------------
      if ((c==0) .or.  (c==1)  )then
      else
         write(*,*)"In definition of operator, spin out of rang."
         write(*,*)"Found spin=",c
         stop
      endif
    endsubroutine

    logical function CheckTwoTheSame(a,b)
      implicit none
      class(FermOper),intent(in)::a,b
      !-------------------------------------
      CheckTwoTheSame = .false.
      if (a%optid.eq.b%optid)then
         if (  sum(abs(a%para - b%para)).eq.0   )then
            CheckTwoTheSame = .true.
         endif
      endif
    endfunction

end module


      program sum
c********************************************************************************
c     Program to combine results from all of the different sub amplitudes
c     and given total
c     cross section and error.
c*****************************************************************************
      implicit none
c
c     Constants
c
      character*(*) rfile
      parameter (rfile='result')
      character*(*) symfile
      parameter (symfile='symfact.dat')
      integer   max_amps
      parameter (max_amps=999)
c
c     local
c
      double precision xsec(max_amps), xerr(max_amps)
      character*80 fname
      integer i,j
      double precision xtot,errtot
c-----
c  Begin Code
c-----
      xtot=0d0
      errtot=0d0
      open(unit=15,file=symfile,status='old',err=999)
      do while (.true.)
         read(15,*,err=99) i,j
         if (j .gt. 0) then
            if (i .lt. 10) then
               write(fname,'(a,i1,a,a)') 'G',i,'/',rfile
c               write(*,*) fname
            else if (i .lt. 100) then
               write(fname,'(a,i2,a,a)') 'G',i,'/',rfile
c               write(*,*) fname
            else if (i .lt. 1000) then
               write(fname,'(a,i3,a,a)') 'G',i,'/',rfile
c               write(*,*) fname
            endif
            open(unit=25,file=fname,status='old',err=95)
            read(25,*) xsec(i), xerr(i)
            xtot = xtot+xsec(i)*j
            errtot=errtot+j*xerr(i)**2
            write(*,'(2i4,2e12.4)') i,j, xsec(i),xerr(i)
 95         close(25)
         endif
      enddo
 99   write(*,*) 'done',xtot,sqrt(errtot)
      close(15)
      stop
 999  write(*,*) 'error'
      end


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Swap poles in real block-Hessenberg pairs:
!     m poles with next k poles
! ___________________________________________________________________
module d_swappolesmk

use u_parameters
use u_activeparts
use d_ctransformations
use d_memorymgmt
use d_computepoles
use d_swappoles12
use d_swappoles22

implicit none
private
public d_swapmk

contains

  subroutine d_swapmk(i, m, k, A, B, compAB, apC, apT, Q, compQ, qcol, &
                      Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! swaps a batch of m poles starting at pole i up to i+m-1 with poles
  ! i+m up to i+m+k(-1).
  ! This moves the entire batch k(+1) positions down along the subdiagonal
  ! The pencil and Q and Z are updated as requested via BLAS operations
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! i       integer [IN]
  !           Index (column in A,B) of the first pole in the batch
  ! m       integer [IN]
  !           Batch size of poles
  ! k       integer [INOUT]
  !           Number of swaps to be made
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  !           Normally, the following order,
  !              tstrt <= cstrt < i < i+m < cstp <= tstp,
  !           holds when calling d_swapm1. c = current, t = total
  ! Q       double array [INOUT]
  !           Orthonormal equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, ..., qcol+m
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, ..., zcol+m
  !___________________________________________________________________________
  ! last edit: September 21, 2018
    real(kind=dp), intent(inout)      :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    integer, intent(in)               :: i, m, qcol, zcol
    integer, intent(inout)            :: k
    logical, intent(in)               :: compAB, compQ, compZ
    type(tAp), pointer, intent(in)    :: apC, apT

    integer                           :: j, jj, LDAB, LDQ, LDQM, LDZ, &
                                         LDZM, LDC, LDR
    integer, pointer                  :: cstrt, cstp, tstrt, tstp

    type(tAp), pointer                :: apCI, apTI
    logical                           :: h1, h2

    external DGEMM

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    call d_getLeadingDim(LDAB,A)
    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDQM,QM)
    call d_getLeadingDim(LDZ,Z)
    call d_getLeadingDim(LDZM,ZM)
    call d_getLeadingDim(LDC,Cu)
    call d_getLeadingDim(LDR,Ru)

    if (i+m+k+1 .le. LDAB) then
      if  (abs(A(i+m+k+1,i+m+k-1)) .gt. dzero) then
        k = k + 1
      end if
    end if

    call tApInit(apCI,i, i+m+k-1)
    call tApInit(apTI,i, i+m+k-1)

    QM = dzero
    do j=1, m+k
      QM(j,j) = done
    end do
    ZM = dzero
    do j=1, m+k
      ZM(j,j) = done
    end do

    j = m
    do while (j .ge. 1)
      jj = 0
      h1 = .false.
      if (j .ge. 2) then
        if (abs(A(i+j,i+j-2)) .gt. dzero) then
          h1 = .true.
          ! this pole is a pair of C.C. shifts
          do while (jj .lt. k)
            h2 = .false.
            if (i+j+jj .lt. LDAB-1) then
              if (abs(A(i+j+jj+2,i+j+jj)) .gt. dzero) then
                h2 = .true.
                ! next pole is C.C.
                call d_swap22(i+j+jj-1, i+j+jj-2, A, B, .false., apCI, apTI,&
                       QM, .true., j+jj-1, ZM, .true., j+jj-1)
                jj = jj + 2
              end if
            end if
            if (.not. h2) then
              ! next pole is real
              call d_swap21(i+j+jj-1, i+j+jj-2, A, B, .false., apCI, apTI,&
                     QM, .true., j+jj-1, ZM, .true., j+jj-1)
              jj = jj + 1
            end if
          end do
          j = j - 2
        end if
      end if
      if (.not. h1) then
        ! this is a real pole
        do while (jj .lt. k)
          h2 = .false.
          if (i+j+jj .lt. LDAB-1) then
            if (abs(A(i+j+jj+2,i+j+jj)) .gt. dzero) then
              h2 = .true.
              ! next pole is C.C.
              call d_swap12(i+j+jj, i+j+jj-1, A, B, .false., apCI, apTI,&
                     QM, .true., j+jj,ZM, .true., j+jj)
              jj = jj + 2
            end if
          end if
          if (.not. h2) then
            call d_swap11(i+j+jj, i+j+jj-1, A, B, .false., apCI, apTI,&
                   QM, .true., j+jj,ZM, .true., j+jj)
            jj = jj + 1
          end if
        end do
        j = j - 1
      end if
    end do

    ! Update the pencil as requested via BLAS
    if (compAB) then
      ! A row update
      call DGEMM('T','N',m+k,tstp-i-m-k+1,m+k,done,QM(1,1),LDQM,&
                 A(i+1,i+m+k),LDAB,dzero,Ru(1,1),LDR)
      A(i+1:i+m+k,i+m+k:tstp) = Ru(1:m+k,1:tstp-i-m-k+1)
      ! B row update
      call DGEMM('T','N',m+k,tstp-i-m-k+1,m+k,done,QM(1,1),LDQM,&
                 B(i+1,i+m+k),LDAB,dzero,Ru(1,1),LDR)
      B(i+1:i+m+k,i+m+k:tstp) = Ru(1:m+k,1:tstp-i-m-k+1)
      ! A column update
      call DGEMM('N','N',i-tstrt,m+k,m+k,done,A(tstrt+1,i),LDAB,ZM(1,1),LDZM,&
                 dzero,Cu(1,1),LDC)
      A(tstrt+1:i,i:i+m+k-1) = Cu(1:i-tstrt,1:m+k)
      ! B column update
      call DGEMM('N','N',i-tstrt,m+k,m+k,done,B(tstrt+1,i),LDAB,ZM(1,1),LDZM,&
                 dzero,Cu(1,1),LDC)
      B(tstrt+1:i,i:i+m+k-1) = Cu(1:i-tstrt,1:m+k)
    else
      ! A row update
      call DGEMM('T','N',m+k,cstp-i-m-k+1,m+k,done,QM(1,1),LDQM,&
                A(i+1,i+m+k),LDAB,dzero,Ru(1,1),LDR)
      A(i+1:i+m+k,i+m+k:cstp) = Ru(:,1:cstp-i-m-k+1)
      ! B row update
      call DGEMM('T','N',m+k,cstp-i-m-k+1,m+k,done,QM(1,1),LDQM,&
                 B(i+1,i+m+k),LDAB,dzero,Ru(1,1),LDR)
      B(i+1:i+m+k,i+m+k:cstp) = Ru(:,1:cstp-i-m-k+1)
      ! A column update
      call DGEMM('N','N',i-cstrt,m+k,m+k,done,A(cstrt+1,i),LDAB,ZM(1,1),LDZM,&
                 dzero,Cu(1,1),LDC)
      A(cstrt+1:i,i:i+m+k-1) = Cu(1:i-cstrt,1:m+k)
      ! B column update
      call DGEMM('N','N',i-cstrt,m+k,m+k,done,B(cstrt+1,i),LDAB,ZM(1,1),LDZM,&
                 dzero,Cu(1,1),LDC)
      B(cstrt+1:i,i:i+m+k-1) = Cu(1:i-cstrt,1:m+k)
    end if

    if (compQ) then
      call DGEMM('N','N',LDQ,m+k,m+k,done,Q(1,qcol),LDQ,QM(1,1),LDQM,&
                dzero,Cu,LDC)
      Q(1:LDQ,qcol:qcol+m+k-1) = Cu(1:LDQ,1:m+k)
    end if

    if (compZ) then
      call DGEMM('N','N',LDZ,m+k,m+k,done,Z(1,zcol),LDZ,ZM(1,1),LDZM,&
           dzero,Cu(1,1),LDC)
      Z(1:LDZ,zcol:zcol+m+k-1) = Cu(1:LDZ,1:m+k)
    end if

    ! Free everything
    call tApFree(apCI)
    call tApFree(apTI)
  end subroutine
end module


      subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
      integer n,ldr
      integer ipvt(n)
      double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n)
c     **********
c
c     subroutine qrsolv
c
c     given an m by n matrix a, an n by n diagonal matrix d,
c     and an m-vector b, the problem is to determine an x which
c     solves the system
c
c           a*x = b ,     d*x = 0 ,
c
c     in the least squares sense.
c
c     this subroutine completes the solution of the problem
c     if it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, if
c     a*p = q*r, where p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, then qrsolv expects
c     the full upper triangle of r, the permutation matrix p,
c     and the first n components of (q transpose)*b. the system
c     a*x = b, d*x = 0, is then equivalent to
c
c                  t       t
c           r*z = q *b ,  p *d*p*z = 0 ,
c
c     where x = p*z. if this system does not have full rank,
c     then a least squares solution is obtained. on output qrsolv
c     also provides an upper triangular matrix s such that
c
c            t   t               t
c           p *(a *a + d*d)*p = s *s .
c
c     s is computed within qrsolv and may be of separate interest.
c
c     the subroutine statement is
c
c       subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
c
c     where
c
c       n is a positive integer input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle
c         must contain the full upper triangle of the matrix r.
c         on output the full upper triangle is unaltered, and the
c         strict lower triangle contains the strict upper triangle
c         (transposed) of the upper triangular matrix s.
c
c       ldr is a positive integer input variable not less than n
c         which specifies the leading dimension of the array r.
c
c       ipvt is an integer input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       diag is an input array of length n which must contain the
c         diagonal elements of the matrix d.
c
c       qtb is an input array of length n which must contain the first
c         n elements of the vector (q transpose)*b.
c
c       x is an output array of length n which contains the least
c         squares solution of the system a*x = b, d*x = 0.
c
c       sdiag is an output array of length n which contains the
c         diagonal elements of the upper triangular matrix s.
c
c       wa is a work array of length n.
c
c     subprograms called
c
c       fortran-supplied ... dabs,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j,jp1,k,kp1,l,nsing
      double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero
      data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/
c
c     copy r and (q transpose)*b to preserve input and initialize s.
c     in particular, save the diagonal elements of r in x.
c
      do 20 j = 1, n
         do 10 i = j, n
            r(i,j) = r(j,i)
   10       continue
         x(j) = r(j,j)
         wa(j) = qtb(j)
   20    continue
c
c     eliminate the diagonal matrix d using a givens rotation.
c
      do 100 j = 1, n
c
c        prepare the row of d to be eliminated, locating the
c        diagonal element using p from the qr factorization.
c
         l = ipvt(j)
         if (diag(l) .eq. zero) go to 90
         do 30 k = j, n
            sdiag(k) = zero
   30       continue
         sdiag(j) = diag(l)
c
c        the transformations to eliminate the row of d
c        modify only a single element of (q transpose)*b
c        beyond the first n, which is initially zero.
c
         qtbpj = zero
         do 80 k = j, n
c
c           determine a givens rotation which eliminates the
c           appropriate element in the current row of d.
c
            if (sdiag(k) .eq. zero) go to 70
            if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40
               cotan = r(k,k)/sdiag(k)
               sin = p5/dsqrt(p25+p25*cotan**2)
               cos = sin*cotan
               go to 50
   40       continue
               tan = sdiag(k)/r(k,k)
               cos = p5/dsqrt(p25+p25*tan**2)
               sin = cos*tan
   50       continue
c
c           compute the modified diagonal element of r and
c           the modified element of ((q transpose)*b,0).
c
            r(k,k) = cos*r(k,k) + sin*sdiag(k)
            temp = cos*wa(k) + sin*qtbpj
            qtbpj = -sin*wa(k) + cos*qtbpj
            wa(k) = temp
c
c           accumulate the transformation in the row of s.
c
            kp1 = k + 1
            if (n .lt. kp1) go to 70
            do 60 i = kp1, n
               temp = cos*r(i,k) + sin*sdiag(i)
               sdiag(i) = -sin*r(i,k) + cos*sdiag(i)
               r(i,k) = temp
   60          continue
   70       continue
   80       continue
   90    continue
c
c        store the diagonal element of s and restore
c        the corresponding diagonal element of r.
c
         sdiag(j) = r(j,j)
         r(j,j) = x(j)
  100    continue
c
c     solve the triangular system for z. if the system is
c     singular, then obtain a least squares solution.
c
      nsing = n
      do 110 j = 1, n
         if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1
         if (nsing .lt. n) wa(j) = zero
  110    continue
      if (nsing .lt. 1) go to 150
      do 140 k = 1, nsing
         j = nsing - k + 1
         sum = zero
         jp1 = j + 1
         if (nsing .lt. jp1) go to 130
         do 120 i = jp1, nsing
            sum = sum + r(i,j)*wa(i)
  120       continue
  130    continue
         wa(j) = (wa(j) - sum)/sdiag(j)
  140    continue
  150 continue
c
c     permute the components of z back to components of x.
c
      do 160 j = 1, n
         l = ipvt(j)
         x(l) = wa(j)
  160    continue
      return
c
c     last card of subroutine qrsolv.
c
      end


      SUBROUTINE KURV1S (N,X,Y,SLOP1,SLOPN,XP,YP,TEMP,S,SIGMA,ISLPSW)
C
C
C +-----------------------------------------------------------------+
C |                                                                 |
C |                Copyright (C) 1986 by UCAR                       |
C |        University Corporation for Atmospheric Research          |
C |                    All Rights Reserved                          |
C |                                                                 |
C |                 NCARGRAPHICS  Version 1.00                      |
C |                                                                 |
C +-----------------------------------------------------------------+
C
C
C
C DIMENSION OF           X(N),Y(N),XP(N),YP(N),TEMP(N)
C ARGUMENTS
C
C LATEST REVISION        FEBRUARY 5, 1974
C
C PURPOSE                KURV1S DETERMINES THE PARAMETERS NECESSARY TO
C                        COMPUTE A SPLINE UNDER TENSION PASSING THROUGH
C                        A SEQUENCE OF PAIRS
C                        (X(1),Y(1)),...,(X(N),Y(N)) IN THE PLANE.
C                        THE SLOPES AT THE TWO ENDS OF THE CURVE MAY BE
C                        SPECIFIED OR OMITTED.  FOR ACTUAL COMPUTATION
C                        OF POINTS ON THE CURVE IT IS NECESSARY TO CALL
C                        THE SUBROUTINE KURV2S.
C
C USAGE                  CALL KURV1S(N,X,Y,SLP1,SLPN,XP,YP,TEMP,S,SIGMA)
C
C ARGUMENTS
C
C ON INPUT               N
C                          IS THE NUMBER OF POINTS TO BE INTERPOLATED
C                          (N .GE. 2).
C
C                        X
C                          IS AN ARRAY CONTAINING THE N X-COORDINATES
C                          OF THE POINTS.
C
C                        Y
C                          IS AN ARRAY CONTAINING THE N Y-COORDINATES
C                          OF THE POINTS.
C
C                        SLOP1 AND SLOPN
C                          CONTAIN THE DESIRED VALUES FOR THE SLOPE OF
C                          THE CURVE AT (X(1),Y(1)) AND (X(N),Y(N)),
C                          RESPECTIVELY.  THESE QUANTITIES ARE IN
C                          DEGREES AND MEASURED COUNTER-CLOCKWISE
C                          FROM THE POSITIVE X-AXIS.  IF ISLPSW IS NON-
C                          ZERO, ONE OR BOTH OF SLP1 AND SLPN MAY BE
C                          DETERMINED INTERNALLY BY KURV1S.
C
C                        XP AND YP
C                          ARE ARRAYS OF LENGTH AT LEAST N.
C
C                        TEMP
C                          IS AN ARRAY OF LENGTH AT LEAST N WHICH IS
C                          USED FOR SCRATCH STORAGE.
C
C                        SIGMA
C                          CONTAINS THE TENSION FACTOR.  THIS IS
C                          NON-ZERO AND INDICATES THE CURVINESS DESIRED.
C                          IF ABS(SIGMA) IS VERY LARGE (E.G., 50.) THE
C                          RESULTING CURVE IS VERY NEARLY A POLYGONAL
C                          LINE.  A STANDARD VALUE FOR SIGMA IS ABOUT 2.
C
C                        ISLPSW
C                          IS AN INTEGER INDICATING WHICH END SLOPES
C                          HAVE BEEN USER PROVIDED AND WHICH MUST BE
C                          COMPUTED BY KURV1S.  FOR ISLPSW
C                            = 0  INDICATES BOTH SLOPES ARE PROVIDED,
C                            = 1  ONLY SLOP1 IS PROVIDED,
C                            = 2  ONLY SLOPN IS PROVIDED,
C                            = 3  NEITHER SLOP1 NOR SLOPN IS PROVIDED.
C                            = 4  NEITHER SLOP1 NOR SLOPN IS PROVIDED,
C                                 BUT SLOP1=SLOPN.  IN THIS CASE X(1)=
C                                 X(N), Y(1)=Y(N) AND N.GE.3.
C ON OUTPUT              XP AND YP
C                          CONTAIN INFORMATION ABOUT THE CURVATURE OF
C                          THE CURVE AT THE GIVEN NODES.
C
C                        S
C                          CONTAINS THE POLYGONAL ARCLENGTH OF THE
C                          CURVE.
C
C                        N, X, Y, SLP1, SLPN, SIGMA AND ISLPSW ARE
C                        UNCHANGED.
C
C ENTRY POINTS           KURV1S
C
C SPECIAL CONDITIONS     NONE
C
C COMMON BLOCKS          NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED ULIB          NONE
C ROUTINES
C
C SPECIALIST             RUSSELL K. REW, NCAR, BOULDER, COLORADO  80302
C
C LANGUAGE               FORTRAN
C
C HISTORY                ORIGINALLY WRITTEN BY A. K. CLINE, MARCH 1972.
C
C
C
C
      INTEGER         N
      REAL            X(N)       ,Y(N)       ,XP(N)      ,YP(N)      ,
     1                TEMP(N)    ,S          ,SIGMA
      SAVE
C
      DATA PI /3.1415926535897932/
C
      NN = N
      JSLPSW = ISLPSW
      SLP1 = SLOP1
      SLPN = SLOPN
      DEGRAD = PI/180.
      NM1 = NN-1
      NP1 = NN+1
      DELX1 = X(2)-X(1)
      DELY1 = Y(2)-Y(1)
      DELS1 = SQRT(DELX1*DELX1+DELY1*DELY1)
      DX1 = DELX1/DELS1
      DY1 = DELY1/DELS1
C
C DETERMINE SLOPES IF NECESSARY
C
      IF (JSLPSW .NE. 0) GO TO 70
   10 SLPP1 = SLP1*DEGRAD
      SLPPN = SLPN*DEGRAD
C
C SET UP RIGHT HAND SIDES OF TRIDIAGONAL LINEAR SYSTEM FOR XP
C AND YP
C
      XP(1) = DX1-COS(SLPP1)
      YP(1) = DY1-SIN(SLPP1)

      TEMP(1) = DELS1
      SS = DELS1
      IF (NN .EQ. 2) GO TO 30
      DO 20 I=2,NM1
         DELX2 = X(I+1)-X(I)
         DELY2 = Y(I+1)-Y(I)
         DELS2 = SQRT(DELX2*DELX2+DELY2*DELY2)
         DX2 = DELX2/DELS2
         DY2 = DELY2/DELS2
         XP(I) = DX2-DX1
         YP(I) = DY2-DY1
         TEMP(I) = DELS2
         DELX1 = DELX2
         DELY1 = DELY2
         DELS1 = DELS2
         DX1 = DX2
         DY1 = DY2
C
C ACCUMULATE POLYGONAL ARCLENGTH
C
         SS = SS+DELS1
   20 CONTINUE
   30 XP(NN) = COS(SLPPN)-DX1
      YP(NN) = SIN(SLPPN)-DY1
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(NN-1)/SS
C
C PERFORM FORWARD ELIMINATION ON TRIDIAGONAL SYSTEM
C
      S = SS
      DELS = SIGMAP*TEMP(1)
      EXPS = EXP(DELS)
      SINHS = .5*(EXPS-1./EXPS)
      SINHIN = 1./(TEMP(1)*SINHS)
      DIAG1 = SINHIN*(DELS*.5*(EXPS+1./EXPS)-SINHS)
      DIAGIN = 1./DIAG1
      XP(1) = DIAGIN*XP(1)
      YP(1) = DIAGIN*YP(1)
      SPDIAG = SINHIN*(SINHS-DELS)
      TEMP(1) = DIAGIN*SPDIAG
      IF (NN .EQ. 2) GO TO 50
      DO 40 I=2,NM1
         DELS = SIGMAP*TEMP(I)
         EXPS = EXP(DELS)
         SINHS = .5*(EXPS-1./EXPS)
         SINHIN = 1./(TEMP(I)*SINHS)
         DIAG2 = SINHIN*(DELS*(.5*(EXPS+1./EXPS))-SINHS)
         DIAGIN = 1./(DIAG1+DIAG2-SPDIAG*TEMP(I-1))
         XP(I) = DIAGIN*(XP(I)-SPDIAG*XP(I-1))
         YP(I) = DIAGIN*(YP(I)-SPDIAG*YP(I-1))
         SPDIAG = SINHIN*(SINHS-DELS)
         TEMP(I) = DIAGIN*SPDIAG
         DIAG1 = DIAG2
   40 CONTINUE
   50 DIAGIN = 1./(DIAG1-SPDIAG*TEMP(NM1))
      XP(NN) = DIAGIN*(XP(NN)-SPDIAG*XP(NM1))
      YP(NN) = DIAGIN*(YP(NN)-SPDIAG*YP(NM1))
C
C PERFORM BACK SUBSTITUTION
C
      DO 60 I=2,NN
         IBAK = NP1-I
         XP(IBAK) = XP(IBAK)-TEMP(IBAK)*XP(IBAK+1)
         YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1)
   60 CONTINUE
      RETURN
   70 IF (NN .EQ. 2) GO TO 100
C
C IF NO SLOPES ARE GIVEN, USE SECOND ORDER INTERPOLATION ON
C INPUT DATA FOR SLOPES AT ENDPOINTS
C
      IF (JSLPSW .EQ. 4) GO TO 90
      IF (JSLPSW .EQ. 2) GO TO 80
      DELNM1 = SQRT((X(NN-2)-X(NM1))**2+(Y(NN-2)-Y(NM1))**2)
      DELN = SQRT((X(NM1)-X(NN))**2+(Y(NM1)-Y(NN))**2)
      DELNN = DELNM1+DELN
      C1 = (DELNN+DELN)/DELNN/DELN
      C2 = -DELNN/DELN/DELNM1
      C3 = DELN/DELNN/DELNM1
      SX = C3*X(NN-2)+C2*X(NM1)+C1*X(NN)
      SY = C3*Y(NN-2)+C2*Y(NM1)+C1*Y(NN)
C
      SLPN = ATAN2(SY,SX)/DEGRAD
   80 IF (JSLPSW .EQ. 1) GO TO 10
      DELS2 = SQRT((X(3)-X(2))**2+(Y(3)-Y(2))**2)
      DELS12 = DELS1+DELS2
      C1 = -(DELS12+DELS1)/DELS12/DELS1
      C2 = DELS12/DELS1/DELS2
      C3 = -DELS1/DELS12/DELS2
      SX = C1*X(1)+C2*X(2)+C3*X(3)
      SY = C1*Y(1)+C2*Y(2)+C3*Y(3)
C
      SLP1 = ATAN2(SY,SX)/DEGRAD
      GO TO 10
   90 DELN = SQRT((X(NM1)-X(NN))**2+(Y(NM1)-Y(NN))**2)
      DELNN = DELS1+DELN
      C1 = -DELS1/DELN/DELNN
      C2 = (DELS1-DELN)/DELS1/DELN
      C3 = DELN/DELNN/DELS1
      SX = C1*X(NM1)+C2*X(1)+C3*X(2)
      SY = C1*Y(NM1)+C2*Y(1)+C3*Y(2)
      IF (SX.EQ.0. .AND. SY.EQ.0.) SX = 1.
      SLP1 = ATAN2(SY,SX)/DEGRAD
      SLPN = SLP1
      GO TO 10
C
C IF ONLY TWO POINTS AND NO SLOPES ARE GIVEN, USE STRAIGHT
C LINE SEGMENT FOR CURVE
C
  100 IF (JSLPSW .NE. 3) GO TO 110
      XP(1) = 0.
      XP(2) = 0.
      YP(1) = 0.
      YP(2) = 0.
C
      SLP1 = ATAN2(Y(2)-Y(1),X(2)-X(1))/DEGRAD
      SLPN = SLP1
      RETURN
C
  110 IF (JSLPSW .EQ. 2)
     1    SLP1 = ATAN2(Y(2)-Y(1)-SLPN*(X(2)-X(1)),
     2                                X(2)-X(1)-SLPN*(Y(2)-Y(1)))/DEGRAD
C
      IF (JSLPSW .EQ. 1)
     1    SLPN = ATAN2(Y(2)-Y(1)-SLP1*(X(2)-X(1)),
     2                                X(2)-X(1)-SLP1*(Y(2)-Y(1)))/DEGRAD
      GO TO 10
      END
      SUBROUTINE KURV2S (T,XS,YS,N,X,Y,XP,YP,S,SIGMA,NSLPSW,SLP)
C
C
C
C DIMENSION OF           X(N),Y(N),XP(N),YP(N)
C ARGUMENTS
C
C LATEST REVISION        OCTOBER 22, 1973
C
C PURPOSE                KURV2S PERFORMS THE MAPPING OF POINTS IN THE
C                        INTERVAL (0.,1.) ONTO A CURVE IN THE PLANE.
C                        THE SUBROUTINE KURV1S SHOULD BE CALLED EARLIER
C                        TO DETERMINE CERTAIN NECESSARY PARAMETERS.
C                        THE RESULTING CURVE HAS A PARAMETRIC
C                        REPRESENTATION BOTH OF WHOSE COMPONENTS ARE
C                        SPLINES UNDER TENSION AND FUNCTIONS OF THE
C                        POLYGONAL ARCLENGTH PARAMETER.
C
C ACCESS CARDS           *FORTRAN,S=ULIB,N=KURV
C                        *COSY
C
C USAGE                  CALL KURV2S (T,XS,YS,N,X,Y,XP,YP,S,SIGMA)
C
C ARGUMENTS
C
C ON INPUT               T
C                          CONTAINS A REAL VALUE OF ABSOLUTE VALUE LESS
C                          THAN OR EQUAL TO 1. TO BE MAPPED TO A POINT
C                          ON THE CURVE.  THE SIGN OF T IS IGNORED AND
C                          THE INTERVAL (0.,1.) IS MAPPED ONTO THE
C                          ENTIRE CURVE.  IF T IS NEGATIVE, THIS
C                          INDICATES THAT THE SUBROUTINE HAS BEEN CALLED
C                          PREVIOUSLY (WITH ALL OTHER INPUT VARIABLES
C                          UNALTERED) AND THAT THIS VALUE OF T EXCEEDS
C                          THE PREVIOUS VALUE IN ABSOLUTE VALUE.  WITH
C                          SUCH INFORMATION THE SUBROUTINE IS ABLE TO
C                          MAP THE POINT MUCH MORE RAPIDLY.  THUS IF THE
C                          USER SEEKS TO MAP A SEQUENCE OF POINTS ONTO
C                          THE SAME CURVE, EFFICIENCY IS GAINED BY
C                          ORDERING THE VALUES INCREASING IN MAGNITUDE
C                          AND SETTING THE SIGNS OF ALL BUT THE FIRST
C                          NEGATIVE.
C
C                        N
C                          CONTAINS THE NUMBER OF POINTS WHICH WERE
C                          INTERPOLATED TO DETERMINE THE CURVE.
C
C                        X AND Y
C                          ARRAYS CONTAINING THE X- AND Y-COORDINATES
C                          OF THE INTERPOLATED POINTS.
C
C                        XP AND YP
C                          ARE THE ARRAYS OUTPUT FROM KURV1 CONTAINING
C                          CURVATURE INFORMATION.
C
C                        S
C                          CONTAINS THE POLYGONAL ARCLENGTH OF THE
C                          CURVE.
C
C                        SIGMA
C                          CONTAINS THE TENSION FACTOR (ITS SIGN IS
C                          IGNORED).
C
C                        NSLPSW
C                          IS AN INTEGER SWITCH WHICH TURNS ON OR OFF
C                          THE CALCULATION OF SLP
C                          NSLPSW
C                                 = 0 INDICATES THAT SLP WILL NOT BE
C                                     CALCULATED
C                                 = 1 SLP WILL BE CALCULATED
C
C                        THE PARAMETERS N, X, Y, XP, YP, S AND SIGMA
C                        SHOULD BE INPUT UNALTERED FROM THE OUTPUT OF
C                        KURV1S.
C
C ON OUTPUT              XS AND YS
C                          CONTAIN THE X- AND Y-COORDINATES OF THE IMAGE
C                          POINT ON THE CURVE.
C
C                        SLP
C                          CONTAINS THE SLOPE OF THE CURVE IN DEGREES AT
C                          THIS POINT.
C
C                        T, N, X, Y, XP, YP, S AND SIGMA ARE UNALTERED.
C
C ENTRY POINTS           KURV2S
C
C SPECIAL CONDITIONS     NONE
C
C COMMON BLOCKS          NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED ULIB          NONE
C ROUTINES
C
C SPECIALIST             RUSSELL K. REW, NCAR, BOULDER, COLORADO  80302
C
C LANGUAGE               FORTRAN
C
C HISTORY                ORIGINALLY WRITTEN BY A. K. CLINE, MARCH 1972.
C
C
C
C
      INTEGER         N
      REAL            T          ,XS         ,YS         ,X(N)       ,
     1                Y(N)       ,XP(N)      ,YP(N)      ,S          ,
     2                SIGMA      ,SLP
      SAVE
C
      DATA PI /3.1415926535897932/
C
C
C DENORMALIZE SIGMA
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S
C
C STRETCH UNIT INTERVAL INTO ARCLENGTH DISTANCE
C
      TN = ABS(T*S)
C
C FOR NEGATIVE T START SEARCH WHERE PREVIOUSLY TERMINATED,
C OTHERWISE START FROM BEGINNING
C
      IF (T .LT. 0.) GO TO 10
      DEGRAD = PI/180.
      I1 = 2
      XS = X(1)
      YS = Y(1)
      SUM = 0.
      IF (T .LT. 0.) RETURN
C
C DETERMINE INTO WHICH SEGMENT TN IS MAPPED
C
   10 DO 30 I=I1,N
         DELX = X(I)-X(I-1)
         DELY = Y(I)-Y(I-1)
         DELS = SQRT(DELX*DELX+DELY*DELY)
         IF (SUM+DELS-TN) 20,40,40
   20    SUM = SUM+DELS
   30 CONTINUE
C
C IF ABS(T) IS GREATER THAN 1., RETURN TERMINAL POINT ON
C CURVE
C
      XS = X(N)
      YS = Y(N)
      RETURN
C
C SET UP AND PERFORM INTERPOLATION
C
   40 DEL1 = TN-SUM
      DEL2 = DELS-DEL1
      EXPS1 = EXP(SIGMAP*DEL1)
      SINHD1 = .5*(EXPS1-1./EXPS1)
      EXPS2 = EXP(SIGMAP*DEL2)
      SINHD2 = .5*(EXPS2-1./EXPS2)
      EXPS = EXPS1*EXPS2
      SINHS = .5*(EXPS-1./EXPS)
      XS = (XP(I)*SINHD1+XP(I-1)*SINHD2)/SINHS+
     1     ((X(I)-XP(I))*DEL1+(X(I-1)-XP(I-1))*DEL2)/DELS
      YS = (YP(I)*SINHD1+YP(I-1)*SINHD2)/SINHS+
     1     ((Y(I)-YP(I))*DEL1+(Y(I-1)-YP(I-1))*DEL2)/DELS
      I1 = I
      IF (NSLPSW .EQ. 0) RETURN
      COSHD1 = .5*(EXPS1+1./EXPS1)*SIGMAP
      COSHD2 = .5*(EXPS2+1./EXPS2)*SIGMAP
      XT = (XP(I)*COSHD1-XP(I-1)*COSHD2)/SINHS+
     1     ((X(I)-XP(I))-(X(I-1)-XP(I-1)))/DELS
      YT = (YP(I)*COSHD1-YP(I-1)*COSHD2)/SINHS+
     1     ((Y(I)-YP(I))-(Y(I-1)-YP(I-1)))/DELS
      SLP = ATAN2(YT,XT)/DEGRAD
      RETURN
      END


************************************************************************
*
*     Subroutine L1NORM                               Called by: LADREG
*
*     solve the initial regression problem with all parameters included
*     in the model
*
*     local vars
*     ----------
C     IBASE:THE INDEX ARRAY OF COLUMNS OF THE BASIS
C     INEXT:A LOCAL ARRAY FOR THE SORT ROUTINE
C     LU:THE LU DECOMPOSITION OF THE CURRENT BASIS
*  this is from KBEST, not sure its correct....
C     SIGMA:INDICATOR ARRAY TO SPECIFY WHETHER A NONBASIC DUAL VARIABLE
C           IS AT UPPER OR LOWER BOUND(+1 IMPLIES UPPER;-1 IMPLIES
C           LOWER)
************************************************************************
      SUBROUTINE L1NORM(X,Y,N,NPAR,PARAM,TOT,INDX,NOBSCI)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 NPAR,N,NOBSCI,INDX(*)
      DOUBLE PRECISION PARAM(*),TOT(*),Y(*),X(NOBSCI,*)
*
*     local vars
*
      LOGICAL INTL
      INTEGER*4 I,IIN,IOUT,IPT,J,K,KKK,KOUNT,L
      INTEGER*4 INEXT(NOBSCI),IBASE(MAXPARMS)
      DOUBLE PRECISION ACU,AHALF,AONE,BONE,RATIO,RHO,SUBT,SUM,T,TEST,VAL
      DOUBLE PRECISION D(NOBSCI),DELTA(NOBSCI),PI(MAXPARMS),
     &                 PRICE(NOBSCI),RHS(MAXPARMS),SIGMA(NOBSCI)
      DOUBLE PRECISION LU(MAXPARMS,MAXPARMS)
*
*     function declaration
*
      DOUBLE PRECISION D1MACH
*
*     assign values to machine dependent constant (see Fox et al., 1978)
*
      ACU = DSQRT(D1MACH(4))
*
*      INITIAL SETTINGS
*
      AONE = 1.D0 + ACU
      AHALF = 0.5D0 + ACU
      BONE = 1.D0 - ACU
*
*     set up initial LU decomposition
*
      INTL = .TRUE.
      K = 1
      CALL UPDATE(K,X,N,NPAR,INDX,LU,IBASE,INTL,NOBSCI)
      INTL = .FALSE.
      DO 10 I=1,NPAR
         RHS(I) = Y(IBASE(I))
 10   CONTINUE
      KKK = 0
      CALL CALBET(KKK,PARAM,RHS,NPAR,INDX,LU)
*
*     calculate initial D, TOT and SIGMA vectors
*
      DO 30 J=1,N
         VAL = 0.D0
         DO 20 I=1,NPAR
            VAL = VAL+PARAM(I)*X(J,I)
 20      CONTINUE
         D(J) = Y(J)-VAL
         SIGMA(J) = DSIGN(1.D0,D(J))
 30   CONTINUE
      DO 40 J=1,NPAR
         RHS(J) = 0.D0
         KKK = IBASE(J)
         SIGMA(KKK) = 0.D0
 40   CONTINUE
      DO 60 J=1,N
         DO 50 I=1,NPAR
            TOT(I)=TOT(I)-SIGMA(J)*X(J,I)
 50      CONTINUE
 60   CONTINUE
*
*     main iterative loop
*
 70   KKK = 0
      CALL CALCPI(KKK,PI,TOT,NPAR,INDX,LU)
      T = AONE
      K = 0
      DO 80 J=1,NPAR
         IF (DABS(PI(J)).GE.T) THEN
            K = J
            T = DABS(PI(J))
            RHO = -DSIGN(1.D0,PI(J))
         ENDIF
   80 CONTINUE
*
*     if K=0, we're done -- calculate optimal param and sum of absolute
*     deviations and RETURN
*
      IF (K.EQ.0) THEN
         DO 230 I=1,NPAR
            RHS(I) = Y(IBASE(I))
 230     CONTINUE
         KKK = 0
         CALL CALBET(KKK,PARAM,RHS,NPAR,INDX,LU)
         RETURN
      ENDIF
*
*     we're not done - continue iterating
*
      KKK = K-1
      RHS(K) = 1.D0
      CALL CALBET(KKK,PARAM,RHS,NPAR,INDX,LU)
      RHS(K) = 0.D0
      DO 100 I=1,N
         DELTA(I) = 0.D0
         IF (SIGMA(I).NE.0.D0) THEN
            DO 90 J=1,NPAR
               DELTA(I) = DELTA(I)+PARAM(J)*X(I,J)
 90         CONTINUE
            DELTA(I) = RHO*DELTA(I)
         ENDIF
 100  CONTINUE
*
*     perform partial sort of ratios
*
      T = T*0.5D0
      KOUNT = 0
      RATIO = D1MACH(2)
      SUM = AHALF
      SUBT = 0.D0
      DO 160 I=1,N
         IF (DELTA(I)*SIGMA(I).LE.ACU) GOTO 160
         TEST = D(I)/DELTA(I)
         IF (TEST.GE.RATIO) GOTO 160
         SUM = SUM+DABS(DELTA(I))
         IF (SUM-SUBT.LT.T) THEN
*
*           insert I in list
*
            KOUNT = KOUNT+1
            PRICE(KOUNT) = TEST
            INEXT(KOUNT) = I
            GOTO 160
         ENDIF
*
*        update SUM and kick IIN out of the list
*
 110     SUM = SUM-SUBT
         RATIO = TEST
         IPT = 0
         KKK = 0
*
*        identify a new IIN
*
 120     KKK = KKK+1
         IF (KKK.LE.KOUNT) THEN
            IF (PRICE(KKK).GT.RATIO) THEN
               RATIO = PRICE(KKK)
               IPT = KKK
            ENDIF
            GOTO 120
         ENDIF
         IF (IPT.NE.0) THEN
*
*           switch values
*
            KKK = INEXT(IPT)
            SUBT = DABS(DELTA(KKK))
            IF (SUM-SUBT.GE.T) THEN
               PRICE(IPT) = PRICE(KOUNT)
               INEXT(IPT) = INEXT(KOUNT)
               KOUNT = KOUNT-1
               GOTO 110
            ENDIF
            IIN = INEXT(IPT)
            INEXT(IPT) = I
            PRICE(IPT) = TEST
         ELSE
            IIN = I
            SUBT = DABS(DELTA(I))
         ENDIF
  160 CONTINUE
*
*     update basic indicators
*
      DO 180 J=1,KOUNT
         KKK = INEXT(J)
         DO 170 L=1,NPAR
            SUBT = SIGMA(KKK)*X(KKK,L)
            TOT(L) = TOT(L)+SUBT+SUBT
 170     CONTINUE
         SIGMA(KKK) = -SIGMA(KKK)
 180  CONTINUE
      IOUT = IBASE(K)
      DELTA(IOUT) = RHO
      DO 200 L=1,NPAR
         TOT(L) = TOT(L)+RHO*X(IOUT,L)+SIGMA(IIN)*X(IIN,L)
 200  CONTINUE
      SIGMA(IOUT) = -RHO
      IBASE(K) = IIN
      CALL UPDATE(K,X,1,NPAR,INDX,LU,IBASE,INTL,NOBSCI)

      DO 210 J=1,N
         D(J) = D(J)-RATIO*DELTA(J)
 210  CONTINUE
      SIGMA(IIN) = 0.D0
      GOTO 70

      END


SUBROUTINE solve

!-------------------------------------------------------------
!
!  Directs the solution by either calling for a mesh
!   sweep (AHOT-N) or for a ITM solution (AHOT-N-NS)
!
!-------------------------------------------------------------

USE invar
USE solvar
USE timevar
USE kernel_module
USE dgfem_kernel_module
USE sct_step_kernel_module
USE tracking_routines
use precision_module, only: dp
IMPLICIT NONE
INTEGER :: i, j, k, t, u, v, m, g, gp
REAL(kind=dp) :: xsct

! Intitialize warn to indicate where warnings may occur
warn = 0
ALLOCATE(cnvf(ng))

! Mark the beginning of the solution phase
WRITE (8,*)
WRITE (8,*) "-------------------------- THE SOLUTION ----------------------------------"
WRITE (8,*)

IF (solver == "AHOTN") THEN
    IF (solvertype == "LN" .or. solvertype == "LL") THEN
        ALLOCATE(f_ahot_l(4,nx,ny,nz,ng), e_ahot_l(4,nx,ny,nz))
        f_ahot_l = 0.0d0
        ! Read spatial weights
        call read_sp_wts_ahotn_l
        ! Start the loop over all energy groups
        DO g = 1, ng
            ! Reset the source as external + scattering
            IF (g > 1) THEN ! Downscattering only considered
                DO gp = 1, (g-1)
                     DO k = 1, nz
                        DO j = 1, ny
                           DO i = 1, nx
                              m = mat(i,j,k)
                              xsct = sigs(m,g,gp)

                              s(0,0,0,i,j,k,g) = s(0,0,0,i,j,k,g) + xsct*f_ahot_l(1,i,j,k,gp)
                              s(0,0,1,i,j,k,g) = s(0,0,1,i,j,k,g) + xsct*f_ahot_l(2,i,j,k,gp)
                              s(0,1,0,i,j,k,g) = s(0,1,0,i,j,k,g) + xsct*f_ahot_l(3,i,j,k,gp)
                              s(1,0,0,i,j,k,g) = s(1,0,0,i,j,k,g) + xsct*f_ahot_l(4,i,j,k,gp)
                           END DO
                        END DO
                     END DO
                END DO
            END IF

            ! Get the time to reach this point
            CALL CPU_TIME(ttosolve)

            ! Check which solution scheme will be employed
            WRITE(8,'(1X,A,I4,A)') "Group", g, " iterations..."
            ! Call for the inner iteration (or ITM solver later)
            CALL inner(g)

       ! Get the time out of the solution
       CALL CPU_TIME(tsolve)

    END DO

  ELSE IF (solvertype == "NEFD") THEN
    ALLOCATE(f(0:lambda,0:lambda,0:lambda,nx,ny,nz,ng), e(0:lambda,0:lambda,0:lambda,nx,ny,nz))
    call read_sp_wts_ahotn_nefd(lambda)

    ! Start the loop over all energy groups
    DO g = 1, ng
       ! Reset the source as external + scattering
       IF (g > 1) THEN ! Downscattering only considered
          DO gp = 1, (g-1)
             DO k = 1, nz
                DO j = 1, ny
                   DO i = 1, nx
                      m = mat(i,j,k)
                      xsct = sigs(m,g,gp)
                      DO v = 0, lambda
                         DO u = 0, lambda
                            DO t = 0, lambda
                               s(t,u,v,i,j,k,g) = s(t,u,v,i,j,k,g) + xsct*f(t,u,v,i,j,k,gp)
                            END DO
                         END DO
                      END DO
                   END DO
                END DO
             END DO
          END DO
       END IF

       ! Get the time to reach this point
       CALL CPU_TIME(ttosolve)

       ! Check which solution scheme will be employed
       WRITE(8,'(1X,A,I4,A)') "Group", g, " iterations..."
       ! Call for the inner iteration (or ITM solver later)
       CALL inner(g)

       ! Get the time out of the solution
       CALL CPU_TIME(tsolve)

    END DO

  ENDIF
ELSE IF (solver == "DGFEM") THEN

  IF (solvertype == "LD" .or. solvertype == "DENSE") THEN
    ALLOCATE(f(dofpc,nx,ny,nz,ng,1,1), e(dofpc,nx,ny,nz,1,1))
  ELSE IF (solvertype == "LAGRANGE") THEN
    ALLOCATE(f(ordcb,nx,ny,nz,ng,1,1), e(ordcb,nx,ny,nz,1,1))
  END IF

  ! Intitialize warn to indicate where warnings may occur
  warn = 0

  ! Construct matrix templates
  IF (solvertype == "DENSE") THEN
    call build_tmats_complete(lambda)
  ELSE IF (solvertype == "LAGRANGE") THEN
    call build_tmats_lagrange(lambda)
  END IF

  ! Start the loop over all energy groups
  DO g = 1, ng
     ! Reset the source as external + scattering
     IF (g > 1) THEN ! Downscattering only considered
        DO gp = 1, (g-1)
           DO k = 1, nz
              DO j = 1, ny
                 DO i = 1, nx
                    m = mat(i,j,k)
                    xsct = sigs(m,g,gp)
                    s(:,i,j,k,g,1,1) = s(:,i,j,k,g,1,1) + xsct*f(:,i,j,k,gp,1,1)
                 END DO
              END DO
           END DO
        END DO
     END IF

     ! Get the time to reach this point
     CALL CPU_TIME(ttosolve)

     ! Check which solution scheme will be employed
     WRITE(8,'(1X,A,I4,A)') "Group", g, " iterations..."
     ! Call for the inner iteration (or ITM solver later)
     CALL inner(g)

     ! Get the time out of the solution
     CALL CPU_TIME(tsolve)

  IF (solvertype == "DENSE") THEN
     ! Clean up
     CALL clean_complete_kernel
  ELSE IF (solvertype == "LAGRANGE") THEN
     CALL clean_lagrange_kernel
  END IF

  END DO

ELSE IF (solver == "SCTSTEP") THEN
  ALLOCATE(f(nx,ny,nz,ng,1,1,1), e(nx,ny,nz,1,1,1))
  !ALLOCATE(cnvf(ng))

  ! Set values in tracking module
  tnx=nx;tny=ny;tnz=nz
  ALLOCATE(xmesh(tnx+1))
  ALLOCATE(ymesh(tny+1))
  ALLOCATE(zmesh(tnz+1))
  xmesh=0.0_pr;ymesh=0.0_pr;zmesh=0.0_pr
  DO k=1,tnx
     xmesh(k+1)=xmesh(k)+REAL( dx(k) , pr)
  END DO
  DO k=1,tny
     ymesh(k+1)=ymesh(k)+REAL( dy(k) , pr)
  END DO
  DO k=1,tnz
     zmesh(k+1)=zmesh(k)+REAL( dz(k) , pr)
  END DO

  ! Set octant_signs
  octant_signs(:,1)=(/1 , 1, 1/)
  octant_signs(:,2)=(/1 ,-1, 1/)
  octant_signs(:,3)=(/-1, 1, 1/)
  octant_signs(:,4)=(/-1,-1, 1/)
  octant_signs(:,5)=(/ 1, 1,-1/)
  octant_signs(:,6)=(/ 1,-1,-1/)
  octant_signs(:,7)=(/-1, 1,-1/)
  octant_signs(:,8)=(/-1,-1,-1/)

  ! Intitialize warn to indicate where warnings may occur
  warn = 0

  ! Read spatial weights
  call read_sp_wts_sct_step(lambda)

  ! Allcoate and initialize reflective boundary condition arrays
  IF(xsbc.eq.1) ALLOCATE( refl_left  (ny,nz,8,apo,ng) )
  IF(xebc.eq.1) ALLOCATE( refl_right (ny,nz,8,apo,ng) )
  IF(ysbc.eq.1) ALLOCATE( refl_front (nx,nz,8,apo,ng) )
  IF(yebc.eq.1) ALLOCATE( refl_back  (nx,nz,8,apo,ng) )
  IF(zsbc.eq.1) ALLOCATE( refl_bottom(nx,ny,8,apo,ng) )
  IF(zebc.eq.1) ALLOCATE( refl_top   (nx,ny,8,apo,ng) )

  ! Mark the beginning of the solution phase
  WRITE (8,*)
  WRITE (8,*) "-------------------------- THE SOLUTION ----------------------------------"
  WRITE (8,*)

  ! Start the loop over all energy groups
  DO g = 1, ng
     ! Reset the source as external + scattering
     IF (g > 1) THEN ! Downscattering only considered
        DO gp = 1, (g-1)
           DO k = 1, nz
              DO j = 1, ny
                 DO i = 1, nx
                    m = mat(i,j,k)
                    xsct = sigs(m,g,gp)
                    s(i,j,k,g,1,1,1) = s(i,j,k,g,1,1,1) + xsct*f(i,j,k,gp,1,1,1)
                 END DO
              END DO
           END DO
        END DO
     END IF

     ! Get the time to reach this point
     CALL CPU_TIME(ttosolve)

     ! Check which solution scheme will be employed
     WRITE(8,'(1X,A,I4,A)') "Group", g, " iterations..."
     ! Call for the inner iteration (or ITM solver later)
     CALL inner(g)

     ! Get the time out of the solution
     CALL CPU_TIME(tsolve)

  END DO
  IF( allocated(xmesh)) deallocate(xmesh)
  IF( allocated(ymesh)) deallocate(ymesh)
  IF( allocated(zmesh)) deallocate(zmesh)
END IF

RETURN
END SUBROUTINE solve


	SUBROUTINE SNDSHR ( nparms, nlevel, delz, hdata, iret )
C************************************************************************
C* SNDSHR								*
C*									*
C* This routine will compute the shear components of the wind.		*
C*									*
C* SNDSHR ( NPARMS, NLEVEL, DELZ, HDATA, IRET )				*
C*									*
C* Input parameters:							*
C*	NPARMS		INTEGER		Number of parameters		*
C*	NLEVEL		INTEGER		Number of levels		*
C*	DELZ		CHAR*		Height intervals		*
C*									*
C* Input/Output parameters:						*
C*	HDATA (LLMXLV)	REAL		Interpolated sounding data	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	CHARACTER*(*)	delz
	REAL		hdata(*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	CALL ST_CRNM ( delz, deltaz, ier )
	IF  ( ier .ne. 0 ) deltaz = 500.
C
	DO  i = 2, nlevel-1
	    IF  ( ERMISS(hdata((i-1+1)*nparms+IUWND)) .or.
     +		  ERMISS(hdata((i-1-1)*nparms+IUWND)) )  THEN
		hdata((i-1)*nparms+IDUDZ) = RMISSD
	    ELSE
	    	hdata((i-1)*nparms+IDUDZ) =
     +			(hdata((i-1+1)*nparms+IUWND)-
     +			 hdata((i-1-1)*nparms+IUWND)) / (2.*deltaz)
	    END IF
	    IF  ( ERMISS(hdata((i-1+1)*nparms+IVWND)) .or.
     +		  ERMISS(hdata((i-1-1)*nparms+IVWND)) )  THEN
		hdata((i-1)*nparms+IDUDZ) = RMISSD
	    ELSE
		hdata((i-1)*nparms+IDVDZ) =
     +			(hdata((i-1+1)*nparms+IVWND)-
     +			 hdata((i-1-1)*nparms+IVWND)) / (2.*deltaz)
	    END IF
	END DO
C*
	RETURN
	END


!***********************************************************
!*               Copyright (c) Wenbin Yu                   *
!*              All rights reserved                        *
!*          Mechanical and Aerospace Engineering           *
!*                                                         *
!*                Utah State University                    *
!***********************************************************

!***************************************************************
!*                                                             *
!> This module assemles within a member without considering the particular conditions of the end points
!Outputs:MemberEqn, MemberJacobian                           *
!***************************************************************

MODULE Member
USE InternalData
USE PrescribedCondition
USE Element

IMPLICIT NONE

PRIVATE       ! So everything is private, except declared by PUBLIC
PUBLIC AssembleMemberRHS,AssembleMemberJacobian,ExtractMemberProperties,ndiv,ncol_memb

INTEGER::ndiv      !< number of divisions
INTEGER::ncol_memb             !< the total number of columns of the member
!=============================================

CONTAINS

!************************************************************
!*                                                          *
!>  Assemble the equations for each member                  *
!*															*
!************************************************************
SUBROUTINE  AssembleMemberRHS(ndof_el,memb_info_i,v_root_a,omega_a,x_memb,rhs_memb,aero_flag,grav_flag,init_cond)

INTEGER,INTENT(IN)::ndof_el !<#ioaero::ndof_el
INTEGER,INTENT(IN)::aero_flag   !<#ioaero::aero_flag
INTEGER,INTENT(IN)::grav_flag   !<#ioaero::grav_flag
TYPE (MemberInf),INTENT(IN)::memb_info_i    !< array containing the characteristics of a beam member

REAL(DBL),INTENT(IN)::v_root_a(:)   !< linear velocity of frame a
REAL(DBL),INTENT(IN)::omega_a(:)     !< angular velocity of frame a
REAL(DBL),INTENT(IN)::x_memb(:) !< solution vector of a beam member

REAL(DBL),INTENT(OUT)::rhs_memb(:)  !<RHS vector of a beam member

REAL(DBL),OPTIONAL,INTENT(IN)::init_cond(:,:)   !<#ioaero::init_cond

INTEGER:: i
INTEGER:: nrl !< the starting row/col for elemental rhs to fill in

rhs_memb=0.0D0

nrl=0

DO i=1,ndiv
   CALL ExtractElementProperties(i,memb_info_i,x_memb(nrl+1:nrl+ndof_el),v_root_a,omega_a,ndof_el,init_memb(:,:),&
																							& aero_flag,grav_flag)

! assemble the equations within one element
!------------------------------------------------------
   rhs_memb(nrl+1:nrl+NDOF_ND+ndof_el) =rhs_memb(nrl+1:nrl+NDOF_ND+ndof_el) +ElemEqn(ndof_el)

   nrl=nrl+ndof_el

ENDDO

END SUBROUTINE AssembleMemberRHS
!****************************************************************

!************************************************************
!*                                                          *
!>  Assemble the Jacobian for each member                   *
!*															*
!************************************************************
SUBROUTINE  AssembleMemberJacobian(ndof_el,niter,memb_info_i,v_root_a,omega_a,x_memb,&
                                 & nz_memb,irn_memb,jcn_memb,coef_memb,aero_flag,grav_flag)

INTEGER,INTENT(IN)::ndof_el !<#ioaero::ndof_el
INTEGER,INTENT(IN)::niter   !<#ioaero::niter
INTEGER,INTENT(IN)::aero_flag   !<#ioaero::aero_flag
INTEGER,INTENT(IN)::grav_flag  !<#ioaero::grav_flag
TYPE (MemberInf),INTENT(IN)::memb_info_i    !< array containing the characteristics of a beam member

REAL(DBL),INTENT(IN)::v_root_a(:)    !< linear velocity of frame a
REAL(DBL),INTENT(IN)::omega_a(:)    !< angular velocity of frame a
REAL(DBL),INTENT(IN)::x_memb(:) !< solution vector of a beam member

INTEGER,INTENT(OUT)::nz_memb    !<Number of nonzero value of the member Jacobian
INTEGER,INTENT(OUT)::irn_memb(:)    !< line index of the nonzero coefficient
INTEGER,INTENT(OUT)::jcn_memb(:)    !< column index of the nonzero coefficient
REAL(DBL),INTENT(OUT)::coef_memb(:) !< value of the nonzero coefficient

INTEGER:: i,j
INTEGER:: nrl ! the starting row/col for elemental matrix to fill in

REAL(DBL)::elemJac(NDOF_ND+ndof_el,ndof_el)

coef_memb=0.0D0

nrl=0
nz_memb=0.0D0

DO i=1,ndiv

   CALL ExtractElementProperties(i,memb_info_i,x_memb(nrl+1:nrl+ndof_el),v_root_a,omega_a,ndof_el,init_memb(:,:),&
								& aero_flag,grav_flag)

!Assemble the Jacobian matrix
!------------------------------------------------------
   IF(assemble_flag/=0) THEN
	   !coef_memb(nrl+1 :nrl+NDOF_ND+ndof_el,nrl+1:nrl+ndof_el)= ElemMass()
	   CALL ElemMass(ndof_el,elemJac)
   ELSE
	   !coef_memb(nrl+1 :nrl+NDOF_ND+ndof_el,nrl+1:nrl+ndof_el)= ElemJacobian(ndof_el,niter)
	   CALL ElemJacobian(ndof_el,niter,elemJac)
   ENDIF

   CALL Insert1DElement(nz_memb,elemJac,irn_memb,jcn_memb,coef_memb,nrl,nrl)

   nrl=nrl+ndof_el

ENDDO

IF(DEBUG)THEN
	WRITE(IOUT,*) 'MEMBER COEFFICIENT MATRIX'
	WRITE(IOUT,*)nz_memb
	DO j=1, nz_memb
		WRITE(IOUT,'(1X,2i5,ES20.12)')irn_memb(j),jcn_memb(j),coef_memb(j)
	ENDDO

ENDIF

END SUBROUTINE  AssembleMemberJacobian
!****************************************************************

!************************************************************
!*                                                          *
!>  Extract member properties                               *
!*															*
!************************************************************
SUBROUTINE  ExtractMemberProperties(memb_no,memb_info_i,member,ncond_mb,mb_condition,distr_fun,error,init_cond)

INTEGER,INTENT(IN)   ::memb_no  !<Number of the current member
INTEGER,INTENT(IN)   ::ncond_mb !<#ioaero::ncond_mb
INTEGER,INTENT(IN)   ::member(:,:)  !<#ioaero::member
TYPE (MemberInf),INTENT(IN)::memb_info_i    !< array containing the characteristics of a beam member
REAL(DBL),INTENT(IN) ::distr_fun(:,:)   !<#ioaero::distr_fun
TYPE(PrescriInf),INTENT(IN)::mb_condition(:) !<#ioaero::mb_condition
CHARACTER(*),INTENT(OUT)::error !<#ioaero::error
REAL(DBL),OPTIONAL,INTENT(IN)::init_cond(:,:)   !<#ioaero::init_cond

INTEGER:: ninit

ndiv=memb_info_i%ndiv
ncol_memb=memb_info_i%ncol_memb

! Distributed load information
!---------------------------------------
exist_load=.FALSE.
follower_load=.FALSE. ! Initialize the load flag and follower flag

IF(ncond_mb>0) CALL ExistPI(memb_no,mb_condition,exist_load,follower_load)
IF(exist_load) load=GetDistributedLoad(memb_no,mb_condition,distr_fun)
!------------------------------------------------------------------------------

! Obtain the initial conditions for this member
! for both initial step and time marching, it holds the values from previous time step
!---------------------------------------------
IF(init_flag/=0) THEN
    ALLOCATE(init_memb(ndiv,12+NSTATES),STAT=allo_stat)
	IF(MemoryError('init_memb',error)) GOTO 9999
	ninit=SUM(member(1:memb_no-1,6))
	init_memb(1:ndiv,:)=init_cond(ninit+1:ninit+ndiv,:)
ENDIF

9999 IF(error/='')THEN
		WRITE(*,*) 'Member.f90 : ',error
        ERROR STOP 107
	 ENDIF

END SUBROUTINE ExtractMemberProperties
!****************************************************************

END MODULE Member


subroutine single_hh_trafo_real_cpu_single(q, hh, nb, nq, ldq)

   use elpa_abstract_impl
   use precision
   ! Perform single real Householder transformation.
   ! This routine is not performance critical and thus it is coded here in Fortran

   implicit none

   integer(kind=ik), intent(in)   :: nb, nq, ldq
   real(kind=rk4), intent(inout)   :: q(ldq, *)
   real(kind=rk4), intent(in)      :: hh(*)
   integer(kind=ik)               :: i
   real(kind=rk4)                  :: v(nq)

   ! v = q * hh
   v(:) = q(1:nq,1)
   do i=2,nb
      v(:) = v(:) + q(1:nq,i) * hh(i)
   enddo

   ! v = v * tau
   v(:) = v(:) * hh(1)

   ! q = q - v * hh**T
   q(1:nq,1) = q(1:nq,1) - v(:)
   do i=2,nb
      q(1:nq,i) = q(1:nq,i) - v(:) * hh(i)
   enddo

end subroutine


!> Author:   Jabir Ali Ouassou
!> Category: Foundation
!>
!> This file defines a module containing the machine size of single-precision, double-precision, and quadruple-precision
!> floating point numbers; to declare the floating point precision of a variable, use real(sp), real(dp), or real(qp) as
!> the type of the variable. It also defines the working-precision, which will be the default kind for module procedures.
!> As for module procedures, this library defines some common utility functions for working with e.g. complex numbers.

module basic_m
  use :: iso_fortran_env

  ! Declare floating-point precisions
  integer,  parameter :: sp  = real32              !! Single precision
  integer,  parameter :: dp  = real64              !! Double precision
  integer,  parameter :: qp  = real128             !! Quadruple precision
  integer,  parameter :: wp  = dp                  !! Working precision

  ! Define common mathematical constants
  real(wp), parameter :: inf = huge(1.0_wp)        !! Numerical infinity
  real(wp), parameter :: eps = epsilon(1.0_wp)     !! Numerical infinitesimal
  real(wp), parameter :: pi  = atan(1.0_wp)*4.0_wp !! Circle constant
contains
  pure elemental function re(z) result(x)
    !! Returns the real part of a complex number z=x+iy.
    !!
    !! @NOTE:
    !!   This function might be replaced by the structure
    !!   notation z%re when common compilers support it.
    complex(wp), intent(in) :: z   !! Complex number
    real(wp)                :: x   !! Real part

    x = real(z,kind=wp)
  end function

  pure elemental function im(z) result(y)
    !! Returns the imaginary part of a complex number z=x+iy.
    !!
    !! @NOTE:
    !!   This function might be replaced by the structure
    !!   notation z%im when common compilers support it.
    complex(wp), intent(in) :: z   !! Complex number
    real(wp)                :: y   !! Imaginary part

    y = aimag(z)
  end function

  pure elemental function cx(x,y) result(z)
    !! Returns the complex number z=x+iy.
    real(wp), intent(in)           :: x   !! Real part
    real(wp), intent(in), optional :: y   !! Imaginary part
    complex(wp)                    :: z   !! Complex number

    if (present(y)) then
      z = cmplx(x,y,kind=wp)
    else
      z = cmplx(x,0,kind=wp)
    end if
  end function

  pure elemental function arg(z) result(t)
    !! Returns the complex argument θ of a complex number z=r·exp(iθ).
    complex(wp), intent(in) :: z   !! Complex number
    real(wp)                :: t   !! Complex argument

    t = atan2(im(z), re(z))
  end function

  pure function unitvector(v) result(r)
    !! If the argument has a finite norm, then it will be rescaled to a unit
    !! vector. If that norm is zero, then a zero vector is returned instead.
    real(wp), dimension(3), intent(in) :: v   !! Vector
    real(wp), dimension(3)             :: r   !! Unit vector

    r = v/(norm2(v)+eps)
  end function

  pure function nonzero(v) result(r)
    !! Checks whether or not the argument has a finite norm.
    real(wp), dimension(:), intent(in) :: v   !! Vector
    logical                            :: r   !! Finite

    r = norm2(v) > eps
  end function
end module