c***********************************************************************
c	                    COORD_J2B.F
c***********************************************************************
*     PURPOSE: Converts from Jacobi to Barycentric coords.
*     ARGUMENTS:  Input is
*                    nbod ==> number of bodies (must be less than NBMAX)
*                             (integer)
*	             mass(*) ==>  masses (real array)
*		     xj(*),yj(*),zj(*) ==> Jacobi particle coords
*                                          (real array)
*		     vxj(*),vyj(*),vzj(*) ==> Jacobi particle velocities
*                                             (real array)
*                 Returned are
*                    xb(*),yb(*),zb(*) ==>  Barycentric particle positions
*                                          (real array)
*                    vxb(*),vyb(*),vzb(*) ==> Barycentric particle velocities
*                                            (real array)
*
*     ALGORITHM: See my notes on Nov 21.
*
*     Authors:  Martin Duncan
*     WRITTEN:  Jan 27/93
*     REVISIONS: 2/17/95  HFL

	subroutine coord_j2b(nbod,mass,xj,yj,zj,vxj,vyj,vzj,
     &      xb,yb,zb,vxb,vyb,vzb)

      include '../swift.inc'

c...  Inputs:
	integer nbod
	real*8 mass(NPLMAX)
	real*8 xj(NPLMAX),yj(NPLMAX),zj(NPLMAX)
	real*8 vxj(NPLMAX),vyj(NPLMAX),vzj(NPLMAX)

c...  Outputs:
	real*8 xb(NPLMAX),yb(NPLMAX),zb(NPLMAX)
	real*8 vxb(NPLMAX),vyb(NPLMAX),vzb(NPLMAX)

c...  Internals:
	integer n
	real*8 xtmp,ytmp,ztmp,vxtmp,vytmp,vztmp
	real*8 capx,capy,capz,capvx,capvy,capvz
	real*8 mtot,rat,rat2
	real*8 eta(NPLMAX)
c----
c...  Executable code

c First compute the necessary auxiliary vbles, then compute the bary. positions

	eta(1) = mass(1)
	do n = 2,nbod
	  eta(n) = eta(n-1) + mass(n)
        enddo

	mtot = eta(nbod)
	xb(nbod) = eta(nbod-1)*xj(nbod)/mtot
	yb(nbod) = eta(nbod-1)*yj(nbod)/mtot
	zb(nbod) = eta(nbod-1)*zj(nbod)/mtot
	vxb(nbod) = eta(nbod-1)*vxj(nbod)/mtot
	vyb(nbod) = eta(nbod-1)*vyj(nbod)/mtot
	vzb(nbod) = eta(nbod-1)*vzj(nbod)/mtot

	capx = mass(nbod)*xj(nbod)/mtot
	capy = mass(nbod)*yj(nbod)/mtot
	capz = mass(nbod)*zj(nbod)/mtot
	capvx = mass(nbod)*vxj(nbod)/mtot
	capvy = mass(nbod)*vyj(nbod)/mtot
	capvz = mass(nbod)*vzj(nbod)/mtot

	do n = nbod-1,2,-1
	  rat = eta(n-1)/eta(n)
	  xb(n) = rat*xj(n) - capx
	  yb(n) = rat*yj(n) - capy
	  zb(n) = rat*zj(n) - capz
	  vxb(n) = rat*vxj(n) - capvx
	  vyb(n) = rat*vyj(n) - capvy
	  vzb(n) = rat*vzj(n) - capvz

	  rat2 = mass(n)/eta(n)
	  capx = capx + rat2*xj(n)
	  capy = capy + rat2*yj(n)
	  capz = capz + rat2*zj(n)
	  capvx = capvx + rat2*vxj(n)
	  capvy = capvy + rat2*vyj(n)
	  capvz = capvz + rat2*vzj(n)
	enddo

c Now compute the Sun's barycentric position
	xtmp =0.d0
	ytmp =0.d0
	ztmp =0.d0
	vxtmp =0.d0
	vytmp =0.d0
	vztmp =0.d0

	do n=2,nbod
	   xtmp = xtmp + mass(n)*xb(n)
	   ytmp = ytmp + mass(n)*yb(n)
	   ztmp = ztmp + mass(n)*zb(n)
	   vxtmp = vxtmp + mass(n)*vxb(n)
	   vytmp = vytmp + mass(n)*vyb(n)
	   vztmp = vztmp + mass(n)*vzb(n)
	enddo

	xb(1) = -xtmp/mass(1)
	yb(1) = -ytmp/mass(1)
	zb(1) = -ztmp/mass(1)
	vxb(1) = -vxtmp/mass(1)
	vyb(1) = -vytmp/mass(1)
	vzb(1) = -vztmp/mass(1)

	return
	end    ! coord_j2b

c--------------------------------------------------------------------------


subroutine kessler_mr2z(nx,ny,nz &
                       ,rho &                                ! kg/m^3
                       ,rainmr,icemr,snowmr,graupelmr  &
                       ,refl)

! Subroutine to compute estimated radar reflectivity (Z) from
! the precipitation mixing ratios.  The estimation
! is done using formulae from Kessler (1969) and
! Rogers and Yau (1989).

! Adapted from USAF Weather Agency routine.
! Brent Shaw, NOAA Forecast System Lab, Dec 2000

! Put into subroutine by Steve Albers

implicit none

integer :: nx,ny,nz,i,j,k
real, parameter :: svnfrth=7.0/4.0
real, dimension(nx,ny,nz) :: rho,rainmr,icemr,snowmr,graupelmr,refl

refl=0.0

do j=1,ny
do i=1,nx
   do k=1,nz

!     Compute the basic reflectivity
      refl(i,j,k) =17300.0 * &
                  (rho(i,j,k) * 1000.0 * &
                   MAX(0.0,rainmr(i,j,k)))**svnfrth

!     Add the ice component
      refl(i,j,k)=refl(i,j,k) + &
                  38000.0*(rho(i,j,k) * 1000.0 * &
                  MAX(0.0,icemr(i,j,k)+snowmr(i,j,k)+graupelmr(i,j,k)))**2.2

   enddo

enddo
enddo

return
end


! gfortran Runge-Kutta4thorder_sub.f90 zufall_sub.f
! Do not forget to include:
!     USE RungeKuttaModule
! in the program using this subroutine

MODULE ODE_RightHandSide
  IMPLICIT NONE
CONTAINS

  !FUNCTION  F(t,y, beta_ijkl,beta_ijkl_map) RESULT(K)
  FUNCTION F(t,y) RESULT(K)
    !USE interaction_interface

    IMPLICIT NONE
    COMPLEX*16,       DIMENSION(:), INTENT(IN) :: y
    !DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: beta_ijkl
    !DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: beta_ijkl_map
    DOUBLE PRECISION,               INTENT(IN) ::  t
    COMPLEX*16,       DIMENSION(SIZE(y))       :: K

    !K(1) =  y(2)
    !K(2) = -y(1)!-0.25*y(2)

    K(1) = -2.0*Y(2)!4.0-Y(1)*Y(1)-4*Y(2)*Y(2)
    K(2) = 0.4 + Y(1) + 0.3*Y(1)*Y(1) - 0.6*Y(2)*Y(2)!Y(2)*Y(2) - Y(1)*Y(1) + 1.0

    !K(1) = DCMPLX(0.0,-1.0)*(0.5*Y(3)+sqrt(2.0)*exp(-t*t/5.0)*cos(t)*Y(2) + Y(1))
    !K(2) = DCMPLX(0.0,-1.0)*(sqrt(2.0)*exp(-t*t/5.0)*cos(t)*Y(3)+sqrt(2.0)*exp(-t*t/5.0)*cos(t)*Y(1))
    !K(3) = DCMPLX(0.0,-1.0)*(-Y(3)+sqrt(2.0)*exp(-t*t/5.0)*cos(t)*Y(2)+0.5*Y(1))
    !CALL INTERACTIONTERM(SIZE(y), y, K, beta_ijkl,beta_ijkl_map)
    !WRITE(*,*) K(2)

  END FUNCTION F

END MODULE ODE_RightHandSide

MODULE RungeKuttaModule
  IMPLICIT NONE
  INTERFACE

     SUBROUTINE RKFOURTHORDER(y,t,dt)
       USE ODE_RightHandSide
       IMPLICIT NONE
       COMPLEX*16, DIMENSION(:), INTENT(IN) :: y
       DOUBLE PRECISION, INTENT(INOUT)  :: t
       DOUBLE PRECISION, INTENT(IN) :: dt
       !DOUBLE PRECISION, DIMENSION(:),  INTENT(IN):: beta_ijkl
       !DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: beta_ijkl_map
     END SUBROUTINE RKFOURTHORDER

  END INTERFACE

END MODULE RungeKuttaModule

PROGRAM RungeKuttaProgram
  USE RungeKuttaModule
  IMPLICIT NONE

  COMPLEX*16,       DIMENSION(:), ALLOCATABLE :: y
  DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: y_aux
  DOUBLE PRECISION                            :: t,dt,pi

  INTEGER dim,i, iterations,j, seed
  !double precision CYCLE
  !data CYCLE/2.0E-8/

  dim  = 2
  ALLOCATE(y(dim))
  ALLOCATE(y_aux(dim))

  pi = 4.0*ATAN(1.0)
  iterations  = 4096

  dt = 10.0*2.0*pi/iterations
  t  = 0.0

  y(1) =  1.0/sqrt(2.0)
  y(2) =  1.0/sqrt(2.0)
  !y(3) =  1.0/sqrt(2.0)

  !y = y/dot_product(y,y)

  write(*,*) t,(real(y(i)),i=1,dim),(aimag(y(i)), i=1,dim)
  DO j=1,iterations
     CALL RKFOURTHORDER(y,t,dt)
     WRITE(*,*) t,(real(y(i)),i=1,dim),(aimag(y(i)), i=1,dim)
  END DO

END PROGRAM RungeKuttaProgram

SUBROUTINE RKFOURTHORDER(y,t,dt)

  USE ODE_RightHandSide

  IMPLICIT NONE
  COMPLEX*16,       DIMENSION(:), INTENT(INOUT) :: y
  DOUBLE PRECISION,               INTENT(INOUT) :: t
  DOUBLE PRECISION,               INTENT(IN)    :: dt
  !DOUBLE PRECISION, DIMENSION(:), INTENT(IN)    :: beta_ijkl
  !DOUBLE PRECISION, DIMENSION(:), INTENT(IN)    :: beta_ijkl_map

  COMPLEX*16, DIMENSION(:), ALLOCATABLE :: K1,K2,K3,K4,y_aux

  INTEGER i,dim

  ALLOCATE(K1(SIZE(Y)))
  ALLOCATE(K2(SIZE(Y)))
  ALLOCATE(K3(SIZE(Y)))
  ALLOCATE(K4(SIZE(Y)))
  ALLOCATE(y_aux(SIZE(Y)))

  !write(*,*) "k1"
  !K1 = f(t,y,beta_ijkl,beta_ijkl_map)
  K1 = f(t,y)
  y_aux = y +K1*dt*0.5

  !write(*,*) "k2"
  !K2 = f(t+0.5*dt,y_aux,beta_ijkl,beta_ijkl_map)
  K2 = f(t+0.5*dt,y_aux)
  y_aux = y +K2*dt*0.5

  !write(*,*) "k3"
  !K3 = f(t+0.5*dt,y_aux,beta_ijkl,beta_ijkl_map)
  K3 = f(t+0.5*dt,y_aux)
  y_aux = y +K3*dt

  !write(*,*) "k4"
  !K4 = f(t+dt,y_aux,beta_ijkl,beta_ijkl_map)
  K4 = f(t+dt,y_aux)
  y = y + dt*(K1 + 2.0*K2 + 2.0*K3 + K4)/6.0

  t = t + dt;
  !write(*,*) t,dt
END SUBROUTINE RKFOURTHORDER


module random_mod
    use, intrinsic :: iso_fortran_env, only : I8 => INT64, error_unit
    implicit none

    private

    public :: random_bitvector

