module maths
use vars
! use Fast_Fourier
use singleton
!use nrutil, ONLY : assert_eq, imaxloc, outerprod, swap
implicit none
contains

!----------------------------------------------------------------
! This function calculates the 3-j symbol
! J_i and M_i have to be twice the actual value of J and M
!----------------------------------------------------------------
   function w3js(j1,j2,j3,m1,m2,m3)
   integer :: m1, m2, m3, j1, j2, j3
	integer :: ia, ib, ic, id, ie, im, ig, ih, z, zmin, zmax, jsum
	real(kind=8) :: w3js, cc, denom, cc1, cc2

!		w3js = w3js_regge(j1/2,j2/2,j3/2,m1/2,m2/2,m3/2)
!		return
      w3js = 0.d0
      if (m1+m2+m3 /= 0) return
      ia = j1 + j2
      if (j3 > ia) return
      ib = j1 - j2
      if (j3 < abs(ib)) return
		if (abs(m1) > j1) return
		if (abs(m2) > j2) return
		if (abs(m3) > j3) return

      jsum = j3 + ia
      ic = j1 - m1
      id = j2 - m2

		ie = j3 - j2 + m1
		im = j3 - j1 - m2
		zmin = max0(0,-ie,-im)
		ig = ia - j3
		ih = j2 + m2
		zmax = min0(ig,ih,ic)
		cc = 0.d0

		do z = zmin, zmax, 2
			denom = fact(z/2)*fact((ig-z)/2)*fact((ic-z)/2)*fact((ih-z)/2)*&
				fact((ie+z)/2)*fact((im+z)/2)
      	if (mod(z,4) /= 0) denom = -denom
			cc = cc + 1.d0/denom
		enddo

		cc1 = fact(ig/2)*fact((j3+ib)/2)*fact((j3-ib)/2)/fact((jsum+2)/2)
      cc2 = fact((j1+m1)/2)*fact(ic/2)*fact(ih/2)*fact(id/2)*fact((j3-m3)/2)*fact((j3+m3)/2)
      cc = cc * sqrt(1.d0*cc1*cc2)
		if (mod(ib-m3,4) /= 0) cc = -cc
		w3js = cc
		if (abs(w3js) < 1.d-8) w3js = 0.d0
1000 		return
   end function w3js

!----------------------------------------------------------------
! This function calculates the 6-j symbol
! J_i and M_i have to be twice the actual value of J and M
!----------------------------------------------------------------
	function w6js(j1,j2,j3,l1,l2,l3)
	integer :: j1,j2,j3,l1,l2,l3
	integer :: ia, ib, ic, id, ie, iif, ig, ih, sum1, sum2, sum3, sum4
	integer :: w, wmin, wmax, ii, ij, ik
   real(kind=8) :: w6js, omega, theta1, theta2, theta3, theta4, theta, denom

      w6js = 0.d0
		ia = j1 + j2
		if (ia < j3) return
		ib = j1 - j2
		if (abs(ib) > j3) return
		ic = j1 + l2
		if (ic < l3) return
		id = j1 - l2
		if (abs(id) > l3) return
		ie = l1 + j2
		if (ie < l3) return
		iif = l1 - j2
		if (abs(iif) > l3) return
		ig = l1 + l2
		if (ig < j3) return
		ih = l1 - l2
		if (abs(ih) > j3) return
      sum1=ia + j3
      sum2=ic + l3
      sum3=ie + l3
      sum4=ig + j3
		wmin = max0(sum1, sum2, sum3, sum4)
		ii = ia + ig
		ij = j2 + j3 + l2 + l3
		ik = j3 + j1 + l3 + l1
		wmax = min0(ii,ij,ik)
		omega = 0.d0
		do w = wmin, wmax, 2
	      denom = fact((w-sum1)/2)*fact((w-sum2)/2)*fact((w-sum3)/2)&
				*fact((w-sum4)/2)*fact((ii-w)/2)*fact((ij-w)/2)&
				*fact((ik-w)/2)
			if (mod(w,4) /= 0) denom = -denom
			omega = omega + fact(w/2+1) / denom
		enddo
      theta1 = fact((ia-j3)/2)*fact((j3+ib)/2)*fact((j3-ib)/2)/fact(sum1/2+1)
      theta2 = fact((ic-l3)/2)*fact((l3+id)/2)*fact((l3-id)/2)/fact(sum2/2+1)
      theta3 = fact((ie-l3)/2)*fact((l3+iif)/2)*fact((l3-iiF)/2)/fact(sum3/2+1)
      theta4 = fact((ig-j3)/2)*fact((j3+ih)/2)*fact((j3-ih)/2)/fact(sum4/2+1)
      theta = theta1 * theta2 * theta3 * theta4
		w6js = omega * sqrt(theta)
      if (abs(w6js) < 1.d-8) w6js = 0.d0
1000 		return
   end function w6js

!----------------------------------------------------------------
! This function calculates the 9-j symbol
! J_i and M_i have to be twice the actual value of J and M
!----------------------------------------------------------------
   function w9js(j1,j2,j3,j4,j5,j6,j7,j8,j9)
	integer :: j1,j2,j3,j4,j5,j6,j7,j8,j9
	integer :: i, kmin, kmax, k
	real(kind=8) :: x, s, x1, x2, x3, w9js

      kmin = abs(j1-j9)
		kmax = j1 + j9
		i = abs(j4-j8)
		if (i > kmin) kmin = i
		i = j4 + j8
		if (i < kmax) kmax = i
		i = abs(j2-j6)
		if (i > kmin) kmin = i
		i = j2 + j6
		if (i < kmax) kmax = i
		x = 0.d0
		do k = kmin, kmax, 2
			s = 1.d0
			if (mod(k,2) /= 0) s = -1.d0
			x1 = w6js(j1,j9,k,j8,j4,j7)
      	x2 = w6js(j2,j6,k,j4,j8,j5)
      	x3 = w6js(j1,j9,k,j6,j2,j3)
      	x = x + s*x1*x2*x3*dfloat(k+1)
		enddo
      w9js = x
      return
   end function w9js

!----------------------------------------------------------------
! Reorder the Regge square to make it similar to eq. (2.11) in Rasch & Yu (SIAM J. Sci. Comput. Vol 25, n 4, 1416)
!----------------------------------------------------------------
   function reorder_regge(regge, factor)
	integer :: reorder_regge(3,3), regge(3,3), temp(3,3), loc_max(2), col_max, row_max, loc_min(2), col_min, row_min, t
	integer :: i, j, tot, minus1, factor

		tot = sum(regge(1,:))
		minus1 = (-1)**tot
		factor = 1

		temp = regge

		loc_max = maxloc(temp)
		row_max = loc_max(2)
		col_max = loc_max(1)

		loc_min = minloc(temp)
		row_min = loc_min(2)
		col_min = loc_min(1)

! Put the maximum and minimum in the same row
		if (col_min == col_max) then
			temp = transpose(regge)

			row_max = loc_max(1)
			col_max = loc_max(2)

			row_min = loc_min(1)
			col_min = loc_min(2)

		endif

		reorder_regge = temp
		if (row_min /= 1) then
			reorder_regge(:,1) = temp(:,row_min)
			reorder_regge(:,row_min) = temp(:,1)
			factor = factor * minus1
		endif
		temp = reorder_regge

		loc_min = minloc(temp)
		row_min = loc_min(2)
		col_min = loc_min(1)

! Put smallest one into R_11
		reorder_regge = temp
		if (col_min /= 1) then
			reorder_regge(1,:) = temp(col_min,:)
			reorder_regge(col_min,:) = temp(1,:)
			factor = factor * minus1
			temp = reorder_regge
		endif

! Put largest one into R_21
		loc_max = maxloc(temp)
		row_max = loc_max(2)
		col_max = loc_max(1)

		if (col_max /= 2) then
			reorder_regge = temp
			reorder_regge(2,:) = temp(col_max,:)
			reorder_regge(col_max,:) = temp(2,:)
			factor = factor * minus1
		endif

   end function reorder_regge

!----------------------------------------------------------------
! Calculate the 3j symbol by indexing a 1D array with all the 3j symbols Rasch & Yu (SIAM J. Sci. Comput. Vol 25, n 4, 1416)
!----------------------------------------------------------------
	function w3js_regge(j1,j2,j3,m1,m2,m3)
	integer :: j1, j2, j3, m1, m2, m3, regge(3,3), regge_order(3,3), L, X, T, B, S, c1, c2, c3, c4, c5, c, factor
	real(kind=8) :: w3js_regge

		w3js_regge = 0.d0
		if (abs(m1) > j1 .or. abs(m2) > j2 .or. abs(m3) > j3 .or. (m1+m2+m3) /= 0) return

		regge(1,1) = -j1+j2+j3
		regge(2,1) = j1-j2+j3
		regge(3,1) = j1+j2-j3

		regge(1,2) = j1-m1
		regge(2,2) = j2-m2
		regge(3,2) = j3-m3

		regge(1,3) = j1+m1
		regge(2,3) = j2+m2
		regge(3,3) = j3+m3

		regge_order = reorder_regge(regge,factor)

		L = regge_order(2,1)
		X = regge_order(1,2)
		T = regge_order(3,3)
		B = regge_order(2,2)
		S = regge_order(1,1)

		c1 = L*(24+L*(50+L*(35+L*(10+L))))/120
		c2 = X*(6+X*(11+X*(6+X)))/24
		c3 = T*(2+T*(3+T))/6
		c4 = B*(B+1)/2
		c5 = S
		c = c1+c2+c3+c4+c5+1

		w3js_regge = factor*threej(c)
	end function w3js_regge

!----------------------------------------------------------------
! Calculate the list of 3j symbols and store them in a 1D array
!----------------------------------------------------------------
	subroutine init_regge(Lmax)
	integer :: S, B, T, X, L, Lmax, cmax, c1, c2, c3, c4, c5, c, k, j1, j2, j3, m1, m2, m3

		cmax = Lmax*(274+Lmax*(225+Lmax*(85+Lmax*(15+Lmax))))/120+1

		allocate(threej(0:cmax))

		k = 0
		do L = 0, Lmax
			do X = 0, L
				do T = 0, X
					do B = 0, T
						do S = 0, B
							j1 = (B+L-T+X)
							j2 = (B+S-T+X)
							j3 = (L+S)
							m1 = (B+L-T-X)
							m2 = (-B+S-T+X)
							m3 = (T+T-L-S)

							c1 = L*(24+L*(50+L*(35+L*(10+L))))/120
							c2 = X*(6+X*(11+X*(6+X)))/24
							c3 = T*(2+T*(3+T))/6
							c4 = B*(B+1)/2
							c5 = S
							c = c1+c2+c3+c4+c5+1

							threej(c) = w3js(j1,j2,j3,m1,m2,m3)

							k = k + 1
						enddo
					enddo
				enddo
			enddo
		enddo

		open(unit=12,file='regge_3j.dat',action='write',form='unformatted')
		write(12) threej
		close(12)

	end subroutine init_regge

!----------------------------------------------------------------
! This function calculates the rotation matrix of order k
! The results are returned in dr(iq,iqp) and di(iq,iqp) representing
! the real and imaginary part of the rotation matrix respectevely.
! The angles alpha, beta and gamma are given in radians
!----------------------------------------------------------------
   subroutine rotmatk(k,alpha,beta,gamma,dr,di)
	integer :: k
	real(kind=8) :: alpha, beta, gamma
   real(kind=8) :: dr(-1:1,-1:1), di(-1:1,-1:1)
	integer :: iq, iqp, it, it1, it2, it3, itmax, itmin, ie1, ie2
	real(kind=8) :: a1, a2, ca, sa, cg, sg, bo2, cb2, sb2, redm, s, den

		dr = 0.d0
		di = 0.d0
		do iq = -k, k
			do iqp = -k, k
				a1 = alpha * dfloat(iq)
				a2 = gamma * dfloat(iqp)
				ca = dcos(a1)
				sa = dsin(a1)
				cg = dcos(a2)
				sg = dsin(a2)
				bo2 = beta / 2.d0
				cb2 = dcos(bo2)
				sb2 = dsin(bo2)
				it1 = k + iq
				it2 = k - iqp
				itmax = it1
				if (it2 < itmax) itmax = it2
				itmin = 0
				it3 = iq - iqp
				if (it3 > 0) itmin = it3
				redm = 0.d0
				if (beta /= 0.d0) then
					do it = itmin, itmax
						s = 1.d0
						if (mod(it,2) /= 0) s = -1.d0
						ie1 = 2*(k-it)+iq-iqp
						ie2 = 2*it+iqp-iq
						den = fact(it1-it) * fact(it2-it) * fact(it) * fact(it-it3)
						redm = redm + s*(cb2**ie1)*(sb2**ie2) / den
					enddo
					redm = redm*sqrt(fact(k+iq)*fact(k-iq)*fact(k+iqp)*fact(k-iqp))
				else
					if (iq == iqp) redm = 1.d0
				endif
				dr(iq,iqp) = redm*(ca*cg-sa*sg)
				di(iq,iqp) = -redm*(ca*sg+sa*cg)
			enddo
		enddo

	end subroutine rotmatk

