MODULE NCA_GREENS_FUNCTIONS
  USE NCA_VARS_GLOBAL
  USE NCA_SETUP
  !
  USE SF_TIMER,    only: start_timer,stop_timer
  USE SF_LINALG,   only: diag,outerprod
  USE SF_CONSTANTS,only: one,xi,zero,pi
  USE SF_IOTOOLS,  only: free_unit,reg,str,splot
  USE SF_ARRAYS,   only: arange,linspace
  USE SF_SPECIAL,  only: fermi
  USE DMFT_FFTGF
  USE DMFT_FFTAUX
  !
  implicit none
  private

  public :: nca_build_bare_propagator
  public :: nca_build_dressed_propagator
  public :: nca_get_impurity_gf

  !Frequency and time arrays:
  !=========================================================
  real(8),dimension(:),allocatable         :: wm,tau
  real(8),allocatable,dimension(:,:,:,:,:) :: impGtau

contains

  !+------------------------------------------------------------------+
  !PURPOSE  :
  ! G(w_n; E) = [iw_n − E]^−1 --> [f(E)-1]*exp(-tau*E)
  !+------------------------------------------------------------------+
  subroutine nca_build_bare_propagator
    integer                     :: iw,itau,istate
    !
    write(LOGfile,"(A)")"Evaluating bare atomic propagator R0(tau)"
    !
    call allocate_grids
    ncaR0=zero
    ncaR =zero
    !
    do istate=1,Nfock
       do itau=0,Ltau
          !this is: exp(-tau*Hloc) = sum_ab <b|exp(-tau*E_a)|a> |b><a| = sum_a exp(-tau*E_a) |a><a|
          ncaR0(istate,istate,itau) = exp(-tau(itau)*EigValues(istate))
          !this is the FFT of one/(iw - E_a):
          !ncaR0(istate,istate,itau) = exp(-tau(itau)*EigValues(istate))*(1d0-fermi(Eigvalues(istate),beta))
       enddo
       call splot("R0_tau.nca",tau,ncaR0(istate,istate,0:),append=.true.)
    enddo
    !
    ncaR = ncaR0
    !
  end subroutine nca_build_bare_propagator

  !+------------------------------------------------------------------+
  !PURPOSE  :
  !This routine performs the NCA self-consistency loop:
  !given R0(tau) and a guess for R(tau)
  !evaluates:
  !Snca(tau) = \sum_ab [C_a * R(tau) * C^+_b . \Delta_{ab}(-tau) -&
  !                     C^+_a * R(tau) * C_b . \Delta_{ab}(tau)]
  !+------------------------------------------------------------------+
  subroutine nca_get_sigma_nca(ncaSigma)
    real(8),dimension(Nfock,Nfock,0:Ltau) :: ncaSigma
    real(8),dimension(Nfock,Nfock)        :: Matrix1,Matrix2
    integer                               :: itau,ispin,iorb
    integer :: i,j,k1
    ncaSigma=0d0
    !
    do itau=0,Ltau
       !
       do ispin=1,Nspin
          do iorb=1,Norb
             Matrix1=0d0
             Matrix2=0d0
             Matrix1 = matmul(matmul(Coperator(ispin,iorb)%Op,ncaR(:,:,itau)),CDGoperator(ispin,iorb)%Op)
             !
             Matrix2 = matmul(matmul(CDGoperator(ispin,iorb)%Op,ncaR(:,:,itau)),Coperator(ispin,iorb)%Op)
             !
             ncaSigma(:,:,itau) = ncaSigma(:,:,itau) - Matrix1*NcaDeltaAnd_tau(ispin,ispin,iorb,iorb,Ltau-itau)
             ncaSigma(:,:,itau) = ncaSigma(:,:,itau) - Matrix2*NcaDeltaAnd_tau(ispin,ispin,iorb,iorb,itau)
             !
          enddo
       enddo
       !
    enddo

  end subroutine nca_get_sigma_nca

!+------------------------------------------------------------------+
!PURPOSE  :
!Given R(tau),R0(tau) and S(tau) solve the Dyson equation:
!R(tau) = R0(tau) + int_0^tau d2 int_0_tau2 d1 R(tau-tau2)*S(tau2-tau1)*R0(tau1)
!+------------------------------------------------------------------+
subroutine nca_build_dressed_propagator
real(8),dimension(Nfock,Nfock,0:Ltau) :: ncaSigma,SxR0,ncaRold
real(8),dimension(Nfock,Nfock)        :: Matrix1
real(8)                                     :: dtau,error
integer                                     :: itau,is
logical                                     :: converged
converged=.false.
dtau=tau(1)-tau(0)
call start_timer()
do while (.not.converged)
 ncaRold = ncaR
 !
 !Get the Self-energy:
 call nca_get_sigma_nca(ncaSigma)
 !
 !Get the polarization SxR0(tau) = int_0^tau d1 ncaSigma(tau-tau1)R0(tau1)
 do itau=0,Ltau
    SxR0(:,:,itau) = tau_convolution(ncaSigma,ncaR0,itau)*dtau
 enddo
 !
 !R(tau) = R0(tau) + int_0^tau d1 R(tau-tau1)SxR0(tau1)
 do itau=0,Ltau
    Matrix1 = tau_convolution(ncaR,SxR0,itau)*dtau
    ncaR(:,:,itau) = ncaR0(:,:,itau) + Matrix1
 enddo
 !
 error = sum(abs(ncaR-ncaRold))/sum(abs(ncaR))
 !
 converged = (error<=nca_error)
 !
 write(LOGfile,*)error,converged
enddo
call stop_timer()
!
!
zeta_function = 0d0
do is=1,Nfock
 zeta_function=zeta_function+ncaR(is,is,Ltau)
end do
!
end subroutine nca_build_dressed_propagator

!+------------------------------------------------------------------+
!PURPOSE  :  G(tau) = -Tr(R(beta-tau)*C*R(tau)*C+)/Z
!+------------------------------------------------------------------+
subroutine nca_get_impurity_gf
integer                        :: ispin,iorb,is,itau,isector,dim,stride
real(8)                        :: trace
real(8),dimension(Nfock,Nfock) :: Matrix
real(8),dimension(0:3)         :: Ctail
!
if(allocated(impGtau))deallocate(impGtau)
allocate(impGtau(Nspin,Nspin,Norb,Norb,0:Ltau))
!
impGtau=0d0
do ispin=1,Nspin
 do iorb=1,Norb
    do itau=0,Ltau
       Matrix = 0d0
       Matrix =-matmul(ncaR(:,:,Ltau-itau),Coperator(ispin,iorb)%Op)
       Matrix = matmul(Matrix,ncaR(:,:,itau))
       Matrix = matmul(Matrix,CDGoperator(ispin,iorb)%Op)
       trace  = 0d0
       do is=1,Nfock
          trace=trace+Matrix(is,is)
       enddo
       impGtau(ispin,ispin,iorb,iorb,itau)=trace/zeta_function
    enddo
 enddo
enddo
!
do ispin=1,Nspin
 do iorb=1,Norb
    Ctail =  tail_coeff_glat(Uloc(iorb),nca_dens_spin(ispin,iorb),xmu,0d0)
    call fft_gf_tau2iw(impGmats(ispin,ispin,iorb,iorb,:),impGtau(ispin,ispin,iorb,iorb,0:Ltau),beta,C=Ctail)
 enddo
enddo
!
!
call Get_Self_Energy()
call print_imp_gf()
!
end subroutine nca_get_impurity_gf

!+------------------------------------------------------------------+
!PURPOSE  : Print normal Green's functions
!+------------------------------------------------------------------+
subroutine Get_Self_Energy
integer           :: i,ispin,iorb
complex(8)        :: fg0
real(8)           :: n0,C0,C1
real(8)           :: wm1,wm2
!
impSmats = zero
!
!Diagonal in both spin and orbital: this is ensured by the special *per impurity" bath structure
!no intra-orbital hoopings
do ispin=1,Nspin
 do iorb=1,Norb
    n0 = nca_dens(iorb)
    C0=Uloc(iorb)*(n0-0.5d0)
    C1=Uloc(iorb)**2*n0*(1.d0-n0)
    do i=1,Lmats
       fg0 = xi*wm(i) + xmu - impHloc(ispin,ispin,iorb,iorb) - ncaDeltaAnd_iw(ispin,ispin,iorb,iorb,i)
       impG0mats(ispin,ispin,iorb,iorb,i) = one/fg0
       impSmats(ispin,ispin,iorb,iorb,i)= fg0 - one/impGmats(ispin,ispin,iorb,iorb,i)
       impStail(ispin,ispin,iorb,iorb,i) = C0 + C1/(xi*wm(i))
    enddo
 enddo
enddo
!
wm1 = pi/beta ; wm2=3d0*pi/beta
do ispin=1,Nspin
 do iorb=1,Norb
    nca_zeta(ispin,iorb)   = 1.d0/( 1.d0 + abs( dimag(impSmats(ispin,ispin,iorb,iorb,1))/wm1 ))
 enddo
enddo
end subroutine Get_Self_Energy