contains

    function random_bitvector(n) result(vector)
        implicit none
        integer(kind=I8), value :: n
        logical, dimension(:), allocatable :: vector
        real, dimension(:), allocatable :: real_vector
        integer :: status

        allocate (real_vector(n), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocated temporary vector'
            stop 10
        end if
        allocate (vector(n), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocated bitvector'
            stop 10
        end if
        call random_number(real_vector)
        vector = real_vector < 0.5
        deallocate (real_vector)
    end function random_bitvector

end module random_mod


PROGRAM TEST
! Driver code for computing Delaunay umbrella neighbourhood of a given vertex.
! Reads a file containing a list of N vertices in R^D and constructs the
! umbrella neighbourhood of some vertex in that file.
!
! Author: Tyler Chang
! Last Update: August, 2017
!
! Usage :$ ./delfan D N V FILENAME
!
! D is an integer specifying the dimension of problem.
! N is an integer specifying the number of lines (vertices) in the file.
! V is an integer specifying the index of vertex to compute the umbrella
!    neighbourhood about.
! FILENAME gives the input file path (32 chars max).
USE DELAUNAYFAN_MOD
IMPLICIT NONE

! Variables and input data.
INTEGER :: D, N, V, ERROR
REAL(KIND=R8), ALLOCATABLE :: PTS(:,:), WEIGHTS(:,:), WORK(:)
REAL(KIND=R8) :: START, FINISH
INTEGER, ALLOCATABLE :: FAN(:,:)
INTEGER :: I, J
CHARACTER(LEN=80) :: ARG

! Read the values of D, N, V, and FILENAME from the command line.
CALL GET_COMMAND_ARGUMENT(1, ARG)
READ(ARG, *) D
CALL GET_COMMAND_ARGUMENT(2, ARG)
READ(ARG, *) N
CALL GET_COMMAND_ARGUMENT(3, ARG)
READ(ARG, *) V
CALL GET_COMMAND_ARGUMENT(4, ARG)

! Allocate memory to store inputs.
ALLOCATE(PTS(D,N), WORK(5*D), STAT=I)
IF (I .NE. 0) PRINT *, 'Warning: Malloc Fail!'

! Read data from input file.
OPEN(1, FILE=TRIM(ARG))
DO I = 1, N
   READ(1, *) PTS(:, I)
END DO
CLOSE(1)

! Get the results and record the computation time.
CALL CPU_TIME(START)
CALL DELAUNAYFAN(D, N, PTS, V, FAN, ERROR, IBUDGET=10000)
CALL CPU_TIME(FINISH)
FINISH = FINISH - START
! Print the timing results.
IF(ERROR .LE. 1) THEN
   PRINT *, 'Fan: '
   DO I = 1, SIZE(FAN,2)
      PRINT *, FAN(:,I)
   END DO
   PRINT *, ''
   IF (ERROR .EQ. 1) PRINT *, 'Vertex ', V, ' is a vertex of the convex hull.'
   PRINT *, ''
ELSE
   PRINT *, 'Error. Code = ', ERROR
END IF
PRINT *, 'Fan of ', SIZE(FAN,2), ' simps built in ', FINISH, ' seconds.'

! Free the heap memory.
DEALLOCATE(PTS, FAN, WORK, STAT=ERROR)
IF (ERROR .NE. 0) PRINT *, 'There was an error freeing memory.'
RETURN
END PROGRAM TEST


MODULE Knuth_random

! Code converted using TO_F90 by Alan Miller
! Date: 2000-09-10  Time: 16:37:48
! Latest revision - 16 January 2003

! FORTRAN 77 version of "ran_array"
! from Seminumerical Algorithms by D E Knuth, 3rd edition (1997)
!       including the MODIFICATIONS made in the 9th printing (2002)
! ********* see the book for explanations and caveats! *********
! Author: Steve Kifowit
! http://ourworld.compuserve.com/homepages/steve_kifowit
! with modifications by Alan Miller to rnarry and rnstrt based upon
! Knuth's code.

! For Donald Knuth's Fortran 77 versions, go to:
! http://www-cs-faculty.stanford.edu/~knuth/programs
! Look for frng.f and frngdb.f

IMPLICIT NONE
INTEGER, PARAMETER  :: kk=100, ll=37, mm=2**30, tt=70, kkk=kk+kk-1
INTEGER, SAVE       :: ranx(kk)

CONTAINS

SUBROUTINE rand(u, n)

! Generate an array of n real values between 0 and 1.

REAL, INTENT(OUT)    :: u(:)
INTEGER, INTENT(IN)  :: n

! Local array
INTEGER  :: aa(n)

CALL rnarry(aa, n)
u(1:n) = SCALE( REAL(aa), -30)

RETURN
END SUBROUTINE rand

SUBROUTINE rnarry(aa, n)

! Generate an array of n integers between 0 and 2^30-1.

INTEGER, INTENT(OUT)  :: aa(:)
INTEGER, INTENT(IN)   :: n

! Local variables
INTEGER  :: j

aa(1:kk) = ranx(1:kk)
DO  j = kk + 1, n
  aa(j) = aa(j-kk) - aa(j-ll)
  IF (aa(j) < 0) aa(j) = aa(j) + mm
END DO
DO  j=1,ll
  ranx(j) = aa(n+j-kk) - aa(n+j-ll)
  IF (ranx(j) < 0) ranx(j) = ranx(j) + mm
END DO
DO  j=ll+1,kk
  ranx(j) = aa(n+j-kk) - ranx(j-ll)
  IF (ranx(j) < 0) ranx(j) = ranx(j) + mm
END DO

RETURN
END SUBROUTINE rnarry

SUBROUTINE rnstrt(seed)

! Initialize integer array ranx using the input seed.

INTEGER, INTENT(IN)  :: seed

! Local variables
INTEGER  :: x(kkk), j, ss, sseed, t

IF (seed < 0) THEN
  sseed = mm - 1 - MOD(-1-seed, mm)
ELSE
  sseed = MOD(seed, mm)
END IF
ss = sseed - MOD(sseed,2) + 2
DO  j=1, kk
  x(j) = ss
  ss = ISHFT(ss, 1)
  IF (ss >= mm) ss = ss - mm + 2
END DO
x(kk+1:kkk) = 0
x(2) = x(2)+1
ss = sseed
t = tt - 1
10 DO  j=kk, 2, -1
  x(j+j-1) = x(j)
END DO
DO  j = kkk, kk + 1, -1
  x(j-(kk-ll)) = x(j-(kk-ll)) - x(j)
  IF (x(j-(kk-ll)) < 0) x(j-(kk-ll)) = x(j-(kk-ll)) + mm
  x(j-kk) = x(j-kk) - x(j)
  IF (x(j-kk) < 0) x(j-kk) = x(j-kk) + mm
END DO
IF (MOD(ss,2) == 1) THEN
  DO  j=kk, 1, -1
    x(j+1) = x(j)
  END DO
  x(1) = x(kk+1)
  x(ll+1) = x(ll+1) - x(kk+1)
  IF (x(ll+1) < 0) x(ll+1) = x(ll+1) + mm
END IF
IF (ss /= 0) THEN
  ss = ISHFT(ss, -1)
ELSE
  t = t - 1
END IF
IF (t > 0) GO TO 10

DO  j=1, ll
  ranx(j+kk-ll) = x(j)
END DO
DO  j=ll+1,kk
  ranx(j-ll) = x(j)
END DO

DO  j = 1, 10
  CALL rnarry(x,kkk)
END DO

RETURN
END SUBROUTINE rnstrt

END MODULE Knuth_random

PROGRAM main
!      a rudimentary test program:
USE Knuth_random
IMPLICIT NONE

INTEGER  :: a(2009), i
REAL     :: u(1000), aver, dev, sumsq, stdev

CALL rnstrt(310952)
DO  i=1,2010
  CALL rnarry(a, 1009)
END DO
WRITE(*, '(I15)') a(1)
!                   the number should be 211101277
CALL rnstrt(310952)
DO  i=1,1010
  CALL rnarry(a, 2009)
END DO
WRITE(*, '(I15)') a(1)
!                                 again, 211101277

! Generate real variables.

CALL rand(u, 1000)
aver = 0.0
sumsq = 0.0
DO i = 1, 1000
  dev = u(i) - aver
  aver = aver + dev/i
  sumsq = sumsq + dev*(u(i) - aver)
END DO

! N.B. Dividing the sum of squares by (n-1) gives an unbiassed estimate
! of the variance; dividing by (n-1.5) gives an almost unbiassed estimate
! of the standard deviation.
stdev = SQRT(sumsq/998.5)

WRITE(*, '(a, f9.4, a, f9.4)') ' Mean = ', aver, '  Std. devn. = ', stdev
WRITE(*, '(a, f6.1, "  ", f9.4)')  &
         ' Values above should be close to ', 0.5, SQRT(1./12.)
STOP
END PROGRAM main


! Program to test
subroutine test (p)
   integer, dimension (3) :: p

   if (any (p .ne. (/ 2, 4, 6/))) call abort
end subroutine

program partparm
   implicit none
   integer, dimension (2, 3) :: a
   external test

   a = reshape ((/ 1, 2, 3, 4, 5, 6/), (/ 2, 3/))
   call test (a(2, :))
end program


program read_netcdf
use netcdf
use real_types
use grid
implicit none
character(len=1024) :: file_name
integer :: ret_val, nc_id, i, j, k
integer, dimension(3) :: dims
real(kind=sp), dimension(:), allocatable :: x, y, z
real(kind=sp), dimension(:,:,:), allocatable :: value
real(kind=sp) :: v, max_diff

! get file name specified as command line argument
if (command_argument_count() /= 1) then
    print *, "### error: expecting file name"
    stop
end if
call get_command_argument(1, file_name)

! open NetCDF file for reading
ret_val = nf90_open(file_name, NF90_NOWRITE, nc_id)
if (ret_val /= nf90_noerr) then
    print *, "### error: file open failed"
    stop
end if

! get the x-, y-, and z-grid coordinates
call grid_axis(nc_id, "x", x)
call grid_axis(nc_id, "y", y)
call grid_axis(nc_id, "z", z)

! get the values
call grid_3d_data(nc_id, "value", value)

dims = shape(value)

max_diff = 0.0_sp
do i = 1, dims(1)
    do j = 1, dims(2)
        do k = 1, dims(3)
            v = exp(-(x(i)**2 + y(j)**2 +z(k)**2))
            max_diff = max(abs(v - value(i, j, k)), max_diff)
        end do
    end do
end do
print *, "maximum difference = ", max_diff

! close NetCDF file
ret_val = nf90_close(nc_id)
if (ret_val /= nf90_noerr) then
    print *, "### error: file close failed"
    stop
end if

! deallocate arrays
deallocate(x)
deallocate(y)
deallocate(z)

end program read_netcdf


      SUBROUTINE W3FA03(PRESS,HEIGHT,TEMP,THETA)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    W3FA03      COMPUTE STANDARD HEIGHT, TEMP, AND POT TEMP
C   PRGMMR: KEYSER           ORG: W/NMC22    DATE: 92-06-29
C
C ABSTRACT: COMPUTES THE STANDARD HEIGHT, TEMPERATURE, AND POTENTIAL
C   TEMPERATURE GIVEN THE PRESSURE IN MILLIBARS ( > 8.68 MB ).  FOR
C   HEIGHT AND TEMPERATURE THE RESULTS DUPLICATE THE VALUES IN THE
C   U.S. STANDARD ATMOSPHERE (L962), WHICH IS THE ICAO STANDARD
C   ATMOSPHERE TO 54.7487 MB (20 KM) AND THE PROPOSED EXTENSION TO
C   8.68 MB (32 KM).  FOR POTENTIAL TEMPERATURE A VALUE OF  2/7  IS
C   USED FOR  RD/CP.
C
C PROGRAM HISTORY LOG:
C   74-06-01  J. MCDONELL W345     -- ORIGINAL AUTHOR
C   84-06-01  R.E.JONES W342       -- CHANGE TO IBM VS FORTRAN
C   92-06-29  D. A. KEYSER W/NMC22 -- CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:    CALL W3FA03(PRESS,HEIGHT,TEMP,THETA)
C   INPUT ARGUMENT LIST:
C     PRESS    - PRESSURE IN MILLIBARS
C
C   OUTPUT ARGUMENT LIST:
C     HEIGHT   - HEIGHT IN METERS
C     TEMP     - TEMPERATURE IN DEGREES KELVIN
C     THETA    - POTENTIAL TEMPERATURE IN DEGREES KELVIN
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       CRAY     - ALOG
C
C
C REMARKS: NOT VALID FOR PRESSURES LESS THAN 8.68 MILLIBARS, DECLARE
C   ALL PARAMETERS AS TYPE REAL.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
      REAL  M0
C
      SAVE
C
      DATA  G/9.80665/,RSTAR/8314.32/,M0/28.9644/,PISO/54.7487/,
     $ ZISO/20000./,SALP/-.0010/,PZERO/1013.25/,T0/288.15/,ALP/.0065/,
     $ PTROP/226.321/,TSTR/216.65/
C
      ROVCP = 2.0/7.0
      R     = RSTAR/M0
      ROVG  = R/G
      FKT   = ROVG * TSTR
      AR    = ALP  * ROVG
      PP0   = PZERO**AR
      IF(PRESS.LT.PISO)   GO TO 100
      IF(PRESS.GT.PTROP)  GO TO 200
C
C     COMPUTE ISOTHERMAL CASES
C
      HEIGHT = 11000.0 + (FKT * ALOG(PTROP/PRESS))
      TEMP = TSTR
      GO TO 300
C
C     COMPUTE LAPSE RATE = -.0010 CASES
C
 100  CONTINUE
      AR     = SALP * ROVG
      PP0    = PISO**AR
      HEIGHT = ((TSTR/(PP0 * SALP )) * (PP0-(PRESS ** AR))) + ZISO
      TEMP   = TSTR - ((HEIGHT - ZISO) * SALP)
      GO TO 300
C
 200  CONTINUE
      HEIGHT = (T0/(PP0 * ALP)) * (PP0 - (PRESS ** AR))
      TEMP   = T0 - (HEIGHT * ALP)
C
 300  CONTINUE
      THETA  = TEMP * ((1000./PRESS)**ROVCP)
      RETURN
      END


    program AOC15B

    implicit none

    integer, parameter :: inpsize = 100
    integer, parameter :: xysize = 5*inpsize
    character(*), parameter :: file='input.txt'

    logical :: notinset(xysize,xysize)
    integer :: risks(xysize/5,xysize/5), costs(xysize,xysize)
    integer :: i,j,curx,cury,candidate(2)
    integer, parameter :: adjx(4) = [-1,1,0,0], adjy(4)=[0,0,1,-1]

    open (unit=1, file=file, form='formatted', status='old')
    do i=1,xysize/5
        read (1,'(*(I1))') (risks(i,j),j=1,inpsize)
    end do
    costs = huge(0)
    costs(1,1) = 0
    notinset = .true.

    do
       ! write (*,'(10(10I3/)/)') (costs(i,:),i=1,10)
        candidate = minloc(costs,mask=notinset)
       !write (*,*) candidate
        cury = candidate(1)
        curx = candidate(2)
        !print *, candidate
        if ((curx == xysize) .and. (cury == xysize)) exit
        notinset(cury,curx) = .false.
        do i=1,4
            if ((curx+adjx(i) < 1) .or. (curx+adjx(i) > xysize)) cycle
            if ((cury+adjy(i) < 1) .or. (cury+adjy(i) > xysize)) cycle
            if (notinset(cury+adjy(i),curx+adjx(i))) then
                block
                    integer :: newcost, newrisk
                    newrisk = getrisk(cury+adjy(i),curx+adjx(i))
                    newcost = costs(cury,curx) + newrisk
                    if (newcost < costs(cury+adjy(i),curx+adjx(i))) &
                        costs(cury+adjy(i),curx+adjx(i)) = costs(cury,curx) + newrisk
                end block
            end if
        end do
    end do

    print *, costs(xysize,xysize)

    contains

    function getrisk (x,y)
    integer :: getrisk
    integer, intent(in) :: x,y
    integer :: origx,origy
    origx = mod(x-1,inpsize)+1
    origy = mod(y-1,inpsize)+1
    getrisk = risks(origy,origx) + ((x-1)/inpsize) + ((y-1)/inpsize)
    if (getrisk > 9) getrisk = getrisk - 9
    end function getrisk

    end program AOC15B


      PROGRAM LA_CGGSVD_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GGSVD
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, M, N, P, K, L
      REAL(WP), ALLOCATABLE :: ALPHA(:), BETA(:)
!  .. "Local Arrays" ..
      COMPLEX(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:), U(:,:), V(:,:), Q(:,:)
!  .. "Intrinsic Functions" ..
      INTRINSIC REAL, AIMAG, INT
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GGSVD Example Program Results'
      N = 3; M=5; P=2
      ALLOCATE( A(M,N), AA(M,N), B(P,N), BB(P,N), ALPHA(N), BETA(N), U(M,M), V(P,P), Q(N,N) )

      OPEN(UNIT=21,FILE='ggsvd.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,M
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=A

      WRITE(*,*)'Matrix A : '
      DO I=1,M
         WRITE(*,"(3('('(I3,1X,',',I3)')',1X,1X))") INT(A(I,1)),INT(AIMAG(A(I,1))), &
              INT(A(I,2)),INT(AIMAG(A(I,2))), &
              INT(A(I,3)),INT(AIMAG(A(I,3)))
      ENDDO

      OPEN(UNIT=21,FILE='ggsvd.mb',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,P
            READ(21,*) B(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      BB=B
      WRITE(*,*)
      WRITE(*,*)'Matrix B : '
      DO I=1,P
         WRITE(*,"(3('('(I3,1X,',',I3)')',1X,1X))") INT(B(I,1)), INT(AIMAG(B(I,1))), &
              INT(B(I,2)),INT(AIMAG(B(I,2))), &
              INT(B(I,3)),INT(AIMAG(B(I,3)))
      ENDDO

      WRITE(*,*)
      WRITE(*,*) "CALL LA_GGSVD( A, B, ALPHA, BETA, K, L ) "
      CALL LA_GGSVD( A, B, ALPHA, BETA, K, L )

      WRITE(*,*)'A on exit : '
      DO I=1,M;
         WRITE(*,"(3('('(E13.6,1X,',',E13.6)')',1X))") REAL(A(I,1)),AIMAG(A(I,1)), &
              REAL(A(I,2)),AIMAG(A(I,2)), &
              REAL(A(I,3)),AIMAG(A(I,3))
      ENDDO
      WRITE(*,*)
      WRITE(*,*)'ALPHA on exit : '
      DO I=1,N
         WRITE(*,"((E14.6,1X))") ALPHA(I)
      ENDDO
      WRITE(*,*)
      WRITE(*,*)'BETA on exit : '
      DO I=1,N
         WRITE(*,"((E14.6,1X))") BETA(I)
      ENDDO
      WRITE(*,*)
      WRITE(*,*)' K = ', K
      WRITE(*,*)' L = ', L

      WRITE(*,*)
      WRITE(*,*)' * EXAMPLE 2 * '
      WRITE(*,*)
      WRITE(*,*) "CALL LA_GGSVD( A, B, ALPHA, BETA, K, L, U, V, Q, INFO=INFO )"
      CALL LA_GGSVD(  AA, BB, ALPHA, BETA, K, L, U, V, Q , INFO=INFO )

      WRITE(*,*)'U on exit : '
      DO I=1,M;
         WRITE(*,"(5('('(E13.6,1X,',',1X,E13.6)')',1X))") REAL(U(I,1)), AIMAG(U(I,1)), &
              REAL(U(I,2)), AIMAG(U(I,2)), &
              REAL(U(I,3)), AIMAG(U(I,3)), &
              REAL(U(I,4)), AIMAG(U(I,4)), &
              REAL(U(I,5)), AIMAG(U(I,5))
      ENDDO
      WRITE(*,*)
      WRITE(*,*)'V on exit : '
      DO I=1,P;
         WRITE(*,"(2('('(E13.6,1X,',',E13.6)')',1X,1X))") REAL(V(I,1)), AIMAG(V(I,1)), &
              REAL(V(I,2)), AIMAG(V(I,2))
      ENDDO
      WRITE(*,*)
      WRITE(*,*)'Q on exit : '
      DO I=1,N;
         WRITE(*,"(3('('(E13.6,1X,',',E13.6)')',1X))") REAL(Q(I,1)), AIMAG(Q(I,1)), &
              REAL(Q(I,2)), AIMAG(Q(I,2)), &
              REAL(Q(I,3)), AIMAG(Q(I,3))
      ENDDO
      WRITE(*,*)
      WRITE(*,*) ' INFO = ', INFO

      END PROGRAM LA_CGGSVD_EXAMPLE


! $UWHPSC/codes/f2py/fcn1.f90

! A test function for trying out f2py:
!   $ f2py -m fcn1 -c fcn1.f90
!   $ python
!   >>> import fcn1
!   >>> fcn1.f1(1.)
!   2.7182818284590451

function f1(x)
    real(kind=8), intent(in) :: x
    real(kind=8) :: f1
    f1 = exp(x)
end function f1


program test_omp
    implicit none
    integer :: m,n,k,batchCount
    real, allocatable :: A(:,:,:), B(:,:,:),C(:,:,:)
    real :: csum

    integer :: i1,i2,i3

    m = 5
    n = 6
    k = 7
    batchCount = 16
    allocate( C(m,n,batchCount) )
    allocate( A(m,k,batchCount) )
    allocate( B(k,n,batchCount) )

    !$omp target data map(A,B,C)

    !$omp target teams distribute parallel do SIMD
    do i3=1,batchCount
    do i2=1,size(C,2)
    C(1:m,i2,i3) = 1
    enddo
    enddo

    !$omp target teams distribute   parallel do SIMD
    do i3=1,size(A,3)
    do i2=1,size(A,2)
    do i1=1,size(A,1)
    A(i1,i2,i3) = i1 + (i2-1)*size(A,1) +                          &
        &       (i3-1)*size(A,1)*size(A,2)
    enddo
    enddo
    enddo

    !$omp target teams distribute   parallel do SIMD
    do i3=1,size(B,3)
    do i2=1,size(B,2)
    do i1=1,size(B,1)
    B(i1,i2,i3) = 1.0/( i1+(i2-1)*size(B,1) +                      &
        &                        (i3-1)*size(B,1)*size(B,2))
    enddo
    enddo
    enddo

    !$omp target teams distribute parallel do SIMD
    do i3=1,batchCount
    C(1:m,1:n,i3) = C(1:m,1:n,i3) +                                  &
        &         matmul( A(1:m,1:k,i3), B(1:k,1:n,i3))
    enddo

    !$omp end target data

    csum = 0
    !$omp parallel do collapse(3) reduction(+:csum)
    do i3=1,size(C,3)
    do i2=1,size(C,2)
    do i1=1,size(C,1)
    csum = csum + abs(C(i1,i2,i3))
    enddo
    enddo
    enddo

    print*,'m,n,k,batchCount',m,n,k,batchCount
    print*,'csum = ', csum

    stop
end program test_omp


      SUBROUTINE amoeba(p,y,mp,np,ndim,ftol,funk,iter)
      INTEGER iter,mp,ndim,np,NMAX,ITMAX
      REAL ftol,p(mp,np),y(mp),funk,TINY
      PARAMETER (NMAX=20,ITMAX=5000,TINY=1.e-10)
      EXTERNAL funk
CU    USES amotry,funk
C	Multidimensional minimization of the function funk(x) where
C	x(1:ndim) is a vector of NDIM dimensions, by the downhill simplex
C	method of Nelder and Mead.  The matrix p(1:ndim+1,1:ndim) is input.
C	Its NDIM+1 rows are ndim-dimensional vectors which are the vertices
C	of the starting simplex.  Also input is the vector y(1:ndim+1)
C	whose components must be pre-initialized to the values of funk
C	evaluated at the NDIM+1 vertices (rows) of p: and ftol is the
C	fractional convergence tolerance to be achieved om the function
C	value (n.b!).  On output, p and y will have been reset to NDIM+1
C	new points all within ftol of a minimum function value, and iter
C	gives the number of function evaluations taken.
C
      INTEGER i,ihi,ilo,inhi,j,m,n
      REAL rtol,sum,swap,ysave,ytry,psum(NMAX),amotry
      iter=0
1     do 12 n=1,ndim
        sum=0.
        do 11 m=1,ndim+1
          sum=sum+p(m,n)
11      continue
        psum(n)=sum
12    continue
2     ilo=1
      if (y(1).gt.y(2)) then
        ihi=1
        inhi=2
      else
        ihi=2
        inhi=1
      endif
      do 13 i=1,ndim+1
        if(y(i).le.y(ilo)) ilo=i
        if(y(i).gt.y(ihi)) then
          inhi=ihi
          ihi=i
        else if(y(i).gt.y(inhi)) then
          if(i.ne.ihi) inhi=i
        endif
13    continue
      rtol=2.*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo))+TINY)
      if (rtol.lt.ftol) then
        swap=y(1)
        y(1)=y(ilo)
        y(ilo)=swap
        do 14 n=1,ndim
          swap=p(1,n)
          p(1,n)=p(ilo,n)
          p(ilo,n)=swap
14      continue
        return
      endif
      if (iter.ge.ITMAX) pause 'ITMAX exceeded in amoeba'
      iter=iter+2
      ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,-1.0)
      if (ytry.le.y(ilo)) then
        ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,2.0)
      else if (ytry.ge.y(inhi)) then
        ysave=y(ihi)
        ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,0.5)
        if (ytry.ge.ysave) then
          do 16 i=1,ndim+1
            if(i.ne.ilo)then
              do 15 j=1,ndim
                psum(j)=0.5*(p(i,j)+p(ilo,j))
                p(i,j)=psum(j)