!----------------------------------------------------------------
! This function calculates the reduced rotation matrix of order 0,1,2,...kmax
! The results are returned in complex format dr(K,iq,iqp)
! The angle beta is given in radians
! The maximum value of kmax is 6
!----------------------------------------------------------------
   subroutine reduced_matrix(kmax,beta,reduced)
	integer :: kmax, K, M, N, t, min_t, max_t
	real(kind=8) :: beta, cos_beta, sin_beta, suma, f1, f2
	real(kind=8) :: reduced(0:kmax,-kmax:kmax,-kmax:kmax)

		cos_beta = cos(beta/2.d0)
      sin_beta = sin(beta/2.d0)

		do K = 0, kmax
			do M = -K, K
				do N = -K, K
					max_t = min(K+M,K-N)
        			min_t = max(0,M-N)
					suma = 0.d0
					f1 = sqrt(fact(K+M)*fact(K-M)*fact(K+N)*fact(K-N))
					do t = min_t, max_t
						f2 = fact(K+M-t)*fact(K-N-t)*fact(t)*fact(t+N-M)
						suma = suma + (-1.d0)**t*cos_beta**(2*K+M-N-2*t)*sin_beta**(2*t-M+N) / f2
					enddo
					reduced(k,M,N) = f1 * suma
				enddo
			enddo
		enddo

	end subroutine reduced_matrix

!----------------------------------------------------------------
! This function calculates the rotation matrix of order 0,1,2,...kmax
! The results are returned in complex format dr(K,iq,iqp)
! The angles alpha, beta and gamma are given in radians
! The maximum value of kmax is 6
!----------------------------------------------------------------
   subroutine rotmatsu(kmax,alpha,beta,gamma,dr)
   integer :: kmax, K, M, N
	real(kind=8) :: alpha, beta, gamma, ca, sa, cg, sg
	complex(kind=8) :: dr(0:kmax,-kmax:kmax,-kmax:kmax), ii
	real(kind=8) :: reduced(0:kmax,-kmax:kmax,-kmax:kmax)

		ii = cmplx(0.d0,1.d0)
		call reduced_matrix(kmax,beta,reduced)

		do K = 0, kmax
			do M = -K, K
				do N = -K, K
					dr(K,M,N) = reduced(K,M,N) * exp(-ii*(alpha*M+gamma*N))
				enddo
			enddo
		enddo

   end subroutine

!----------------------------------------------------------------
! This function returns the Kronecker delta
!----------------------------------------------------------------
	function delta(A,B)
	integer :: A, B, delta
		delta = 0.d0
		if (A == B) delta = 1.d0
	end function delta

!----------------------------------------------------------------
! This function calculates the t^K_P(i) symbol
!----------------------------------------------------------------
   function tkp(K,P)
	integer :: K, P
	complex(kind=8) :: tkp(0:3), ii

		tkp = 0.d0
		ii = cmplx(0.d0,1.d0)
		if (K == 0) then
			tkp(0) = delta(P,0)
			return
		endif

		if (K == 1) then
			tkp(3) = sqrt(3.d0/2.d0) * delta(P,0)
			return
		endif

		if (K == 2) then
			tkp(0) = sqrt(1.d0/2.d0) * delta(P,0)
			tkp(1) = -sqrt(3.d0)/2.d0 * (delta(P,-2) + delta(P,2))
			tkp(2) = ii * sqrt(3.d0)/2.d0 * (delta(P,-2) - delta(P,2))
			return
		endif
	end function tkp

!----------------------------------------------------------------
! This function calculates the tensor T^K_P(i,Omega) taking into account a double rotation
!----------------------------------------------------------------
   subroutine tkq2(alpha,beta,gamma,alphap,betap,gammap,tr)
	real(kind=8) :: alpha, beta, gamma, alphap, betap, gammap
	complex(kind=8) :: tr(0:2,-2:2,0:3), tkpi(0:3), dr1(0:2,-2:2,-2:2), dr2(0:2,-2:2,-2:2), suma
	integer :: i, K, Q, P, Qp

		call rotmatsu(2,alpha,beta,gamma,dr1)
		call rotmatsu(2,alphap,betap,gammap,dr2)

		tr = 0.d0

		do i = 0, 3
			do K = 0, 2
				do Q = -K, K
					suma = 0.d0
					do P = -K, K
						tkpi = tkp(K,P)
						do Qp = -K, K
							suma = suma + tkpi(i) * dr1(K,P,Qp) * dr2(K,Qp,Q)
						enddo
					enddo
					tr(K,Q,i) = suma
				enddo
			enddo
		enddo

	end subroutine tkq2

!----------------------------------------------------------------
! Calculates part of eq. 7.41 from Landi Degl'Innocenti & Landolfi (2004)
!----------------------------------------------------------------
   subroutine bigpar(l2,is2,k2,kp2,j2,jp2,js2,jt2,x)
	integer :: l2, is2, k2, kp2, j2, jp2, js2, jt2
	real(kind=8) :: x, x1, x2, x3, g

      x = 0.d0
      if (jp2 /= jt2 .and. j2 /= js2) return
      if (jp2 == jt2) then
      	if (iabs(j2-js2) > 2 .or. j2+js2 == 0) then
			else
      		call gamma(l2,is2,j2,js2,g)
      		x1 = g
      		x2 = w6js(k2,kp2,2,js2,j2,jp2)
      		x = x1*x2
			endif
		endif

      if (j2 /= js2) return
      if (iabs(jt2-jp2) > 2 .or. jt2+jp2 == 0) return
      call gamma(l2,is2,jt2,jp2,g)
      x1 = g
      x2 = 1.d0
      if (mod(k2-kp2,4) /= 0) x2 = -1.d0
      x3 = w6js(k2,kp2,2,jt2,jp2,j2)
      x = x + x1*x2*x3
	end subroutine bigpar

!----------------------------------------------------------------
! Calculates eq. 7.42 from Landi Degl'Innocenti & Landolfi (2004)
!----------------------------------------------------------------
   subroutine gamma(l2,is2,j2,jp2,g)
	integer :: l2, is2, j2, jp2
	real(kind=8) :: g
	real(kind=8) :: x1, x2, x3

      g = 0.d0
      if (j2 == jp2) then
			g = g + dsqrt(dfloat(j2*(j2+2)*(j2+1))/4.d0)
		endif
      x1 = 1.d0
      if (mod(2+l2+is2+j2,4) /= 0) x1 = -1.d0
      x2 = dsqrt(dfloat((j2+1)*(jp2+1)*is2*(is2+2)*(is2+1))/4.d0)
      x3 = w6js(j2,jp2,2,is2,is2,l2)
      g = g + x1*x2*x3
	end subroutine gamma

!----------------------------------------------------------------
! Calculates the factorial of the integers up to 301 and save it into the fact array
!----------------------------------------------------------------
   subroutine factrl
	integer :: i
      fact(0) = 1.d0
      do i=1,301
			fact(I) = fact(I-1) * dble(I)
		enddo
   END subroutine factrl

! ---------------------------------------------------------
! LU decomposition of a matrix
!  INPUT:
!		- a is the matrix to decompose
!
!  OUTPUT:
!		- a is the LU decomposition of a
!		- indx is a vector that records the row permutation effected by the partial pivoting
!		- d takes values +1/-1 depending on whether the number of row interchanges was odd or even
! ---------------------------------------------------------
	subroutine ludcmp(a,indx,d)
	integer, INTENT(INOUT) :: indx(:)
	real*8, INTENT(INOUT) :: a(:,:), d
	real*8, parameter :: TINY = 1.d-20
	integer :: i, imax, j, k, n
	real*8 :: aamax, dum, sum, vv(size(a,1))
	integer :: values_start(8), values_end(8)
	real(kind=8) :: start_time, end_time

!		call date_and_time(values=values_start)

		d = 1.d0
		n = size(a,1)

		do i = 1, n
			aamax = 0.d0
			aamax = maxval(dabs(a(i,:)))
			if (aamax == 0.d0) then
				print *, 'Singular matrix in LU decomposition'
				stop
			endif
			vv(i) = 1.d0 / aamax
		enddo

		do j = 1, n
			do i = 1, j-1
				sum = a(i,j)
				do k = 1, i-1
					sum = sum - a(i,k) * a(k,j)
				enddo
				a(i,j) = sum
			enddo
			aamax = 0.d0
			do i = j, n
				sum = a(i,j)
				do k = 1, j-1
					sum = sum - a(i,k) * a(k,j)
				enddo
				a(i,j) = sum
				dum = vv(i) * dabs(sum)
				if (dum >= aamax) then
					imax = i
					aamax = dum
				endif
			enddo
			if (j /= imax) then
				do k = 1, n
					dum = a(imax,k)
					a(imax,k) = a(j,k)
					a(j,k) = dum
				enddo
				d = -d
				vv(imax) = vv(j)
			endif
			indx(j) = imax
			if (a(j,j) == 0.d0) a(j,j) = TINY
			if (j /= n) then
				dum = 1.d0 / a(j,j)
				do i = j+1, n
					a(i,j) = a(i,j) * dum
				enddo
			endif
		enddo

!		call date_and_time(values=values_end)
!		start_time = values_start(5) * 3600 + values_start(6) * 60 + values_start(7) + 0.001 * values_start(8)
!		end_time = values_end(5) * 3600 + values_end(6) * 60 + values_end(7) + 0.001 * values_end(8)
!		print *, 'Time : ', end_time-start_time

	end subroutine ludcmp

! ---------------------------------------------------------
! Solves the set of equations AX=b where A is the LU decomposition of a matrix
!  INPUT:
!		- a is the LU decomposition of the system matrix
!		- b is the right hand side vector of the system
! 		- indx is the vector returned by ludcmp
!  OUTPUT:
!		- b is the solution of the system
! ---------------------------------------------------------
	subroutine lubksb(a,indx,b)
	real*8, INTENT(IN) :: a(:,:)
	real*8, INTENT(INOUT) :: b(:)
	integer, INTENT(IN) :: indx(:)
	integer :: i, ii, n, j, ll
	real*8 :: sum
		n = size(a,1)
		ii = 0
		do i = 1, n
			ll = indx(i)
			sum = b(ll)
			b(ll) = b(i)
			if (ii /= 0) then
				do j = ii, i-1
					sum = sum - a(i,j) * b(j)
				enddo
			else if (sum /= 0.d0) then
				ii = i
			endif
			b(i) = sum
		enddo
		do i = n, 1, -1
			sum = b(i)
			do j = i+1, n
				sum = sum - a(i,j) * b(j)
			enddo
			b(i) = sum / a(i,i)
		enddo
	end subroutine lubksb

! ---------------------------------------------------------
! Read lines that don't mind in a file
! INPUT:
!     - unit : unit to whom the file is associated
!     - n : number of lines to read
! ---------------------------------------------------------
   subroutine lb(unit, n)
   integer, INTENT(IN) :: unit, n
   integer :: i
   		  do i = 1, n
   					 read(unit,*)
   		  enddo
   end subroutine lb

! ---------------------------------------------------------
! Returns the sizes of the eigenvectors of the Paschen Back effect
! ---------------------------------------------------------
	subroutine paschen_size(l2,is2,j2max,njlargest)
	integer :: l2, is2
	integer :: m2, j2max, j2min, j2a, j2b, nj, njlargest

		j2min = abs(l2-is2)
		j2max = l2 + is2

! First find the largest value of nj
		njlargest = 0
		do m2 = -j2max, j2max, 2
			j2a = abs(m2)
			if (j2a < j2min) j2a = j2min
			j2b = j2max
			nj = 1 + (j2b-j2a) / 2
			if (nj > njlargest) njlargest = nj
		enddo
	end subroutine paschen_size