!+------------------------------------------------------------------+
!PURPOSE  : Print normal Green's functions
!+------------------------------------------------------------------+
subroutine print_imp_gf
integer                                           :: i,ispin,iorb
character(len=20)                                 :: suffix
!
do ispin=1,Nspin
 do iorb=1,Norb
    suffix="_l"//str(iorb)//str(iorb)//"_s"//str(ispin)
    call splot("impSigma"//reg(suffix)//"_iw.nca",wm,impSmats(ispin,ispin,iorb,iorb,:))
    call splot("impStail"//reg(suffix)//"_iw.nca",wm,impStail(ispin,ispin,iorb,iorb,:))
    call splot("impG"//reg(suffix)//"_iw.nca"    ,wm,impGmats(ispin,ispin,iorb,iorb,:))
    call splot("impG0"//reg(suffix)//"_iw.nca"   ,wm,impG0mats(ispin,ispin,iorb,iorb,:))
    call splot("impG"//reg(suffix)//"_tau.nca",tau,impGtau(ispin,ispin,iorb,iorb,:))
 enddo
enddo
end subroutine print_imp_gf

!+------------------------------------------------------------------+
!PURPOSE  : Allocate and setup arrays with frequencies and times
!+------------------------------------------------------------------+
subroutine allocate_grids
integer :: i
allocate(wm(Lmats))
allocate(tau(0:Ltau))
wm     = pi/beta*dble(2*arange(1,Lmats)-1)
tau(0:)= linspace(0.d0,beta,Ltau+1)
end subroutine allocate_grids

!+------------------------------------------------------------------+
!PURPOSE  :
!+------------------------------------------------------------------+
function tau_convolution(A,B,itau) result(C)
real(8),dimension(Nfock,Nfock,0:Ltau) :: A,B
real(8),dimension(Nfock,Nfock)        :: C
real(8),dimension(Nfock,Nfock,0:Ltau) :: AxB
integer                                     :: itau
integer                                     :: itau1
AxB=0d0
do itau1=0,itau
 AxB(:,:,itau1)=matmul(A(:,:,itau-itau1),B(:,:,itau1))
end do
C = tau_trapz(AxB(:,:,0:),0,itau)
end function tau_convolution

!----------------------------------------------------------------------------
!  This function calculates the sum
!    \sum_{k=i}^{j} w_{k}^{i,j} f_{k}.
!    w_{k}^{i,j} = 1/2  for k=i,j
!                = 1    for i<k<j
!                      OR
!                = 1    for i<k<=j (half-edge)
!----------------------------------------------------------------------------
function tau_trapz(f,ia,ib) result(sum)
real(8),dimension(Nfock,Nfock,0:Ltau),intent(in) :: f
integer,intent(in)                                     :: ia, ib
integer                                                :: k
real(8),dimension(Nfock,Nfock)                   :: sum
sum=0d0
if(ia==ib)then
 return
else
 sum=sum+0.5d0*f(:,:,ia)
 do k=ia+1,ib-1
    sum=sum+f(:,:,k)
 end do
 sum=sum+0.5d0*f(:,:,ib)
end if
end function tau_trapz

end MODULE NCA_GREENS_FUNCTIONS

!


      PROGRAM xgammln
C     driver for routine gammln
      INTEGER i,nval
      REAL actual,calc,gammln,x
      CHARACTER text*14
      open(7,file='FNCVAL.DAT',status='OLD')
10    read(7,'(a)') text
      if (text.ne.'Gamma Function') goto 10
      read(7,*) nval
      write(*,*) 'Log of gamma function:'
      write(*,'(1x,t11,a1,t24,a6,t40,a10)')
     *     'X','Actual','GAMMLN(X)'
      do 11 i=1,nval
        read(7,*) x,actual
        if (x.gt.0.0) then
          if (x.ge.1.0) then
            calc=gammln(x)
          else
            calc=gammln(x+1.0)-log(x)
          endif
          write(*,'(f12.2,2f18.6)') x,log(actual),calc
        endif
11    continue
      close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xgammln.for


PROGRAM timer
	IMPLICIT NONE
	REAL :: t1,t2,rate
	INTEGER :: c1,c2,cr,cm,i,j,n,s
	INTEGER , PARAMETER :: x=500,y=500,runs=10000
	REAL :: array(x,y),a_diff,diff

	! First initialize the system_clock
	CALL system_clock(count_rate=cr)
	CALL system_clock(count_max=cm)
	rate = REAL(cr)
	WRITE(*,*) "system_clock rate ",rate

	CALL CPU_TIME(t1)
	CALL SYSTEM_CLOCK(c1)
	DO n = 1 , runs
	   FORALL(i = 1:x,j = 1:y)
		  array(i,j) = REAL(i)*REAL(j) + 2
	   END FORALL
	   array(1,1) = array(1,2)
	END DO
	CALL CPU_TIME(t2)
	CALL SYSTEM_CLOCK(c2)

	WRITE(*,*) "system_clock : ",(c2 - c1)/rate
	WRITE(*,*) "cpu_time     : ",(t2-t1)

	CALL CPU_TIME(t1)
	CALL SYSTEM_CLOCK(c1)
	DO n = 1 , runs
	   !DIR$ NOPARALLEL
	   FORALL(i = 1:x,j = 1:y)
		  array(i,j) = REAL(i)*REAL(j) + 2
	   END FORALL
	   array(1,1) = array(1,2)
	END DO
	CALL CPU_TIME(t2)
	CALL SYSTEM_CLOCK(c2)
	print *, 'NOPARALLEL'
	WRITE(*,*) "system_clock : ",(c2 - c1)/rate
	WRITE(*,*) "cpu_time     : ",(t2-t1)

  END PROGRAM timer


! { dg-do compile }
! { dg-options "-ffrontend-optimize" }
! PR fortran/66385 - this used to ICE
! Original test case by Mianzhi Wang
program test
  double precision::aa(30)
  double precision::a(3,3),b
  b=1d0
  forall(i=1:3)
    a(:,i)=b*[1d0,2d0,3d0]
  end forall

  forall(i=1:10)
    aa(10*[0,1,2]+i)=1d0
  end forall

end program


! { dg-do run }
! { dg-require-effective-target offload_device_nonshared_as }

module e_50_5_mod
integer, parameter :: THRESHOLD1 = 500, THRESHOLD2 = 100
contains
  subroutine init (v1, v2, N)
    integer :: i, N
    real :: v1(N), v2(N)
    do i = 1, N
      v1(i) = i + 2.0
      v2(i) = i - 3.0
    end do
  end subroutine

  subroutine check (p, N)
    integer :: i, N
    real, parameter :: EPS = 0.00001
    real :: diff, p(N)
    do i = 1, N
      diff = p(i) - (i + 2.0) * (i - 3.0)
      if (diff > EPS .or. -diff > EPS) call abort
    end do
  end subroutine

  subroutine vec_mult (N)
    use omp_lib, only: omp_is_initial_device
    integer :: i, N
    real :: p(N), v1(N), v2(N)
    call init (v1, v2, N)
    !$omp target if(N > THRESHOLD1) map(to: v1,v2) map(from: p)
      if (omp_is_initial_device ()) call abort
      !$omp parallel do if(N > THRESHOLD2)
      do i = 1, N
        p(i) = v1(i) * v2(i)
      end do
    !$omp end target
    call check (p, N)
  end subroutine
end module

program e_50_5
  use e_50_5_mod, only : vec_mult
  integer :: n
  n = 1000
  call vec_mult (n)
end program


!
!  Copyright 2017-2019 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine hpsi1_RT_stencil(A,B,Cx,Cy,Cz,Dx,Dy,Dz,E,F)
  use global_variables, only: NL
  use opt_variables,    only: zifdx, zifdy, zifdz
  implicit none
  real(8),intent(in)     :: A
  real(8),intent(in)     :: B(0:NL-1)
  real(8),intent(in)     :: Cx(4),Cy(4),Cz(4)
  real(8),intent(in)     :: Dx(4),Dy(4),Dz(4)
  complex(8),intent(in)  :: E(0:NL-1)
  complex(8),intent(out) :: F(0:NL-1)
  complex(8),parameter   :: zI = (0.d0, 1.d0)

  integer    :: i
  complex(8) :: v(3), w(3)

#define IDX zifdx
#define IDY zifdy
#define IDZ zifdz

  do i=0,NL-1
    v(1)=Cx(1)*(E(IDX(1,i))+E(IDX(-1,i))) &
    &   +Cx(2)*(E(IDX(2,i))+E(IDX(-2,i))) &
    &   +Cx(3)*(E(IDX(3,i))+E(IDX(-3,i))) &
    &   +Cx(4)*(E(IDX(4,i))+E(IDX(-4,i)))

    w(1)=Dx(1)*(E(IDX(1,i))-E(IDX(-1,i))) &
    &   +Dx(2)*(E(IDX(2,i))-E(IDX(-2,i))) &
    &   +Dx(3)*(E(IDX(3,i))-E(IDX(-3,i))) &
    &   +Dx(4)*(E(IDX(4,i))-E(IDX(-4,i)))

    v(2)=Cy(1)*(E(IDY(1,i))+E(IDY(-1,i))) &
    &   +Cy(2)*(E(IDY(2,i))+E(IDY(-2,i))) &
    &   +Cy(3)*(E(IDY(3,i))+E(IDY(-3,i))) &
    &   +Cy(4)*(E(IDY(4,i))+E(IDY(-4,i)))

    w(2)=Dy(1)*(E(IDY(1,i))-E(IDY(-1,i))) &
    &   +Dy(2)*(E(IDY(2,i))-E(IDY(-2,i))) &
    &   +Dy(3)*(E(IDY(3,i))-E(IDY(-3,i))) &
    &   +Dy(4)*(E(IDY(4,i))-E(IDY(-4,i)))

    v(3)=Cz(1)*(E(IDZ(1,i))+E(IDZ(-1,i))) &
    &   +Cz(2)*(E(IDZ(2,i))+E(IDZ(-2,i))) &
    &   +Cz(3)*(E(IDZ(3,i))+E(IDZ(-3,i))) &
    &   +Cz(4)*(E(IDZ(4,i))+E(IDZ(-4,i)))

    w(3)=Dz(1)*(E(IDZ(1,i))-E(IDZ(-1,i))) &
    &   +Dz(2)*(E(IDZ(2,i))-E(IDZ(-2,i))) &
    &   +Dz(3)*(E(IDZ(3,i))-E(IDZ(-3,i))) &
    &   +Dz(4)*(E(IDZ(4,i))-E(IDZ(-4,i)))

    F(i) = B(i)*E(i) + A*E(i) - 0.5d0*(v(1)+v(2)+v(3)) - zI*(w(1)+w(2)+w(3))
  end do
end subroutine


 !
 ! This file is part of the ExaHyPE project.
 ! Copyright (c) 2016  http://exahype.eu
 ! All rights reserved.
 !
 ! The project has received funding from the European Union's Horizon
 ! 2020 research and innovation programme under grant agreement
 ! No 671698. For copyrights and licensing, please consult the webpage.
 !
 ! Released under the BSD 3 Open Source License.
 ! For the full license text, see LICENSE.txt
 !

SUBROUTINE ADERRiemannSolverLinear(lQbndL,lFbndL,lQbndR, lFbndR,nv)
    USE typesDef

    USE, INTRINSIC :: ISO_C_BINDING
    IMPLICIT NONE
    ! Argument list
    REAL, INTENT(IN)     :: lQbndL(nVar,nDOF(2),nDOF(3))              ! left space-time degrees of freedom
    REAL, INTENT(IN)     :: lQbndR(nVar,nDOF(2),nDOF(3))              ! right space-time degrees of freedom
    REAL, INTENT(IN)     :: nv(d)                                     ! normal vector
    REAL, INTENT(OUT)  :: lFbndL(nVar,nDOF(2),nDOF(3))              ! left flux
    REAL, INTENT(OUT)  :: lFbndR(nVar,nDOF(2),nDOF(3))              ! right flux
    ! Local variables
    INTEGER           :: i,j,k,l
    REAL              :: aux(d), QavL(nVar), QavR(nVar), Id(nVar,nVar), smax
    REAL              :: Bn(nVar,nVar)
    REAL              :: LL(nVar), LR(nVar)
    !
    ! Identity matrix
    Id = 0.0
    DO i=1,nVar
        Id(i,i)=1.0
    ENDDO
    !
    ! Compute the average states from the left and the right, which we need to compute the numerical dissipation
    QavL = 0.
    QavR = 0.
    DO k = 1, nDOF(3)
      DO j = 1, nDOF(2)
            aux = (/ 1., wGPN(j), wGPN(k) /)
            QavL = QavL + PRODUCT(aux(1:nDim))*lQbndL(:,j,k)
            QavR = QavR + PRODUCT(aux(1:nDim))*lQbndR(:,j,k)
        ENDDO
    ENDDO
    !
    ! If necessary, compute the left and right averages of the material parameters
    !

    !@todo anisotropic material
    !IF(nParam.GT.0) THEN
    !    parL = 0.
    !    parR = 0.
    !    DO k = 1, nDOF(3)
    !      DO j = 1, nDOF(2)
    !            aux = (/ 1., wGPN(j), wGPN(k) /)
    !            parL = parL + PRODUCT(aux(1:nDim))*lparbndL(:,j,k)
    !            parR = parR + PRODUCT(aux(1:nDim))*lparbndR(:,j,k)
    !        ENDDO
    !    ENDDO
    !ENDIF
    !
    ! Here, we implement a very simple Rusanov scheme with scalar dissipation (smax*Id).
    ! We can change this into a more sophisticated Osher or HLLEM Riemann solver whenever needed!
    !
    !CALL PDEEigenvalues(LL,QavL,parL,nv)
    !CALL PDEEigenvalues(LR,QavR,parR,nv)

    !@todo anisotropic material
    CALL PDEEigenvalues(LL,QavL,nv)
    CALL PDEEigenvalues(LR,QavR,nv)

    smax = MAX( MAXVAL(ABS(LL)), MAXVAL(ABS(LR)) )

    !print *, smax
    !stop
    !
    ! We now compute the numerical flux. Note that the scheme is at the moment written in
    ! CONSERVATION FORM => no fluctuations, but real fluxes.
    ! Later, this will be converted into the left and right fluctuations.
    !
    CALL PDEMatrixB(Bn,0.5*(QavL+QavR),nv) ! evaluate the system matrix just once in the averaged state

    DO k = 1, nDOF(3)
       DO j = 1, nDOF(2)
          !CALL PDEMatrixB(Bn,0.5*(QavL+QavR),nv)
          !CALL PDEMatrixB(Bn,0.5*(lQbndL(:,j,k)+lQbndR(:,j,k)),nv,0.5*(lparbndL(:,j,k)+lparbndR(:,j,k))) ! evaluate the system matrix in each Gaussian point again (slow)

          lFbndL(:,j,k) = 0.5*MATMUL(Bn - Id*smax, lQbndR(:,j,k) - lQbndL(:,j,k) )
          lFbndR(:,j,k) = 0.5*MATMUL(Bn + Id*smax, lQbndR(:,j,k) - lQbndL(:,j,k) )

          !lFbndL(:,j,k) = 0.5*( lFbndR(:,j,k) + lFbndL(:,j,k) ) - 0.5*smax*( lQbndR(:,j,k) - lQbndL(:,j,k) )
          !lFbndR(:,j,k) = lFbndL(:,j,k)

        ENDDO
     ENDDO

    !
    !
    !PRINT *, ' --------lFbndL-ADERRiemannSolver-------------------------------- '
    !PRINT *, lFbndL
    !PRINT *, ' --------lFbndL-ADERRiemannSolver-------------------------------- '

    !OPEN(UNIT=12, FILE="aoutput_lFbndL.txt", ACTION="write", STATUS="replace")
    !WRITE(12, '(ES24.16,1x)') , lFbndL
    !CALL EXIT
    !

END SUBROUTINE ADERRiemannSolverLinear


*     TC01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, PMAX, INDMAX
      PARAMETER        ( MMAX = 20, PMAX = 20, INDMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDPCO1, LDPCO2, LDQCO1, LDQCO2
      PARAMETER        ( LDPCO1 = MAXMP, LDPCO2 = MAXMP,
     $                   LDQCO1 = MAXMP, LDQCO2 = MAXMP )
*     .. Local Scalars ..
      INTEGER          I, INDLIM, INFO, J, K, M, P, PORM
      CHARACTER*1      LERI
      LOGICAL          LLERI
*     .. Local Arrays ..
      DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,INDMAX),
     $                 QCOEFF(LDQCO1,LDQCO2,INDMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TC01OD
*     .. 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 = * ) M, P, INDLIM, LERI
      LLERI = LSAME( LERI, 'L' )
      IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) M
      ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) P
      ELSE IF ( INDLIM.LE.0 .OR. INDLIM.GT.INDMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) INDLIM
      ELSE
         PORM = P
         IF ( .NOT.LLERI ) PORM = M
         READ ( NIN, FMT = * )
     $      ( ( ( PCOEFF(I,J,K), K = 1,INDLIM ), J = 1,PORM ),
     $                           I = 1,PORM )
         READ ( NIN, FMT = * )
     $      ( ( ( QCOEFF(I,J,K), K = 1,INDLIM ), J = 1,M ), I = 1,P )
*        Find the dual right pmr of the given left pmr.
         CALL TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2,
     $                QCOEFF, LDQCO1, LDQCO2, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 40 I = 1, PORM
               DO 20 J = 1, PORM
                  WRITE ( NOUT, FMT = 99996 ) I, J,
     $              ( PCOEFF(I,J,K), K = 1,INDLIM )
   20          CONTINUE
   40       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 80 I = 1, M
               DO 60 J = 1, P
                  WRITE ( NOUT, FMT = 99996 ) I, J,
     $              ( QCOEFF(I,J,K), K = 1,INDLIM )
   60          CONTINUE
   80       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' TC01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TC01OD = ',I2)
99997 FORMAT (' The coefficients of the denominator matrix of the dual',
     $       ' system are ')
99996 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2))
99995 FORMAT (//' The coefficients of the numerator matrix of the dual',
     $       ' system are ')