15            continue
              y(i)=funk(psum)
            endif
16        continue
          iter=iter+ndim
          goto 1
        endif
      else
        iter=iter-1
      endif
      goto 2
      END
      FUNCTION amotry(p,y,psum,mp,np,ndim,funk,ihi,fac)
      INTEGER ihi,mp,ndim,np,NMAX
      REAL amotry,fac,p(mp,np),psum(np),y(mp),funk
      PARAMETER (NMAX=20)
      EXTERNAL funk
CU    USES funk
      INTEGER j
      REAL fac1,fac2,ytry,ptry(NMAX)
      fac1=(1.-fac)/ndim
      fac2=fac1-fac
      do 11 j=1,ndim
        ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11    continue
      ytry=funk(ptry)
      if (ytry.lt.y(ihi)) then
        y(ihi)=ytry
        do 12 j=1,ndim
          psum(j)=psum(j)-p(ihi,j)+ptry(j)
          p(ihi,j)=ptry(j)
12      continue
      endif
      amotry=ytry
      return
      END


C     NUMERICAL METHODS: FORTRAN Programs, (c) John H. Mathews 1994
C     To accompany the text:
C     NUMERICAL METHODS for Mathematics, Science and Engineering, 2nd Ed, 1992
C     Prentice Hall, Englewood Cliffs, New Jersey, 07632, U.S.A.
C     This free software is complements of the author.
C
C     Algorithm 7.5 (Adaptive Quadrature Using Simpson's Rule).
C     Section 7.4, Adaptive Quadrature, Page 389
C

C     add missing variable F in Refine subrutine.
      SUBROUTINE AdaptQuad(F,A,B,Tol,SRmat,Integral,ErrBdd,M,State)
      INTEGER M,State
      DOUBLE PRECISION A,B,Tol,SRmat,Integral,ErrBdd
      INTEGER J,K,N,Iterating,Done
      DOUBLE PRECISION Sum1,Sum2,SRvec
      DIMENSION SRmat(1:101,1:11),SRvec(1:11)
      EXTERNAL F
      Iterating = 0
      Done = 1
      CALL Srule(F,A,B,Tol,SRvec)
      DO K=1,11
        SRmat(1, K) = SRvec(K)
      ENDDO
      M = 1
      State = Iterating
      DO WHILE (State .EQ. Iterating)
        N = M
        DO J=N,1,-1
          CALL Refine(F,J,SRmat,M,State)
        ENDDO
      ENDDO
      Sum1 = 0
      Sum2 = 0
      DO J=1,M
        Sum1 = Sum1 + SRmat(J, 8)
        Sum2 = Sum2 + Abs(SRmat(J, 9))
      ENDDO
      Integral = Sum1
      ErrBdd = Sum2
      RETURN
      END

      SUBROUTINE Refine(F, P,SRmat,M,State)
      INTEGER P,M,State
      DOUBLE PRECISION SRmat
      INTEGER J,K,Iterating,Done
      DOUBLE PRECISION A,B,C,Err,Fa,Fb,Fc,S,S2,Tol,Tol2,Err,Check
      DOUBLE PRECISION SR0vec,SR1vec,SR2vec
      DIMENSION SRmat(1:101,1:11)
      DIMENSION SR0vec(1:11),SR1vec(1:11),SR2vec(1:11)
      EXTERNAL F
      Iterating = 0
      Done = 1
      State = Done
      DO K=1,11
        SR0vec(K) = SRmat(P, K)
      ENDDO
      A = SR0vec(1)
      C = SR0vec(2)
      B = SR0vec(3)
      Fa = SR0vec(4)
      Fc = SR0vec(5)
      Fb = SR0vec(6)
      S = SR0vec(7)
      S2 = SR0vec(8)
      Err = SR0vec(9)
      Tol = SR0vec(10)
      Check = SR0vec(11)
      IF (Check .EQ. 1) RETURN
      Tol2 = Tol / 2
      CALL Srule(F, A, C, Tol2, SR1vec)
      CALL Srule(F, C, B, Tol2, SR2vec)
      Err = ABS(SR0vec(7) - SR1vec(7) - SR2vec(7)) / 10
      IF (Err .LT. Tol) THEN
        SR0vec(11) = 1
      ENDIF
      IF (Err .LT. Tol) THEN
        DO K=1,11
          SRmat(P, K) = SR0vec(K)
        ENDDO
        SRmat(P, 8) = SR1vec(7) + SR2vec(7)
        SRmat(P, 9) = Err
      ELSE
        DO J=(M + 1),P,-1
          DO K=1,11
            SRmat(J, K) = SRmat(J - 1, K)
          ENDDO
        ENDDO
        M = M + 1
        DO K=1,11
          SRmat(P, K) = SR1vec(K)
        ENDDO
        DO K=1,11
          SRmat(P + 1, K) = SR2vec(K)
        ENDDO
        State = Iterating
      ENDIF
      RETURN
      END

      SUBROUTINE Srule(F,A,B,Tol0,SRvec)
      DOUBLE PRECISION A,B,Tol0,SRvec
      DOUBLE PRECISION C,H,Fa,Fb,Fc,S,S2,Tol1,Err,Check
      DIMENSION SRvec(1:11)
      EXTERNAL F
        H = (B - A) / 2
        C = (A + B) / 2
        Fa = F(A)
        Fc = F(C)
        Fb = F(B)
        S = H * (F(A) + 4 * F(C) + F(B)) / 3
        S2 = S
        Tol1 = Tol0
        Err = Tol0
        Check = 0
        SRvec(1) = A
        SRvec(2) = C
        SRvec(3) = B
        SRvec(4) = Fa
        SRvec(5) = Fc
        SRvec(6) = Fb
        SRvec(7) = S
        SRvec(8) = S2
        SRvec(9) = Err
        SRvec(10) = Tol1
        SRvec(11) = Check
      RETURN
      END


c     program DrSCKDER
c>> 2007-01/02 DRSCKDER Krogh  Put commas around ':' in formats.
c>> 1996-06-28 DrSCKDER Krogh  Format changes for conversion to C.
c>> 1994-11-02 DrSCKDER Krogh  Changes to use M77CON
c>> 1992-04-15 DrSCKDER CLL
c>> 1992-01-13 C. L. Lawson, JPL.
c  DRSCKDER..  Demo driver for SCKDER.  Checks derivative calculation.
c     ------------------------------------------------------------------
c--S replaces "?": Dr?CKDER, ?CKDER, ?TRG11
c     ------------------------------------------------------------------
      integer I,IMAX, J, JMAX, M,N,LDFJAC,MODE, NMAX
      parameter(LDFJAC = 5, NMAX = 5)
      real             FVEC(15),FJAC(LDFJAC,NMAX)
      real             TEST(LDFJAC,NMAX), TSTMAX, X(NMAX)
      data M, N / LDFJAC, NMAX /
      data X / 0.13e0, 0.14e0, 0.15e0, 0.16e0, 0.17e0 /
c     ------------------------------------------------------------------
      print*,'Program DrSCKDER..  Demo driver for SCKDER.'
      call STRG11(N, X, FVEC ,FJAC, 2)
      MODE = 1
   10 continue
      call SCKDER(MODE, M, N, X, FVEC, FJAC, LDFJAC,
     *            TEST, IMAX, JMAX, TSTMAX)
      if(MODE .eq. 2) then
         call STRG11(N, X, FVEC ,FJAC, 1)
         go to 10
      endif
c
      call STRG11(N, X, FVEC ,FJAC, 1)
      print'(/11x,''X(J) ='',5g11.3,:,/(17x,5g11.3))',(X(J),J=1,N)
      print'(/1x,''  I    FVEC(I)   .....................'',
     *   ''FJAC(I,J)........................''/)'
      do 20 I = 1,M
         print'(1x,i3,1x,g11.3,1x,5g11.3,:,/(17x,5g11.3))',
     *         I,FVEC(I),(FJAC(I,J),J=1,N)
   20 continue