! ---------------------------------------------------------
! Calculates the eigenvalues and eigenvectors of the Paschen-Back matrix
! INPUT:
!     l2 = 2*L
!     is2 = 2*S
!     e0 = a vector containing the energy in cm^-1 of the level J (Jmin <= J <= Jmax) organized in terms of the J2 value
!          ex. e0(3) is the energy of the J=3/2 level. (Some elements remain undefined)
!     b = magnetic field in gauss
! OUTPUT:
!     njlev = number of levels for each m2
!     e = a vector containing the eigenvalues of the matrix. It is organized as e(m2,jsmall), where m2 is 2*M and
!         jsmall is a quantum number which takes values between 1 and the number of J compatible with M
!     c = eigenvectors, organized as c(m2,jsmall,J2)
! ---------------------------------------------------------
	subroutine paschen(l2,is2,e0,B,njlev,e,c,j2m,njl)
	integer :: l2, is2, j2m, njl
	integer :: njlev(-j2m:j2m)
	real(kind=8) :: e(-j2m:j2m,njl), c(-j2m:j2m,njl,0:j2m)
	real(kind=8) :: b, e0(0:jlimit2), bb
	real(kind=8), allocatable :: d(:), ud(:), z(:,:)
	integer :: m2, j2max, j2min, j2a, j2b, nj, j2vero, j, jp, jp2vero, njlargest, i, jsmall, jaux, j2
	real(kind=8) :: x1, x2, x3, x4

		bb = PE / (4.d0*PI*PME*PC**2) * B
		j2min = abs(l2-is2)
		j2max = l2 + is2

		do m2 = -j2max, j2max, 2

! Build the matrix which corresponds to the value of M
			j2a = abs(m2)
			if (j2a < j2min) j2a = j2min
			j2b = j2max
			nj = 1 + (j2b-j2a) / 2
			njlev(m2) = nj

			allocate(d(nj))
			d = 0.d0
			allocate(ud(nj))
			ud = 0.d0
			allocate(z(nj,nj))

! First the diagonal part
			do j = 1, nj
				j2vero = j2a+2*(j-1)
      		d(j) = e0(j2vero)
      		x1 = 1.d0
      		if (mod(2*j2vero+l2+is2+m2,4) /= 0) x1 = -1.d0
      		x2 = dfloat(j2vero+1)*dsqrt(dfloat(is2*(is2+2)*(is2+1))/4.d0)
      		x3 = w3js(j2vero,j2vero,2,-m2,m2,0)
      		x4 = w6js(j2vero,j2vero,2,is2,is2,l2)
      		d(j) = d(j) + bb * (dfloat(m2)/2.d0+x1*x2*x3*x4)
			enddo

! If we use the Pashen-Back regime
			if (use_paschen_back == 1) then
! Then the upper diagonal (only if the matrix is at least 2x2)
				if (nj /= 1) then
					do jp = 2, nj
      				jp2vero = j2a+2*(jp-1)
      				j2vero = jp2vero-2
      				x1 = 1.d0
      				if (mod(j2vero+jp2vero+l2+is2+m2,4) /= 0) x1 = -1.d0
      				x2 = dsqrt(dfloat((j2vero+1)*(jp2vero+1)*is2*(is2+2)*(is2+1))/4.d0)
      				x3 = w3js(j2vero,jp2vero,2,-m2,m2,0)
      				x4 = w6js(j2vero,jp2vero,2,is2,is2,l2)
      				ud(jp) = bb*x1*x2*x3*x4
					enddo
				endif
			endif

! Initializes the matrix z with the eigenvectors
			z = 0.d0
			do i = 1, nj
				z(i,i) = 1.d0
			enddo

! Diagonalize the matrix
			call tqli(d,ud,nj,nj,z)

			do jsmall = 1, nj
				e(m2,jsmall) = d(jsmall)
				do jaux = 1, nj
					j2 = j2a + 2*(jaux-1)
					c(m2,jsmall,j2) = z(jaux,jsmall)
				enddo
			enddo

			deallocate(d)
			deallocate(ud)
			deallocate(z)

		enddo

	end subroutine paschen

! ---------------------------------------------------------
! Diagonalizes a tridiagonal matrix
! ---------------------------------------------------------
	subroutine tqli(d,e,n,np,z)
	integer :: n, np, i, l, m, iter, k
	real(kind=8) :: d(np),e(np),z(np,np), g, r, s, c, p, f, b, dd

		if (n.gt.1) then
      do 11 i=2,n
      e(i-1)=e(i)
 11   continue
      e(n)=0.d0
      do 15 l=1,n
      iter=0
 1    do 12 m=l,n-1
      dd=dabs(d(m))+dabs(d(m+1))
      if(dabs(e(m))+dd.eq.dd) go to 2
 12   continue
      m=n
 2    if(m.ne.l) then
      if(iter.eq.30) then
      	print *, 'too many iterations'
      	stop
      endif
      iter=iter+1
      g=(d(l+1)-d(l))/(2.d0*e(l))
      r=dsqrt(g**2+1.d0)
      g=d(m)-d(l)+e(l)/(g+dsign(r,g))
      s=1.d0
      c=1.d0
      p=0.d0
      do 14 i=m-1,l,-1
      f=s*e(i)
      b=c*e(i)
      if(dabs(f).ge.dabs(g)) then
      c=g/f
      r=dsqrt(c**2+1.d0)
      e(i+1)=f*r
      s=1.d0/r
      c=c*s
      else
      s=f/g
      r=dsqrt(s**2+1.d0)
      e(i+1)=g*r
      c=1.d0/r
      s=s*c
      endif
      g=d(i+1)-p
      r=(d(i)-g)*s+2.d0*c*b
      p=s*r
      d(i+1)=g+p
      g=c*r-b
      do 13 k=1,n
      f=z(k,i+1)
      z(k,i+1)=s*z(k,i)+c*f
      z(k,i)=c*z(k,i)-s*f
 13   continue
 14   continue
      d(l)=d(l)-p
      e(l)=g
      e(m)=0.d0
      go to 1
      endif
 15   continue
      endif
      return
      end subroutine tqli

! ---------------------------------------------------------
! Sets the imaginary part of a complex to a given number
! ---------------------------------------------------------
		subroutine set_imaginary(A,b)
		complex(kind=8) :: A
		real(kind=8) :: b
			A = cmplx(real(A),b)
		end subroutine set_imaginary

! ---------------------------------------------------------
! Sets the imaginary part of a complex to a given number
! ---------------------------------------------------------
		subroutine set_real(A,b)
		complex(kind=8) :: A
		real(kind=8) :: b
			A = cmplx(b,aimag(A))
		end subroutine set_real

!--------------------------------------------------------------
! Generates Voigt and anomalous dispersion profiles using a different damping for each frequency
! point
! See Humlicek (1982) JQSRT 27, 437
!--------------------------------------------------------------
	function profile(da, dv)
	real(kind=8) :: da
	real(kind=8) :: dv(:)
	complex(kind=8) :: profile(size(dv))
	complex(kind=8) :: w4, z, t, u, v4
	real(kind=8) :: s
	integer :: i, n

		n = size(dv)
		if (da < 1.d-4) da = 0.d0
		do i = 1, n
! There is a problem for very small dampings. We force it to be 0 using a threshold
			z = cmplx(dv(i), da)
			t = cmplx(da, -dv(i))
			s = dabs(dv(i)) + da
			u = t*t

			if (s >= 15.d0) then
				w4 = t * 0.5641896d0 / (0.5d0+u)
			elseif (s >= 5.5) then
				w4 = t*(1.410474d0+u*0.5641896d0)/(0.75d0+u*(3.d0+u))
			elseif (da >= 0.195d0*dabs(dv(i))-0.176d0) then
				w4 = (16.4955d0+t*(20.20933d0+t*(11.96482d0+t*(3.778987d0+t*0.5642236d0)))) / &
					(16.4955d0+t*(38.82363d0+t*(39.27121d0+t*(21.69274d0+t*(6.699398d0+t)))))
			else
				w4 = t*(36183.31d0-u*(3321.9905d0-u*(1540.787d0-u*(219.0313d0-u*(35.76683d0-&
					u*(1.320522d0-u*0.56419d0))))))
				v4 = (32066.6d0-u*(24322.84d0-u*(9022.228d0-u*(2186.181d0-u*(364.2191d0-&
					u*(61.57037d0-u*(1.841439d0-u)))))))
				w4 = exp(u) - w4/v4
			endif
			profile(i) = w4
		enddo

	end function profile

! ---------------------------------------------------------
! Given xa(:) and ya(:) which tabulate a function, returns the interpolation using
! linear interpolation of vector x(:) in y(:)
! ---------------------------------------------------------
	subroutine lin_interpol(xa,ya,x,y)
	real*8, INTENT(IN) :: xa(:), ya(:), x(:)
	real*8, INTENT(INOUT) :: y(:)
	integer :: i, n
	integer :: locat(1), loc

		n = size(x)

		do i = 1, n
			locat = minloc(dabs(xa-x(i)))
			loc = locat(1)
			if (loc == 1) then
				y(i) = ya(loc)
			else
				y(i) = (ya(loc)-ya(loc-1))/(xa(loc)-xa(loc-1)) * (x(i)-xa(loc-1)) + ya(loc-1)
			endif
		enddo

	end subroutine lin_interpol

! ---------------------------------------------------------
! Given etaI, etaQ, etaU, etaV, rhoQ, rhoU and rhoV, fill the absorption matrix
! ---------------------------------------------------------
	subroutine fill_absorption_matrix(matrix,etaI,etaQ,etaU,etaV,rhoQ,rhoU,rhoV)
	real(kind=8) :: matrix(4,4), etaI, etaQ, etaU, etaV, rhoQ, rhoU, rhoV

		matrix(1,1) = etaI
		matrix(2,2) = etaI
		matrix(3,3) = etaI
		matrix(4,4) = etaI
		matrix(1,2) = etaQ
		matrix(2,1) = etaQ
		matrix(1,3) = etaU
		matrix(3,1) = etaU
		matrix(1,4) = etaV
		matrix(4,1) = etaV
		matrix(2,3) = rhoV
		matrix(3,2) = -rhoV
		matrix(2,4) = -rhoU
		matrix(4,2) = rhoU
		matrix(3,4) = rhoQ
		matrix(4,3) = -rhoQ

	end subroutine fill_absorption_matrix

!--------------------------------------------------------------
! Inversion of a 4x4 matrix
!--------------------------------------------------------------
	subroutine invert(a)
	real*8 :: a(4,4)
	real*8 :: b(4,4), det, maxim, fabsmax
	! First some tests of singularity
		b = dabs(a)
		maxim = maxval(b)
		fabsmax = 1.d0 / maxim
		if (maxim == 0.d0) then
			print *, 'Singularity in the inversion'