99994 FORMAT (/' M is out of range.',/' M = ',I5)
99993 FORMAT (/' P is out of range.',/' P = ',I5)
99992 FORMAT (/' INDLIM is out of range.',/' INDLIM = ',I5)
      END


c--------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE DCOMPUTEPV(PV,U,V,THETA,PRS,MSFU,MSFV,MSFT,COR,DX,DY,
     +                      NX,NY,NZ,NXP1,NYP1)

      IMPLICIT NONE
      INTEGER NX,NY,NZ,NXP1,NYP1
      DOUBLE PRECISION U(NXP1,NY,NZ),V(NX,NYP1,NZ),PRS(NX,NY,NZ)
      DOUBLE PRECISION THETA(NX,NY,NZ),PV(NX,NY,NZ)
      DOUBLE PRECISION MSFU(NXP1,NY),MSFV(NX,NYP1),MSFT(NX,NY)
      DOUBLE PRECISION COR(NX,NY)
      DOUBLE PRECISION DX,DY
C NCLEND
      INTEGER KP1,KM1,JP1,JM1,IP1,IM1,I,J,K
      DOUBLE PRECISION DSY,DSX,DP,DUDY,DVDX,DUDP,DVDP,DTHDP,AVORT
      DOUBLE PRECISION DTHDX,DTHDY,MM

c          print*,'nx,ny,nz,nxp1,nyp1'
c          print*,nx,ny,nz,nxp1,nyp1
      DO K = 1,NZ
          KP1 = MIN(K+1,NZ)
          KM1 = MAX(K-1,1)
          DO J = 1,NY
              JP1 = MIN(J+1,NY)
              JM1 = MAX(J-1,1)
              DO I = 1,NX
                  IP1 = MIN(I+1,NX)
                  IM1 = MAX(I-1,1)
c         print *,jp1,jm1,ip1,im1
                  DSX = (IP1-IM1)*DX
                  DSY = (JP1-JM1)*DY
                  MM = MSFT(I,J)*MSFT(I,J)
c         print *,j,i,u(i,jp1,k),msfu(i,jp1),u(i,jp1,k)/msfu(i,jp1)
                  DUDY = 0.5D0* (U(I,JP1,K)/MSFU(I,JP1)+
     +                   U(I+1,JP1,K)/MSFU(I+1,JP1)-
     +                   U(I,JM1,K)/MSFU(I,JM1)-
     +                   U(I+1,JM1,K)/MSFU(I+1,JM1))/DSY*MM
                  DVDX = 0.5D0* (V(IP1,J,K)/MSFV(IP1,J)+
     +                   V(IP1,J+1,K)/MSFV(IP1,J+1)-
     +                   V(IM1,J,K)/MSFV(IM1,J)-
     +                   V(IM1,J+1,K)/MSFV(IM1,J+1))/DSX*MM
                  AVORT = DVDX - DUDY + COR(I,J)
                  DP = PRS(I,J,KP1) - PRS(I,J,KM1)
                  DUDP = 0.5D0* (U(I,J,KP1)+U(I+1,J,KP1)-U(I,J,KM1)-
     +                   U(I+1,J,KM1))/DP
                  DVDP = 0.5D0* (V(I,J,KP1)+V(I,J+1,KP1)-V(I,J,KM1)-
     +                   V(I,J+1,KM1))/DP
                  DTHDP = (THETA(I,J,KP1)-THETA(I,J,KM1))/DP
                  DTHDX = (THETA(IP1,J,K)-THETA(IM1,J,K))/DSX*MSFT(I,J)
                  DTHDY = (THETA(I,JP1,K)-THETA(I,JM1,K))/DSY*MSFT(I,J)
                  PV(I,J,K) = -9.81D0* (DTHDP*AVORT-DVDP*DTHDX+
     +                        DUDP*DTHDY)*10000.D0
c               if(i.eq.300 .and. j.eq.300) then
c                 print*,'avort,dudp,dvdp,dthdp,dthdx,dthdy,pv'
c                 print*,avort,dudp,dvdp,dthdp,dthdx,dthdy,pv(i,j,k)
c               endif
                  PV(I,J,K) = PV(I,J,K)*1.D2
              END DO
          END DO
      END DO
      RETURN
      END

c--------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE DCOMPUTEABSVORT(AV,U,V,MSFU,MSFV,MSFT,COR,DX,DY,NX,NY,
     +                           NZ,NXP1,NYP1)

      IMPLICIT NONE
      INTEGER NX,NY,NZ,NXP1,NYP1
      DOUBLE PRECISION U(NXP1,NY,NZ),V(NX,NYP1,NZ)
      DOUBLE PRECISION AV(NX,NY,NZ)
      DOUBLE PRECISION MSFU(NXP1,NY),MSFV(NX,NYP1),MSFT(NX,NY)
      DOUBLE PRECISION COR(NX,NY)
      DOUBLE PRECISION DX,DY
C NCLEND
      INTEGER KP1,KM1,JP1,JM1,IP1,IM1,I,J,K
      DOUBLE PRECISION DSY,DSX,DP,DUDY,DVDX,DUDP,DVDP,DTHDP,AVORT
      DOUBLE PRECISION DTHDX,DTHDY,MM

c          print*,'nx,ny,nz,nxp1,nyp1'
c          print*,nx,ny,nz,nxp1,nyp1
      DO K = 1,NZ
          DO J = 1,NY
              JP1 = MIN(J+1,NY)
              JM1 = MAX(J-1,1)
              DO I = 1,NX
                  IP1 = MIN(I+1,NX)
                  IM1 = MAX(I-1,1)
c         print *,jp1,jm1,ip1,im1
                  DSX = (IP1-IM1)*DX
                  DSY = (JP1-JM1)*DY
                  MM = MSFT(I,J)*MSFT(I,J)
c         print *,j,i,u(i,jp1,k),msfu(i,jp1),u(i,jp1,k)/msfu(i,jp1)
                  DUDY = 0.5D0* (U(I,JP1,K)/MSFU(I,JP1)+
     +                   U(I+1,JP1,K)/MSFU(I+1,JP1)-
     +                   U(I,JM1,K)/MSFU(I,JM1)-
     +                   U(I+1,JM1,K)/MSFU(I+1,JM1))/DSY*MM
                  DVDX = 0.5D0* (V(IP1,J,K)/MSFV(IP1,J)+
     +                   V(IP1,J+1,K)/MSFV(IP1,J+1)-
     +                   V(IM1,J,K)/MSFV(IM1,J)-
     +                   V(IM1,J+1,K)/MSFV(IM1,J+1))/DSX*MM
                  AVORT = DVDX - DUDY + COR(I,J)
                  AV(I,J,K) = AVORT*1.D5
              END DO
          END DO
      END DO
      RETURN
      END


      subroutine density(x,y,z,ne1,ne2,nea,negum,ip,lip)