c
      print'(/1x,''TEST(,):''/)'
      do 30 I = 1,M
         print'(1x,i3,13x,5g11.3,:,/(17x,5g11.3))',I,(TEST(I,J),J=1,N)
   30 continue
      print'(/1x,''IMAX ='',i3,'',    JMAX ='',i3,'',    TSTMAX ='',
     *   g11.3)', IMAX, JMAX, TSTMAX
      stop
      end
c     ==================================================================
      subroutine STRG11(N, X, FVEC ,FJAC, IFLAG)
c     Trigonometric test case No. 11 from MINPACK test set developed by
c     J. J. More', B. S. Garbow, and K. E. Hillstrom, Argonne National
c     Laboratories, 1980.
c     ------------------------------------------------------------------
      integer I, IFLAG, J, N
      real             FJAC(N,N), FVEC(N), SUM, TEMP, X(N)
c     ------------------------------------------------------------------
      if (IFLAG .eq. 1) then
c                                        Compute function vector.
         SUM = 0.0e0
         do 10 J = 1, N
            FVEC(J) = cos(X(J))
            SUM = SUM + FVEC(J)
  10     continue
         do 20 J = 1, N
            FVEC(J) = real(N+J) - sin(X(J)) - SUM - real(J)*FVEC(J)
  20     continue
      elseif (IFLAG .eq. 2) then
c                                        Compute Jacobian matrix.
         do 40 J = 1, N
            TEMP = sin(X(J))
            do 30 I = 1, N
               FJAC(I,J) = TEMP
  30        continue
            FJAC(J,J) = real(J+1)*TEMP - cos(X(J))
  40     continue
      endif
      return
      end


module random_normal
use kinds, only: r_single,i_kind
contains
real(r_single) function rnorm() result( fn_val )

!   Generate a random normal deviate using the polar method.
!   Reference: Marsaglia,G. & Bray,T.A. 'A convenient method for generating
!              normal variables', Siam Rev., vol.6, 260-264, 1964.

implicit none

! Local variables

real(r_single)            :: u, sum
real(r_single), save      :: v, sln
logicaL, save           :: second = .false.
real(r_single), parameter :: one = 1.0_r_single, vsmall = TINY( one )

if (second) then
! If second, use the second random number generated on last call

  second = .false.
  fn_val = v*sln

else
! First call; generate a pair of random normals

  second = .true.
  do
    call random_number( u )
    call random_number( v )
    u = scale( u, 1 ) - one
    v = scale( v, 1 ) - one
    sum = u*u + v*v + vsmall         ! vsmall added to prevent LOG(zero) / zero
    IF(sum < one) exit
  end do
  sln = sqrt(- scale( log(sum), 1 ) / sum)
  fn_val = u*sln
end if

return
end function rnorm

subroutine iran(l,n,ran_int)
! generate an array of N random integers between 0 and L-1.
 real(r_single) :: rnd
 integer(i_kind) :: L,i,N
 integer(i_kind) :: ran_int(N)
 do i = 1,n
    call random_number(rnd)
    ran_int(i) = nint(float(l-1)*rnd)
 end do
end subroutine iran

subroutine set_random_seed ( iseed , myrank)
!
!*******************************************************************************
!
!! SET_RANDOM_SEED initializes the FORTRAN 90 random number generator.
!
!
!  Discussion:
!
!    If ISEED is nonzero, then that value is used to construct a seed.
!
!    If ISEED is zero, then the seed is determined by calling the date
!    and time routine.  Thus, if the code is run at different times,
!    different seed values will be set.
!
!  Parameters:
!
!    Input, integer ISEED, is nonzero for a user seed, or 0 if the
!    seed should be determined by this routine.
!
  implicit none
!
  integer(i_kind), intent(in), optional :: myrank
  integer(i_kind) date_time(8)
  logical, parameter :: debug = .false.
  integer(i_kind) i,j,k
  integer(i_kind) iseed
  integer(i_kind), allocatable :: seed(:)

!
!  Initialize the random seed routine.
!
  call random_seed