!			stop
		endif

		a = a * fabsmax

   	b(1,1) = a(2,2) * a(3,3) * a(4,4) + a(2,3) * a(3,4) * a(4,2)&
      	+ a(2,4) * a(3,2) * a(4,3) - a(2,2) * a(3,4) * a(4,3)&
	   	- a(2,3) * a(3,2) * a(4,4) - a(2,4) * a(3,3) * a(4,2)
   	b(2,1) = a(2,3) * a(3,1) * a(4,4) + a(2,4) * a(3,3) * a(4,1)&
	   	+ a(2,1) * a(3,4) * a(4,3) - a(2,3) * a(3,4) * a(4,1)&
   		- a(2,4) * a(3,1) * a(4,3) - a(2,1) * a(3,3) * a(4,4)
   	b(3,1) = a(2,4) * a(3,1) * a(4,2) + a(2,1) * a(3,2) * a(4,4)&
	   	+ a(2,2) * a(3,4) * a(4,1) - a(2,4) * a(3,2) * a(4,1)&
   		- a(2,1) * a(3,4) * a(4,2) - a(2,2) * a(3,1) * a(4,4)
   	b(4,1) = a(2,1) * a(3,3) * a(4,2) + a(2,2) * a(3,1) * a(4,3)&
	   	+ a(2,3) * a(3,2) * a(4,1) - a(2,1) * a(3,2) * a(4,3)&
   		- a(2,2) * a(3,3) * a(4,1) - a(2,3) * a(3,1) * a(4,2)
   	b(1,2) = a(3,2) * a(4,4) * a(1,3) + a(3,3) * a(4,2) * a(1,4)&
	   	+ a(3,4) * a(4,3) * a(1,2) - a(3,2) * a(4,3) * a(1,4)&
   		- a(3,3) * a(4,4) * a(1,2) - a(3,4) * a(4,2) * a(1,3)
   	b(2,2) = a(3,3) * a(4,4) * a(1,1) + a(3,4) * a(4,1) * a(1,3)&
	   	+ a(3,1) * a(4,3) * a(1,4) - a(3,3) * a(4,1) * a(1,4)&
   		- a(3,4) * a(4,3) * a(1,1) - a(3,1) * a(4,4) * a(1,3)
   	b(3,2) = a(3,4) * a(4,2) * a(1,1) + a(3,1) * a(4,4) * a(1,2)&
	   	+ a(3,2) * a(4,1) * a(1,4) - a(3,4) * a(4,1) * a(1,2)&
   		- a(3,1) * a(4,2) * a(1,4) - a(3,2) * a(4,4) * a(1,1)
   	b(4,2) = a(3,1) * a(4,2) * a(1,3) + a(3,2) * a(4,3) * a(1,1)&
	   	+ a(3,3) * a(4,1) * a(1,2) - a(3,1) * a(4,3) * a(1,2)&
   		- a(3,2) * a(4,1) * a(1,3) - a(3,3) * a(4,2) * a(1,1)
   	b(1,3) = a(4,2) * a(1,3) * a(2,4) + a(4,3) * a(1,4) * a(2,2)&
   		+ a(4,4) * a(1,2) * a(2,3) - a(4,2) * a(1,4) * a(2,3)&
	   	- a(4,3) * a(1,2) * a(2,4) - a(4,4) * a(1,3) * a(2,2)
   	b(2,3) = a(4,3) * a(1,1) * a(2,4) + a(4,4) * a(1,3) * a(2,1)&
	   	+ a(4,1) * a(1,4) * a(2,3) - a(4,3) * a(1,4) * a(2,1)&
   		- a(4,4) * a(1,1) * a(2,3) - a(4,1) * a(1,3) * a(2,4)
   	b(3,3) = a(4,4) * a(1,1) * a(2,2) + a(4,1) * a(1,2) * a(2,4)&
	   	+ a(4,2) * a(1,4) * a(2,1) - a(4,4) * a(1,2) * a(2,1)&
   		- a(4,1) * a(1,4) * a(2,2) - a(4,2) * a(1,1) * a(2,4)
   	b(4,3) = a(4,1) * a(1,3) * a(2,2) + a(4,2) * a(1,1) * a(2,3)&
	   	+ a(4,3) * a(1,2) * a(2,1) - a(4,1) * a(1,2) * a(2,3)&
   		- a(4,2) * a(1,3) * a(2,1) - a(4,3) * a(1,1) * a(2,2)
   	b(1,4) = a(1,2) * a(2,4) * a(3,3) + a(1,3) * a(2,2) * a(3,4)&
	   	+ a(1,4) * a(2,3) * a(3,2) - a(1,2) * a(2,3) * a(3,4)&
   		- a(1,3) * a(2,4) * a(3,2) - a(1,4) * a(2,2) * a(3,3)
   	b(2,4) = a(1,3) * a(2,4) * a(3,1) + a(1,4) * a(2,1) * a(3,3)&
	   	+ a(1,1) * a(2,3) * a(3,4) - a(1,3) * a(2,1) * a(3,4)&
   		- a(1,4) * a(2,3) * a(3,1) - a(1,1) * a(2,4) * a(3,3)
   	b(3,4) = a(1,4) * a(2,2) * a(3,1) + a(1,1) * a(2,4) * a(3,2)&
	   	+ a(1,2) * a(2,1) * a(3,4) - a(1,4) * a(2,1) * a(3,2)&
   		- a(1,1) * a(2,2) * a(3,4) - a(1,2) * a(2,4) * a(3,1)
   	b(4,4) = a(1,1) * a(2,2) * a(3,3) + a(1,2) * a(2,3) * a(3,1)&
	   	+ a(1,3) * a(2,1) * a(3,2) - a(1,1) * a(2,3) * a(3,2)&
   		- a(1,2) * a(2,1) * a(3,3) - a(1,3) * a(2,2) * a(3,1)

		det = a(1,1) * b(1,1) + a(1,2) * b(2,1) + a(1,3) * b(3,1) + a(1,4) * b(4,1)

		a = b * (fabsmax / det)

	end subroutine invert

!--------------------------------------------------------------
! Returns in b the evolution operator if the propagation matrix is constant
! given by exp(-A*t). It uses Eqs. A5.20 of Landi Degl'Innocenti & Landolfi 2004
!--------------------------------------------------------------
	subroutine evol_operator(a,t,b)
	real(kind=8) :: a(4,4), t
	real(kind=8) :: b(4,4), det, maxim, fabsmax, w(3), y(3), w_y_scalar, sigma
	real(kind=8) :: Lambda_plus, Lambda_minus, tt, Theta, w_mod_sq, y_mod_sq, factor1, factor2, factor3, factor4, w0, temp1, temp2
	real(kind=8), dimension(4,4) :: M1, M2, M3, M4
	integer :: i

		w0 = a(1,1)

		w(1) = a(1,2)
		w(2) = a(1,3)
		w(3) = a(1,4)
		w_mod_sq = sum(w*w)

		y(1) = a(3,4)
		y(2) = a(4,2)
		y(3) = a(2,3)
		y_mod_sq = sum(y*y)

		w_y_scalar = sum(w*y)
		sigma = 1.d0
		if (w_y_scalar < 0.d0) sigma = -1.d0

! Eigenvalues
		temp1 = sqrt((w_mod_sq - y_mod_sq)**2 / 4.d0 + w_y_scalar**2)
		temp2 = (w_mod_sq - y_mod_sq) / 2.d0
		if (temp1+temp2 < 0.d0) then
			Lambda_plus = 0.d0
		else
			Lambda_plus = sqrt(temp1 + temp2)
		endif
		if (temp1-temp2 < 0.d0) then
			Lambda_minus = 0.d0
		else
			Lambda_minus = sqrt(temp1 - temp2)
		endif

		Theta = 2.d0 * temp1
		tt = (w_mod_sq + y_mod_sq) / 2.d0

		M1 = 0.d0
		M2 = 0.d0
		M3 = 0.d0
		M4 = 0.d0

! M1
		do i = 1, 4
			M1(i,i) = 1.d0
		enddo

! M2
		M2(1,2) = Lambda_minus * w(1) - sigma * Lambda_plus * y(1)
		M2(1,3) = Lambda_minus * w(2) - sigma * Lambda_plus * y(2)
		M2(1,4) = Lambda_minus * w(3) - sigma * Lambda_plus * y(3)
		M2(2,1) = M2(1,2)
		M2(2,3) = sigma * Lambda_plus * w(3) + Lambda_minus * y(3)
		M2(2,4) = -sigma * Lambda_plus * w(2) - Lambda_minus * y(2)
		M2(3,1) = M2(1,3)
		M2(3,2) = -M2(2,3)
		M2(3,4) = sigma * Lambda_plus * w(1) + Lambda_minus * y(1)
		M2(4,1) = M2(1,4)
		M2(4,2) = -M2(2,4)
		M2(4,3) = -M2(3,4)

! M3
		M3(1,2) = Lambda_plus * w(1) + sigma * Lambda_minus * y(1)
		M3(1,3) = Lambda_plus * w(2) + sigma * Lambda_minus * y(2)
		M3(1,4) = Lambda_plus * w(3) + sigma * Lambda_minus * y(3)
		M3(2,1) = M3(1,2)
		M3(2,3) = -sigma * Lambda_minus * w(3) + Lambda_plus * y(3)
		M3(2,4) = sigma * Lambda_minus * w(2) - Lambda_plus * y(2)
		M3(3,1) = M3(1,3)
		M3(3,2) = -M3(2,3)
		M3(3,4) = -sigma * Lambda_minus * w(1) + Lambda_plus * y(1)
		M3(4,1) = M3(1,4)
		M3(4,2) = -M3(2,4)
		M3(4,3) = -M3(3,4)

! M4
		M4(1,1) = tt
		M4(1,2) = w(3)*y(2) - w(2)*y(3)
		M4(1,3) = w(1)*y(3) - w(3)*y(1)
		M4(1,4) = w(2)*y(1) - w(1)*y(2)
		M4(2,1) = -M4(1,2)
		M4(2,2) = w(1)**2 + y(1)**2 - tt
		M4(2,3) = w(1)*w(2) + y(1)*y(2)
		M4(2,4) = w(3)*w(1) + y(3)*y(1)
		M4(3,1) = -M4(1,3)
		M4(3,2) = M4(2,3)
		M4(3,3) = w(2)**2 + y(2)**2 - tt
		M4(3,4) = w(2)*w(3) + y(2)*y(3)
		M4(4,1) = -M4(1,4)
		M4(4,2) = M4(2,4)
		M4(4,3) = M4(3,4)
		M4(4,4) = w(3)**2 + y(3)**2 - tt

		M2 = M2 / Theta
		M3 = M3 / Theta
		M4 = 2.d0 * M4 / Theta

		factor1 = 0.5d0*(cosh(t*Lambda_plus) + cos(t*Lambda_minus))
		factor2 = sin(t*Lambda_minus)
		factor3 = sinh(t*Lambda_plus)
		factor4 = 0.5d0*(cosh(t*Lambda_plus) - cos(t*Lambda_minus))

		b = factor1*M1 - factor2*M2 - factor3*M3 + factor4*M4
		b = exp(-t*w0) * b

	end subroutine evol_operator

! ---------------------------------------------------------
! Return the input array but shifted by a sub-pixel amount
! Note that it works only for any length of series which has no prime factor greater than 23
! ---------------------------------------------------------
		function fft_shift(x, sh)
		real(kind=8) :: x(:), fft_shift(size(x)), sh
		complex(kind=8) :: k(size(x)), ff(size(x))
		integer :: nx, i, n21

			nx = size(x)

			do i = 1, nx
         	k(i) = i-1
         enddo
         n21 = nx/2+1
         do i = n21+1, nx
         	k(i) = n21-nx+(i-1-n21)
         enddo

         k = 2.d0*PI*k/(1.d0*nx)
         k = k * cmplx(0.d0,1.d0)

         ff = x

         ff = fft(ff)

         fft_shift = real(fft(ff * exp(k*sh), inv=.TRUE.))

		end function fft_shift

end module maths


       subroutine insol(boxtime,sinayr,boxlat,sfac)
! find light as function of date and latitude
! based on paltridge and parson
       implicit none
       REAL*8 :: boxtime
       REAL*8 :: sinayr
       REAL*8 :: boxlat
       REAL*8 :: sfac
       REAL*8 :: dayfrac
       REAL*8 :: yday
       REAL*8 :: delta
       REAL*8 :: sun
       REAL*8 :: dayhrs
       REAL*8 :: cosz
       REAL*8 :: frac
       REAL*8 :: fluxi
       REAL*8, PARAMETER :: pi = 3.14159265358979323844d0
!fraction of sunlight that is photosynthetically active
       REAL*8, PARAMETER :: parfrac = 0.4
!solar constant
       REAL*8, PARAMETER :: solar=1360.00
!planetary albedo
       REAL*8, PARAMETER :: albedo=0.60

! find day (****NOTE for year starting in winter*****)
       dayfrac=mod(boxtime,sinayr)/(sinayr) !fraction of year
       yday = 2.0*pi*dayfrac                 !convert to radians
       delta = (0.006918
     &      -(0.399912*cos(yday))
     &      +(0.070257*sin(yday))
     &      -(0.006758*cos(2.0*yday))
     &      +(0.000907*sin(2.0*yday))
     &      -(0.002697*cos(3.0*yday))
     &      +(0.001480*sin(3.0*yday)))

! latitude in radians
       boxlat=boxlat*(pi/180.d0)
       sun  = max(-0.999,min(
     &       -sin(delta)/cos(delta) * sin(boxlat)/cos(boxlat)
     &       ,0.999))

!       IF (sun1.LE.-0.999) sun1=-0.999
!       IF (sun1.GE. 0.999) sun1= 0.999

       dayhrs = abs(acos(sun))
       cosz = ( sin(delta)*sin(boxlat)+       !average zenith angle
     &        ( cos(delta)*cos(boxlat)*sin(dayhrs)/dayhrs) )
!       IF (cosz.LE.5.d-3) cosz= 5.d-3
       cosz=max(cosz,5.d-3)
       frac = dayhrs/pi                    !fraction of daylight in day

! daily average photosynthetically active solar radiation just below surface
       fluxi = solar*(1.0-albedo)*cosz*frac*parfrac