c  Returns four components of the free electron density of the
c  interstellar medium at Galactic location (x,y,z).  Add them together
c  to get the total density.  Combine terms with `fluctuation'
c  parameters to get the scattering measure.
c
c  Origin of coordinate system is at Galactic center;
c  x,y,z are in kpc;
c  the sun os at (x,y,z) = (0,R0,0), x is in l=90 direction;
c  electron densities in cm^-3.

C	ne1:	outer zone
C	ne2:	galactic center zone
C	nea:	spiral arms
C	negum:	Gum Nebula

C  Spiral arm locations are contained in array arm(j,k,i), where
C    j=1,4 distinguishes the four independent arms;
C    k=1,kmax(j) selects numerical spiral arm coordinates;
C    i=1,2 for coordinate=x,y
C  The arm locations were digitized and tabulated by hand; loop "do 20"
C  re-creates close approximations to curves fitting the arm axes.

      real n1h1,n2,na,ngum,ne1,ne2,nea,negum
      real th1(7,4),r1(7,4)
      logical first
      save
      common/params/n1h1,h1,A1,F1,n2,h2,A2,F2,na,ha,wa,Aa,Fa,Fg
      common/armcom/arm(4,500,2),kmax(4)
      character*120 path
      integer ldir,lun
      character ip*(*)
      integer lip
      data first/.true./,ks/3/,NN/7/
      data rad/57.2957795/,R0/8.5/
      data th1/164.,200.,240.,280.,290.,315.,330.,
     +            63.,120.,160.,200.,220.,250.,288.,
     +            52.,120.,170.,180.,200.,220.,252.,
     +            20.,70.,100.,160.,180.,200.,223./
	data r1/3.1,3.3,3.9,4.6,4.7,5.1,5.1,
     +          3.3,4.0,4.2,5.0,5.7,6.4,7.2,
     +          4.3,5.5,5.7,6.1,7.2,7.8,8.4,
     +          5.2,6.2,6.9,8.5,9.1,10.0,10.6/

	data xgum/-0.492/,ygum/8.587/		! Location of Gum Nebula
	data rgum/0.182/			! Radius of Gum nebula
	data ngum/0.20/				! n_e inside Gum Nebula

        Fg=0.                           ! Fluctuation parameter for Gum
	if(first) then			! Reconstruct spiral arm axes
c	call getpath(path,ldir)
        call glun(lun)
	do 20 j=1,4
	dth=5.0/r1(1,j)
	th=th1(1,j)-0.999*dth
	call cspline(th1(1,j),r1(1,j),-NN,th,r)
	do 10 k=1,499
	th=th+dth
	if(th.gt.th1(7,j)) go to 20
	call cspline(th1(1,j),r1(1,j),NN,th,r)
	arm(j,k,1)=(R0/7.46)*r*sin(th/rad)
	arm(j,k,2)= -(R0/7.46)*r*cos(th/rad)
10	continue
20	kmax(j)=k
        open(lun,file=ip(1:lip)//'/lookuptables/gal.dat')
	read(lun,1020) n1h1,h1,A1,F1,n2,h2,A2,F2,na,ha,wa,Aa,Fa
1020	format(6x,f8.0)
	close(lun)
	first=.false.
	endif

	rr=sqrt(x**2 + y**2)		! Galactocentric radius
 	g1=sech2(rr/A1)/sech2(8.5/A1)
 	ne1=(n1h1/h1)*g1*sech2(z/h1)	! Outer component

	g2=0.0
	rrarg=((rr-A2)/1.8)**2
	if(rrarg.lt.10.0) g2=exp(-rrarg)
	ne2=n2*g2*sech2(z/h2)		! Galactic center component

	nea=0.
	if(abs(z/ha).lt.3) then		! Get spiral arm component
	  do 50 j=1,4
	    sqmin=1.e10
	    do 30 k=1+ks,kmax(j)-ks,2*ks+1 ! Find min dist to this arm
	      sq=(x-arm(j,k,1))**2 + (y-arm(j,k,2))**2
	      if(sq.lt.sqmin) then
	        sqmin=sq
		kk=k
	      endif
30	    continue
	    do 40 k=kk-ks,kk+ks
	      sq=(x-arm(j,k,1))**2 + (y-arm(j,k,2))**2
	      if(sq.lt.sqmin) then
	        sqmin=sq
		kk=k
	      endif
40	    continue
	    smin=sqrt(sqmin)		! Distance of (x,y,z) from arm axis
	    if(smin.lt.3*wa) then	! If (x,y,z) is close to this
	      ga=exp(-(smin/wa)**2)	! arm, get the arm weighting factor
	      if(rr.gt.Aa) ga=ga*sech2((rr-Aa)/2.0) ! Radial dependence of arms
	      if(j.eq.2.and.k.ge.101) then
		fac=2.0
		if(k.le.115) fac=1.0 + (k-101)/14.0
		ga=ga*fac
	      endif
	      if(j.eq.3.and.k.ge.60.and.k.le.94) then
	        th=6.2831853*(k-60.0)/34.0
		fac=(3.0+cos(th))/4.0
		ga=ga*fac
	      endif
	      nea=nea + na*ga*sech2(z/ha) ! Add this arm contribution
	    endif
50	  continue
	endif

	negum=0.0			! Gum Nebula component
	r=sqrt((x-xgum)**2 + (y-ygum)**2 + z**2)
	if(r.lt.2*rgum) then
	  negum=ngum
	  ag=0.7
	  r2=ag*rgum
	  if(r.gt.r2) negum=ngum*exp(-((r-r2)/(rgum-r2))**2)
	endif

	return
	end


Real Function fdelta(dmass)
  Save
  amn = 0.938869
  avpi = 0.13803333
  am0 = 1.232
  fd = 0.25*width(dmass)**2/((dmass-1.232)**2+0.25*width(dmass)**2)
  fdelta = fd
  Return
End Function fdelta


!*==dlaln2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLALN2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B,
!                          LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
!
!       .. Scalar Arguments ..
!       LOGICAL            LTRANS
!       INTEGER            INFO, LDA, LDB, LDX, NA, NW
!       DOUBLE PRECISION   CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), X( LDX, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLALN2 solves a system of the form  (ca A - w D ) X = s B
!> or (ca A**T - w D) X = s B   with possible scaling ("s") and
!> perturbation of A.  (A**T means A-transpose.)
!>
!> A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
!> real diagonal matrix, w is a real or complex value, and X and B are
!> NA x 1 matrices -- real if w is real, complex if w is complex.  NA
!> may be 1 or 2.
!>
!> If w is complex, X and B are represented as NA x 2 matrices,
!> the first column of each being the real part and the second
!> being the imaginary part.
!>
!> "s" is a scaling factor (<= 1), computed by DLALN2, which is
!> so chosen that X can be computed without overflow.  X is further
!> scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
!> than overflow.
!>
!> If both singular values of (ca A - w D) are less than SMIN,
!> SMIN*identity will be used instead of (ca A - w D).  If only one
!> singular value is less than SMIN, one element of (ca A - w D) will be
!> perturbed enough to make the smallest singular value roughly SMIN.
!> If both singular values are at least SMIN, (ca A - w D) will not be
!> perturbed.  In any case, the perturbation will be at most some small
!> multiple of max( SMIN, ulp*norm(ca A - w D) ).  The singular values
!> are computed by infinity-norm approximations, and thus will only be
!> correct to a factor of 2 or so.
!>
!> Note: all input quantities are assumed to be smaller than overflow
!> by a reasonable factor.  (See BIGNUM.)
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] LTRANS
!> \verbatim
!>          LTRANS is LOGICAL
!>          =.TRUE.:  A-transpose will be used.
!>          =.FALSE.: A will be used (not transposed.)
!> \endverbatim
!>
!> \param[in] NA
!> \verbatim
!>          NA is INTEGER
!>          The size of the matrix A.  It may (only) be 1 or 2.
!> \endverbatim
!>
!> \param[in] NW
!> \verbatim
!>          NW is INTEGER
!>          1 if "w" is real, 2 if "w" is complex.  It may only be 1
!>          or 2.
!> \endverbatim
!>
!> \param[in] SMIN
!> \verbatim
!>          SMIN is DOUBLE PRECISION
!>          The desired lower bound on the singular values of A.  This
!>          should be a safe distance away from underflow or overflow,
!>          say, between (underflow/machine precision) and  (machine
!>          precision * overflow ).  (See BIGNUM and ULP.)
!> \endverbatim
!>
!> \param[in] CA
!> \verbatim
!>          CA is DOUBLE PRECISION
!>          The coefficient c, which A is multiplied by.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,NA)
!>          The NA x NA matrix A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least NA.
!> \endverbatim
!>
!> \param[in] D1
!> \verbatim
!>          D1 is DOUBLE PRECISION
!>          The 1,1 element in the diagonal matrix D.
!> \endverbatim
!>
!> \param[in] D2
!> \verbatim
!>          D2 is DOUBLE PRECISION
!>          The 2,2 element in the diagonal matrix D.  Not used if NA=1.
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,NW)
!>          The NA x NW matrix B (right-hand side).  If NW=2 ("w" is
!>          complex), column 1 contains the real part of B and column 2
!>          contains the imaginary part.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of B.  It must be at least NA.
!> \endverbatim
!>
!> \param[in] WR
!> \verbatim
!>          WR is DOUBLE PRECISION
!>          The real part of the scalar "w".
!> \endverbatim
!>
!> \param[in] WI
!> \verbatim
!>          WI is DOUBLE PRECISION
!>          The imaginary part of the scalar "w".  Not used if NW=1.
!> \endverbatim
!>
!> \param[out] X
!> \verbatim
!>          X is DOUBLE PRECISION array, dimension (LDX,NW)
!>          The NA x NW matrix X (unknowns), as computed by DLALN2.
!>          If NW=2 ("w" is complex), on exit, column 1 will contain
!>          the real part of X and column 2 will contain the imaginary
!>          part.
!> \endverbatim
!>
!> \param[in] LDX
!> \verbatim
!>          LDX is INTEGER
!>          The leading dimension of X.  It must be at least NA.
!> \endverbatim
!>
!> \param[out] SCALE
!> \verbatim
!>          SCALE is DOUBLE PRECISION
!>          The scale factor that B must be multiplied by to insure
!>          that overflow does not occur when computing X.  Thus,
!>          (ca A - w D) X  will be SCALE*B, not B (ignoring
!>          perturbations of A.)  It will be at most 1.
!> \endverbatim
!>
!> \param[out] XNORM
!> \verbatim
!>          XNORM is DOUBLE PRECISION
!>          The infinity-norm of X, when X is regarded as an NA x NW
!>          real matrix.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          An error flag.  It will be set to zero if no error occurs,
!>          a negative number if an argument is in error, or a positive
!>          number if  ca A - w D  had to be perturbed.
!>          The possible values are:
!>          = 0: No error occurred, and (ca A - w D) did not have to be
!>                 perturbed.
!>          = 1: (ca A - w D) had to be perturbed to make its smallest
!>               (or only) singular value greater than SMIN.
!>          NOTE: In the interests of speed, this routine does not
!>                check the inputs for errors.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE DLALN2(Ltrans,Na,Nw,Smin,Ca,A,Lda,D1,D2,B,Ldb,Wr,Wi,X, &
     &                  Ldx,Scale,Xnorm,Info)
      IMPLICIT NONE
!*--DLALN2222
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      LOGICAL Ltrans
      INTEGER Info , Lda , Ldb , Ldx , Na , Nw
      DOUBLE PRECISION Ca , D1 , D2 , Scale , Smin , Wi , Wr , Xnorm
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , B(Ldb,*) , X(Ldx,*)
!     ..
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.0D0)
!     ..
!     .. Local Scalars ..
      INTEGER icmax , j
      DOUBLE PRECISION bbnd , bi1 , bi2 , bignum , bnorm , br1 , br2 ,  &
     &                 ci21 , ci22 , cmax , cnorm , cr21 , cr22 , csi , &
     &                 csr , li21 , lr21 , smini , smlnum , temp ,      &
     &                 u22abs , ui11 , ui11r , ui12 , ui12s , ui22 ,    &
     &                 ur11 , ur11r , ur12 , ur12s , ur22 , xi1 , xi2 , &
     &                 xr1 , xr2
!     ..
!     .. Local Arrays ..
      LOGICAL rswap(4) , zswap(4)
      INTEGER ipivot(4,4)
      DOUBLE PRECISION ci(2,2) , civ(4) , cr(2,2) , crv(4)
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL DLADIV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX
!     ..
!     .. Equivalences ..
      EQUIVALENCE (ci(1,1),civ(1))
      EQUIVALENCE (cr(1,1),crv(1))
!     ..
!     .. Data statements ..
      DATA zswap/.FALSE. , .FALSE. , .TRUE. , .TRUE./
      DATA rswap/.FALSE. , .TRUE. , .FALSE. , .TRUE./
      DATA ipivot/1 , 2 , 3 , 4 , 2 , 1 , 4 , 3 , 3 , 4 , 1 , 2 , 4 ,   &
     &     3 , 2 , 1/
!     ..
!     .. Executable Statements ..
!
!     Compute BIGNUM
!
      smlnum = TWO*DLAMCH('Safe minimum')
      bignum = ONE/smlnum
      smini = MAX(Smin,smlnum)
!
!     Don't check for input errors
!
      Info = 0
!
!     Standard Initializations
!
      Scale = ONE
!
      IF ( Na/=1 ) THEN
!
!        2x2 System
!
!        Compute the real part of  C = ca A - w D  (or  ca A**T - w D )
!
         cr(1,1) = Ca*A(1,1) - Wr*D1
         cr(2,2) = Ca*A(2,2) - Wr*D2
         IF ( Ltrans ) THEN
            cr(1,2) = Ca*A(2,1)
            cr(2,1) = Ca*A(1,2)
         ELSE
            cr(2,1) = Ca*A(2,1)
            cr(1,2) = Ca*A(1,2)
         ENDIF
!
         IF ( Nw==1 ) THEN
!
!           Real 2x2 system  (w is real)
!
!           Find the largest element in C
!
            cmax = ZERO
            icmax = 0
!
            DO j = 1 , 4
               IF ( ABS(crv(j))>cmax ) THEN
                  cmax = ABS(crv(j))
                  icmax = j
               ENDIF
            ENDDO
!
!           If norm(C) < SMINI, use SMINI*identity.
!
            IF ( cmax<smini ) THEN
               bnorm = MAX(ABS(B(1,1)),ABS(B(2,1)))
               IF ( smini<ONE .AND. bnorm>ONE ) THEN
                  IF ( bnorm>bignum*smini ) Scale = ONE/bnorm
               ENDIF
               temp = Scale/smini
               X(1,1) = temp*B(1,1)
               X(2,1) = temp*B(2,1)
               Xnorm = temp*bnorm
               Info = 1
               RETURN
            ENDIF
!
!           Gaussian elimination with complete pivoting.
!
            ur11 = crv(icmax)
            cr21 = crv(ipivot(2,icmax))
            ur12 = crv(ipivot(3,icmax))
            cr22 = crv(ipivot(4,icmax))
            ur11r = ONE/ur11
            lr21 = ur11r*cr21
            ur22 = cr22 - ur12*lr21
!
!           If smaller pivot < SMINI, use SMINI
!
            IF ( ABS(ur22)<smini ) THEN
               ur22 = smini
               Info = 1
            ENDIF
            IF ( rswap(icmax) ) THEN
               br1 = B(2,1)
               br2 = B(1,1)
            ELSE
               br1 = B(1,1)
               br2 = B(2,1)
            ENDIF
            br2 = br2 - lr21*br1
            bbnd = MAX(ABS(br1*(ur22*ur11r)),ABS(br2))
            IF ( bbnd>ONE .AND. ABS(ur22)<ONE ) THEN
               IF ( bbnd>=bignum*ABS(ur22) ) Scale = ONE/bbnd
            ENDIF
!
            xr2 = (br2*Scale)/ur22
            xr1 = (Scale*br1)*ur11r - xr2*(ur11r*ur12)
            IF ( zswap(icmax) ) THEN
               X(1,1) = xr2
               X(2,1) = xr1
            ELSE
               X(1,1) = xr1
               X(2,1) = xr2
            ENDIF
            Xnorm = MAX(ABS(xr1),ABS(xr2))
!
!           Further scaling if  norm(A) norm(X) > overflow
!
            IF ( Xnorm>ONE .AND. cmax>ONE ) THEN
               IF ( Xnorm>bignum/cmax ) THEN
                  temp = cmax/bignum
                  X(1,1) = temp*X(1,1)
                  X(2,1) = temp*X(2,1)
                  Xnorm = temp*Xnorm
                  Scale = temp*Scale
               ENDIF
            ENDIF
         ELSE
!
!           Complex 2x2 system  (w is complex)
!
!           Find the largest element in C
!
            ci(1,1) = -Wi*D1
            ci(2,1) = ZERO
            ci(1,2) = ZERO
            ci(2,2) = -Wi*D2
            cmax = ZERO
            icmax = 0
!
            DO j = 1 , 4
               IF ( ABS(crv(j))+ABS(civ(j))>cmax ) THEN
                  cmax = ABS(crv(j)) + ABS(civ(j))
                  icmax = j
               ENDIF
            ENDDO
!
!           If norm(C) < SMINI, use SMINI*identity.
!
            IF ( cmax<smini ) THEN
               bnorm = MAX(ABS(B(1,1))+ABS(B(1,2)),ABS(B(2,1))          &
     &                 +ABS(B(2,2)))
               IF ( smini<ONE .AND. bnorm>ONE ) THEN
                  IF ( bnorm>bignum*smini ) Scale = ONE/bnorm
               ENDIF
               temp = Scale/smini
               X(1,1) = temp*B(1,1)
               X(2,1) = temp*B(2,1)
               X(1,2) = temp*B(1,2)
               X(2,2) = temp*B(2,2)
               Xnorm = temp*bnorm
               Info = 1
               RETURN
            ENDIF
!
!           Gaussian elimination with complete pivoting.
!
            ur11 = crv(icmax)
            ui11 = civ(icmax)
            cr21 = crv(ipivot(2,icmax))
            ci21 = civ(ipivot(2,icmax))
            ur12 = crv(ipivot(3,icmax))
            ui12 = civ(ipivot(3,icmax))
            cr22 = crv(ipivot(4,icmax))
            ci22 = civ(ipivot(4,icmax))
            IF ( icmax==1 .OR. icmax==4 ) THEN
!
!              Code when off-diagonals of pivoted C are real
!
               IF ( ABS(ur11)>ABS(ui11) ) THEN
                  temp = ui11/ur11
                  ur11r = ONE/(ur11*(ONE+temp**2))
                  ui11r = -temp*ur11r
               ELSE
                  temp = ur11/ui11
                  ui11r = -ONE/(ui11*(ONE+temp**2))
                  ur11r = -temp*ui11r
               ENDIF
               lr21 = cr21*ur11r
               li21 = cr21*ui11r
               ur12s = ur12*ur11r
               ui12s = ur12*ui11r
               ur22 = cr22 - ur12*lr21
               ui22 = ci22 - ur12*li21
            ELSE
!
!              Code when diagonals of pivoted C are real
!
               ur11r = ONE/ur11
               ui11r = ZERO
               lr21 = cr21*ur11r
               li21 = ci21*ur11r
               ur12s = ur12*ur11r
               ui12s = ui12*ur11r
               ur22 = cr22 - ur12*lr21 + ui12*li21
               ui22 = -ur12*li21 - ui12*lr21
            ENDIF
            u22abs = ABS(ur22) + ABS(ui22)
!
!           If smaller pivot < SMINI, use SMINI
!
            IF ( u22abs<smini ) THEN
               ur22 = smini
               ui22 = ZERO
               Info = 1
            ENDIF
            IF ( rswap(icmax) ) THEN
               br2 = B(1,1)
               br1 = B(2,1)
               bi2 = B(1,2)
               bi1 = B(2,2)
            ELSE
               br1 = B(1,1)
               br2 = B(2,1)
               bi1 = B(1,2)
               bi2 = B(2,2)
            ENDIF
            br2 = br2 - lr21*br1 + li21*bi1
            bi2 = bi2 - li21*br1 - lr21*bi1
            bbnd = MAX((ABS(br1)+ABS(bi1))                              &
     &             *(u22abs*(ABS(ur11r)+ABS(ui11r))),ABS(br2)+ABS(bi2))
            IF ( bbnd>ONE .AND. u22abs<ONE ) THEN
               IF ( bbnd>=bignum*u22abs ) THEN
                  Scale = ONE/bbnd
                  br1 = Scale*br1
                  bi1 = Scale*bi1
                  br2 = Scale*br2
                  bi2 = Scale*bi2
               ENDIF
            ENDIF
!
            CALL DLADIV(br2,bi2,ur22,ui22,xr2,xi2)
            xr1 = ur11r*br1 - ui11r*bi1 - ur12s*xr2 + ui12s*xi2
            xi1 = ui11r*br1 + ur11r*bi1 - ui12s*xr2 - ur12s*xi2
            IF ( zswap(icmax) ) THEN
               X(1,1) = xr2
               X(2,1) = xr1
               X(1,2) = xi2
               X(2,2) = xi1
            ELSE
               X(1,1) = xr1
               X(2,1) = xr2
               X(1,2) = xi1
               X(2,2) = xi2
            ENDIF
            Xnorm = MAX(ABS(xr1)+ABS(xi1),ABS(xr2)+ABS(xi2))
!
!           Further scaling if  norm(A) norm(X) > overflow
!
            IF ( Xnorm>ONE .AND. cmax>ONE ) THEN
               IF ( Xnorm>bignum/cmax ) THEN
                  temp = cmax/bignum
                  X(1,1) = temp*X(1,1)
                  X(2,1) = temp*X(2,1)
                  X(1,2) = temp*X(1,2)
                  X(2,2) = temp*X(2,2)
                  Xnorm = temp*Xnorm
                  Scale = temp*Scale
               ENDIF
            ENDIF
         ENDIF
!
!        1 x 1  (i.e., scalar) system   C X = B
!
      ELSEIF ( Nw==1 ) THEN
!
!           Real 1x1 system.
!
!           C = ca A - w D
!
         csr = Ca*A(1,1) - Wr*D1
         cnorm = ABS(csr)
!
!           If | C | < SMINI, use C = SMINI
!
         IF ( cnorm<smini ) THEN
            csr = smini
            cnorm = smini
            Info = 1
         ENDIF
!
!           Check scaling for  X = B / C
!
         bnorm = ABS(B(1,1))
         IF ( cnorm<ONE .AND. bnorm>ONE ) THEN
            IF ( bnorm>bignum*cnorm ) Scale = ONE/bnorm
         ENDIF
!
!           Compute X
!
         X(1,1) = (B(1,1)*Scale)/csr
         Xnorm = ABS(X(1,1))
      ELSE
!
!           Complex 1x1 system (w is complex)
!
!           C = ca A - w D
!
         csr = Ca*A(1,1) - Wr*D1
         csi = -Wi*D1
         cnorm = ABS(csr) + ABS(csi)
!
!           If | C | < SMINI, use C = SMINI
!
         IF ( cnorm<smini ) THEN
            csr = smini
            csi = ZERO
            cnorm = smini
            Info = 1
         ENDIF
!
!           Check scaling for  X = B / C
!
         bnorm = ABS(B(1,1)) + ABS(B(1,2))
         IF ( cnorm<ONE .AND. bnorm>ONE ) THEN
            IF ( bnorm>bignum*cnorm ) Scale = ONE/bnorm
         ENDIF
!
!           Compute X
!
         CALL DLADIV(Scale*B(1,1),Scale*B(1,2),csr,csi,X(1,1),X(1,2))
         Xnorm = ABS(X(1,1)) + ABS(X(1,2))
!
      ENDIF
!
!
!     End of DLALN2
!
      END SUBROUTINE DLALN2


      SUBROUTINE BMG2_SymStd_SETUP_lines_y(&
     &                SO, SOR, Nx, Ny, NStncl, JPN&
     &                ) BIND(C,NAME='BMG2_SymStd_SETUP_lines_y')

! ======================================================================
!  --------------------
!   DESCRIPTION:
!  --------------------
!
!     BMG2_SymStd_SETUP_lines_y.f performs a factorization of the
!     tridiagonal matrix that arises in y-line relaxation.  It assumes
!     that the system is diagonally dominant and it works directly with
!     the stencil.
!
! ======================================================================
! $license_flag$
! ======================================================================
!  --------------------
!   INPUT:
!  --------------------
!
!
! ======================================================================
!  --------------------
!   INPUT/OUTPUT:
!  --------------------
!
!
! ======================================================================
!  --------------------
!   OUTPUT:
!  --------------------
!
!
! ======================================================================
!  --------------------
!   LOCAL:
!  --------------------
!
!
! ======================================================================
      USE ModInterface
      IMPLICIT NONE

! -----------------------------
!     Includes
!
      INCLUDE 'BMG_constants_f90.h'
      INCLUDE 'BMG_parameters_f90.h'
      INCLUDE 'BMG_stencils_f90.h'

! ----------------------------
!     Argument Declarations
!
      integer(len_t), VALUE :: Nx, Ny
      integer(c_int), VALUE :: NStncl, JPN
      real(real_t) :: SO(Nx,Ny,NStncl), SOR(Ny,Nx,2)

! ----------------------------
!     Local Declarations
!
      INTEGER   i, j
      INTEGER   INFO, IPN, PER_y, PER_xy

! ======================================================================

      IPN = IABS(JPN)

      DO i=2, Nx-1
         DO j=2, Ny-1
            SOR(j,i,2) = -SO(i,j,KS)  ! off diagonal
            SOR(j,i,1) =  SO(i,j,KO)  ! diagonal
         ENDDO
      ENDDO

      PER_y = IABS(BMG_BCs_def_per_y)
      PER_xy = IABS(BMG_BCs_def_per_xy)
      IF(IPN.EQ.PER_y .OR. IPN.EQ.PER_xy) THEN
         DO i = 2, Nx-1
            SOR(2,i,1) = SOR(2,i,1) + SO(i,2,KS)
            SOR(Ny-1,i,1) = SOR(Ny-1,i,1) + SO(i,Ny,KS)
         ENDDO
      ENDIF

!     calculate the L*D*L' factorizations for the lines in y-direction
      DO i=2, Nx-1
         CALL DPTTRF (Ny-2, SOR(2,i,1), SOR(3,i,2), INFO)
      ENDDO

!      DO i=2, Nx-1
!         SOR(i,2,MSOS)=rONE/SO(i,2,KO)
!         DO j=3, Ny-1
!            SOR(i,j,MSOS)=rONE
!     &                   /( SO(i,j,KO) - SOR(i,j-1,MSOS)*SO(i,j,KS)**2
!         ENDDO
!      ENDDO

! ======================================================================

      RETURN
      END


MODULE SourceMod

   IMPLICIT NONE
   INTEGER, PARAMETER :: PRTFIL = 6, STSFIL = 10
   INTEGER, PARAMETER :: MaxNt = 10000000, MaxNST = 10000000
   INTEGER, PRIVATE   :: it_Src = 1, it, is ! it_Src used to store the current step into the source time series

CONTAINS

  SUBROUTINE SOURCE( T, S, SD, Nsd, Ntout, omega, fmin, fmax, Pulse, PulseTitle, IniFlag )

    ! Evaluate the source time series (STS) at the time vector T
    ! This should be converted to a module

    ! stemp is a temporary workspace

    ! IniFlag, used to control filtering, has to be controlled on the outside
    ! since SPARC changes the filtering as a function of wavenumber.

    LOGICAL,   INTENT( INOUT ) :: IniFlag
    INTEGER,   INTENT( IN    ) :: Ntout
    INTEGER,   INTENT( INOUT ) :: Nsd
    REAL,      INTENT( IN    ) :: T( * ), omega, fmin, fmax
    REAL,      INTENT( OUT   ) :: SD( Nsd )
    CHARACTER, INTENT( IN    ) :: Pulse*4
    CHARACTER, INTENT( OUT   ) :: PulseTitle*( * )

    INTEGER            :: Nt
    REAL               :: TF( MaxNt ), stempR( MaxNt ), deltat, TStart
    COMPLEX            :: S( Nsd, * ), stemp( MaxNt )
    EQUIVALENCE ( stempR, stemp )
    COMPLEX, ALLOCATABLE :: SF( :, : )

    SAVE TF, SF, Nt

    ! If first call, tabulate the time series

    IF ( IniFlag ) THEN
       Nt = MaxNST / NSd
       IF ( .NOT. ALLOCATED( SF ) ) ALLOCATE( SF( Nsd, Nt ) )

       IF ( Pulse( 1 : 1 ) == 'F' .OR. Pulse( 1 : 1 ) == 'B' ) THEN
          ! From a file
          CALL ReadSTS( Pulse, PulseTitle, SD, Nsd, TF, stempR, SF, Nt )
          deltat = TF( 2 ) - TF( 1 )
          !!! should check that the time series is evenly sampled, i.e. deltat constant
          !!! affects the filtering
       ELSE
          ! Use one of the canned wavelets
          Nsd    = 1
          deltat = 0.2 / omega
          TStart = -200.0 * deltat
          Nt     = 1024

          DO it = 1, Nt
             TF( it ) = TStart + ( it - 1 ) * deltat
             CALL CANS( TF( it ), omega, Pulse, SF, Nsd, it, PulseTitle )
          END DO
       ENDIF

       ! Filter the time series

       DO is = 1, Nsd
          stemp( 1 : Nt ) = SF( is, 1 : Nt ) !  Copy time series into stemp

          IF ( Pulse( 4 : 4 ) /= 'N' ) CALL BandPass( stemp, Nt, deltat, fmin, fmax )   ! Band-pass filter
          IF ( Pulse( 2 : 2 ) == 'H' ) CALL PreEnv(   stemp, Nt )   ! Form the pre-envelope
          IF ( Pulse( 2 : 2 ) == 'Q' ) CALL Hilbert(  stemp, Nt )   ! Hilbert transform

          SF( is, 1 : Nt ) = stemp( 1 : Nt )   ! Copy time series back
       END DO   ! next source depth

       IniFlag = .FALSE.
    ENDIF

    CALL EvaluateSTS( T, Pulse, TF, SF, Nsd, Nt, S, Ntout )

  END SUBROUTINE SOURCE

  !**********************************************************************C

  SUBROUTINE ReadSTS( Pulse, PulseTitle, SD, Nsd, TF, stemp, SF, Nt )

    ! Time series from file
    ! stemp is used to hold a temporary real vector

    INTEGER,   INTENT( INOUT ) :: NSd, Nt
    REAL,      INTENT( OUT   ) :: SD( NSd ), TF( * )
    COMPLEX,   INTENT( OUT   ) :: SF( Nsd, * )
    CHARACTER, INTENT( IN    ) :: Pulse*4
    CHARACTER, INTENT( OUT )   :: PulseTitle*( * )

    REAL :: stemp( Nsd ), tempV( Nsd ), temp, TMax

    OPEN( FILE = 'STSFIL', UNIT = STSFIL, STATUS = 'OLD', FORM = 'FORMATTED' )

    READ( STSFIL, * ) PulseTitle
    READ( STSFIL, * ) Nsd, SD   ! Number of source depths, vector of source depths

    ! Read in time series data

    Nt = 0
    DO it = 1, MaxNt

       READ( STSFIL, *, END = 2000 ) TF( it ), stemp

       IF ( it > 1 ) THEN
          IF ( TF( it ) < TF( it - 1 ) ) CALL ERROUT( PRTFIL, 'F', 'SOURCE:SFILE', 'Time series not ordered in time' )
       ENDIF

       SF( :, it ) = stemp
       Nt = Nt + 1

       IF ( Nt * Nsd > MaxNST ) CALL ERROUT( PRTFIL, 'F', 'SOURCE:SFILE', 'Too many time series points' )
    END DO

    ! normal exit is by EOF in file, not by falling through loop
    CALL ERROUT( PRTFIL, 'F', 'SOURCE:SFILE', 'Too many time series points' )

    ! Time reversal
    ! note if Nt is odd, middle point doesn't move

2000 IF ( Pulse( 1 : 1 ) == 'B' ) THEN
       TMax = TF( Nt )
       DO it = 1, Nt / 2
          tempV                = REAL( SF( :, it ) )
          SF( :, it )          = SF( :, Nt - it + 1 )
          SF( :, Nt - it + 1 ) = tempV

          temp                  = TMax - TF( it )
          TF( it )              = TMax - TF( Nt - it + 1 )
          TF( Nt - it + 1 )     = temp
       END DO
    ENDIF

    CLOSE( STSFIL )

  END SUBROUTINE ReadSTS

  !**********************************************************************C

  SUBROUTINE EvaluateSTS( T, Pulse, TF, SF, Nsd, Nt, S, Ntout )

    ! Evaluate the source function by linear interpolation between time samples

    INTEGER,   INTENT( IN  ) :: Nsd, Nt, Ntout
    REAL,      INTENT( IN  ) :: T( * ), TF( * )
    COMPLEX,   INTENT( IN  ) :: SF( Nsd, * )
    COMPLEX,   INTENT( OUT ) :: S( Nsd, * )
    CHARACTER, INTENT( IN  ) :: Pulse*4   ! controls a pulse sign-flip

    INTEGER :: itout
    REAL    :: W

    ! it_Src is a saved variable containing the index into the source time series at the current step

    DO itout = 1, Ntout

       ! Necessary to advance time window?

       IF ( T( itout ) < TF( it_Src ) ) it_Src = 1 ! Case of T reset to origin for new march

       !!! It is possible that the following accesses TF( Nt + 1 )
       DO WHILE ( T( itout ) > TF( it_Src + 1 ) .AND. it_Src < Nt - 1 )
          it_Src = it_Src + 1
       END DO

       ! Linear interpolation in time

       S( :, itout ) = 0.0   ! in case T outside time window

       IF ( T( itout ) >= TF( 1  ) .AND. T( itout ) <= TF( Nt ) ) THEN
          W = ( T( itout ) - TF( it_Src ) ) / ( TF( it_Src + 1 ) - TF( it_Src ) )
          S( :, itout ) = SF( :, it_Src ) + W * ( SF( :, it_Src + 1 ) - SF( :, it_Src ) )

          IF ( Pulse( 3 : 3 ) == '-' ) S( :, itout ) = -S( :, itout )
       ENDIF

    END DO   ! next itout

  END SUBROUTINE EvaluateSTS

END MODULE SourceMod


      subroutine clawpack46_b4step2(maxmx, maxmy, mbc,mx,my,meqn,q,
     &      xlower,ylower,dx,dy,time,dt,maux,aux)
      implicit none

      integer mbc, mx, my, meqn, maux, maxmx, maxmy
      double precision xlower, ylower, dx, dy, time, dt
      double precision q(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, maux)

      integer i, j, k
      double precision tperiod, pi2, vt, xll,yll, psi

      common /comvt/ tperiod,pi2
c
      if (tperiod .eq. 0.d0) then
c        # special case --- indication that velocities specified in
c        # setaux should be used for all time.
         return
      endif

      vt = cos(pi2*(time+dt/2.d0)/tperiod)

      do k = 1,2
         do j = 1-mbc,my+mbc
            do i = 1-mbc,mx+mbc
c               # coordinates of lower left corner of grid cell:
                xll = xlower + (i-1)*dx
                yll = ylower + (j-1)*dy

c               # difference stream function psi to get normal velocities:
                if (k .eq. 1) then
                    aux(i,j,k) = (psi(xll, yll+dy) - psi(xll,yll)) / dy
                else
                    aux(i,j,k) = -(psi(xll+dx, yll) - psi(xll,yll)) / dx
                endif

c               # multiply by time-factor:
                aux(i,j,k) = vt * aux(i,j,k)
c                aux(i,j,2) = vt * aux(i,j,2)
           enddo
        enddo
      enddo

      return
      end


!> This module containes subroutines and functions
!! necessary for imaginary time path integral calculations
MODULE imaginary_time
    USE kinds
    IMPLICIT NONE

CONTAINS

    !> This subroutine calculated the cavariance matrix for imaginary time
    !! path integral simulation for equilibrium reduced density matrix calculations.
    !! It is the imaginary time version of the force autocorrelation function of
    !! the harmonic bath. Each state has its own bath.
    SUBROUTINE get_covariance_matrix( covariance_matrix, beta )
        USE parameters
        USE input_output
        USE unit_conversions
        IMPLICIT NONE
        INTEGER :: npts, istate, ipt, istep, istept
        REAL(dp), INTENT(out) :: covariance_matrix( 0 : nbstep, 0 : nbstep, nstate )
        REAL(dp), INTENT(in) :: beta
        REAL(dp), ALLOCATABLE :: sd(:,:), freq(:)
        REAL(dp) :: dw, dt, t1, t2
        CHARACTER :: junk
        npts = 0 ; dw = 0.0_dp ; dt = beta / nbstep

        OPEN(UNIT=10, FILE=SPECTRALIN)
        DO
            READ(10, *, ERR=11, END=11) junk
            npts=npts+1
        END DO
        11  CONTINUE ; CLOSE(10)

        ! Warn if there was no continuum spectral density provided
        IF (npts==0) THEN
            OPEN(unit=20,file=ERRORLOG)
            WRITE(20,*) 'No continuum spectral density file found!'
            CLOSE(20)
        END IF

        ALLOCATE( sd( nstate, npts ), freq( npts ) )

        OPEN(UNIT=10, FILE=SPECTRALIN)
        DO ipt=1, npts
            READ(10, *) freq(ipt), ( sd(istate,ipt), istate=1, nstate )
        END DO
        CLOSE(10)

        freq = freq * convert('wvnbr','au_ang_freq')
        sd = sd * convert('wvnbr','au_energy')

        dw = freq(2) - freq(1)

        DO istep = 0, nbstep
            t1 = istep * dw
            DO istept = 0, istep
                t2 = istept * dw
                DO ipt = 1 , npts
                    covariance_matrix( istep, istept, : ) = ( dw / pi ) &
                            * sd( :, ipt ) &
                            * COSH( ( beta * freq(ipt) ) / 2.0_dp - freq(ipt) * ABS(t1-t2) ) &
                            / SINH( beta * freq(ipt) / 2.0_dp )
                END DO
                covariance_matrix( istept, istep, : ) = covariance_matrix( istep, istept, : )
            END DO
        END DO

        DEALLOCATE( sd, freq )

    END SUBROUTINE get_covariance_matrix

END MODULE imaginary_time


! laas.f90
!
! "LAPACK as a Service" web application for nginx, solves the system of linear
! equations A * x = B:
!
!     | a1  a3 | * | x1 | = | b1 |
!     | a2  a4 |   | x2 |   | b2 |
!
! Send a GET request to:
!
!     http://localhost/api/solve?a1=2.0&a2=3.0&a3=1.0&a4=1.0&b1=5.0&b2=6.0
!
! Get the response:
!
!     x1,1.00000000,x2,3.00000000
!
! Author:  Philipp Engel
! Licence: ISC
module laas
    use, intrinsic :: iso_c_binding, only: c_null_char
    use :: ngx_link_func
    implicit none

    logical, save :: is_service_on = .false.
contains
    subroutine ngx_link_func_init_cycle(cyc) bind(c)
        type(ngx_link_func_cycle_t), intent(in) :: cyc

        call ngx_link_func_cyc_log_info(cyc, 'Starting the web app ...' // c_null_char)
        is_service_on = .true.
    end subroutine ngx_link_func_init_cycle

    subroutine ngx_link_func_exit_cycle(cyc) bind(c)
        type(ngx_link_func_cycle_t), intent(in) :: cyc

        call ngx_link_func_cyc_log_info(cyc, 'Shutting down the web app ...' // c_null_char)
        is_service_on = .false.
    end subroutine ngx_link_func_exit_cycle

    subroutine ngx_solve(ctx) bind(c)
        use :: f95_lapack,   only: la_gesv
        use :: la_precision, only: wp => dp
        type(ngx_link_func_ctx_t), intent(in) :: ctx
        character(len=128)                    :: response
        real(kind=wp)                         :: a(2, 2)
        real(kind=wp)                         :: b(2)
        character(len=:), allocatable         :: a1, a2, a3, a4, b1, b2
        integer                               :: rc

        call ngx_link_func_log_info(ctx, 'Solving ...' // c_null_char)

        a = 0._wp
        b = 0._wp

        a1 = ngx_link_func_get_query_param(ctx, 'a1' // c_null_char)
        a2 = ngx_link_func_get_query_param(ctx, 'a2' // c_null_char)
        a3 = ngx_link_func_get_query_param(ctx, 'a3' // c_null_char)
        a4 = ngx_link_func_get_query_param(ctx, 'a4' // c_null_char)

        read (a1, *, iostat=rc) a(1, 1)
        read (a2, *, iostat=rc) a(2, 1)
        read (a3, *, iostat=rc) a(1, 2)
        read (a4, *, iostat=rc) a(2, 2)

        b1 = ngx_link_func_get_query_param(ctx, 'b1' // c_null_char)
        b2 = ngx_link_func_get_query_param(ctx, 'b2' // c_null_char)

        read (b1, *, iostat=rc) b(1)
        read (b2, *, iostat=rc) b(2)

        call la_gesv(a=a, b=b, info=rc)

        write (response, '("x1,", f0.8, ",x2,", f0.8)') b(1), b(2)

        call ngx_link_func_write_resp(ctx, &
                                      int(200, kind=8), &
                                      '200 OK' // c_null_char, &
                                      'text/plain' // c_null_char, &
                                      trim(response) // c_null_char, &
                                      int(len_trim(response), kind=8))
    end subroutine ngx_solve
end module laas


subroutine cylinder_compute_area(mx,my,mbc,dx,dy, &
    xlower, ylower, blockno, maxlevel, level, area)
    IMPLICIT NONE

    INTEGER mx,my,mbc,blockno, maxlevel, level
    DOUBLE PRECISION dx,dy, xlower, ylower
    DOUBLE PRECISION area(-mbc:mx+mbc+1,-mbc:my+mbc+1)

    double precision pi, pi2
    common /compi/ pi, pi2

    double precision r_cyl, h_cyl
    common /cylinder_comm/ r_cyl, h_cyl

    integer exact_metric
    common /metric_comm/ exact_metric

    integer i,j, rfactor, N
    double precision dth, dz, hx, hy, af

!!  # Refinement factor
    rfactor = 2**(maxlevel-level)

!!  Number of cells that go around cylinder
!!  For conservation, we use finest level to estimate the area
    N = mx*2**level*rfactor

    dth = (2*pi/N)
    dz = h_cyl/N

!!  # Cell height and width, in physical coordinates
    if (exact_metric .eq. 1) then
        hx = r_cyl*dth
    else
        hx = 2*r_cyl*sin(dth/2)
    endif
    hy = dz

!!  Area of the finest level cell;  multiply by factor to get coarser areas.
    af = hx*hy

    do j = -mbc,my+mbc+1
        do i = -mbc,mx+mbc+1
            area(i,j) = af*rfactor**2
        enddo
    enddo
end

SUBROUTINE cylinder_compute_tangents(mx,my,mbc, dx,dy, level, &
    xd,yd,zd, xtangents,ytangents,edge_lengths)
    IMPLICIT NONE

    INTEGER mx,my,mbc, level
    double precision dx,dy

    DOUBLE PRECISION xd(-mbc:mx+mbc+2,-mbc:my+mbc+2)
    DOUBLE PRECISION yd(-mbc:mx+mbc+2,-mbc:my+mbc+2)
    DOUBLE PRECISION zd(-mbc:mx+mbc+2,-mbc:my+mbc+2)

    DOUBLE PRECISION xtangents(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)
    DOUBLE PRECISION ytangents(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)
    DOUBLE PRECISION edge_lengths(-mbc:mx+mbc+2,-mbc:my+mbc+2,2)

    DOUBLE PRECISION pi, pi2
    COMMON /compi/ pi, pi2

    DOUBLE PRECISION r_cyl, h_cyl
    COMMON /cylinder_comm/ r_cyl, h_cyl

    INTEGER exact_metric
    COMMON /metric_comm/ exact_metric

    INTEGER i,j,m
    DOUBLE PRECISION taup(3),tlen

    INTEGER N
    DOUBLE PRECISION hx, hy, dz, dth

    dth = 2*pi*dx
    dz = h_cyl*dy
    if (exact_metric .eq. 1) then
        hx = r_cyl*dth
    else
        hx = 2*r_cyl*sin(dth/2)
    endif
    hy = dz

!!  # Get x-face tangents
    DO j = -mbc,my+mbc+1
        DO i = -mbc,mx+mbc+2

            taup(1) = xd(i,j+1) - xd(i,j)
            taup(2) = yd(i,j+1) - yd(i,j)
            taup(3) = zd(i,j+1) - zd(i,j)
            tlen = sqrt(taup(1)**2 + taup(2)**2 + taup(3)**2)

            DO m = 1,3
               xtangents(i,j,m) = taup(m)/tlen
            ENDDO
            edge_lengths(i,j,1) = hy
        ENDDO
    ENDDO

    DO j = -mbc,my+mbc+2
        DO i = -mbc,mx+mbc+1
!!          # Now do y-faces
            taup(1) = xd(i+1,j) - xd(i,j)
            taup(2) = yd(i+1,j) - yd(i,j)
            taup(3) = zd(i+1,j) - zd(i,j)
            tlen = sqrt(taup(1)**2 + taup(2)**2 + taup(3)**2)

            DO m = 1,3
               ytangents(i,j,m) = taup(m)/tlen
            ENDDO
            edge_lengths(i,j,2) = hx
        ENDDO
    ENDDO

END SUBROUTINE  cylinder_compute_tangents

SUBROUTINE cylinder_compute_normals(mx,my,mbc, &
    xp,yp,zp,xd,yd,zd,xnormals,ynormals)
    IMPLICIT NONE

    INTEGER mx,my,mbc

    DOUBLE PRECISION xp(-mbc:mx+mbc+1,-mbc:my+mbc+1)
    DOUBLE PRECISION yp(-mbc:mx+mbc+1,-mbc:my+mbc+1)
    DOUBLE PRECISION zp(-mbc:mx+mbc+1,-mbc:my+mbc+1)

    DOUBLE PRECISION xd(-mbc:mx+mbc+2,-mbc:my+mbc+2)
    DOUBLE PRECISION yd(-mbc:mx+mbc+2,-mbc:my+mbc+2)
    DOUBLE PRECISION zd(-mbc:mx+mbc+2,-mbc:my+mbc+2)

    DOUBLE precision xnormals(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)
    DOUBLE precision ynormals(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)

    INTEGER i,j,m, ibc, jbc
    DOUBLE PRECISION taud(3),taup(3),nv(3), sp, xv(3)

!!  # Compute normals at all interior edges.

!!  # Get x-face normals
    DO j =  -mbc,my+mbc+1
        DO i = 1-mbc,mx+mbc+1

            taud(1) = xp(i,j) - xp(i-1,j)
            taud(2) = yp(i,j) - yp(i-1,j)
            taud(3) = zp(i,j) - zp(i-1,j)

            taup(1) = xd(i,j+1) - xd(i,j)
            taup(2) = yd(i,j+1) - yd(i,j)
            taup(3) = zd(i,j+1) - zd(i,j)

            CALL get_normal(taup,taud,nv,sp)

            DO m = 1,3
               xnormals(i,j,m) = nv(m)
            ENDDO
        ENDDO
    ENDDO

    DO j = 1-mbc,my+mbc+1
        DO i =  -mbc,mx+mbc+1
!!          # Now do y-faces
            taud(1) = xp(i,j) - xp(i,j-1)
            taud(2) = yp(i,j) - yp(i,j-1)
            taud(3) = zp(i,j) - zp(i,j-1)

            taup(1) = xd(i+1,j) - xd(i,j)
            taup(2) = yd(i+1,j) - yd(i,j)
            taup(3) = zd(i+1,j) - zd(i,j)

            call get_normal(taup,taud,nv,sp)

!!          # nv has unit length
            DO m = 1,3
               ynormals(i,j,m) = nv(m)
            ENDDO
        ENDDO
    ENDDO

END SUBROUTINE cylinder_compute_normals


C
C
*+ image_gscan

       subroutine image_gscan( minirt,data,uv,gate,
     *                         xbar_in,sigma_in,
     *                         xbar_out,sigma_out, status)
C      ---------------------------------------------------
C
C Find the mean and SD in a region of the map gateing as required
C
C Given:
C   mini redtape for image
        integer    minirt(8)
C   image data
        real*4     data(*)
C   range to scan
        integer    uv(4)
C   gate, only values below gate*sigma_in
        real*4     gate
C   input mean
        real*4     xbar_in
C   input SD
        real*4     sigma_in
C Returned:
C   output mean in map region
        real*4     xbar_out
C   output SD in map region
        real*4     sigma_out
C   error return code
        integer    status
C
C The map is scanned in the specified region for the mean and sd.
C Only those points which are within gate*sigma_in of xbar_in are
C included in the analysis.
*-
C local variables
       integer        npts
       real*4         value
       integer        iu, iv, uv_point(2)
       equivalence    (uv_point(1), iu)
       equivalence    (uv_point(2), iv)

C check status on entry
       if (status.ne.0) return

C initialise counter for total number of points
       npts = 0

C find mean on data
       xbar_out = 0.0
       do iv=uv(3),uv(4),-1
         do iu=uv(1),uv(2)
           call iuvval2(minirt,data,uv_point,value,status)
           if (abs(value-xbar_in).le.gate*sigma_in) then
             npts = npts+1
             xbar_out = xbar_out + value
           end if
         end do
       end do
       xbar_out = xbar_out/float(npts)

C find SD on data
       sigma_out = 0.0
       do iv=uv(3),uv(4),-1
         do iu=uv(1),uv(2)
           call iuvval2(minirt,data,uv_point,value,status)
           if (abs(value-xbar_in).le.gate*sigma_in) then
             sigma_out = sigma_out + (value-xbar_out)**2
           end if
         end do
       end do
       sigma_out = sqrt( sigma_out/float(npts-1) )
       call cmd_err(status,'IMAGE_GSCAN',' ')
       end


program BubbleSort
    implicit none
    integer, dimension(:), allocatable :: ar
    integer :: length
    integer :: i,j,t
    read (*,*) length

    ! memory allocation dynamically
    allocate (ar(length))

    p0: do i=1,length,1
        read(*,*) ar(i)
    end do p0

    p1: do  i=1,length,1
        p2: do  j=1,length-1,1
            swap: if (ar(j) > ar(j+1)) then
                t=ar(j)
                ar(j)=ar(j+1)
                ar(j+1)=t
            end if swap
        end do p2
    end do p1

    p3: do i=1,length,1
        write(*,*) ar(i)
    end do p3

end program BubbleSort


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE UNROT (NUM, NPROT, ROTMAT, ROTCEN,
     &   HZ, VT, PD, XN, YN, ZN)
C=======================================================================

C   --*** UNROT *** (MESH) "Unrotate" 3D coordinates
C   --   Written by Amy Gilkey - revised 07/08/86
C   --
C   --UNROT returns the original coordinates from the rotated coordinates.
C   --It multiplies by the inverse of the rotation matrix and adds the
C   --rotation center.
C   --
C   --Parameters:
C   --   NUM - IN - the number of nodes to rotate
C   --   NPROT - IN - the node numbers of the nodes to rotate
C   --   ROTMAT - IN - the rotation matrix
C   --   ROTCEN - IN - the center of the rotation
C   --   HZ, VT, PD - IN - the rotated nodal coordinates
C   --   XN, YN, ZN - OUT - the original nodal coordinates

      INTEGER NPROT(NUM)
      REAL ROTMAT(3,3), ROTCEN(3)
      REAL HZ(*), VT(*), PD(*)
      REAL XN(*), YN(*), ZN(*)

      DO 100 IX = 1, NUM
         INP = NPROT(IX)
         X = HZ(INP)
         Y = VT(INP)
         Z = PD(INP)
         XN(INP) = X*ROTMAT(1,1) + Y*ROTMAT(1,2) + Z*ROTMAT(1,3)
         YN(INP) = X*ROTMAT(2,1) + Y*ROTMAT(2,2) + Z*ROTMAT(2,3)
         ZN(INP) = X*ROTMAT(3,1) + Y*ROTMAT(3,2) + Z*ROTMAT(3,3)
         XN(INP) = XN(INP) + ROTCEN(1)
         YN(INP) = YN(INP) + ROTCEN(2)
         ZN(INP) = ZN(INP) + ROTCEN(3)
  100 CONTINUE

      RETURN
      END


C    @(#)sfctr.f	20.3 2/13/96
      subroutine sfctr (ne, indx, amtx, iamtx, iodx, fmtx, ifmtx,
     &                  diag, work)
      integer ifmtx(*), indx(*), iodx(*), iamtx(*)
      real amtx(*), diag(*), fmtx(*), work(*)
C
C          THIS SUBROUTINE FACTORS A REAL SYMMETRIC MATRIX IN TO
C          THE FORM L D L(TRANSPOSE).  THE INPUT IS ASSUMED TO BE
C          STORED IN A SPARSE FORM.
C     ON INPUT:
C          NE      NUMBER OF ROWS
C          INDX    BASE ADDRESS OF EACH ROW IN ARRAY AMTX AND IAMTX
C          AMTX    VALUE OF EACH NON-ZERO ELEMENT.
C          IAMTX   COLUMN NUMBER OF EACH NON-ZERO ELEMENT -- E.G.,
C                  IAMTX(1) = COLUMN NUMBER OF FIRST NON-ZERO ELEMENT IN
C                             ROW 1
C                  AMTX(1)  = VALUE OF THE FIRST NON-ZERO ELEMENT IN
C                             ROW 1
C                  ETC., ALL THE NON-ZERO ELEMENTS ARE STORED.
C          WORK    WORKING ARRAY OF LENGTH NE
C
C     ON OUTPUT:
C          IODX    BASE ADDRESS OF EACH ROW OF L(TRANSPOSE)
C          FMTX    VALUE OF EACH NON-ZERO ELEMENT IN
C                  L(TRANSPOSE). SAME FORMAT AS AMTX.
C          IFMTX   COLUMN NUMBER OF EACH NON-ZERO ELEMENT IN
C                  L(TRANSPOSE). SAME FORMAT AS IAMTX.
C          DIAG    CONTAINS THE RECIPRICOL OF EACH DIAGONAL ELEMENT
C
C
C     HISTORY:
C          WRITTEN BY SHERMAN M. CHAN, AUGUST 1980.
C
      iodx(1) = 1
      iou = 1
      zero = 0.

C        LOOP THROUGH ALL THE ROWS
C
      do 1000 k=1,ne
         ki = indx( k)
         kl = indx( k+1) - ki
C
C        ZERO OUT WORK AND COPY WORKING ROW TO WORK ARRAY
C
         call fvfill (zero,work,1,ne)
C
         do 200 i=1,kl
         i2 = i + ki - 1
  200    work( iamtx(i2) ) = amtx(i2)
C
         if (k.eq.1) go to 600
         k1 = k - 1
C
C        SCAN THE FIRST K-1 ELEMENTS OF THE WORKING ROW
C
         do 500 m=1,k1
         if (work(m) .eq. 0) go to 500
         mi = iodx(m)
         ml = iodx(m+1) - mi
         g = work(m)
C
C        ELIMINATE THE MTH ELEMENT OF THE WORKING ROW
C
         do 400 l=1,ml
            l2 = l + mi -1
            lcol = ifmtx(l2)
  400       work(lcol) = work(lcol) - g*fmtx(l2)
  500    continue
C
C           PROCESS THE DIAGONAL ELEMENT
C
  600 if (work(k) .eq. 0.0) work(k) = 1.0e-6
      g = 1./work(k)
      diag(k) = g
C
C             STORE THE RESULT IN FMTX
C
      if (k.eq.ne) go to 1000
      k1 = k + 1
      do 700 m=k1,ne
          if (work(m) .eq. 0.) go to 700
          ifmtx(iou) = m
          fmtx(iou) = g * work(m)
          iou = iou + 1
  700 continue
      iodx(k1) = iou
 1000 continue
C
      iodx(ne+1) = iodx(ne)
      return
      end


      PROGRAM xstifbs
C     driver for routine stifbs
      INTEGER KMAXX,NMAX
      PARAMETER (KMAXX=200,NMAX=50)
      INTEGER kmax,kount,nbad,nok
      REAL dxsav,eps,hstart,x1,x2,y(3),xp,yp
      COMMON /path/ kmax,kount,dxsav,xp(KMAXX),yp(NMAX,KMAXX)
      EXTERNAL stifbs,derivs
1     continue
      write(*,*) 'ENTER EPS,HSTART:'
      read(*,*,END=999) eps,hstart
      kmax=0
      x1=0.
      x2=50.
      y(1)=1.
      y(2)=1.
      y(3)=0.
      call odeint(y,3,x1,x2,eps,hstart,0.,nok,nbad,derivs,stifbs)
      write(*,'(/1x,a,t30,i3)') 'Successful steps:',nok
      write(*,'(1x,a,t30,i3)') 'Bad steps:',nbad
      write(*,*) 'Y(END)=',y(1),y(2),y(3)
      goto 1
999   write(*,*) 'NORMAL COMPLETION'
      STOP
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xstifbs.for


*
* $Id: dlsqp2.f,v 1.1 2009/07/30 22:46:16 madgraph Exp $
*
* $Log: dlsqp2.f,v $
* Revision 1.1  2009/07/30 22:46:16  madgraph
* JA: Implemented CKKW-style matching with Pythia pT-ordered showers
*
* Revision 1.1.1.1  1996/04/01 15:02:24  mclareni
* Mathlib gen
*
*
      SUBROUTINE DLSQP2(N,X,Y,A0,A1,A2,SD,IFAIL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION X(*),Y(*)

      PARAMETER (R0 = 0)

      A0=0
      A1=0
      A2=0
      SD=0
      IF(N .LE. 2) THEN
       IFAIL=1
      ELSE
       FN=N
       XM=0
       DO 1 K = 1,N
       XM=XM+X(K)
    1  CONTINUE
       XM=XM/FN
       SX=0
       SXX=0
       SXXX=0
       SXXXX=0
       SY=0
       SYY=0
       SXY=0
       SXXY=0
       DO 2 K = 1,N
       XK=X(K)-XM
       YK=Y(K)
       XK2=XK**2
       SX=SX+XK
       SXX=SXX+XK2
       SXXX=SXXX+XK2*XK
       SXXXX=SXXXX+XK2**2
       SY=SY+YK
       SYY=SYY+YK**2
       SXY=SXY+XK*YK
       SXXY=SXXY+XK2*YK
    2  CONTINUE
       DET=(FN*SXXXX-SXX**2)*SXX-FN*SXXX**2
       IF(DET .GT. 0) THEN
        A2=(SXX*(FN*SXXY-SXX*SY)-FN*SXXX*SXY)/DET
        A1=(SXY-SXXX*A2)/SXX
        A0=(SY-SXX*A2)/FN
        IFAIL=0
       ELSE
        IFAIL=-1
       ENDIF
      ENDIF
      IF(IFAIL .EQ. 0 .AND. N .GT. 3)
     1   SD=SQRT(MAX(R0,SYY-A0*SY-A1*SXY-A2*SXXY)/(N-3))
      A0=A0+XM*(XM*A2-A1)
      A1=A1-2*XM*A2
      RETURN
      END


C-----------------------------------------------------------------------
      SUBROUTINE SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPDZ2UV     COMPUTE WINDS FROM DIVERGENCE AND VORTICITY
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: COMPUTES THE WIND COMPONENTS FROM DIVERGENCE AND VORTICITY
C           IN SPECTRAL SPACE.
C           SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY.
C           IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER,
C           EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS,
C           THEN THE ZONAL WIND COMPONENT U IS COMPUTED AS
C             U(L,N)=-I*L/(N*(N+1))*A*D(L,N)
C                    +EPS(L,N+1)/(N+1)*A*Z(L,N+1)-EPS(L,N)/N*A*Z(L,N-1)
C           AND THE MERIDIONAL WIND COMPONENT V IS COMPUTED AS
C             V(L,N)=-I*L/(N*(N+1))*A*Z(L,N)
C                    -EPS(L,N+1)/(N+1)*A*D(L,N+1)+EPS(L,N)/N*A*D(L,N-1)
C           WHERE D IS DIVERGENCE AND Z IS VORTICITY.
C           U AND V ARE WEIGHTED BY THE COSINE OF LATITUDE.
C           EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN.
C           ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0
C           IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN.
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C
C USAGE:    CALL SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C     ENN1     - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2
C     ELONN1   - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A
C     EON      - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A
C     EONTOP   - REAL (M+1) EPSILON/N*A OVER TOP
C     D        - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE
C     Z        - REAL ((M+1)*((I+1)*M+2)) VORTICITY
C
C   OUTPUT ARGUMENT LIST:
C     U        - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (TIMES COSLAT)
C     V        - REAL ((M+1)*((I+1)*M+2)) MERID WIND (TIMES COSLAT)
C     UTOP     - REAL (2*(M+1)) ZONAL WIND (TIMES COSLAT) OVER TOP
C     VTOP     - REAL (2*(M+1)) MERID WIND (TIMES COSLAT) OVER TOP
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
      REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2)
      REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
      REAL D((M+1)*((I+1)*M+2)),Z((M+1)*((I+1)*M+2))
      REAL U((M+1)*((I+1)*M+2)),V((M+1)*((I+1)*M+2))
      REAL UTOP(2*(M+1)),VTOP(2*(M+1))
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE WINDS IN THE SPECTRAL DOMAIN
      K=1
      U(2*K-1)=EON(K+1)*Z(2*K+1)
      U(2*K)=EON(K+1)*Z(2*K+2)
      V(2*K-1)=-EON(K+1)*D(2*K+1)
      V(2*K)=-EON(K+1)*D(2*K+2)
      DO K=2,(M+1)*((I+1)*M+2)/2-1
        U(2*K-1)=ELONN1(K)*D(2*K)+EON(K+1)*Z(2*K+1)-EON(K)*Z(2*K-3)
        U(2*K)=-ELONN1(K)*D(2*K-1)+EON(K+1)*Z(2*K+2)-EON(K)*Z(2*K-2)
        V(2*K-1)=ELONN1(K)*Z(2*K)-EON(K+1)*D(2*K+1)+EON(K)*D(2*K-3)
        V(2*K)=-ELONN1(K)*Z(2*K-1)-EON(K+1)*D(2*K+2)+EON(K)*D(2*K-2)
      ENDDO
      K=(M+1)*((I+1)*M+2)/2
      U(2*K-1)=ELONN1(K)*D(2*K)-EON(K)*Z(2*K-3)
      U(2*K)=-ELONN1(K)*D(2*K-1)-EON(K)*Z(2*K-2)
      V(2*K-1)=ELONN1(K)*Z(2*K)+EON(K)*D(2*K-3)
      V(2*K)=-ELONN1(K)*Z(2*K-1)+EON(K)*D(2*K-2)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE WINDS OVER TOP OF THE SPECTRAL DOMAIN
      DO L=0,M
        K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1
        UTOP(2*L+1)=-EONTOP(L+1)*Z(2*K-1)
        UTOP(2*L+2)=-EONTOP(L+1)*Z(2*K)
        VTOP(2*L+1)=EONTOP(L+1)*D(2*K-1)
        VTOP(2*L+2)=EONTOP(L+1)*D(2*K)
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


subroutine out2d4n(rng,d,ien,xglobal,p)
! This subroutine is to apply B.C. du/dx=0 for 2D-4Node elements

use fluid_variables, only:mapping, neface, nnface, etype, ne, nn, nsd, nen, ndf,outedge
implicit none
integer rng(neface,ne) ! mrng matrix, for this case I know neface=4
integer ien(nen,ne)
real(8) xglobal(nsd,nn) ! global node cooridnates
real(8) p(ndf,nn) ! residual vector passed in
real(8) d(nsd,nn) ! solution variables on the nodes

integer local_node(2) !local node index who sit on the boudary
real(8) xref(nsd,nen) ! local coordinates for the quad element
real(8) xq(nsd)   ! local cooridnates of middle point on the picked edge
real(8) sq(0:nsd,nen)
real(8) sh(0:nsd,nen) ! shape functions
real(8) xr(nsd,nsd),cf(nsd,nsd),sx(nsd,nsd)
real(8) det
real(8) x(nsd,nen) ! global node cooridnates on the local element nodes
real(8) du(nsd)   ! spacial derivative of the velocity
real(8) dl ! length of the edge
real(8) d_local(ndf,nen)

integer ie
integer iface
integer node
integer i,j

! node 1
xref(1,1) = -1.0
xref(2,1) = -1.0
!node 2
xref(1,2) =  1.0
xref(2,2) = -1.0
!node 3
xref(1,3) =  1.0
xref(2,3) =  1.0
!node 4
xref(1,4) = -1.0
xref(2,4) =  1.0

do ie=1,ne ! loop over element
	do iface=1,neface ! loop over element edges
		if ( rng(iface,ie) == outedge) then ! find the element edge on the boundary
			local_node(1:2)=mapping(1:2,iface,etype) ! get local node index on the boudnary

			do i=1,2
				node = ien(local_node(i),ie)
				p(1,node) = 0.0d0     ! set the residual in x direction as zero
			end do
		end if
	end do

end do

do ie=1,ne ! loop over element
        do iface=1,neface ! loop over element edges
		if ( rng(iface,ie) == outedge) then ! find the element edge on the boundary
			local_node(1:2)=mapping(1:2,iface,etype) ! get local node index on the boudnary

			xq(:)=0.0d0

			do i=1,2
				node = ien(local_node(i),ie)
				xq(:) = xq(:) + xref(:,node)
			end do

			do i=1,nen
				node = ien(i,ie)
				x(:,i) = xglobal(:,node)
				d_local(:,i) = d(:,node)
			end do

			xq(:) = xq(:) / 2.0 ! get local the cooridnates of the middle point at the edge

			sq(0,1) = (1 - xq(1)) * (1 - xq(2)) / 4
			sq(0,2) = (1 + xq(1)) * (1 - xq(2)) / 4
			sq(0,3) = (1 + xq(1)) * (1 + xq(2)) / 4
			sq(0,4) = (1 - xq(1)) * (1 + xq(2)) / 4
			sq(1,1) = - (1 - xq(2)) / 4
			sq(1,2) = + (1 - xq(2)) / 4
			sq(1,3) = + (1 + xq(2)) / 4
			sq(1,4) = - (1 + xq(2)) / 4
			sq(2,1) = - (1 - xq(1)) / 4
			sq(2,2) = - (1 + xq(1)) / 4
			sq(2,3) = + (1 + xq(1)) / 4
			sq(2,4) = + (1 - xq(1)) / 4
			! calcualte the shape funciton based on the middle point

			sh(0,1) = sq(0,1)
			sh(0,2) = sq(0,2)
			sh(0,3) = sq(0,3)
			sh(0,4) = sq(0,4)
			xr(1,1) = sq(1,1) * x(1,1) + sq(1,2) * x(1,2) &
			+ sq(1,3) * x(1,3) + sq(1,4) * x(1,4)
			xr(1,2) = sq(1,1) * x(2,1) + sq(1,2) * x(2,2) &
			+ sq(1,3) * x(2,3) + sq(1,4) * x(2,4)
			xr(2,1) = sq(2,1) * x(1,1) + sq(2,2) * x(1,2) &
			+ sq(2,3) * x(1,3) + sq(2,4) * x(1,4)
			xr(2,2) = sq(2,1) * x(2,1) + sq(2,2) * x(2,2) &
			+ sq(2,3) * x(2,3) + sq(2,4) * x(2,4)

				!  jacobian
    			cf(1,1) = + (xr(1,1)*xr(2,2) - xr(2,1)*xr(1,2))

        		det = cf(1,1)

	        	sx(1,1) = xr(2,2)/det
		        sx(1,2) = -xr(1,2)/det
		        sx(2,1) = -xr(2,1)/det
		        sx(2,2) = xr(1,1)/det
				!  global first derivatives
    			sh(1,1)= sq(1,1) * sx(1,1) + sq(2,1) * sx(1,2)
        		sh(1,2)= sq(1,2) * sx(1,1) + sq(2,2) * sx(1,2)
	    		sh(1,3)= sq(1,3) * sx(1,1) + sq(2,3) * sx(1,2)
	            	sh(1,4)= sq(1,4) * sx(1,1) + sq(2,4) * sx(1,2)
		        sh(2,1)= sq(1,1) * sx(2,1) + sq(2,1) * sx(2,2)
			sh(2,2)= sq(1,2) * sx(2,1) + sq(2,2) * sx(2,2)
			sh(2,3)= sq(1,3) * sx(2,1) + sq(2,3) * sx(2,2)
		        sh(2,4)= sq(1,4) * sx(2,1) + sq(2,4) * sx(2,2)
			! get the first derivative of the shape function

			du(:) = 0.0d0
			do i=1,nen
				do j=1,nsd
				du(j) = du(j) + sh(j,i) * d_local(1,i)
				end do
			end do
			! get du/dx and du/dy

			dl=0.0d0
			do j=1,nsd
			dl = dl + ( x(j,local_node(1)) - x(j,local_node(2)) )**2
			end do
			dl = sqrt(dl)
			! get the length of the edge

			do i=1,2
			node = ien(local_node(i), ie)
			p(1,node) = p(1,node) + du(1)*dl*0.5
			end do
			! distribute dl*dudx on the global nodes
		end if
	end do
end do

end


      subroutine qltri6(s,m2sq,m3sq,musq,Ires)
C-----calculate the IR divergent box in DIM reg
C-----Note choosing the cutoff equal to musq, we exactly get
C-----the e=0, dim reg result
      implicit none
      include 'qlconstants.f'
      double precision s,m2sq,m3sq,musq,m2,m3,iepsd,rexs,imxs
      double complex Ires(-2:0),cxs(3),fac,xlog,cln,qlcLi2omx2
      logical qlzero

      m2 = sqrt(m2sq)
      m3 = sqrt(m3sq)

C     ieps gives the sign of the imaginary part of K
      call qlkfn(cxs,iepsd,s,m2,m3)
      fac=dcmplx(1d0/(m2*m3))*cxs(1)/(cxs(2)*cxs(3))
      xlog = cln(cxs(1),iepsd)

      rexs=dreal(cxs(1))
      imxs=dimag(cxs(1))
C----deal with s=(m2-m3)^2
      if ((qlzero(rexs-1d0)) .and. (qlzero(imxs))) then
      fac=dcmplx(0.5d0/(m2*m3))
      Ires(-2)=czip
      Ires(-1)=fac
      if (qlzero(m2-m3)) then
      Ires(0)=fac*dcmplx(log(musq/(m2*m3)))
      else
      Ires(0)=fac*(dcmplx(log(musq/(m2*m3)))-ctwo
     .        -dcmplx((m3+m2)/(m3-m2)*log(m2/m3)))
      endif
      else
C----deal with s .ne. (m2-m3)^2
      Ires(-2)=  czip
      Ires(-1)= -fac*xlog
      Ires(0) = fac*(xlog*(-chalf*xlog
     . +dcmplx(log(m2*m3/musq)))
     . -qlcLi2omx2(cxs(1),cxs(1),iepsd,iepsd)
     . +chalf*dcmplx(log(m2/m3)**2)
     . +qlcLi2omx2(cxs(1),dcmplx(m2/m3),iepsd,0d0)
     . +qlcLi2omx2(cxs(1),dcmplx(m3/m2),iepsd,0d0))
      endif

      return
      end