!
!  Request the size of a typical seed.
!  (On the DEC ALPHA, K is returned as 2.)
!
  call random_seed ( size = k )

  if ( debug ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_RANDOM_SEED:'
    write ( *, '(a,i6)' ) '  Random seed size is K = ', k
  end if
!
!  Set up space for a seed vector.
!
  allocate ( seed(k) )

  if ( iseed /= 0 ) then

    print *,'using input random seed',iseed

    seed(1:k) = iseed

  else

    print *,'using system clock to set random seed...'
!
!  Make up a "random" value based on date and time information.
!
    call date_and_time ( values = date_time )

    do i = 1, k

      seed(i) = 0

      do j = 1, 8
        if (present(myrank)) then
        seed(i) = seed(i) + ( j + i ) * date_time(j) + myrank * 100
        else
        seed(i) = seed(i) + ( j + i ) * date_time(j)
        endif
        seed(i) = ishftc ( seed(i), 4 * ( j - 1 ) )
      end do

    end do

  end if

  if  ( debug ) then

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_RANDOM_SEED:'
    write ( *, '(a)' ) '  The random seed vector:'
    write ( *, '(a)' ) ' '

    do i = 1, k
      write ( *, '(i12)' ) seed(i)
    end do

  end if
!
!  Send this random value back to the RANDOM_SEED routine, to be
!  used as the seed of the random number generator.
!
  call random_seed ( put = seed(1:k) )

  deallocate ( seed )

  end subroutine set_random_seed
end module random_normal


choose(0,0,1).
choose(1,0,1).
choose(1,1,1).
choose(2,0,1).
choose(2,1,2).
choose(2,2,1).
choose(3,0,1).
choose(3,1,3).
choose(3,2,3).
choose(3,3,1).
choose(3,4,0).
choose(4,0,1).
choose(4,1,4).
choose(4,2,6).
choose(4,3,4).
choose(4,4,1).
choose(5,0,1).
choose(5,1,5).
choose(5,2,10).
choose(5,3,10).
choose(5,4,5).
choose(5,5,1).
choose(6,0,1).
choose(6,1,6).
% choose(6,2,15).
% choose(6,3,20).
% choose(6,4,15).
% choose(6,5,6).
% choose(6,6,1).


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Swap poles in real block-Hessenberg pairs:
!     2x2 with 2x2
! ___________________________________________________________________
module d_swappoles22

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

implicit none
private
public d_swap22

contains
  subroutine d_swap22(i,j,A,B,compAB,apC,apT,Q,compQ,qcol,Z,compZ,zcol)
  !   DESCRIPTION
  !___________________________________________________________________________
  ! Swaps complex conjugate pole/ev at  (i:i+1,j:j+1)
  ! with complex conjugate pole/ev at (i+2:i+3,j+2:j+3)
  ! The pencil (A,B) and equivalences Q and Z are updated as requested
  ! It is assumed that both are complex conjugate pairs but this
  ! is still explicitly checked in this subroutine and if one or both
  ! are actually real, alternative swapping methods are used.
  !
  ! This procedure is based on:
  ! "Swapping 2x2 blocks in the Schur and generalized Schur form"
  ! -- D. Camps, N. Mastronardi, R. Vandebril, and P. Van Dooren
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! i       integer [IN]
  !           Index (row in A,B) of the first pole/ev
  ! j       integer [IN]
  !           Index (column in A,B) of the first pole/ev
  !           It is assumed that (i:i+3,j:j+3) is block upper triangular
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper 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) [IN]
  !           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+3 < cstp <= tstp,
  !           holds when calling d_swap. c = current, t = total
  ! Q       double array [INOUT]
  !           Unitary 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+1, qcol+2, qcol+3
  ! Z       double array [INOUT]
  !           Unitary 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+1, zcol+2, zcol+3
  !___________________________________________________________________________
  ! last edit: January 16, 2019
    real(kind=dp), intent(inout)    :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    logical, intent(in)             :: compAB, compQ, compZ
    integer, intent(in)             :: i, j, qcol, zcol
    type(tAp), pointer, intent(in)  :: apC, apT

    real(kind=dp)                   :: l1,l2,l3,l4,M(8,8),TAU(2),WORK(138),&
                                       c,s,r, RHS(8), Ac(4,4), Bc(4,4)
    integer,pointer                 :: cstrt, cstp, tstrt, tstp
    integer                         :: LDAB, LDC, LDR, LDQ, LDZ, ERR, k, &
                                       kmax, IPIV(8)
    logical                         :: isreal1, isreal2, nconv
    real(kind=dp) DLANGE
    external                        :: DGEMM, DGEQRF, DGERQF, DORMQR, DORGQR,&
                                         DORGRQ, DTGEX2, DGESVD, ZGESVD, DGETRF

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

    call d_getLeadingDim(LDAB,A)
    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDZ,Z)
    call d_getLeadingDim(LDC,Cu)
    call d_getLeadingDim(LDR,Ru)

    call d_eigenvalues2x2(A,B,i,j,l1,l2,isreal1)
    call d_eigenvalues2x2(A,B,i+2,j+2,l3,l4,isreal2)

    ! Check if all eigenvalues are complex conjugates
    if (isreal1) then
      call d_make_hess(l1,i,j,A,B,compAB,apC,apT,Q,compQ,qcol,Z,compZ,zcol)
      if (isreal2) then
        call d_make_hess(l3,i+2,j+2,A,B,compAB,apC,apT,&
                 Q,compQ,qcol+2,Z,compZ,zcol+2)
        call d_swap11(i+1,j+1,A,B,compAB,apC,apT,&
                 Q,compQ,qcol+1,Z,compZ,zcol+1)
        call d_swap11(i+2,j+2,A,B,compAB,apC,apT,&
                 Q,compQ,qcol+2,Z,compZ,zcol+2)
        call d_swap11(i,j,A,B,compAB,apC,apT,&
                 Q,compQ,qcol,Z,compZ,zcol)
        call d_swap11(i+1,j+1,A,B,compAB,apC,apT,&
                 Q,compQ,qcol+1,Z,compZ,zcol+1)
      else
        call d_swap12(i+1,j+1,A,B,compAB,apC,apT,&
                 Q,compQ,qcol+1,Z,compZ,zcol+1)
        call d_swap12(i,j,A,B,compAB,apC,apT,&
                 Q,compQ,qcol,Z,compZ,zcol)
      end if
      return
    elseif (isreal2) then
      call d_make_hess(l3,i+2,j+2,A,B,compAB,apC,apT,&
               Q,compQ,qcol+2,Z,compZ,zcol+2)
      call d_swap21(i,j,A,B,compAB,apC,apT,Q,compQ,qcol,Z,compZ,zcol)
      call d_swap21(i+1,j+1,A,B,compAB,apC,apT,Q,compQ,qcol+1,Z,compZ,zcol+1)
      return
    end if

    ! Check the gap between the eigenvalues
    if (sqrt((l1-l3)**2 + (l2-l4)**2) .lt. 2 * mp * &
          (DLANGE('F',4,4,A(i,j),LDAB,WORK) + &
           DLANGE('F',4,4,B(i,j),LDAB,WORK))) then
      return
    end if
    Ac = A(i:i+3,j:j+3)
    Bc = B(i:i+3,j:j+3)
    ! True 2x2 swap with large enough gap
    ! Create Kronecker system by copying data from (A,B)
    M = dzero
    ! I (x) A11
    M(1:2,1:2) = A(i:i+1,j:j+1)
    M(3:4,3:4) = A(i:i+1,j:j+1)
    ! I (x) B11
    M(5:6,1:2) = B(i:i+1,j:j+1)
    M(7:8,3:4) = B(i:i+1,j:j+1)
    ! A22T (x) I
    M(1,5) = A(i+2,j+2)
    M(2,6) = A(i+2,j+2)
    M(3,5) = A(i+2,j+3)
    M(4,6) = A(i+2,j+3)
    M(1,7) = A(i+3,j+2)
    M(2,8) = A(i+3,j+2)
    M(3,7) = A(i+3,j+3)
    M(4,8) = A(i+3,j+3)
    ! B22T (x) I
    M(5,5) = B(i+2,j+2)
    M(6,6) = B(i+2,j+2)
    M(7,5) = B(i+2,j+3)
    M(8,6) = B(i+2,j+3)
    M(7,7) = B(i+3,j+3)
    M(8,8) = B(i+3,j+3)

    ! Create RHS
    RHS(1:2) = -A(i:i+1,j+2)
    RHS(3:4) = -A(i:i+1,j+3)
    RHS(5:6) = -B(i:i+1,j+2)
    RHS(7:8) = -B(i:i+1,j+3)

    ! LU factorization of M with partial pivoting
    call DGETRF(8,8,M,8,IPIV,ERR)
    if (ERR .ne. 0) then
      write(*,*) ' '//achar(27)//'[93m warning '//achar(27)//&
                '[0m factorization in 2 with 2 swap failed. element: ', ERR, &
                 'value: ', M(ERR,ERR)
      ! We try with a small perturbation
      M(ERR,ERR) = 2*mp
    end if
    ! Solve system
    call DGETRS('N',8,1,M,8,IPIV,RHS,8,ERR)
    if (ERR .ne. 0) then
      write(*,*) ' '//achar(27)//'[93m warning '//achar(27)//&
      '[0m solving 2 with 2 swap failed. '
      ! We undo it ...
      A(i:i+3,j:j+3) = Ac
      B(i:i+3,j:j+3) = Bc
      return
    end if
    ! TODO iterative refinement when required

    ! Create L in Q4(3:4,:)
    Q4 = dzero
    Q4(3,1) = done
    Q4(4,2) = done
    Q4(3:4,3) = RHS(5:6)
    Q4(3:4,4) = RHS(7:8)
    ! Create Q
    call DGERQF(2,4,Q4(3,1),4,TAU,WORK,128,ERR)
    call DORGRQ(4,4,2,Q4(1,1),4,TAU,WORK,128,ERR)

    ! Row update within window
    call DGEMM('N','N',4,4,4,done,Q4(1,1),4,A(i,j),LDAB,dzero,Ru(1,1),LDR)
    A(i:i+3,j:j+3) = Ru(1:4,1:4)
    call DGEMM('N','N',4,4,4,done,Q4(1,1),4,B(i,j),LDAB,dzero,Ru(1,1),LDR)
    B(i:i+3,j:j+3) = Ru(1:4,1:4)

    ! Create R in Z4(:,1:2)
    Z4 = dzero
    Z4(1:2,1) = RHS(1:2)
    Z4(1:2,2) = RHS(3:4)
    Z4(3,1) = done
    Z4(4,2) = done
    ! Create Z
    call DGEQRF(4,2,Z4(1,1),4,TAU,WORK,128,ERR)
    call DORGQR(4,4,2,Z4(1,1),4,TAU,WORK,128,ERR)

    ! Column update within window
    call DGEMM('N','N',4,4,4,done,A(i,j),LDAB,Z4(1,1),4,dzero,Cu(1,1),LDC)
    A(i:i+3,j:j+3) = Cu(1:4,1:4)
    call DGEMM('N','N',4,4,4,done,B(i,j),LDAB,Z4(1,1),4,dzero,Cu(1,1),LDC)
    B(i:i+3,j:j+3) = Cu(1:4,1:4)

    ! Check error and update if required
    if ((DLANGE('F',2,2,A(i+2,j),LDAB,WORK) .gt. &
         mp*(DLANGE('F',4,4,A(i,j),LDAB,WORK))) .or. &
         (DLANGE('F',2,2,B(i+2,j),LDAB,WORK) .gt. &
         mp*(DLANGE('F',4,4,B(i,j),LDAB,WORK)))) then
      nconv = .true.
      k = 1
      kmax = 4
      do while (nconv .and. (k .lt. kmax))
        call updateTransformation(A,B,i,j)
        k = k + 1
        if ((DLANGE('F',2,2,A(i+2,j),LDAB,WORK) .lt. &
            mp*(DLANGE('F',4,4,A(i,j),LDAB,WORK))) .and. &
            (DLANGE('F',2,2,B(i+2,j),LDAB,WORK) .lt. &
            mp*(DLANGE('F',4,4,B(i,j),LDAB,WORK)))) then
          nconv = .false.
        end if
      end do
      if ((k .eq. kmax) .and. nconv) then
        ! Swap did not converge within reasonable number of iterations
        write(*,*) ' '//achar(27)//'[93m warning '//achar(27)//'[0m 2x2 with &
                  &2x2 swap not converged'
        ! We undo it ...
        A(i:i+3,j:j+3) = Ac
        B(i:i+3,j:j+3) = Bc
        return
      end if
    end if

    ! Make B triangular if required
    if (abs(B(i+1,j)) .gt. dzero) then
      call d_compute_ct(B(i+1,j+1),B(i+1,j),c,s,r)
      call d_apply_ct_r(A(i:i+1,j),A(i:i+1,j+1),c,s)
      call d_apply_ct_r(B(i:i+1,j),B(i:i+1,j+1),c,s)
      call d_apply_ct_r(Z4(:,1),Z4(:,2),c,s)
    end if
    if (abs(B(i+3,j+2)) .gt. dzero) then
      call d_compute_ct(B(i+3,j+3),B(i+3,j+2),c,s,r)
      call d_apply_ct_r(A(i:i+3,j+2),A(i:i+3,j+3),c,s)
      call d_apply_ct_r(B(i:i+3,j+2),B(i:i+3,j+3),c,s)
      call d_apply_ct_r(Z4(:,3),Z4(:,4),c,s)
    end if

    ! Update outside window and equivalence
    if (compAB) then
      ! Row
      if (j+3 .lt. tstp) then
        call DGEMM('N','N',4,tstp-j-3,4,done,Q4(1,1),4,A(i,j+4),LDAB,&
               dzero,Ru(1,1),LDR)
        A(i:i+3,j+4:tstp) = Ru(1:4,1:tstp-j-3)
        call DGEMM('N','N',4,tstp-j-3,4,done,Q4(1,1),4,B(i,j+4),LDAB,&
               dzero,Ru(1,1),LDR)
        B(i:i+3,j+4:tstp) = Ru(1:4,1:tstp-j-3)
      end if
      ! Column
      if (i .gt. tstrt+1) then
        call DGEMM('N','N',i-tstrt-1,4,4,done,A(tstrt+1,j),LDAB,&
              Z4(1,1),4,dzero,Cu(1,1),LDC)
        A(tstrt+1:i-1,j:j+3) = Cu(1:i-tstrt-1,1:4)
        call DGEMM('N','N',i-tstrt-1,4,4,done,B(tstrt+1,j),LDAB,&
              Z4(1,1),4,dzero,Cu(1,1),LDC)
        B(tstrt+1:i-1,j:j+3) = Cu(1:i-tstrt-1,1:4)
      end if
    else
      ! Row
      if (j+3 .lt. cstp) then
        call DGEMM('N','N',4,cstp-j-3,4,done,Q4(1,1),4,A(i,j+4),LDAB,&
              dzero,Ru(1,1),LDR)
        A(i:i+3,j+4:cstp) = Ru(1:4,1:cstp-j-3)
        call DGEMM('N','N',4,cstp-j-3,4,done,Q4(1,1),4,B(i,j+4),LDAB,&
              dzero,Ru(1,1),LDR)
        B(i:i+3,j+4:cstp) = Ru(1:4,1:cstp-j-3)
      end if
      ! Column
      if (i .gt. cstrt+1) then
        call DGEMM('N','N',i-cstrt-1,4,4,done,A(cstrt+1,j),LDAB,&
              Z4(1,1),4,dzero,Cu(1,1),LDC)
        A(cstrt+1:i-1,j:j+3) = Cu(1:i-cstrt-1,1:4)
        call DGEMM('N','N',i-cstrt-1,4,4,done,B(cstrt+1,j),LDAB,&
              Z4(1,1),4,dzero,Cu(1,1),LDC)
        B(cstrt+1:i-1,j:j+3) = Cu(1:i-cstrt-1,1:4)
      end if
    end if

    if (compQ) then
      call DGEMM('N','T',LDQ,4,4,done,Q(1,qcol),LDQ,Q4(1,1),4,dzero,Cu(1,1),LDC)
      Q(:,qcol:qcol+3) = Cu(1:LDQ,1:4)
    end if

    if (compZ) then
      call DGEMM('N','N',LDZ,4,4,done,Z(1,zcol),LDZ,Z4(1,1),4,dzero,Cu(1,1),LDC)
      Z(:,zcol:zcol+3) = Cu(1:LDZ,1:4)
    end if

    ! Set to zero
    A(i+2:i+3,j:j+1) = dzero
    B(i+2:i+3,j:j+1) = dzero
    B(i+1,j) = dzero
    B(i+3,j+2) = dzero
  end subroutine

  subroutine updateTransformation(A,B,i,j)
  !   DESCRIPTION
  !___________________________________________________________________________
  ! Update the swapping transformation to reduce magnitude of subdiagonal block
  ! in 2-by-2 with 2-by-2 swap, after invoking this function, the
  ! norm of the A_{21} and B_{21} blocks should decrease.
  ! B is not made upper triangular in this routine.
  !
  ! This procedure is based on:
  ! "Swapping 2x2 blocks in the Schur and generalized Schur form"
  ! -- D. Camps, N. Mastronardi, R. Vandebril, and P. Van Dooren
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper Hessenberg matrix B
  ! i       integer [IN]
  !           Index (row in A,B) of the first pole/ev
  ! j       integer [IN]
  !           Index (column in A,B) of the first pole/ev
  !           It is assumed that (i:i+3,j:j+3) is block upper triangular
  !
  ! NOTA
  !___________________________________________________________________________
  ! Internal subroutine, not public
  !___________________________________________________________________________
  ! last edit: January 3, 2019
   real(kind=dp), intent(inout)    :: A(:,:), B(:,:)
   integer,intent(in)              :: i,j

   integer       :: LDC, LDR, LDAB, ERR, IPIV(8)
   real(kind=dp) :: At(2,2), Bt(2,2),D(2,2),E(2,2),X(2,2),&
                    Y(2,2),Qup(4,4),Zup(4,4), SVAL(2), CS(2), SN(2), WORK(134),&
                    Z(8,8), RHS(8)
   external DGEMM, DLASV2, DGESVD, DGESV

   call d_getLeadingDim(LDAB,A)
   call d_getLeadingDim(LDC,Cu)
   call d_getLeadingDim(LDR,Ru)

   ! Create Kronecker product system
   Z = dzero
   Z(1:2,1:2) = A(i+2:i+3,j+2:j+3)
   Z(3:4,3:4) = A(i+2:i+3,j+2:j+3)
   Z(5:6,1:2) = B(i+2:i+3,j+2:j+3)
   Z(7:8,3:4) = B(i+2:i+3,j+2:j+3)
   Z(1,5) = -A(i,j)
   Z(2,6) = -A(i,j)
   Z(1,7) = -A(i+1,j)
   Z(2,8) = -A(i+1,j)
   Z(3,5) = -A(i,j+1)
   Z(4,6) = -A(i,j+1)
   Z(3,7) = -A(i+1,j+1)
   Z(4,8) = -A(i+1,j+1)

   Z(5,5) = -B(i,j)
   Z(6,6) = -B(i,j)
   Z(5,7) = -B(i+1,j)
   Z(6,8) = -B(i+1,j)
   Z(7,5) = -B(i,j+1)
   Z(8,6) = -B(i,j+1)
   Z(7,7) = -B(i+1,j+1)
   Z(8,8) = -B(i+1,j+1)

   RHS(1:2) = A(i+2:i+3,j)
   RHS(3:4) = A(i+2:i+3,j+1)
   RHS(5:6) = B(i+2:i+3,j)
   RHS(7:8) = B(i+2:i+3,j+1)

   ! Solve it
   call DGESV(8,1,Z,8,IPIV,RHS,8,ERR)
   X = reshape(RHS(1:4),(/2,2/))
   Y = reshape(RHS(5:8),(/2,2/))

   ! TWO SIDED FACTORIZED APPROACH
   ! --------------------------------------------------------------------------
   ! X
   call DGESVD('A','A',2,2,X(1,1),2,SVAL(1),D(1,1),2,E(1,1),2,WORK,134,ERR)
   call cosine_sv(SVAL,CS,SN)

   ! Zup
   ! 11 block
   At = transpose(E)
   At(:,1) = At(:,1) * CS(1)
   At(:,2) = At(:,2) * CS(2)
   Bt = matmul(At,E)
   Zup(1:2,1:2) = Bt
   ! 12 block
   At = transpose(E)
   At(:,1) = At(:,1) * SN(1)
   At(:,2) = At(:,2) * SN(2)
   Bt = matmul(At,transpose(D))
   Zup(1:2,3:4) = Bt
   ! 21 block
   At = -D
   At(:,1) = At(:,1) * SN(1)
   At(:,2) = At(:,2) * SN(2)
   Bt = matmul(At,E)
   Zup(3:4,1:2) = Bt
   ! 22 block
   At = D
   At(:,1) = At(:,1) * CS(1)
   At(:,2) = At(:,2) * CS(2)
   Bt = matmul(At,transpose(D))
   Zup(3:4,3:4) = Bt

   ! Y
   call DGESVD('A','A',2,2,Y(1,1),2,SVAL(1),D(1,1),2,E(1,1),2,WORK,134,ERR)
   call cosine_sv(SVAL,CS,SN)

   ! Qup^T
   ! 11 block
   At = transpose(E)
   At(:,1) = At(:,1) * CS(1)
   At(:,2) = At(:,2) * CS(2)
   Bt = matmul(At,E)
   Qup(1:2,1:2) = Bt
   ! 12 block
   At = transpose(E)
   At(:,1) = At(:,1) * SN(1)
   At(:,2) = At(:,2) * SN(2)
   Bt = matmul(At,transpose(D))
   Qup(1:2,3:4) = Bt
   ! 21 block
   At = -D
   At(:,1) = At(:,1) * SN(1)
   At(:,2) = At(:,2) * SN(2)
   Bt = matmul(At,E)
   Qup(3:4,1:2) = Bt
   ! 22 block
   At = D
   At(:,1) = At(:,1) * CS(1)
   At(:,2) = At(:,2) * CS(2)
   Bt = matmul(At,transpose(D))
   Qup(3:4,3:4) = Bt

   ! Update within window
   ! Row update within window
   call DGEMM('T','N',4,4,4,done,Qup(1,1),4,A(i,j),LDAB,dzero,Ru(1,1),LDR)
   A(i:i+3,j:j+3) = Ru(1:4,1:4)
   call DGEMM('T','N',4,4,4,done,Qup(1,1),4,B(i,j),LDAB,dzero,Ru(1,1),LDR)
   B(i:i+3,j:j+3) = Ru(1:4,1:4)
   ! Column update within window
   call DGEMM('N','N',4,4,4,done,A(i,j),LDAB,Zup(1,1),4,dzero,Cu(1,1),LDC)
   A(i:i+3,j:j+3) = Cu(1:4,1:4)
   call DGEMM('N','N',4,4,4,done,B(i,j),LDAB,Zup(1,1),4,dzero,Cu(1,1),LDC)
   B(i:i+3,j:j+3) = Cu(1:4,1:4)

   ! Update Q4,Z4
   call DGEMM('T','N',4,4,4,done,Qup(1,1),4,Q4(1,1),4,dzero,Cu(1,1),LDC)
   Q4(:,:) = Cu(1:4,1:4)
   call DGEMM('N','N',4,4,4,done,Z4(1,1),4,Zup(1,1),4,dzero,Cu(1,1),LDC)
   Z4(:,:) = Cu(1:4,1:4)
  end subroutine

  subroutine cosine_sv(sv,cs,sn)
  !   DESCRIPTION
  !___________________________________________________________________________
  ! Computes the cosine and sine of the singular values up to highest precision
  !
  ! This procedure is based on:
  ! "Swapping 2x2 blocks in the Schur and generalized Schur form"
  ! -- D. Camps, N. Mastronardi, R. Vandebril, and P. Van Dooren
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! sv       double array [IN]
  !           length 2 array with singular values
  ! cs       double array [OUT]
  !           length 2 array with cosine of singular values
  ! sn       double array [OUT]
  !           length 2 array with sine of singular values
  !
  ! NOTA
  !___________________________________________________________________________
  ! Internal subroutine, not public
  !___________________________________________________________________________
  ! last edit: January 3, 2019
    real(kind=dp), intent(in)   :: sv(2)
    real(kind=dp), intent(out)  :: cs(2), sn(2)

    integer k
    do k = 1,2
     if (sv(k) .gt. 1) then
       cs(k) = done/sqrt(done+sv(k)**2)
       sn(k) = cs(k) * sv(k)
     else
       sn(k) = done/sqrt(done+done/sv(k)**2)
       cs(k) = sn(k) / sv(k)
     end if
    end do
  end subroutine