! convert to sfac
       sfac = max(1.d-5,fluxi)

       return
       end


      SUBROUTINE DERI21 (A,NVAR,MINEAR,NFIRST,VNERT,PNERT
     1                  ,B,NCUT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(MINEAR,NVAR),VNERT(NVAR),PNERT(NVAR),B(MINEAR,*)
************************************************************************
*
*     LEAST-SQUARE ANALYSIS OF A SET OF NVAR POINTS {A} :
*
*     PRODUCE A SUBSET OF NCUT ORTHONORMALIZED VECTORS B, OPTIMUM IN A
*     LEAST-SQUARE SENSE WITH RESPECT TO THE INITIAL SPACE {A}.
*     EACH NEW HIERARCHIZED VECTOR B EXTRACTS A MAXIMUM PERCENTAGE FROM
*     THE REMAINING DISPERSION OF THE SET {A} OUT OF THE PREVIOUS
*     {B} SUBSPACE.
*   INPUT
*     A(MINEAR,NVAR): ORIGINAL SET {A}.
*     NFIRST        : MAXIMUM ALLOWED SIZE OF THE BASIS B.
*   OUTPUT
*     VNERT(NVAR)   : LOWEST EIGENVECTOR OF A'* A.
*     PNERT(NVAR)     : SQUARE ROOT OF THE ASSOCIATED EIGENVALUES
*                     IN DECREASING ORDER.
*     B(MINEAR,NCUT): OPTIMUM ORTHONORMALIZED SUBSET {B}.
*
************************************************************************
      DIMENSION WORK(4)
C
C     VNERT = A' * A
      CUTOFF=0.85D0
      SUM2=0.D0
      CALL MTXMC(A,NVAR,A,MINEAR,WORK)
      DO 10 I=1,(NVAR*(NVAR+1))/2
  10      WORK(I)=-WORK(I)
C     DIAGONALIZE IN DECREASING ORDER OF EIGENVALUES
      IF(ABS(WORK(1)).LT.1.D-28 .AND. NVAR.EQ.1)THEN
      PNERT(1)=SQRT(-WORK(1))
      WORK(1)=1.D15
      VNERT(1)=1.D0
      NCUT=1
      GOTO 50
      ELSE
      CALL HQRII(WORK,NVAR,NVAR,PNERT, VNERT)
C     FIND NCUT ACCORDING TO CUTOFF, BUILD WORK = VNERT * (PNERT)**-0.5
      SUM=0.D0
      DO 20 I=1,NVAR
   20 SUM=SUM-PNERT(I)
      L=1
      DO 40 I=1,NFIRST
         SUM2=SUM2-PNERT(I)/SUM
         PNERT(I)=SQRT(-PNERT(I))
         DO 30 J=1,NVAR
            WORK(L)=VNERT(L)/PNERT(I)
   30    L=L+1
         IF(SUM2.GE.CUTOFF) THEN
            NCUT=I
            GO TO 50
         ENDIF
   40 CONTINUE
      NCUT=NFIRST
C     ORTHONORMALIZED BASIS
C     B(MINEAR,NCUT) = A(MINEAR,NVAR)*WORK(NVAR,NCUT)
      ENDIF
   50 CALL MXM (A,MINEAR,WORK,NVAR,B,NCUT)
      RETURN
      END


C******************************************************************************
C FILE: mpi_mm.f
C DESCRIPTION:
C   MPI Matrix Multiply - Fortran Version
C   In this code, the master task distributes a matrix multiply
C   operation to numtasks-1 worker tasks.
C   NOTE1:  C and Fortran versions of this code differ because of the way
C   arrays are stored/passed.  C arrays are row-major order but Fortran
C   arrays are column-major order.
C AUTHOR: Blaise Barney. Adapted from Ros Leibensperger, Cornell Theory
C   Center. Converted to MPI: George L. Gusciora, MHPCC (1/95)
C LAST REVISED: 04/02/05
C******************************************************************************

      program mm
      include 'mpif.h'

      parameter (NRA = 62)
      parameter (NCA = 15)
      parameter (NCB = 7)
      parameter (MASTER = 0)
      parameter (FROM_MASTER = 1)
      parameter (FROM_WORKER = 2)

      integer 	numtasks,taskid,numworkers,source,dest,mtype,
     &          cols,avecol,extra, offset,i,j,k,ierr
      integer status(MPI_STATUS_SIZE)
      real*8	a(NRA,NCA), b(NCA,NCB), c(NRA,NCB)

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, taskid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numtasks, ierr )
      numworkers = numtasks-1
      print *, 'task ID= ',taskid

C *************************** master task *************************************
      if (taskid .eq. MASTER) then

C     Initialize A and B
        do 30 i=1, NRA
          do 30 j=1, NCA
          a(i,j) = (i-1)+(j-1)
 30     continue
        do 40 i=1, NCA
          do 40 j=1, NCB
	    b(i,j) = (i-1)*(j-1)
 40     continue

C     Send matrix data to the worker tasks
        avecol = NCB/numworkers
        extra = mod(NCB, numworkers)
        offset = 1
        mtype = FROM_MASTER
        do 50 dest=1, numworkers
          if (dest .le. extra) then
            cols = avecol + 1
          else
            cols = avecol
          endif
          write(*,*)'   sending',cols,' cols to task',dest
          call MPI_SEND( offset, 1, MPI_INTEGER, dest, mtype,
     &                   MPI_COMM_WORLD, ierr )
          call MPI_SEND( cols, 1, MPI_INTEGER, dest, mtype,
     &                   MPI_COMM_WORLD, ierr )
          call MPI_SEND( a, NRA*NCA, MPI_DOUBLE_PRECISION, dest, mtype,
     &                   MPI_COMM_WORLD, ierr )
          call MPI_SEND( b(1,offset), cols*NCA, MPI_DOUBLE_PRECISION,
     &                   dest, mtype, MPI_COMM_WORLD, ierr )
          offset = offset + cols
 50     continue

C     Receive results from worker tasks
        mtype = FROM_WORKER
        do 60 i=1, numworkers
          source = i
          call MPI_RECV( offset, 1, MPI_INTEGER, source,
     &                   mtype, MPI_COMM_WORLD, status, ierr )
          call MPI_RECV( cols, 1, MPI_INTEGER, source,
     &                   mtype, MPI_COMM_WORLD, status, ierr )
          call MPI_RECV( c(1,offset), cols*NRA, MPI_DOUBLE_PRECISION,
     &                   source, mtype, MPI_COMM_WORLD, status, ierr )
 60     continue

C     Print results
        do 90 i=1, NRA
          do 80 j = 1, NCB
            write(*,70)c(i,j)
  70        format(2x,f8.2,$)
  80      continue
          print *, ' '
  90    continue
      endif

C *************************** worker task *************************************
      if (taskid > MASTER) then
C     Receive matrix data from master task
        mtype = FROM_MASTER
        call MPI_RECV( offset, 1, MPI_INTEGER, MASTER,
     &                 mtype, MPI_COMM_WORLD, status, ierr )
        call MPI_RECV( cols, 1, MPI_INTEGER, MASTER,
     &                 mtype, MPI_COMM_WORLD, status, ierr )
        call MPI_RECV( a, NRA*NCA, MPI_DOUBLE_PRECISION, MASTER,
     &                 mtype, MPI_COMM_WORLD, status, ierr )
        call MPI_RECV( b, cols*NCA, MPI_DOUBLE_PRECISION, MASTER,
     &                 mtype, MPI_COMM_WORLD, status, ierr )

C     Do matrix multiply
        do 100 k=1, cols
          do 100 i=1, NRA
            c(i,k) = 0.0
            do 100 j=1, NCA
              c(i,k) = c(i,k) + a(i,j) * b(j,k)
  100   continue

C     Send results back to master task
        mtype = FROM_WORKER
        call MPI_SEND( offset, 1, MPI_INTEGER, MASTER, mtype,
     &                 MPI_COMM_WORLD, ierr )
        call MPI_SEND( cols, 1, MPI_INTEGER, MASTER, mtype,
     &                 MPI_COMM_WORLD, ierr )
        call MPI_SEND( c, cols*NRA, MPI_DOUBLE_PRECISION, MASTER,
     &                  mtype, MPI_COMM_WORLD, ierr )
      endif
      call MPI_FINALIZE(ierr)
      end


! File lu_fact.f90
subroutine lu_factorization (nrow, ncol, A)

  implicit none

  integer, intent(in) :: nrow, ncol
  real, intent(inout), dimension(nrow, ncol) :: A

  integer :: i, j, k

  do j = 1,nrow
    do i = j+1,nrow
      A(i,j) = A(i,j) / A(j,j)
      do k = j+1,ncol
        A(i,k) = A(i,k) - A(j,k) * A(i,j)
      enddo
    enddo
  enddo

end


PROGRAM test_vectors
!
!  Purpose:
!    To test adding and subtracting 2D vectors.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     12/04/06    S. J. Chapman        Original code
! 1.  12/22/06    S. J. Chapman        Use bound procedures
!
USE vector_module
IMPLICIT NONE

! Enter first point
TYPE(vector) :: v1              ! First point
TYPE(vector) :: v2              ! Second point

! Get the first vector
WRITE (*,*) 'Enter the first vector (x,y):'
READ (*,*) v1%x, v1%y

! Get the second point
WRITE (*,*) 'Enter the second vector (x,y):'
READ (*,*) v2%x, v2%y

! Add the points
WRITE (*,1000) v1%vector_add(v2)
1000 FORMAT(1X,'The sum of the points is (',F8.2,',',F8.2,')')

! Subtract the points
WRITE (*,1010) v1%vector_sub(v2)
1010 FORMAT(1X,'The difference of the points is (',F8.2,',',F8.2,')')

END PROGRAM test_vectors


      SUBROUTINE point_wise_to_power(npts, x, f, n, ac, i_full,
     1                               nsp_pts)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: npts, i_full, nsp_pts, n
      REAL(rprec), DIMENSION(npts), INTENT(IN) :: x, f
      REAL(rprec), DIMENSION(0:n), INTENT(OUT) :: ac
!-----------------------------------------------
      REAL, PARAMETER :: tol_res = 0.005_dp
      INTEGER :: i, j, k , n_count, n_int
      CHARACTER(len=2) :: cdum
      CHARACTER(len=15) :: form
      REAL(rprec) :: res, ohs_sp
      REAL(rprec), DIMENSION(:), ALLOCATABLE   :: tc, norm, y,
     1                                            fy, y_sp, fy_sp
      REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: a_inv, b_inv,
     1                                            a, b, inorm, tleg
!-----------------------------------------------
!   E x t e r n a l   F u n c t i o n s
!-----------------------------------------------
      REAL(rprec) , EXTERNAL :: integral
!--------------------------------------------------------------------------------
!      MEANING OF ARGUMENTS:
!      NPTS = number of points where the point-wise function is given
!      X = independent variable values for these points in [0,1]
!      F = dependent variable values on the X points
!      N = input number, 0:n, of Legendre polynomials used in the expansion
!      N_INT = actual computed number, 0:N_INT
!      AC = final power series coefficients in x ([0,1])
!      I_FULL =0, if input data on full mesh; =1, if on half mesh
!      NSP_PTS = number of points for the spline fit of F on the half mesh.
!--------------------------------------------------------------------------------
!
!      ABSTRACT:
!      Conversion of a point-wise solution in [0,1] given on a discrete set
!      of NPTS radial points (either on the half or the full mesh, see below)
!      first to an expansion in Legendre polynomials in [-1,1] via:
!
!          F = sum_m=0^N  <F,P_m>/<P_m,P_m>   <f,g> == int_[-1,1] f(x)g(x)dx
!
!      and defining the Legendre coefficient vector TC as:
!
!          TC = {<F,P_m>/<P_m,P_m>, m=1, N}
!
!      Then calculates the equivalent power series coefficients vector in
!      [0,1], AC:
!
!                AC = TC*A_inv*B_inv
!
!      The value of Legendre Polynomials used "N" depends CRITICALLY on the
!      number of points NPTS in the discrete data set of the incoming point-wise
!      solution. Because if the integrals are evaluated using these points, the
!      wiggles in the polynomial may not be well sampled by the existing set of
!      points and may cause deviations of the ortogonality condition:
!
!                        <P_m,P_n> = 2/(2*n+1)* delta_{mn}
!
!      This makes the reconstruction deteriorate quickly for increasing "N".
!      To avoid this, the incoming data values are splined to a number of points
!      NSP_PTS on a half-like mesh using Hermite cubic splines. Then, the
!      value of "N" is chosen requiring:
!
!               | 1- .5*(2*n+1)*<P_N,P_n> | < TOL_RES
!
!      TOL_RES is prescribed to be <= .5%. Until this condition is achieved, "N" is
!      subsequently reduced. If "N" gets equal to 2 in this reduction, the
!      calculation is stopped and an error message issued.
!
!      WARNING: The point-wise solution MAY BE given on the half mesh or full mesh
!      of a equally spaced radial grid, that is:
!
!      ***I_FULL = 1 beginning with x(3/2) and finishing with x(M-1/2), where
!         x(1) = 0. and x(M) = 1.
!      ***I_FULL = 0 beginning with x(1) = 0. and finishing with x(M) = 1.
!
!--------------------------------------------------------------------------------

      ac = 0
      res = 1

!...   Map [0,1] to [-1,1]

      ALLOCATE (y(npts), fy(npts),
     1          y_sp(nsp_pts), fy_sp(nsp_pts), stat=i)
      IF (i .ne. 0) STOP 'Allocation error in point_wise_to_power!'

      y(:npts) = 2*x(:npts) - 1
      fy(:npts) = f(:npts)
      IF (i_full .eq. 1) fy(1)= fy(2)