end module


!*==zgees.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGEES + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
!                         LDVS, WORK, LWORK, RWORK, BWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVS, SORT
!       INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
!       ..
!       .. Array Arguments ..
!       LOGICAL            BWORK( * )
!       DOUBLE PRECISION   RWORK( * )
!       COMPLEX*16         A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
!       ..
!       .. Function Arguments ..
!       LOGICAL            SELECT
!       EXTERNAL           SELECT
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
!> eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!> vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).
!>
!> Optionally, it also orders the eigenvalues on the diagonal of the
!> Schur form so that selected eigenvalues are at the top left.
!> The leading columns of Z then form an orthonormal basis for the
!> invariant subspace corresponding to the selected eigenvalues.
!>
!> A complex matrix is in Schur form if it is upper triangular.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVS
!> \verbatim
!>          JOBVS is CHARACTER*1
!>          = 'N': Schur vectors are not computed;
!>          = 'V': Schur vectors are computed.
!> \endverbatim
!>
!> \param[in] SORT
!> \verbatim
!>          SORT is CHARACTER*1
!>          Specifies whether or not to order the eigenvalues on the
!>          diagonal of the Schur form.
!>          = 'N': Eigenvalues are not ordered:
!>          = 'S': Eigenvalues are ordered (see SELECT).
!> \endverbatim
!>
!> \param[in] SELECT
!> \verbatim
!>          SELECT is a LOGICAL FUNCTION of one COMPLEX*16 argument
!>          SELECT must be declared EXTERNAL in the calling subroutine.
!>          If SORT = 'S', SELECT is used to select eigenvalues to order
!>          to the top left of the Schur form.
!>          IF SORT = 'N', SELECT is not referenced.
!>          The eigenvalue W(j) is selected if SELECT(W(j)) is true.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the N-by-N matrix A.
!>          On exit, A has been overwritten by its Schur form T.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] SDIM
!> \verbatim
!>          SDIM is INTEGER
!>          If SORT = 'N', SDIM = 0.
!>          If SORT = 'S', SDIM = number of eigenvalues for which
!>                         SELECT is true.
!> \endverbatim
!>
!> \param[out] W
!> \verbatim
!>          W is COMPLEX*16 array, dimension (N)
!>          W contains the computed eigenvalues, in the same order that
!>          they appear on the diagonal of the output Schur form T.
!> \endverbatim
!>
!> \param[out] VS
!> \verbatim
!>          VS is COMPLEX*16 array, dimension (LDVS,N)
!>          If JOBVS = 'V', VS contains the unitary matrix Z of Schur
!>          vectors.
!>          If JOBVS = 'N', VS is not referenced.
!> \endverbatim
!>
!> \param[in] LDVS
!> \verbatim
!>          LDVS is INTEGER
!>          The leading dimension of the array VS.  LDVS >= 1; if
!>          JOBVS = 'V', LDVS >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,2*N).
!>          For good performance, LWORK must generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[out] BWORK
!> \verbatim
!>          BWORK is LOGICAL array, dimension (N)
!>          Not referenced if SORT = 'N'.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value.
!>          > 0: if INFO = i, and i is
!>               <= N:  the QR algorithm failed to compute all the
!>                      eigenvalues; elements 1:ILO-1 and i+1:N of W
!>                      contain those eigenvalues which have converged;
!>                      if JOBVS = 'V', VS contains the matrix which
!>                      reduces A to its partially converged Schur form.
!>               = N+1: the eigenvalues could not be reordered because
!>                      some eigenvalues were too close to separate (the
!>                      problem is very ill-conditioned);
!>               = N+2: after reordering, roundoff changed values of
!>                      some complex eigenvalues so that leading
!>                      eigenvalues in the Schur form no longer satisfy
!>                      SELECT = .TRUE..  This could also be caused by
!>                      underflow due to scaling.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16GEeigen
!
!  =====================================================================
      SUBROUTINE ZGEES(Jobvs,Sort,SELECT,N,A,Lda,Sdim,W,Vs,Ldvs,Work,   &
     &                 Lwork,Rwork,Bwork,Info)
      IMPLICIT NONE
!*--ZGEES201
!
!  -- LAPACK driver 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 ..
      CHARACTER Jobvs , Sort
      INTEGER Info , Lda , Ldvs , Lwork , N , Sdim
!     ..
!     .. Array Arguments ..
      LOGICAL Bwork(*)
      DOUBLE PRECISION Rwork(*)
      COMPLEX*16 A(Lda,*) , Vs(Ldvs,*) , W(*) , Work(*)
!     ..
!     .. Function Arguments ..
      LOGICAL SELECT
      EXTERNAL SELECT
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , scalea , wantst , wantvs
      INTEGER hswork , i , ibal , icond , ierr , ieval , ihi , ilo ,    &
     &        itau , iwrk , maxwrk , minwrk
      DOUBLE PRECISION anrm , bignum , cscale , eps , s , sep , smlnum
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DLABAD , XERBLA , ZCOPY , ZGEBAK , ZGEBAL , ZGEHRD ,     &
     &         ZHSEQR , ZLACPY , ZLASCL , ZTRSEN , ZUNGHR
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH , ZLANGE
      EXTERNAL LSAME , ILAENV , DLAMCH , ZLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      lquery = (Lwork==-1)
      wantvs = LSAME(Jobvs,'V')
      wantst = LSAME(Sort,'S')
      IF ( (.NOT.wantvs) .AND. (.NOT.LSAME(Jobvs,'N')) ) THEN
         Info = -1
      ELSEIF ( (.NOT.wantst) .AND. (.NOT.LSAME(Sort,'N')) ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -4
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -6
      ELSEIF ( Ldvs<1 .OR. (wantvs .AND. Ldvs<N) ) THEN
         Info = -10
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       CWorkspace refers to complex workspace, and RWorkspace to real
!       workspace. NB refers to the optimal block size for the
!       immediately following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by ZHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.)
!
      IF ( Info==0 ) THEN
         IF ( N==0 ) THEN
            minwrk = 1
            maxwrk = 1
         ELSE
            maxwrk = N + N*ILAENV(1,'ZGEHRD',' ',N,1,N,0)
            minwrk = 2*N
!
            CALL ZHSEQR('S',Jobvs,N,1,N,A,Lda,W,Vs,Ldvs,Work,-1,ieval)
            hswork = Work(1)
!
            IF ( .NOT.wantvs ) THEN
               maxwrk = MAX(maxwrk,hswork)
            ELSE
               maxwrk = MAX(maxwrk,N+(N-1)                              &
     &                  *ILAENV(1,'ZUNGHR',' ',N,1,N,-1))
               maxwrk = MAX(maxwrk,hswork)
            ENDIF
         ENDIF
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -12
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGEES ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Sdim = 0
         RETURN
      ENDIF
!
!     Get machine constants
!
      eps = DLAMCH('P')
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = ZLANGE('M',N,N,A,Lda,dum)
      scalea = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         scalea = .TRUE.
         cscale = smlnum
      ELSEIF ( anrm>bignum ) THEN
         scalea = .TRUE.
         cscale = bignum
      ENDIF
      IF ( scalea ) CALL ZLASCL('G',0,0,anrm,cscale,N,N,A,Lda,ierr)
!
!     Permute the matrix to make it more nearly triangular
!     (CWorkspace: none)
!     (RWorkspace: need N)
!
      ibal = 1
      CALL ZGEBAL('P',N,A,Lda,ilo,ihi,Rwork(ibal),ierr)
!
!     Reduce to upper Hessenberg form
!     (CWorkspace: need 2*N, prefer N+N*NB)
!     (RWorkspace: none)
!
      itau = 1
      iwrk = N + itau
      CALL ZGEHRD(N,ilo,ihi,A,Lda,Work(itau),Work(iwrk),Lwork-iwrk+1,   &
     &            ierr)
!
      IF ( wantvs ) THEN
!
!        Copy Householder vectors to VS
!
         CALL ZLACPY('L',N,N,A,Lda,Vs,Ldvs)