!...   i_full = 0 IF FY given on the full mesh, and =1 IF on the half mesh.
!      FY is splined on nsp_pts on the half_mesh

      ohs_sp = 2._dp/nsp_pts
      y_sp= (/( -1 + (i -0.5_dp)*ohs_sp, i = 1,nsp_pts)/)

      CALL spline_it(npts, y, fy, nsp_pts, y_sp, fy_sp, i_full)

!...   Determine number of Legendre Polynomials to be used

      n_count = 0
      DO WHILE(res .gt. tol_res)
         n_int = n - n_count
         IF(n_int < n) DEALLOCATE (a, b, a_inv, b_inv, tleg,
     1                             inorm, norm)
         ALLOCATE(a(0:n_int,0:n_int), b(0:n_int,0:n_int),
     1            a_inv(0:n_int,0:n_int), b_inv(0:n_int,0:n_int),
     2            tleg(0:n_int, nsp_pts), inorm(0:n_int,0:n_int),
     3            norm(0:n_int), stat=i)
         IF (i .ne. 0) STOP 'Allocation error in point_wise_to_power!'

         norm(0:n_int) = (/(2._dp/(2*i+1), i=0, n_int)/)

         CALL build_matrices_legendre (n_int, a, b, a_inv, b_inv)

!...   Build Initial Legendre polynomials on grid

         DO i = 0, n_int
            tleg(i,:nsp_pts) = 0
            DO k = n_int, 0, -1
               tleg(i,:nsp_pts) = a_inv(i,k) + y_sp(:nsp_pts)
     1                          * tleg(i,:nsp_pts)
            END DO
         END DO

!...   Compute orthogonality and norms

         DO j = 0, n_int
            DO i = 0, n_int
               inorm(i,j) = integral(nsp_pts, y_sp, tleg(j,1:nsp_pts),
     1                               tleg(i,1:nsp_pts))
            END DO
            WRITE(cdum,'(i2)')n_int+1
            cdum = ADJUSTL(cdum)
            form = '('//TRIM(cdum)//'(x,f8.3))'
            form = ADJUSTL(form)
!           WRITE(20,TRIM(form)) (inorm(i,j), i=0, n)
         END DO

!...   Compute residual. If res > tol_res, reduce N and iterate while loop

         res = ABS((norm(n_int) - inorm(n_int,n_int))/(norm(n_int)))
         n_count = n_count + 1
         IF(n_count == n-1) STOP 'Precision bad for even 2 Polynomial'

      END DO

      ALLOCATE(tc(0:n_int))
      DO j = 0, n_int
         tc(j) = integral(nsp_pts, y_sp, fy_sp, tleg(j,1:nsp_pts))
     1              /norm(j)
      END DO

!
!     FIND ac COEFFICIENTS, 0:n_int; IF n_int < n, ac(n_int:n) = 0
!
      CALL legendre_to_power(n_int, a_inv, b_inv, tc, ac(0))

      DEALLOCATE(a_inv, b_inv, a, b, tc, tleg, inorm, norm, y,
     1           fy, y_sp, fy_sp)

      END SUBROUTINE point_wise_to_power


!program test
!    a = (/ 2, 3, 5, 7, 11, 13, 17 /)
!    call myfft(a)
!    contains
subroutine fft(N,in,out)
    use, intrinsic :: iso_c_binding
    include 'fftw3.f03'
    double complex :: in
    double complex, optional, intent(out):: out
    dimension in(N), out(N)
    integer*8 plan

    call dfftw_plan_dft_1d(plan,N,in,out,FFTW_FORWARD,FFTW_ESTIMATE)
    call dfftw_execute_dft(plan, in, out)
    call dfftw_destroy_plan(plan)

    return

end subroutine
!end program

subroutine fft2(M,N,in,out)
    use, intrinsic :: iso_c_binding
    include 'fftw3.f03'
    double complex in
    dimension in(M,N)
    double complex, intent(out) :: out
    dimension out(M, N)
    integer*8 plan

    call dfftw_plan_dft_2d( plan,N,M, in,out, FFTW_FORWARD, FFTW_ESTIMATE)
    call dfftw_execute_dft(plan, in, out)
    call dfftw_destroy_plan(plan)

    return
    end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of lin_interpol in forward (tangent) mode:
!   variations   of useful results: lin_interpol
!   with respect to varying inputs: da db
!>    @brief linear interpolation
!>    @param[in] da value A
!>    @param[in] db value B
!>    @param[in] dp relative position
!>    @param[in] dd (delta) cell size
!>    @return linear interpolated value
DOUBLE PRECISION FUNCTION g_LIN_INTERPOL(da, g_da, db, g_db, dp, &
& dd, lin_interpol)
  IMPLICIT NONE
!       da: value A; db: value B; dp: relative position; dd: (delta) cell size
  DOUBLE PRECISION :: da, db, dp, dd
  DOUBLE PRECISION :: g_da, g_db
  DOUBLE PRECISION :: lin_interpol
  g_lin_interpol = ((dd-dp)*g_da+dp*g_db)/dd
  lin_interpol = (da*(dd-dp)+db*dp)/dd
  RETURN
END FUNCTION g_LIN_INTERPOL


      SUBROUTINE slCLDJ (IY, IM, ID, DJM, J)
*+
*     - - - - -
*      C L D J
*     - - - - -
*
*  Gregorian Calendar to Modified Julian Date
*
*  Given:
*     IY,IM,ID     int    year, month, day in Gregorian calendar
*
*  Returned:
*     DJM          dp     modified Julian Date (JD-2400000.5) for 0 hrs
*     J            int    status:
*                           0 = OK
*                           1 = bad year   (MJD not computed)
*                           2 = bad month  (MJD not computed)
*                           3 = bad day    (MJD computed)
*
*  The year must be -4699 (i.e. 4700BC) or later.
*
*  The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55).
*
*  Last revision:   27 July 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER IY,IM,ID
      DOUBLE PRECISION DJM
      INTEGER J

*  Month lengths in days
      INTEGER MTAB(12)
      DATA MTAB / 31,28,31,30,31,30,31,31,30,31,30,31 /

*  Preset status.
      J = 0

*  Validate year.
      IF ( IY .LT. -4699 ) THEN
         J = 1
      ELSE

*     Validate month.
         IF ( IM.GE.1 .AND. IM.LE.12 ) THEN

*        Allow for leap year.
            IF ( MOD(IY,4) .EQ. 0 ) THEN
               MTAB(2) = 29
            ELSE
               MTAB(2) = 28
            END IF
            IF ( MOD(IY,100).EQ.0 .AND. MOD(IY,400).NE.0 )
     :         MTAB(2) = 28

*        Validate day.
            IF ( ID.LT.1 .OR. ID.GT.MTAB(IM) ) J=3

*        Modified Julian Date.
            DJM = DBLE ( ( 1461 * ( IY - (12-IM)/10 + 4712 ) ) / 4
     :               + ( 306 * MOD ( IM+9, 12 ) + 5 ) / 10
     :               - ( 3 * ( ( IY - (12-IM)/10 + 4900 ) / 100 ) ) / 4
     :               + ID - 2399904 )

*        Bad month.
         ELSE
            J=2
         END IF

      END IF

      END


module sub
contains
subroutine matmul(a,b,c,n)
	real(8) a(n,n),b(n,n),c(n,n)
	c=0.d0
	!DIR$ PARALLEL  ALWAYS
	do i=1,n         ! Outer loop is parallelized.
	   do j=1,n      ! inner loops are interchanged
		  do k=1,n   ! new inner loop is vectorized
			 c(j,i)=c(j,i)+a(k,i)*b(j,k)
		  enddo
	   enddo
	enddo
end
end module sub


! ============================================================================
! Name        : main2d_cpml.f90
! Author      : Kei Hasegawa, Kensuke Konishi
! Version     : 0.0.1
! Copyright   : It is Complicated.
! Description : Wave propagation in 2D space.
! ============================================================================
program main2d

  use parameter_2dwave
  use copt2d_cpml
  implicit none

!---------------------------------------------------------------
  include 'declaration.f90'
  call get_arguments
  call read_parameter
  call allocate_main
  call allocate_cpml(NX, NY, NX_CPML_lef,NX_CPML_rig, NY_CPML_btm)

!###########################################################################
  DELTAX = X_size / dble(NX)
  DELTAY = Y_size / dble(NY)
  DELTAT = CFL * min(DELTAX,DELTAY) / maxvp
  NT = int( tlen / DELTAT)

  print *, 'DELTAX = ', DELTAX
  print *, 'DELTAY = ', DELTAY
  print *, 'DELTAT = ', DELTAT

  print *, 'NX = ', NX
  print *, 'NY = ', NY
  print *, 'NT = ', NT
  call output_parameter

  call set_physical_parameters&
    (NX, NY, rho, C, modelfile, header_model)

  if (need_waveform) then

    call set_receiver_info&
      ( num_rec, X_rec, Y_rec, outfname_rec, recinfo )

    allocate( buffer_ux(num_rec,NT), buffer_uy(num_rec,NT) )
    allocate (NX_rec(num_rec), NY_rec(num_rec))
    allocate(inpo_rec(3,3,num_rec))
    call set_reciever_interpolating_function&
      ( NX,NY,num_rec,DELTAX,DELTAY,X_rec,Y_rec,NX_rec,NY_rec,inpo_rec )
  endif

  call make_mask&
    ( NX,NY,rho,MASK_CELL,MASK_NODE,MASK1X,MASK1Y,MASK2X,MASK2Y )

  call compt_inverse_diagonal_mass&
    ( NX,NY,MASK1Y,MASK2X,rho,DELTAT,INV_MASS )

  allocate( wavelet(NT) )
  call calc_Ricker_wavelet&
    ( NT, DELTAT, tp, ts, wavelet )

  if ( source_type_single ) then

    call set_source_interpolating_function_single&
      ( NX,NY,DELTAX,DELTAY,X_source,Y_source,vx,vy,NX_source,NY_source,gx,gy )

  elseif ( source_type_double_couple ) then

    call set_source_interpolating_function_double_couple&
      ( NX,NY,DELTAX,DELTAY,X_source,Y_source,mxx,mxy,myx,myy,NX_source,NY_source,gx,gy )

  else

    stop 'invalid source type'

  endif

  call set_CPML_parameters&
    ( NX,NY,DELTAT,DELTAX,DELTAY, &
      NX_CPML_lef, NX_CPML_rig, NY_CPML_btm, &
      maxvp, reflection_rate, source_freq, NPOWER, &
      a1_lef, a1_rig, a1_btm, &
      b1_lef, b1_rig, b1_btm, &
      a2_lef, a2_rig, a2_btm, &
      b2_lef, b2_rig, b2_btm )

!#######################compute wavefield##########################################
  do itime = 1,NT

!-----------write snapshot-------------------------------------------
    if ( need_snapshot .and. mod(itime, NT_snap) == 0 ) then

      write(*,*) 'itime = ',itime
      write(snap_file,*) itime

      snap_file = 'field_' // ( trim( adjustl(snap_file) ) ) // '.dat'

      call write_snapshot( NX,NY,MASK_NODE,DELTAX,DELTAY,u1x,u1y,snap_file )

    endif
!-----END------------------------------------------------------------

!---save waveforms to buffer arrays----------------------------------
    if ( need_waveform ) then

      do irec = 1,num_rec

        buffer_ux(irec,itime) = sum( &
          u1x( NX_rec(irec)-2:NX_rec(irec), NY_rec(irec)-2:NY_rec(irec) ) &
          * inpo_rec(:,:,irec) )

        buffer_uy(irec,itime) = sum( &
          u1y( NX_rec(irec)-2:NX_rec(irec), NY_rec(irec)-2:NY_rec(irec) ) &
          * inpo_rec(:,:,irec) )

      enddo

    endif
!-------END--------------------------------------------------------

    call compt_traction_force&
      ( NX,NY,MASK1X,MASK1Y,MASK2X,MASK2Y,u1x,u1y,C,DELTAX,DELTAY, &
        NX_CPML_lef, NX_CPML_rig, NY_CPML_btm, &
        a1_lef, a1_rig, a1_btm, &
        b1_lef, b1_rig, b1_btm, &
        a2_lef, a2_rig, a2_btm, &
        b2_lef, b2_rig, b2_btm, &
        dux_dx_lef, duy_dx_lef, &
        dux_dx_rig, duy_dx_rig, &
        dux_dy_btm, duy_dy_btm, &
        dTxx_dx_lef, dTyx_dx_lef, &
        dTxx_dx_rig, dTyx_dx_rig, &
        dTxy_dy_btm, dTyy_dy_btm, &
        mem1_xx_lef, mem1_xy_lef, &
        mem1_xx_rig, mem1_xy_rig, &
        mem1_yx_btm, mem1_yy_btm, &
        mem2_xx_lef, mem2_xy_lef, &
        mem2_xx_rig, mem2_xy_rig, &
        mem2_yx_btm, mem2_yy_btm, &
        u2x,u2y )

    u2x(NX_source-2:NX_source,NY_source-2:NY_source) &
      = u2x(NX_source-2:NX_source,NY_source-2:NY_source) - gx * wavelet(itime)
    u2y(NX_source-2:NX_source,NY_source-2:NY_source) &
      = u2y(NX_source-2:NX_source,NY_source-2:NY_source) - gy * wavelet(itime)

    u2x = - INV_MASS * u2x
    u2y = - INV_MASS * u2y

!----Dirichlet boundary contion----------------------
    u2x(0,:) = 0.d0
    u2y(0,:) = 0.d0

    u2x(NX,:) = 0.d0
    u2y(NX,:) = 0.d0

    u2x(:,0) = 0.d0
    u2y(:,0) = 0.d0
!-------END------------------------------------------

    call compt_corrector_force&
      ( NX,NY,MASK1X,MASK1Y,MASK2X,MASK2Y,u2x,u2y,C,rho,DELTAT,DELTAX,DELTAY, &
        NX_CPML_lef, NX_CPML_rig, NY_CPML_btm, &
        a1_lef, a1_rig, a1_btm, &
        b1_lef, b1_rig, b1_btm, &
        a2_lef, a2_rig, a2_btm, &
        b2_lef, b2_rig, b2_btm, &
        corr_dux_dx_lef, corr_duy_dx_lef, &
        corr_dux_dx_rig, corr_duy_dx_rig, &
        corr_dux_dy_btm, corr_duy_dy_btm, &
        corr_dTxx_dx_lef, corr_dTyx_dx_lef, &
        corr_dTxx_dx_rig, corr_dTyx_dx_rig, &
        corr_dTxy_dy_btm, corr_dTyy_dy_btm, &
        corr_mem1_xx_lef, corr_mem1_xy_lef, &
        corr_mem1_xx_rig, corr_mem1_xy_rig, &
        corr_mem1_yx_btm, corr_mem1_yy_btm, &
        corr_mem2_xx_lef, corr_mem2_xy_lef, &
        corr_mem2_xx_rig, corr_mem2_xy_rig, &
        corr_mem2_yx_btm, corr_mem2_yy_btm, &
        corr_ux,corr_uy )

    corr_ux = - INV_MASS * corr_ux
    corr_uy = - INV_MASS * corr_uy

    u2x = u2x + corr_ux
    u2y = u2y + corr_uy

!----Dirichlet boundary contion----------------------
    u2x(0,:) = 0.d0
    u2y(0,:) = 0.d0

    u2x(NX,:) = 0.d0
    u2y(NX,:) = 0.d0

    u2x(:,0) = 0.d0
    u2y(:,0) = 0.d0
!------END-------------------------------------------

!---Carjan abrorbing boundary condition (optional)---------
    if ( use_Cerjan ) then

      call compt_absorbing_boundary_Cerjan&
        ( NX,NY,u0x,u0y,u1x,u1y,u2x,u2y,N_Cerjan,dumping_rate_Cerjan )

    endif
!----END------------------------------------------------------

    u2x = u2x + 2.d0 * u1x - u0x
    u2y = u2y + 2.d0 * u1y - u0y

    u0x = u1x
    u0y = u1y
    u1x = u2x
    u1y = u2y

  enddo !end of time loop

!------output waveforms-------------------------------------------

  if ( need_waveform ) then

    do irec = 1,num_rec
      open(17,file=outfname_rec(irec),status='replace')

      write (17,*) 0.d0, 0.d0, 0.d0

      do itime = 1,NT

        write(17,fmt=wave_format) DELTAT*dble(itime), buffer_ux(irec,itime), buffer_uy(irec,itime)

      enddo

      close(17)

    enddo

  endif

!----------------------------------------------------------------

contains

!##################################################################################
  subroutine allocate_main
    allocate(MASK_CELL(NX,NY), MASK_NODE(0:NX,0:NY))
    allocate(MASK1X(NX,0:NY), MASK1Y(0:NX,NY))
    allocate(MASK2X(NX,NY), MASK2Y(NX,NY))
    allocate(u0x(0:NX,0:NY), u0y(0:NX,0:NY))
    allocate(u1x(0:NX,0:NY), u1y(0:NX,0:NY))
    allocate(u2x(0:NX,0:NY), u2y(0:NX,0:NY))
    allocate(corr_ux(0:NX,0:NY), corr_uy(0:NX,0:NY))
    allocate(C(3,3,NX,NY), rho(NX,NY))
    allocate(INV_MASS(0:NX,0:NY))
!    allocate(X_rec(num_rec), Y_rec(num_rec))
!    allocate (NX_rec(num_rec), NY_rec(num_rec))
!    allocate(inpo_rec(3,3,num_rec))
!    allocate(outfname_rec(num_rec))

    u0x = 0.d0
    u0y = 0.d0
    u1x = 0.d0
    u1y = 0.d0

  end subroutine allocate_main

  subroutine write_snapshot( NX,NY,MASK_NODE,DELTAX,DELTAY,ux,uy,fname )

    integer, intent(in) :: &
      NX, NY, MASK_NODE(0:NX,0:NY)

    double precision, intent(in) :: &
      DELTAX, DELTAY, &
      ux(0:NX,0:NY), uy(0:NX,0:NY)

    character(*), intent(in) :: &
      fname

    double precision :: X, Y
    integer :: i, j

    open(17,file=fname,status='replace')

    do i = 0,NX

      X = dble(i) * DELTAX

      do j = 0,NY

        Y = dble(j) * DELTAY

        if ( MASK_NODE(i,j) == 1) then

          write(17,fmt=snap_format) X, Y, ux(i,j), uy(i,j)

        endif

      enddo

      write(17,*) ''

    enddo

    close(17)

  end subroutine

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

  subroutine  calc_Ricker_wavelet( NT,DELTAT,tp,ts,wavelet )

    integer, intent(in) :: &
      NT
    double precision, intent(in) :: &
      DELTAT, tp, ts

    double precision, intent(out) :: &
      wavelet(NT)

    double precision, parameter :: PI = 3.1415926535897932d0
    double precision :: t, b
    integer :: i

    do i = 1,NT

      t = dble(i) * DELTAT

      b = PI * (t-ts) / tp

      wavelet(i) = 0.5d0 * sqrt(PI) * (b * b - 0.5d0) * exp( -b * b )

    enddo

  end subroutine

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

  subroutine set_source_interpolating_function_single&
    ( NX,NY,DELTAX,DELTAY,X_source,Y_source,vx,vy,NX_source,NY_source,gx,gy )

    integer, intent(in) :: &
      NX, NY
    double precision, intent(in) :: &
      DELTAX, DELTAY, X_source, Y_source, vx, vy

    integer, intent(out) :: &
      NX_source, NY_source

    double precision, intent(out) :: &
      gx(3,3), gy(3,3)

    integer :: i,j

    double precision :: a, lx(3), ly(3)

    do i = 1,NX

      if ( dble(i-1) * DELTAX < X_source .and. X_source <= dble(i) * DELTAX ) NX_source = i

    enddo

    a = X_source / DELTAX - dble(NX_source - 1)

    lx(1) = a * (a - 1.d0) / 2.d0
    lx(2) = - (a + 1.d0) * (a - 1.d0)
    lx(3) = (a + 1.d0) * a / 2.d0

    do i = 1,NY

      if ( dble(i-1) * DELTAY < Y_source .and. Y_source <= dble(i) * DELTAY ) NY_source = i

    enddo

    a = Y_source / DELTAY - dble(NY_source - 1)

    ly(1) = a * (a - 1.d0) / 2.d0
    ly(2) = - (a + 1.d0) * (a - 1.d0)
    ly(3) = (a + 1.d0) * a / 2.d0

    do i = 1,3
    do j = 1,3

      gx(i,j) = vx * lx(i) * ly(j) / DELTAX / DELTAY
      gy(i,j) = vy * lx(i) * ly(j) / DELTAX / DELTAY

    enddo
    enddo

  end subroutine

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

  subroutine set_source_interpolating_function_double_couple&
    ( NX,NY,DELTAX,DELTAY,X_source,Y_source,mxx,mxy,myx,myy,NX_source,NY_source,gx,gy )

    integer, intent(in) :: &
      NX, NY
    double precision, intent(in) :: &
      DELTAX, DELTAY, X_source, Y_source
    double precision, intent(in) :: &
      mxx, mxy, myx, myy

    integer, intent(out) :: &
      NX_source, NY_source

    double precision, intent(out) :: &
      gx(3,3), gy(3,3)

    integer :: i,j

    double precision :: a, lx(3), ly(3), dlx(3), dly(3)

    do i = 1,NX

      if ( dble(i-1) * DELTAX < X_source .and. X_source <= dble(i) * DELTAX ) NX_source = i

    enddo

    a = X_source / DELTAX - dble(NX_source - 1)

    lx(1) = a * (a - 1.d0) / 2.d0
    lx(2) = - (a + 1.d0) * (a - 1.d0)
    lx(3) = (a + 1.d0) * a / 2.d0

    dlx(1) = ( 2.0d0 * a - 1.0d0 ) / 2.0d0 / DELTAX
    dlx(2) = - 2.0d0 * a / DELTAX
    dlx(3) = ( 2.0d0 * a + 1.0d0 ) / 2.0d0 / DELTAX

    do i = 1,NY

      if ( dble(i-1) * DELTAY < Y_source .and. Y_source <= dble(i) * DELTAY ) NY_source = i

    enddo

    a = Y_source / DELTAY - dble(NY_source - 1)

    ly(1) = a * (a - 1.d0) / 2.d0
    ly(2) = - (a + 1.d0) * (a - 1.d0)
    ly(3) = (a + 1.d0) * a / 2.d0

    dly(1) = ( 2.0d0 * a - 1.0d0 ) / 2.0d0 / DELTAY
    dly(2) = - 2.0d0 * a / DELTAY
    dly(3) = ( 2.0d0 * a + 1.0d0 ) / 2.0d0 / DELTAY

    do i = 1,3
    do j = 1,3

      gx(i,j) = mxx * dlx(i) * ly(j) + mxy * lx(i) * dly(j)
      gy(i,j) = myx * dlx(i) * ly(j) + myy * lx(i) * dly(j)

    enddo
    enddo

    gx = gx / DELTAX / DELTAY
    gy = gy / DELTAX / DELTAY

  end subroutine

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

  subroutine set_reciever_interpolating_function&
    ( NX,NY,num_rec,DELTAX,DELTAY,X_rec,Y_rec,NX_rec,NY_rec,inpo_rec )

    integer, intent(in) :: &
      NX, NY, num_rec
    double precision, intent(in) :: &
      DELTAX, DELTAY, X_rec(num_rec), Y_rec(num_rec)

    integer, intent(out) :: &
      NX_rec(num_rec), NY_rec(num_rec)

    double precision, intent(out) :: &
      inpo_rec(3,3,num_rec)

    integer :: i, j, irec

    double precision :: a, lx(3), ly(3)

    do irec = 1,num_rec

      do i = 1,NX

        if ( dble(i-1) * DELTAX < X_rec(irec) .and. X_rec(irec) <= dble(i) * DELTAX ) NX_rec(irec) = i

      enddo

      a = X_rec(irec) / DELTAX - dble(NX_rec(irec) - 1)

      lx(1) = a * (a - 1.d0) / 2.d0
      lx(2) = - (a + 1.d0) * (a - 1.d0)
      lx(3) = (a + 1.d0) * a / 2.d0

      do i = 1,NY

        if ( dble(i-1) * DELTAY < Y_rec(irec) .and. Y_rec(irec) <= dble(i) * DELTAY ) NY_rec(irec) = i

      enddo

      a = Y_rec(irec) / DELTAY - dble(NY_rec(irec) - 1)

      ly(1) = a * (a - 1.d0) / 2.d0
      ly(2) = - (a + 1.d0) * (a - 1.d0)
      ly(3) = (a + 1.d0) * a / 2.d0

      do i = 1,3
      do j = 1,3

        inpo_rec(i,j,irec) = lx(i) * ly(j)

      enddo
      enddo

    enddo

  end subroutine set_reciever_interpolating_function