!
!        Generate unitary matrix in VS
!        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
!        (RWorkspace: none)
!
         CALL ZUNGHR(N,ilo,ihi,Vs,Ldvs,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
      ENDIF
!
      Sdim = 0
!
!     Perform QR iteration, accumulating Schur vectors in VS if desired
!     (CWorkspace: need 1, prefer HSWORK (see comments) )
!     (RWorkspace: none)
!
      iwrk = itau
      CALL ZHSEQR('S',Jobvs,N,ilo,ihi,A,Lda,W,Vs,Ldvs,Work(iwrk),       &
     &            Lwork-iwrk+1,ieval)
      IF ( ieval>0 ) Info = ieval
!
!     Sort eigenvalues if desired
!
      IF ( wantst .AND. Info==0 ) THEN
         IF ( scalea ) CALL ZLASCL('G',0,0,cscale,anrm,N,1,W,N,ierr)
         DO i = 1 , N
            Bwork(i) = SELECT(W(i))
         ENDDO
!
!        Reorder eigenvalues and transform Schur vectors
!        (CWorkspace: none)
!        (RWorkspace: none)
!
         CALL ZTRSEN('N',Jobvs,Bwork,N,A,Lda,Vs,Ldvs,W,Sdim,s,sep,      &
     &               Work(iwrk),Lwork-iwrk+1,icond)
      ENDIF
!
!
!        Undo balancing
!        (CWorkspace: none)
!        (RWorkspace: need N)
!
      IF ( wantvs ) CALL ZGEBAK('P','R',N,ilo,ihi,Rwork(ibal),N,Vs,Ldvs,&
     &                          ierr)
!
      IF ( scalea ) THEN
!
!        Undo scaling for the Schur form of A
!
         CALL ZLASCL('U',0,0,cscale,anrm,N,N,A,Lda,ierr)
         CALL ZCOPY(N,A,Lda+1,W,1)
      ENDIF
!
      Work(1) = maxwrk
!
!     End of ZGEES
!
      END SUBROUTINE ZGEES


module fft_m

use, intrinsic :: iso_c_binding

implicit none
include "fftw3.f03"

integer     :: nfft
type(C_PTR) :: plan_fw
type(C_PTR) :: plan_bw

interface fft
    module procedure fft_1d
    module procedure fft_2d
end interface fft

interface ifft
    module procedure ifft_1d
    module procedure ifft_2d
end interface ifft

contains

subroutine init_fft( n, source, destination )

    integer,    intent(in)     :: n
    complex(8), intent(inout)  :: source(:)
    complex(8), intent(inout)  :: destination(:)

    nfft = n

    plan_fw = fftw_plan_dft_1d(n, source, destination, FFTW_FORWARD, FFTW_ESTIMATE)
    plan_bw = fftw_plan_dft_1d(n, destination, source, FFTW_BACKWARD,FFTW_ESTIMATE)

end subroutine init_fft

subroutine fft_2d( source, destination)

    complex(8), intent(inout)  :: source(:,:)
    complex(8), intent(out)    :: destination(:,:)

    call fftw_execute_dft(plan_fw, source(:,1), destination(:,1))
    call fftw_execute_dft(plan_fw, source(:,2), destination(:,2))

    destination = destination / nfft

end subroutine fft_2d

subroutine ifft_2d( source, destination)

    complex(8), intent(inout) :: source(:,:)
    complex(8), intent(out)   :: destination(:,:)

    call fftw_execute_dft(plan_bw, source(:,1), destination(:,1))
    call fftw_execute_dft(plan_bw, source(:,2), destination(:,2))

end subroutine ifft_2d

subroutine fft_1d( source, destination)

    complex(8), intent(inout)  :: source(:)
    complex(8), intent(out)    :: destination(:)

    call fftw_execute_dft(plan_fw, source, destination)

    destination = destination / nfft

end subroutine fft_1d

subroutine ifft_1d( source, destination)

    complex(8), intent(inout) :: source(:)
    complex(8), intent(out)   :: destination(:)

    call fftw_execute_dft(plan_bw, source, destination)

end subroutine ifft_1d

end module fft_m


! calmat.f for wcalprem.f
!----------------------------------------------------------
subroutine calmatc(nlayer,vnp,vra,con,rpow,w1dn,w2dn,ra,m,work)
!----------------------------------------------------------
! Computing \int r^rpow con W_p^(w1dn) W_q^(w2dn) dr.
!----------------------------------------------------------
    implicit none
    integer:: maxrpow
    parameter ( maxrpow = 2 )
    integer,intent(in):: nlayer,vnp,rpow,w1dn,w2dn
    double precision:: vra(vnp),con(vnp),ra(*),m(*),work(*)
    integer:: i,j,k,l,nn,snp
    double precision:: a(2,2),b(2,2),c(5),rh
    ! parameter check
    if (maxrpow<rpow) stop 'Invalid arguments.(calmatc)'
    ! computing of the matrix elements
    snp = 1
    do i=1,nlayer
        rh = ra(i+1) - ra(i)
        if ( w1dn == 0 ) then
            a(2,1) = -1.d0 / rh
            a(1,1) = ra(i+1) / rh
            a(2,2) = 1.d0 / rh
            a(1,2) = -ra(i) / rh
        elseif ( w1dn == 1 ) then
                a(2,1) = 0.d0
                a(1,1) = -1.d0 / rh
                a(2,2) = 0.d0
                a(1,2) = 1.d0 / rh
        else
            stop 'Invalid arguments.(calmatc)'
        endif

        if ( w2dn == 0 ) then
            b(2,1) = -1.d0 / rh
            b(1,1) = ra(i+1) / rh
            b(2,2) = 1.d0 / rh
            b(1,2) = -ra(i) / rh
        elseif ( w2dn == 1 ) then
                b(2,1) = 0.d0
                b(1,1) = -1.d0 / rh
                b(2,2) = 0.d0
                b(1,2) = 1.d0 / rh
        else
            stop 'Invalid arguments.(calmatc)'
        endif

        do j=1,2
            do k=1,2
                c(1:5) = 0.d0

                call pmulti( 2,a(1,j),2,b(1,k),3,c )
                do l=3,1,-1
                    c(l+rpow) = c(l)
                    if ( rpow>0 ) c(l)=0.d0
                enddo
                nn = 4 * (i-1) + 2 * (j-1) + k
                call pinteg(snp,5,c,ra(i),ra(i+1),vnp,vra,con,work(nn))
            enddo
        enddo
    enddo
    if ( w1dn /= w2dn ) then
        m(1:nlayer*4-3:4)=2*work(1:nlayer*4-3:4)
        m(2:nlayer*4-2:4)=work(2:nlayer*4-2:4)+work(3:nlayer*4-1:4)
        m(3:nlayer*4-1:4)=work(2:nlayer*4-2:4)+work(3:nlayer*4-1:4)
        m(4:nlayer*4:4)=2*work(4:nlayer*4:4)
    else
        m(1:4*nlayer) = work(1:4*nlayer)
    endif
    return
end

!----------------------------------------------------------
subroutine caltl( nlayer,vnp,vra,rho,ra,tl)
!----------------------------------------------------------
! Computing of lumped mass matrix.
!----------------------------------------------------------
    implicit none
    integer:: nlayer,vnp
    double precision:: vra(vnp),rho(vnp),ra(*),tl(*)
    integer:: i,nn,snp
    double precision:: c(3),from,to

    snp = 1
    do i=1,nlayer
        c(1:2) = 0.d0
        c(3) = 1.d0

        from = ra(i)
        to = ( ra(i) + ra(i+1) ) / 2.d0
        nn = 4 * (i-1)
        call pinteg( snp,3,c,from,to,vnp,vra,rho,tl(nn+1) )

        tl(nn+2:nn+3) = 0.d0

        from = to
        to = ra(i+1)
        call pinteg( snp,3,c,from,to,vnp,vra,rho,tl(nn+4) )

    enddo
    return
end

!----------------------------------------------------------
subroutine calhl( nlayer,vnp,vra,mu,ra,hl)
!----------------------------------------------------------
! Computing of lumped rigidity matrix.
!----------------------------------------------------------
    implicit none
    integer:: nlayer,vnp
    double precision:: vra(vnp),mu(vnp),ra(*),hl(*)
    integer:: i,nn,snp
    double precision:: c(1),from,to

    snp = 1
    do  i=1,nlayer
        c(1) = 1.d0

        from = ra(i)
        to = ( ra(i) + ra(i+1) ) / 2.d0
        nn = 4 * (i-1)
        call pinteg( snp,1,c,from,to,vnp,vra,mu,hl(nn+1) )

        hl(nn+2:nn+3) = 0.d0

        from = to
        to = ra(i+1)
        call pinteg( snp,1,c,from,to,vnp,vra,mu,hl(nn+4) )

    enddo
    return
end

!----------------------------------------------------------
subroutine pmulti(n,a,m,b,l,c)
!----------------------------------------------------------
! Computing the (l-1) degrees polynomial c(n) which is the product of
! (n-1) degrees polynomial a(n) and (m-1) degrees polynomial b(n).
!----------------------------------------------------------
    integer:: n,m,l,i,j
    double precision:: a(n),b(m),c(l)

    if (n+m-1/=l) stop 'Invalid arguments.(pmulti)'

    c(1:l)=0.d0

    do i=1,n
        do j=1,m
            c(i+j-1) = c(i+j-1) + a(i)*b(j)
        enddo
    enddo

    return
end

!----------------------------------------------------------
subroutine pinteg(snp,n,p,from,to,vnp,vra,con,pint)
!----------------------------------------------------------
! Evaluating the integrated value pint from 'from' to 'to' of p(n)*con
! which is the product of (n-1) degrees polynomial 'p(n)' and 'con'.
!----------------------------------------------------------
    implicit none
    integer:: maxn
    parameter ( maxn = 5 )

    integer:: snp,n,vnp
    double precision:: from,to,p(n),vra(vnp),con(vnp),pint
    double precision:: x1,x2,q(2),pq(maxn+1),psint

    if ( maxn<n )stop 'Degrees of a polynomial is too large.(pinteg)'
    if ( snp>=vnp ) snp = 1

    pint = 0.d0
    x1 = from
    do
        if (  vra(snp)<=x1 .and. vra(snp+1)>x1  ) then
            x2 = dmin1( to, vra(snp+1) )
        else
            snp = snp + 1
            if ( snp==vnp ) snp = 1
            cycle
        endif
        ! evaluating the integrated value
        q(2) = ( con(snp+1)-con(snp) ) / ( vra(snp+1)-vra(snp) )
        q(1) = - q(2) * vra(snp) + con(snp)
        call pmulti( n,p,2,q,n+1,pq )
        call polint( n+1,pq,x1,x2,psint )
        pint = pint + psint

        if ( x2==to ) exit
        x1 = x2
    enddo
    return
end

!----------------------------------------------------------
subroutine polint( n,p,x1,x2,pint )
!----------------------------------------------------------
!c Evaluating the integrated value 'pint' from 'x1' to 'x2'
!c of (n-1) degrees polynomial 'p(n)'.
!----------------------------------------------------------
    implicit none
    integer,parameter:: maxn=6
    integer:: n
    double precision:: p(*),x1,x2,pint
    integer:: i,j
    double precision:: a(maxn),b(maxn),dx,xx

    if (maxn<n) stop 'Degrees of a polynomial is too large.(polint)'

    a(1) = 1.d0
    b(1) = 1.d0
    if ( n>=2 ) then
        do i=2,n
            a(i) = a(i-1) * x1
            b(i) = b(i-1) * x2
        enddo
    endif
    dx = x2 - x1

    pint = 0.d0
    do i=1,n
        xx = 0.d0
        do j=1,i
            xx = xx + a(j) * b(i-j+1) / dble(i)
        enddo
        pint = pint + p(i) * dx * xx
    enddo
    return
end

!----------------------------------------------------------
subroutine overlap( nlayer,a,a2 )
!----------------------------------------------------------
! Overlapping the coefficient matrix elements in the solid part.
!----------------------------------------------------------
    use parameters
    implicit none
    integer,intent(in):: nlayer
    complex(dp):: a(*),a2(2,*)
    integer:: i,j,k,mu,m,i1,i2,k1,k2,nsize

    nsize = nlayer+1
    mu = 1
    m = mu + 1
    do j=1,nsize
        i1 = max0(1,j-mu)
        i2 = j
        do i=i1,i2
            k = i - j + m
            if ( i==j ) then
                if ( i==1 ) then
                    a2(k,j) = a2(k,j) + a(1)
                else
                    if ( i==nsize ) then
                        a2(k,j) = a2(k,j) + a( 4*nlayer )
                    else
                        k1 = 4 * i - 4
                        k2 = k1 + 1
                        a2(k,j) = a2(k,j) + a(k1) + a(k2)
                    endif
                endif
            endif
            if (i+1==j) then
                k1 = 4 * i - 2
                a2(k,j) = a2(k,j) + a(k1)
            endif
        enddo
    enddo
    return
end

!----------------------------------------------------------
subroutine calg2( l,m,spo,r0,mt,mu0,coef,ga,a,ga2,dr,g2 )
!----------------------------------------------------------
    use parameters
    implicit none

    integer:: l,m
    double precision:: spo,r0,mt(3,3),mu0
    complex(dp) coef,ga(*),a(*),ga2(2,*),g2(*)
    integer:: i,itmp
    double precision:: b1,sgn,eps,ier
    complex(dp) dd,cg2(3),dr(3),z(3)

    data eps/ -1.d0 /

    ! computing of particular solution with free surface boundary conditions
    cg2=0
    dd = 0
    if ( m>=0 ) then
        sgn = 1.d0
    else
        sgn = - 1.d0
    endif
    if ( iabs(m)==1 ) then
        b1 = dsqrt( dble( 2*l+1 ) / ( 16.d0 * pi ) )
        !c
        dd = dcmplx( b1 ) * ( dcmplx( sgn * mt(1,3), mt(1,2) ) )/ ( dcmplx( r0 * r0 * mu0 ) * coef )
        itmp = 4
        cg2=0
        do  i=2,3
            cg2(i) = - dd * ( ga(itmp+1) + ga(itmp+2) )
            itmp = itmp + 2
        enddo
    else
        if ( iabs(m)==2 ) then
            b1 = dsqrt( dble(2*l+1)*dble(l-1)*dble(l+2)/(64.d0*pi) )
            cg2(2) = dcmplx( b1 / r0 ) * dcmplx( 2.d0*mt(2,3), sgn*( mt(2,2)-mt(3,3) ) )
        endif
    endif
    if ( m==-2 .or. m==-l ) then
        call dclisb0( ga2,3,1,2,cg2,eps,dr,z,ier)
    else
        call dcsbsub0( ga2,3,1,2,cg2,eps,dr,z,ier)
    endif
    cg2(3) = cg2(3) + dd
    ! computation of the excitation vector
    itmp = dint(spo)
    g2(itmp+1) = a(1) * cg2(1) + a(2) * cg2(3)
    g2(itmp+2) = a(3) * cg2(1) + a(4) * cg2(3)

    return
end


module boundary
    use parameters
    implicit none

    contains

        subroutine apply_boundary(u,v,lev,it)
        ! update the boundary conditions for the flow. Currently only defined
        ! for steady winds from left to right (lev == 1)

            ! u (inout): downstream wind direction
            ! v (inout): crossstream wind direction
            ! lev (in):  the type of boundary condition
            !            (1) constant flow from left to right
            ! it (in):   current time level
            ! yvel:      temp storage for y velocity
            ! iy:        iteration variable
            real, dimension(:,:), intent(inout) :: u,v
            integer, intent(in) :: lev
            integer, intent(in) :: it
            real :: yvel
            integer :: iy

            if (lev == 1) then ! steady winds
                yvel = 0.125*sin(pi*it*dt/tf*10)
                do iy=1,nny
                    u(1,iy) = uvel
                    v(1,iy) = yvel
                end do

                u(nnx,:) = u(nnx-1,:) ! periodic on top and bottom
                v(nny,:) = v(nnx-1,:)
            end if
        end subroutine

end module


subroutine search_inf_re(xyz_solid, xyz_fluid, nn_fluid,nn_solid, nsd, ne_solid, nen_solid, ien_solid,&
			 flag_fnode,node_local,nn_local)
! Seach all the fluid nodes overlapping with solid domain and give flag_node =1
use mpi_variables
implicit none
include 'mpif.h'
integer nn_fluid
integer nn_solid
integer nsd
integer ne_solid
integer nen_solid
integer ien_solid(ne_solid,nen_solid)
integer flag_fnode(nn_fluid)
real(8) xyz_solid(nsd,nn_solid)
real(8) xyz_fluid(nsd,nn_fluid)
integer node_local(nn_local)
integer nn_local
integer i
integer finf
real(8) x(nsd)
integer flag_fnode_s(nn_fluid)
integer inn
integer maxconn
integer ien_solid_tmp(nen_solid,ne_solid)

maxconn=30
flag_fnode(:)=0
flag_fnode_s(:)=0

do i=1,ne_solid
	ien_solid_tmp(:,i)=ien_solid(i,:)
end do

do i=1,nn_local
	inn=node_local(i)
	x=xyz_fluid(1:nsd,inn)
	finf=0
	call getinf_el_3d(finf,x,xyz_solid,nn_solid,nsd,ne_solid,nen_solid,ien_solid_tmp,maxconn)
	if (finf .ne. 0) then
		flag_fnode_s(inn)=1
	end if
end do

call mpi_barrier(mpi_comm_world,ierror)
call mpi_allreduce(flag_fnode_s(1),flag_fnode(1),nn_fluid,mpi_integer,mpi_sum,mpi_comm_world,ierror)

      return
end