!##################################################################################

  subroutine compt_absorbing_boundary_Cerjan&
    ( NX,NY,u0x,u0y,u1x,u1y,u2x,u2y,N_Cerjan,dumping_rate_Cerjan )

    integer, intent(in) :: &
      NX, NY, N_Cerjan
    double precision, intent(in) :: &
      dumping_rate_Cerjan

    double precision, dimension(0:NX,0:NY), intent(inout) :: &
      u0x, u0y, u1x, u1y, u2x, u2y

    double precision :: r

    integer :: i, j

    do i = 0, N_Cerjan

      r = dble( N_Cerjan - i )
      r = exp( - dumping_rate_Cerjan * dumping_rate_Cerjan * r * r )

      u0x(i,:) = u0x(i,:) * r
      u0y(i,:) = u0y(i,:) * r
      u1x(i,:) = u1x(i,:) * r
      u1y(i,:) = u1y(i,:) * r
      u2x(i,:) = u2x(i,:) * r
      u2y(i,:) = u2y(i,:) * r

      j = NX - j

      u0x(j,:) = u0x(j,:) * r
      u0y(j,:) = u0y(j,:) * r
      u1x(j,:) = u1x(j,:) * r
      u1y(j,:) = u1y(j,:) * r
      u2x(j,:) = u2x(j,:) * r
      u2y(j,:) = u2y(j,:) * r

    enddo

    do i = 0, N_Cerjan

      r = dble( N_Cerjan - i )
      r = exp( - dumping_rate_Cerjan * dumping_rate_Cerjan * r * r )

      u0x(:,i) = u0x(:,i) * r
      u0y(:,i) = u0y(:,i) * r
      u1x(:,i) = u1x(:,i) * r
      u1y(:,i) = u1y(:,i) * r
      u2x(:,i) = u2x(:,i) * r
      u2y(:,i) = u2y(:,i) * r

    enddo

  end subroutine

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

  subroutine make_mask&
    ( NX,NY,rho,MASK_CELL,MASK_NODE,MASK1X,MASK1Y,MASK2X,MASK2Y )

    integer, intent(in) :: &
      NX, NY

    double precision, intent(in) :: &
      rho(NX,NY)

    integer, intent(out) :: &
      MASK_CELL(NX,NY), &
      MASK_NODE(0:NX,0:NY), &
      MASK1X(NX,0:NY), MASK1Y(0:NX,NY), &
      MASK2X(NX,NY), MASK2Y(NX,NY)

    integer :: i, j

! making masks for cells and nodes
    MASK_CELL = 0
    MASK_NODE = 0

    do j = 1,NY
    do i = 1,NX

      if ( rho(i,j) > 0.d0 ) then

        MASK_CELL(i,j) = 1

        MASK_NODE(i-1,j-1) = 1
        MASK_NODE(i-1,j) = 1
        MASK_NODE(i,j-1) = 1
        MASK_NODE(i,j) = 1

      end if

    enddo
    enddo

! making MASK1X
    MASK1X = 0

    do j = 0,NY
    do i = 1,NX

      if ( MASK_NODE(i-1,j) == 1 .and. MASK_NODE(i,j) == 1 ) MASK1X(i,j) = 1
      if ( i == NX ) cycle
      if ( MASK1X(i,j) == 1 .and. MASK_NODE(i+1,j) == 1 ) MASK1X(i,j) = 2

    enddo
    enddo

! making MASK2Y
    MASK2Y = 0

    do j = 1,NY
    do i = 1,NX

      if ( MASK_CELL(i,j) == 1 ) MASK2Y(i,j) = 1
      if ( j == NY ) cycle
      if ( MASK2Y(i,j) == 1 .and. MASK_CELL(i,j+1) == 1 ) MASK2Y(i,j) = 2

    enddo
    enddo

! making MASK1Y
    MASK1Y = 0

    do j = 1,NY
    do i = 0,NX

      if ( MASK_NODE(i,j-1) == 1 .and. MASK_NODE(i,j) == 1 ) MASK1Y(i,j) = 1
      if ( j== NY ) cycle
      if ( MASK1Y(i,j) == 1 .and. MASK_NODE(i,j+1) == 1 ) MASK1Y(i,j) = 2

    enddo
    enddo

! making MASK2X
    MASK2X = 0

    do j = 1,NY
    do i = 1,NX

      if (MASK_CELL(i,j) == 1 ) MASK2X(i,j) = 1
      if ( i == NX ) cycle
      if ( MASK2X(i,j) == 1 .and. MASK_CELL(i+1,j) == 1 ) MASK2X(i,j) = 2

    enddo
    enddo

  end subroutine

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

  subroutine set_physical_parameters&
    ( NX,NY,rho,C,model_csv,header )

    integer, intent(in) :: &
      NX, NY

    character(*), intent(in) :: &
      model_csv

    logical, intent(in) :: &
      header

    double precision, intent(out) :: &
      rho(NX,NY), C(3,3,NX,NY)

    double precision :: &
      density, vp, vs, mu, lambda, elas(3,3)

    integer :: &
      iline, ix, iy, i, j

    rho = - 80704.d0

    open (17, file=model_csv, status='old')

    if ( header ) read (17, '()')  !skip header

    do iline = 1, NX*NY

      read (17, *) ix, iy, density, vp, vs

      mu = density * vs * vs
      lambda = density * ( vp * vp - 2.d0 * vs * vs )

      elas = 0.d0

      do i = 1,2

        elas(i,i) = mu

        do j = 1,2

          elas(i,j) = elas(i,j) + lambda

        enddo

      enddo

      do i = 1,3

        elas(i,i) = elas(i,i) + mu

      enddo

      rho(ix,iy) = density
      C(:,:,ix,iy) = elas(:,:)

    enddo

    close (17)

!--check if csv is correctly inputted----
    do ix = 1,NX
    do iy = 1,NY

        if ( rho(ix,iy) < 0.d0 .or. &
             rho(1,iy) <= 1.d-10 .or. &
             rho(NX,iy) <= 1.d-10 .or. &
             rho(ix,1) <= 1.d-10 ) stop 'this model is invalid'

    enddo
    enddo

!----END-------------------------------

  end subroutine

!##################################################################################
  subroutine set_receiver_info&
   ( num_rec, X_rec, Y_rec, outfname_rec, recinfo )
    implicit none
    character(*), intent(in) :: recinfo

    integer, intent(out) :: num_rec

    double precision,allocatable, intent(out) :: &
      X_rec(:), Y_rec(:)

    character(100),allocatable, intent(out) :: &
      outfname_rec(:)

    character(1024) buffer
    integer :: iline, io, name_length

!    X_rec = - 80704.d0

    open (17, file=recinfo, status='old')
    num_rec =0
!    if ( header ) read (17, '()')  !skip header
    do
      read(17,'(a)',iostat=io) buffer
      buffer = adjustl(buffer)
      name_length = index(buffer,',')
      buffer = buffer(1:1)
      if(buffer =='#' .or. buffer == '!') cycle
      if (io/=0) exit
      if(name_length ==0) stop 'Something wrong.'
      if(name_length >101) stop 'Each length of each output path must be less than 100 characters.'
      num_rec = num_rec + 1
    enddo
    allocate(outfname_rec(num_rec))
    allocate(X_rec(num_rec), Y_rec(num_rec))
    rewind(17)
    iline =1
    do
      read (17,'(a)', iostat = io) buffer
      if (io/=0) exit
      buffer = adjustl(buffer)
      if(buffer(1:1) =='#' .or. buffer(1:1) == '!') cycle
      buffer = trim(buffer)
      read (buffer,*) outfname_rec(iline), X_rec(iline), Y_rec(iline)
      outfname_rec(iline) = trim(adjustl(outfname_rec(iline)))
      if ( X_rec(iline) < 0.d0 .or. Y_rec(iline) <0) stop 'reciever info file is invalid'
      iline = iline +1
    enddo
    close (17)

  end subroutine set_receiver_info

end program


      SUBROUTINE MB03QW( N, L, A, LDA, E, LDE, U, LDU, V, LDV,
     $                   ALPHAR, ALPHAI, BETA, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a selected 2-by-2 diagonal block
C     pair of an upper quasi-triangular pencil, to reduce the selected
C     block pair to the standard form and to split it in the case of
C     real eigenvalues, by constructing orthogonal matrices UT and VT.
C     The transformations UT and VT are applied to the pair (A,E) by
C     computing (UT'*A*VT, UT'*E*VT ), to the matrices U and V,
C     by computing U*UT and V*VT.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, E, UT and VT.  N >= 2.
C
C     L       (input) INTEGER
C             Specifies the position of the block.  1 <= L < N.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper quasi-triangular matrix A whose
C             selected 2-by-2 diagonal block is to be processed.
C             On exit, the leading N-by-N part of this array contains
C             the upper quasi-triangular matrix A after its selected
C             block has been split and/or put in the LAPACK standard
C             form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= N.
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper triangular matrix E whose selected
C             2-by-2 diagonal block is to be processed.
C             On exit, the leading N-by-N part of this array contains
C             the transformed upper triangular matrix E (in the LAPACK
C             standard form).
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= N.
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
C             On entry, the leading N-by-N part of this array must
C             contain a transformation matrix U.
C             On exit, the leading N-by-N part of this array contains
C             U*UT, where UT is the transformation matrix used to
C             split and/or standardize the selected block pair.
C
C     LDU     INTEGER
C             The leading dimension of the array U.  LDU >= N.
C
C     V       (input/output) DOUBLE PRECISION array, dimension (LDV,N)
C             On entry, the leading N-by-N part of this array must
C             contain a transformation matrix V.
C             On exit, the leading N-by-N part of this array contains
C             V*VT, where VT is the transformation matrix used to
C             split and/or standardize the selected block pair.
C
C     LDV     INTEGER
C             The leading dimension of the array V.  LDV >= N.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (2)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (2)
C     BETA    (output) DOUBLE PRECISION array, dimension (2)
C             (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
C             block pair of the pencil (A,B), k=1,2, i = sqrt(-1).
C             Note that BETA(k) may be zero.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Let A1 = ( A(L,L)    A(L,L+1)   ), E1 = ( E(L,L)    E(L,L+1)   ),
C              ( A(L+1,L)  A(L+1,L+1) )       ( E(L+1,L)  E(L+1,L+1) )
C     be the specified 2-by-2 diagonal block pair of the pencil (A,B).
C     If the eigenvalues of (A1,E1) are complex, then they are computed
C     and stored in ER and EI, where the real part is stored in ER and
C     the positive imaginary part in EI. The 2-by-2 block pair is
C     reduced if necessary to the standard form, such that
C     A(L,L) = A(L+1,L+1), and A(L,L+1) and A(L+1,L) have oposite signs.
C     If the eigenvalues are real, the 2-by-2 block pair is reduced to
C     upper triangular form such that ABS(A(L,L)) >= ABS(A(L+1,L+1)).
C     In both cases, an orthogonal rotation U1' is constructed such that
C     U1'*A1*U1 has the appropriate form. Let UT be an extension of U1
C     to an N-by-N orthogonal matrix, using identity submatrices. Then A
C     and E are replaced by UT'*A*UT and UT'*E*UT, and the contents of
C     the arrays U and V are U * UT and V * VT, respectively.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     March 1998. Based on the RASP routine SPLITB.
C
C     REVISIONS
C
C     V. Sima, Dec. 2016.
C
C     KEYWORDS
C
C     Eigenvalues, orthogonal transformation, real Schur form,
C     equivalence transformation.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER          INFO, L, LDA, LDE, LDU, LDV, N
      DOUBLE PRECISION ALPHAI(*), ALPHAR(*), BETA(*)
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), E(LDE,*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      INTEGER          L1
      DOUBLE PRECISION CSL, CSR, SNL, SNR
C     .. External Subroutines ..
      EXTERNAL         DLAGV2, DROT, XERBLA
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.2 ) THEN
         INFO = -1
      ELSE IF( L.LT.1 .OR. L.GE.N ) THEN
         INFO = -2
      ELSE IF( LDA.LT.N ) THEN
         INFO = -4
      ELSE IF( LDE.LT.N ) THEN
         INFO = -6
      ELSE IF( LDU.LT.N ) THEN
         INFO = -8
      ELSE IF( LDV.LT.N ) THEN
         INFO = -10
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03QW', -INFO )
         RETURN
      END IF
C
C     Compute the generalized eigenvalues and the elements of the Givens
C     transformations.
C
      L1 = L + 1
      CALL DLAGV2( A(L,L), LDA, E(L,L), LDE, ALPHAR, ALPHAI, BETA,
     $             CSL, SNL, CSR, SNR )
C
C     Apply the transformations to A and E.
C
      IF( L1.LT.N ) THEN
         CALL DROT( N-L1, A(L,L1+1), LDA, A(L1,L1+1), LDA, CSL, SNL )
         CALL DROT( N-L1, E(L,L1+1), LDE, E(L1,L1+1), LDE, CSL, SNL )
      END IF
      CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CSR, SNR )
      CALL DROT( L-1, E(1,L), 1, E(1,L1), 1, CSR, SNR )
C
C     Accumulate the transformations in U and V.
C
      CALL DROT( N, U(1,L), 1, U(1,L1), 1, CSL, SNL )
      CALL DROT( N, V(1,L), 1, V(1,L1), 1, CSR, SNR )
C
      RETURN
C *** Last line of MB03QW ***
      END