MODULE SOI_doubling

	USE Type_Kinds, only : fpk => fp_kind

IMPLICIT NONE

    INTEGER, PUBLIC, PARAMETER  ::  ndoub_max = 13
    INTEGER, PUBLIC, PARAMETER  ::  nstrm_max = 3
	INTEGER, PUBLIC, PARAMETER	::	nlay_max = 100
    REAL(fpk), PUBLIC, SAVE     ::  R_store( nstrm_max, nstrm_max, nlay_max, 0:ndoub_max )
    REAL(fpk), PUBLIC, SAVE     ::  T_store( nstrm_max, nstrm_max, nlay_max, 0:ndoub_max )
    REAL(fpk), PUBLIC, SAVE     ::  Y_store( nstrm_max, nlay_max, 0:ndoub_max )
    REAL(fpk), PUBLIC, SAVE     ::  Z_store( nstrm_max, nlay_max, 0:ndoub_max )
    REAL(fpk), PUBLIC, SAVE     ::  RT_store( nstrm_max, nlay_max )

	REAL, PRIVATE, PARAMETER	:: ONE = 1.0_fpk
	REAL, PRIVATE, PARAMETER	:: TWO = 2.0_fpk
	REAL, PRIVATE, PARAMETER	:: HALF = 0.5_fpk
	REAL, PRIVATE, PARAMETER	:: FOUR = 4.0_fpk
	REAL, PRIVATE, PARAMETER	:: ZERO = 0.0_fpk
	REAL, PRIVATE, PARAMETER	:: SSA_CUTOFF = 0.65_fpk

PUBLIC ::	truncated_doubling, &
			truncated_doubling_TL, &
			truncated_doubling_AD, &
			Gamma_Matrix, &
           Gamma_Matrix_TL, &
           Gamma_Matrix_AD

PRIVATE :: outer_prod

CONTAINS

    SUBROUTINE TRUNCATED_DOUBLING(  ilay,   &   ! Input, Layer number (needed for adjoint)
									k,      &   ! Input, Number of Doublings to Perform
                                    tau,    &   ! Input, Extinction optical depth of the layer
                                    wo,     &   ! Input, Single Scatter Albedo of the layer
                                    Pp,     &   ! Input, Forward-Scattering Phase Function
                                    Pm,     &   ! Input, Backward-Scattering Phase Function
                                    mu,     &   ! Input, Array of quadrature points
                                    w,      &   ! Input, Array of quadrature weights
                                    Bo,     &   ! Input, Planck Radiance of lower boundary
                                    Bn,     &   ! Input, Planck Radiance of upper boundary
                                    R,      &   ! Output, Reflection matrix
                                    T,      &   ! Output, Scattering Transmission matrix
                                    Sp,     &   ! Upwelling source function (including scattering)
                                    Sm,     &    ! Downwelling source funtion (including scattering)
									method )

    ! Arguments
		integer, intent(in) 	:: ilay
        integer, intent(inout) :: k
        REAL(fpk), dimension(:,:),intent(in):: Pp,Pm
        REAL(fpk), dimension(:),intent(in):: mu,w
        REAL(fpk), intent(in):: tau,wo,Bo,Bn
        REAL(fpk), dimension(:,:),intent(out) :: R,T
        REAL(fpk), dimension(:),intent(out):: Sp,Sm
		integer, intent(in), optional :: method

    ! Local Variables
        REAL(fpk), dimension(size(mu),size(mu))  ::  E,A,B, Gamma
        REAL(fpk)                                ::  Bd, delta_tau,g, m
        REAL(fpk), dimension(size(mu))           ::  Y,Z, RT, trans
        integer                             :: i,j,l,npts
		integer 							:: imethod

		if (.NOT. PRESENT(method)) then
			if ( (wo > SSA_CUTOFF) ) then
				imethod = 1
			else
				imethod = 2
			endif
		else
			imethod = method
		endif

		if (k > ndoub_max) k = ndoub_max ! do not exceed maximum number of doublings
        npts = size(mu)
        delta_tau = tau/(2**k)

    !--- slope of blackbody emission through layer
        Bd = (Bn - Bo) / tau

    !--  for the first layer, initialize with a thin layer approximation

	! This section gets the difference in up and downwelling source correct.
        do i = 1,npts
			trans(i) = exp(-delta_tau/mu(i))

			if (delta_tau/mu(i) < 0.2_fpk) then
			Z(i) = delta_tau * delta_tau / mu(i) / 12.0_fpk * (ONE-wo)*(ONE-trans(i))
			else
			Z(i) = (ONE-wo)*delta_tau*(trans(i) + (ONE-trans(i))*(HALF - mu(i)/delta_tau))
			endif

		    do j = 1, npts
              E(i,j) = ZERO
              if (i == j) E(i,j) = ONE
            enddo
       enddo

		select case(imethod)
		case(1) ! O'DELL (EIGI) initialization
        do i = 1, npts
            do j = 1, npts
                R(i,j) = wo * Pm(i,j) * w(j) * (ONE-trans(i))
				T(i,j) = E(i,j)*trans(i) + wo*Pp(i,j)*w(j)*(ONE-trans(i))
            enddo
            Y(i) = (ONE-wo) * (ONE - trans(i))
        enddo
		case(2)  ! Single Scatter Initialization with Tdirect determined from energy conservation
		do i = 1, npts
			RT(i) = ZERO
            do j = 1, npts
				m = mu(j) / ( mu(i) + mu(j) )
			    R(i,j) = wo * Pm(i,j) * w(j) * m *(ONE-exp(-delta_tau/(m*mu(i))))
        	 	if (i == j) then
        	    	T(i,j) = wo*Pp(i,j)*w(j) * delta_tau/mu(i) * trans(i)
        	 	else
        	    	T(i,j) = wo*Pp(i,j)*w(j) * mu(j)/(mu(j)-mu(i))*(exp(-delta_tau/mu(j)) - trans(i))
        	 	end if
			  	RT(i) = RT(i) + R(i,j) + T(i,j)
			enddo
			Y(i) = (ONE-wo*wo)*(ONE - trans(i)) - (ONE-wo)*RT(i)
			T(i,i) = T(i,i) + ONE - Y(i) - RT(i)
			RT_store(i,ilay) = RT(i) ! store for adjoint calculation
		enddo

		end select

        g = delta_tau / 4.0_fpk

!	store initial matrices (needed for adjoint)
	R_store(:, :, ilay, 0) = R
	T_store(:, :, ilay, 0) = T
	Y_store(:, ilay, 0) = Y
	Z_store(:, ilay, 0) = Z

    !-- if there is doubling, perform doubling
        do l = 1, k
            g = g * TWO
			CALL Gamma_Matrix(R, g, Gamma)

			A = matmul(T, Gamma)
            B = matmul(A , R)

            R = matmul(B , T) + R
            T = matmul(A , T)
            Z = Z + g*Y + matmul((A - B) , (Z - g*Y))
            Y = matmul((A + B + E) , Y)

			! store matrices for each iteration (needed for adjoint)
	    	R_store( :, :, ilay, l ) = R
			if (l < k) T_store(:, :, ilay, l ) = T
			Y_store(:, ilay, l) = Y
			Z_store(:, ilay, l) = Z
        end do

    !  finish thermal source computation
        Sp = HALF*(Bo + Bn)*Y + Bd*Z
        Sm = HALF*(Bo + Bn)*Y - Bd*Z

    !---------- subtract off direct transmission from total Transmission Matrix
        do i = 1,npts
            T(i,i) = T(i,i) - exp(-tau/mu(i))
        end do
		T_store(:, :, ilay, k ) = T

    END SUBROUTINE TRUNCATED_DOUBLING

    SUBROUTINE TRUNCATED_DOUBLING_TL(  k,      &   ! Input, Number of Doublings to Perform
                                    tau,    &   ! Input, Extinction optical depth of the layer
                                    wo,     &   ! Input, Single Scatter Albedo of the layer
                                    Pp,     &   ! Input, Forward-Scattering Phase Function
                                    Pm,     &   ! Input, Backward-Scattering Phase Function
                                    mu,     &   ! Input, Array of quadrature points
                                    w,      &   ! Input, Array of quadrature weights
                                    Bo,     &   ! Input, Planck Radiance of lower boundary
                                    Bn,     &   ! Input, Planck Radiance of upper boundary
                                    tau_TL,    &   ! Input, Extinction optical depth of the layer
                                    wo_TL,     &   ! Input, Single Scatter Albedo of the layer
                                    Pp_TL,     &   ! Input, Forward-Scattering Phase Function
                                    Pm_TL,     &   ! Input, Backward-Scattering Phase Function
                                    Bo_TL,     &   ! Input, Planck Radiance of lower boundary
                                    Bn_TL,     &   ! Input, Planck Radiance of upper boundary
                                    R,      &   ! Output, Reflection matrix
                                    T,      &   ! Output, Scattering Transmission matrix
                                    Sp,     &   ! Upwelling source function (including scattering)
                                    Sm,     &    ! Downwelling source funtion (including scattering)
                                    R_TL,      &   ! Output, Reflection matrix
                                    T_TL,      &   ! Output, Scattering Transmission matrix
                                    Sp_TL,     &   ! Upwelling source function (including scattering)
                                    Sm_TL,     &    ! Downwelling source funtion (including scattering)
									method )

    ! Arguments
        integer, intent(inout) :: k
        REAL(fpk), dimension(:,:),intent(in):: Pp,Pm
        REAL(fpk), dimension(:),intent(in):: mu,w
        REAL(fpk), intent(in):: tau,wo,Bo,Bn
		REAL(fpk), intent(in):: tau_TL, wo_TL, Bo_TL, Bn_TL
        REAL(fpk), dimension(:,:),intent(in):: Pp_TL,Pm_TL
        REAL(fpk), dimension(:,:),intent(out):: R, T, R_TL, T_TL
        REAL(fpk), dimension(:),intent(out):: Sp, Sm, Sp_TL,Sm_TL
		integer, intent(in), optional :: method

    ! Local Variables
        REAL(fpk), dimension(size(mu),size(mu))  :: E,A,B, Gamma, Gamma_TL, A_TL, B_TL
        REAL(fpk)                                ::  Bd, delta_tau,g, m, etemp, etemp2
		REAL(fpk)								 ::  g_TL, delta_tau_TL, Bd_TL
        REAL(fpk), dimension(size(mu))           :: Y,Z, RT, trans
		REAL(fpk), dimension(size(mu))			 :: Y_TL, Z_TL, RT_TL, trans_TL
        integer                             :: i,j,l,npts
		integer 							:: imethod

		if (.NOT. PRESENT(method)) then
			if ( (wo > SSA_CUTOFF) ) then
				imethod = 1
			else
				imethod = 2
			endif
		else
			imethod = method
		endif

		if (k > ndoub_max) k = ndoub_max ! do not exceed maximum number of doublings
        npts = size(mu)

        delta_tau = tau/(2**k)
		delta_tau_TL = tau_TL / (2**k)

    !--- slope of blackbody emission through layer
        Bd = (Bn - Bo) / tau
		Bd_TL = ( tau*(Bn_TL - Bo_TL) - (Bn-Bo)*tau_TL ) / (tau*tau)

    !--  for the first layer, initialize with a thin layer approximation

	! This section gets the difference in up and downwelling source correct.
        do i = 1,npts
			trans(i) = exp(-delta_tau/mu(i))
			trans_TL(i) = -delta_tau_TL * trans(i) / mu(i)

			if (delta_tau/mu(i) < 0.2_fpk) then
			Z_TL(i) = ONE/(mu(i)*12.0_fpk)*( 2*delta_tau*delta_tau_TL* (ONE-wo)*(ONE-trans(i)) &
				  - delta_tau*delta_tau* ( wo_TL * (ONE-trans(i)) + (ONE-wo)*trans_TL(i)) )
			Z(i) = delta_tau * delta_tau / mu(i) / 12.0_fpk * (ONE-wo)*(ONE-trans(i))
			else
			Z_TL(i) = (-wo_TL*delta_tau + (ONE-wo)*delta_tau_TL) * &
    			  (trans(i) + (ONE-trans(i))*(HALF - mu(i)/delta_tau)) + &
    			  (ONE-wo)*delta_tau*(trans_TL(i)*(HALF + mu(i)/delta_tau) + &
    			  (ONE-trans(i))*mu(i)/(delta_tau**2)*delta_tau_TL )
			Z(i) = (ONE-wo)*delta_tau*(trans(i) + (ONE-trans(i))*(HALF - mu(i)/delta_tau))
			endif

		    do j = 1, npts
              E(i,j) = ZERO
              if (i == j) E(i,j) = ONE
            enddo
        enddo

		select case(imethod)
		case(1) ! O'DELL (EIGI) initialization
    	do i = 1,npts
    	  do j = 1, npts
			 R_TL(i,j) = wo_TL * Pm(i,j) * w(j) * (ONE-trans(i)) &
	            		 + Pm_TL(i,j) * wo * w(j) * (ONE-trans(i)) &
	            		 - trans_TL(i) * wo * Pm(i,j) * w(j)

			 R(i,j) = wo * Pm(i,j) * w(j) * (ONE-trans(i))

	    	 T_TL(i,j) = E(i,j)*trans_TL(i) + &
                         wo_TL*Pp(i,j)*w(j)*(ONE-trans(i)) &
		               + wo*Pp_TL(i,j)*w(j)*(ONE-trans(i)) &
		               - trans_TL(i)*wo*Pp(i,j)*w(j)

        	 T(i,j) = E(i,j)*trans(i) + wo*Pp(i,j)*w(j)*(ONE-trans(i))
    	  enddo
    	  Y_TL(i) = -wo_TL * (ONE - trans(i)) - trans_TL(i) * (ONE - wo)
    	  Y(i) = (ONE - wo) * (ONE - trans(i))
        enddo

		case(2)  ! Single Scatter Initialization with Tdirect determined from energy conservation
		do i = 1, npts
			RT(i) = ZERO
            RT_TL(i) = ZERO
            do j = 1, npts
				m = mu(j) / ( mu(i) + mu(j) )
				etemp = exp(-delta_tau/(m*mu(i)))
				etemp2 = w(j) * m * (ONE - etemp)
				R(i,j) = wo * Pm(i,j) * etemp2
			    R_TL(i,j) = wo_TL * Pm(i,j) * etemp2 + wo * Pm_TL(i,j) * etemp2 + wo*Pm(i,j)*w(j)*m* etemp * delta_tau_TL/(m*mu(i))

        	 	if (i == j) then
        	    	T(i,j) = wo*Pp(i,j)*w(j) * delta_tau/mu(i) * trans(i)
					T_TL(i,j) = (wo_TL*Pp(i,j)+wo*Pp_TL(i,j))*w(j) * delta_tau/mu(i) * trans(i) + &
							    wo*Pp(i,j)*w(j)/mu(i) * ( delta_tau_TL * trans(i) + delta_tau * trans_TL(i))
        	 	else
					etemp = exp(-delta_tau/mu(j))
					T(i,j) = wo*Pp(i,j)*w(j) * mu(j)/(mu(j)-mu(i))*(etemp - trans(i))
        	    	T_TL(i,j) = w(j) * mu(j)/(mu(j)-mu(i)) * &
							( (wo_TL*Pp(i,j) + wo*Pp_TL(i,j))*(etemp - trans(i)) - &
							wo*Pp(i,j)*(delta_tau_TL/mu(j)*etemp + trans_TL(i)) )
        	 	end if
			  	RT(i) = RT(i) + R(i,j) + T(i,j)
				RT_TL(i) = RT_TL(i) + R_TL(i,j) + T_TL(i,j)
			enddo
			Y_TL(i) = -2*wo*wo_TL*(ONE - trans(i)) - (ONE-wo*wo)*trans_TL(i) + wo_TL*RT(i) - (ONE-wo)*RT_TL(i)
			Y(i) = (ONE-wo*wo)*(ONE - trans(i)) - (ONE-wo)*RT(i)
			T_TL(i,i) = T_TL(i,i) - Y_TL(i) - RT_TL(i)
			T(i,i) = T(i,i) + ONE - Y(i) - RT(i)
		enddo

		end select

        g = delta_tau / 4.0_fpk
		g_TL = delta_tau_TL / 4.0_fpk

    !-- if there is doubling, perform doubling
        do l = 1, k
            g = g * TWO
			g_TL = g_TL * TWO
			Call Gamma_Matrix(R, g, Gamma)
			Call Gamma_Matrix_TL(R, Gamma, g, R_TL, Gamma_TL)

			A_TL = matmul(T_TL,Gamma) + matmul(T,Gamma_TL)
			A = matmul(T, Gamma)

			B_TL =matmul(A_TL, R) + matmul(A, R_TL)
            B = matmul(A, R)

			R_TL = matmul(B_TL, T) + matmul(B, T_TL) + R_TL
            R = matmul(B, T) + R

			T_TL = matmul(A_TL, T) + matmul(A, T_TL)
            T = matmul(A, T)

			Z_TL = Z_TL + g_TL*Y + g*Y_TL + matmul((A_TL - B_TL) , (Z - g*Y)) + matmul((A-B),(Z_TL-g_TL*Y-g*Y_TL))
            Z = Z + g*Y + matmul((A - B), (Z - g*Y))

			Y_TL = matmul((A_TL + B_TL) , Y) + matmul((A+B+E),Y_TL)
            Y = matmul((A + B + E) , Y)
        end do

    !  finish thermal source computation
		Sp_TL = HALF*((Bo_TL+Bn_TL)*Y + (Bo+Bn)*Y_TL)
		Sm_TL = Sp_TL - Bd_TL*Z - Bd*Z_TL
		Sp_TL = Sp_TL + Bd_TL*Z + Bd*Z_TL
		Sp = HALF*(Bo + Bn)*Y
        Sm = Sp - Bd*Z
		Sp = Sp + Bd*Z
    !---------- subtract off direct transmission from total Transmission Matrix
        do i = 1,npts
			etemp = exp(-tau/mu(i))
            T(i,i) = T(i,i) - etemp
			T_TL(i,i) = T_TL(i,i) + etemp*tau_TL/mu(i)
        end do

    END SUBROUTINE TRUNCATED_DOUBLING_TL

SUBROUTINE truncated_doubling_AD(ilay,  &   ! Input: Layer index
                                 k,     &   ! Input: Number of doubling steps
                                 tau,   &   ! Input: Optical depth of layer
                                 wo,    &   ! Input: Single scatter albedo
                                 Pp,    &   ! Input: Forward scattering phase matrix
                                 Pm,    &   ! Input: Backward scattering phase matrix
                                 mu,    &   ! Input: Quadrature points
                                 w,     &   ! Input: Quadrature weights
                                 Bo,    &   ! Input: Emission (temperature) at top of layer
                                 Bn,    &   ! Input: Emission (temperature) at bottom of layer
                                 tau_AD, &   ! Output: Adjoint of tau
                                 wo_AD,  &   ! Output: Adjoint of ssalb
                                 Pp_AD,  &   ! Output: Adjoint of Pp
                                 Pm_AD,  &   ! Output: Adjoint of Pm
                                 Bo_AD,  &   ! Output: Adjoint of Bo
                                 Bn_AD,  &   ! Output: Adjoint of Bn
                                 R_AD,   &   ! Input: Adjoint forcing for R
                                 T_AD,  &   ! Input: Adjoint forcing for Ts
                                 Sp_AD,  &   ! Input: Adjoint forcing for Sp
                                 Sm_AD,  &     ! Input: Adjoint forcing for Sm
								 method )

!
!------------------------------------------------------------------------------
!   Adjoint model for the truncated doubling algorithm. Uses R/T matrix values
!   stored from forward run.
!
!   Written by Chris O'Dell
!
!  NOTE: 	It is up to the user to pre-set all in/out adjoint values to whatever they like (ie, 0)
!------------------------------------------------------------------------------

!--------------------
! Define arguments
!--------------------
        INTEGER, INTENT( in )							:: ilay
        INTEGER, INTENT( in )                 	  		:: k
        REAL(fpk), DIMENSION( :, : ), INTENT( in )      :: Pp
        REAL(fpk), DIMENSION( :, : ), INTENT( in )		:: Pm
        REAL(fpk), DIMENSION( : ), INTENT( in )       	:: mu
        REAL(fpk), DIMENSION( : ), INTENT( in )      	:: w
        REAL(fpk), INTENT( in )                   		:: tau
        REAL(fpk), INTENT( in )                     	:: wo
        REAL(fpk), INTENT( in )						  	:: Bo
        REAL(fpk), INTENT( in )                    		:: Bn
        REAL(fpk), INTENT( inout )                      :: tau_AD
        REAL(fpk), INTENT( inout )                      :: wo_AD
        REAL(fpk), DIMENSION( :, : ), INTENT( inout )   :: Pp_AD
        REAL(fpk), DIMENSION( :, : ), INTENT( inout )   :: Pm_AD
        REAL(fpk), INTENT( inout )                      :: Bo_AD
        REAL(fpk), INTENT( inout )                      :: Bn_AD
        REAL(fpk), DIMENSION( :, : ), INTENT( inout )   :: R_AD
        REAL(fpk), DIMENSION( :, : ), INTENT( inout )   :: T_AD
        REAL(fpk), DIMENSION( : ), INTENT( in )         :: Sp_AD
        REAL(fpk), DIMENSION( : ), INTENT( in )         :: Sm_AD
		INTEGER, INTENT(in), OPTIONAL					:: method

!-------------------------
! Define local variables
!-------------------------
        REAL(fpk), DIMENSION(size(mu), size(mu))   :: At, Bt, Rt, Tt, At_Bt, E, Gamma, Gammat
        REAL(fpk)                                  :: Bd, delta_tau, g
        INTEGER  :: i, j, l, npts
        REAL(fpk), DIMENSION(size(mu), size(mu))   :: B_AD, A_AD, Td_AD, YadY, ZadZ_gY, Gamma_AD
		REAL(fpk), DIMENSION(size(mu))			   :: RTvector, RTvector_AD
        REAL(fpk), DIMENSION(size(mu))             :: Y_AD, Z_AD, Y, Z, trans, trans_AD
        REAL(fpk)                                  :: Bd_AD, g_AD
		REAL(fpk)								   :: delta_tau_AD
		REAL(fpk)								   :: tmp, etemp, m
		INTEGER                                    :: imethod

!-------------------------
! Forward recomputations
!-------------------------

		if (.NOT. PRESENT(method)) then
			if ( (wo > SSA_CUTOFF) ) then
				imethod = 1
			else
				imethod = 2
			endif
		else
			imethod = method
		endif

        npts = size( mu )
        delta_tau = tau / ( 2 ** k )
        Bd = ( Bn - Bo ) / tau
        E = ZERO
        DO i = 1, npts
          E( i, i ) = ONE
        END DO

	!-----------------------
	! Adjoint computations
	!-----------------------
	Td_AD = -T_AD

	do i = 1, npts
		tau_AD = - exp(-tau/mu(i)) / mu(i) * Td_AD(i,i) + tau_AD
	enddo

	tmp = sum( HALF * (Sp_AD + Sm_AD) * Y_store(:,ilay,k))
	Bo_AD = tmp + Bo_AD
	Bn_AD = tmp + Bn_AD
	Bd_AD = sum((Sp_AD - Sm_AD) * Z_store(:,ilay,k) )

	Y_AD = HALF * (Bo+Bn) * (Sp_AD + Sm_AD)
	Z_AD = Bd * (Sp_AD - Sm_AD)

	g_AD = ZERO
	g = (delta_tau / FOUR) * 2**k ! set initial value of g

	!--- PERFORM DOUBLING ADJOINT

	do l = k, 1, -1

!	extract stored matrices for the index (l-1)
		Rt = transpose(R_store(:, :, ilay, l-1))
		Tt = transpose(T_store(:, :, ilay, l-1))
		Y = Y_store(:, ilay, l-1)
		Z = Z_store(:, ilay, l-1)

!	re-calculate Gamma, A and B matrices for this index (l-1)
		Call Gamma_Matrix(transpose(Rt), g, Gamma)
		Gammat = transpose(Gamma)
		At = matmul(Gammat, Tt)
		Bt = matmul(Rt, At)
		At_Bt = At - Bt
		YadY = outer_prod(Y_AD,Y)
		ZadZ_gY = outer_prod(Z_AD, Z - g*Y)

! Begin Adjoint Doubling Rules
		g_AD	=		sum( (Y - matmul(Y, At_Bt)) * Z_AD ) + g_AD

		B_AD	=		matmul(R_AD, Tt) + YadY - ZadZ_gY

		A_AD	=		matmul(T_AD, Tt) + YadY + ZadZ_gY

		Y_AD	=		matmul((At + Bt + E), Y_AD) + g*matmul((E - At_Bt), Z_AD)

		Z_AD	=		matmul( (E + At_Bt) , Z_AD)

		T_AD	=		matmul(Bt, R_AD) + matmul(At, T_AD)

		A_AD	=		matmul(B_AD, Rt) + A_AD

		R_AD	=		matmul(At, B_AD) + R_AD

		T_AD	=		matmul(A_AD, Gammat) + T_AD

		Gamma_AD =		matmul(Tt, A_AD)  ! in this cycle, create this adjoint variable here!

		CALL Gamma_Matrix_AD(Rt, Gammat, g, Gamma_AD, R_AD)

		g_AD = TWO * g_AD

		g = g / TWO ! re-calculate g for next iteration

	enddo

	delta_tau_AD = g_AD / FOUR

	! This section gets the difference in up and downwelling source correct.
        Z = ZERO
		trans_AD = ZERO
        do i = 1,npts
		  trans(i) = exp(-delta_tau/mu(i))
		  if (delta_tau/mu(i) < 0.2_fpk) then
			wo_AD = wo_AD - delta_tau * delta_tau / mu(i) / 12.0_fpk*(ONE-trans(i)) * Z_AD(i)
			trans_AD(i) = - delta_tau * delta_tau / mu(i) / 12.0_fpk * (ONE-wo) * Z_AD(i) + trans_AD(i)
            delta_tau_AD = 2 * delta_tau / mu(i) / 12.0_fpk * (ONE-wo)*(ONE-trans(i)) * Z_AD(i) + delta_tau_AD
          else
			wo_AD = wo_AD - delta_tau*(trans(i) + (ONE-trans(i))*(HALF - mu(i)/delta_tau))*Z_AD(i)
			trans_AD(i) = (ONE-wo)*delta_tau*(ONE - (HALF - mu(i)/delta_tau))*Z_AD(i) + trans_AD(i)
			delta_tau_AD = (ONE-wo)*((trans(i) + (ONE-trans(i))*(HALF - mu(i)/delta_tau)) + &
							delta_tau*(ONE-trans(i))*mu(i)/delta_tau**2 ) * Z_AD(i) + delta_tau_AD
          endif
        enddo

	! Now perform Adjoint of layer initialization
	select case(imethod)
	case(1) ! O'DELL (EIGI) initialization

	do i = 1, npts
		wo_AD = -(ONE-trans(i)) * Y_AD(i) + wo_AD
		trans_AD(i) = trans_AD(i) - (ONE-wo) * Y_AD(i)

		do j = 1, npts

			wo_AD = wo_AD + Pm(i,j) * w(j) * (ONE-trans(i)) * R_AD(i,j)
			Pm_AD(i,j) = wo * w(j) * (ONE-trans(i)) * R_AD(i,j)
			trans_AD(i) = trans_AD(i) - wo*Pm(i,j)*w(j)*R_AD(i,j)

			if (i==j) then
				trans_AD(i) = (ONE - wo*Pp(i,j)*w(j))*T_AD(i,j) + trans_AD(i)
			else
				trans_AD(i) =  - wo*Pp(i,j)*w(j)*T_AD(i,j) + trans_AD(i)
			endif
			wo_AD = wo_AD + Pp(i,j) * w(j) * (ONE-trans(i)) * T_AD(i,j)
			Pp_AD(i,j) = wo*w(j)*(ONE-trans(i)) * T_AD(i,j)
		enddo

		delta_tau_AD = -trans(i)/mu(i) * trans_AD(i) + delta_tau_AD
	enddo

	case(2)  ! Single Scatter Initialization with Tdirect determined from energy conservation

	do i = 1, npts
		RTvector(i) = RT_store(i,ilay) ! retrieve RTvector(i) from FORWARD calc
 		Y_AD(i) = -T_AD(i,i) + Y_AD(i)
		RTvector_AD(i) = -T_AD(i,i)
		wo_AD = (RTvector(i) - TWO*wo*(ONE-trans(i)))*Y_AD(i) + wo_AD
		trans_AD(i) = trans_AD(i) - (ONE - wo*wo) * Y_AD(i)
        RTvector_AD(i) = RTvector_AD(i) - (ONE-wo)*Y_AD(i)

        do j = 1, npts
			m = mu(j) / ( mu(i) + mu(j) ) ! needed for each iteration

			R_AD(i,j) = RTvector_AD(i) + R_AD(i,j)
			T_AD(i,j) = RTvector_AD(i) + T_AD(i,j)

			etemp = exp(-delta_tau/(m*mu(i)))
			wo_AD = Pm(i,j) * w(j) * m *(ONE-etemp) * R_AD(i,j) + wo_AD
			Pm_AD(i,j) =  wo * w(j) * m *(ONE-etemp) * R_AD(i,j)
			delta_tau_AD = wo * Pm(i,j) * w(j) * etemp / mu(i) * R_AD(i,j) + delta_tau_AD

        	if (i == j) then
				wo_AD = Pp(i,j)*w(j) * delta_tau/mu(i) * trans(i) * T_AD(i,j) + wo_AD
				Pp_AD(i,j) = wo*w(j) * delta_tau/mu(i) * trans(i) * T_AD(i,j)
				delta_tau_AD = wo*Pp(i,j)*w(j) / mu(i) * trans(i) * T_AD(i,j) + delta_tau_AD
				trans_AD(i) = wo*Pp(i,j)*w(j) * delta_tau/mu(i) * T_AD(i,j) + trans_AD(i)
        	else
				etemp = exp(-delta_tau/mu(j))
				m = mu(j) / (mu(j)-mu(i))
				wo_AD = Pp(i,j)*w(j) * m *(etemp - trans(i))*T_AD(i,j) + wo_AD
				Pp_AD(i,j) = wo*w(j) * m *(etemp - trans(i))*T_AD(i,j)
				delta_tau_AD = - wo*Pp(i,j)*w(j) * m /mu(j) * etemp* T_AD(i,j) + delta_tau_AD
				trans_AD(i) = -wo*Pp(i,j)*w(j)*m*T_AD(i,j) + trans_AD(i)
        	end if

		enddo

		delta_tau_AD = -trans(i)/mu(i) * trans_AD(i) + delta_tau_AD
	enddo
	end select

	Bn_AD = Bd_AD / tau + Bn_AD
	Bo_AD = -Bd_AD / tau + Bo_AD
	tau_AD = - Bd/tau * Bd_AD + tau_AD

	tau_AD = delta_tau_AD / (2**k) + tau_AD

END SUBROUTINE truncated_doubling_AD

	Subroutine Gamma_Matrix( R, g, Gamma )
		! This simple routine calculates Gamma = (E - R^2)^-1,
		!	It is assumed that R has last column all zeroes.
		!   For R = 2x2 or 3x3, inverse is explicitly calculated.
		!   For R > 3x3, use truncated doubling technique.

		implicit none

		real(fpk), intent(in), dimension(:,:)		::	R
		real(fpk), intent(in)						::	g
		real(fpk), intent(out), dimension(:,:)		::	Gamma

		real(fpk), dimension(size(R,1),size(R,2))   ::  store, store2

		integer ::	n, k
		real(fpk)	:: idet
		real(fpk), dimension(size(R,1), size(R,2))	::	A, E

		n = size(R, 1)
		E = ZERO
		do k = 1, n
			E(k,k) = ONE
		enddo

		select case(n)
		case(2) ! 2-stream case
			idet = ONE/(ONE-R(1,1)*R(1,1))
			Gamma(1,1) = idet
			Gamma(1,2) = ZERO
			Gamma(2,1) = R(1,1)*R(2,1) * idet
			Gamma(2,2) = ONE

		case(3)
			A(1,1) = ONE - (R(1,1)*R(1,1) + R(1,2)*R(2,1))
			A(1,2) = -R(1,2) * ( R(1,1) + R(2,2) )
			A(2,1) = -R(2,1) * ( R(1,1) + R(2,2) )
			A(2,2) = ONE - (R(1,2) * R(2,1) + R(2,2)*R(2,2))
			A(3,1) = -( R(1,1)*R(3,1) + R(2,1)*R(3,2) )
			A(3,2) = -( R(1,2)*R(3,1) + R(2,2)*R(3,2) )
			A(1:2, 3) = ZERO
			A(3,3) = ONE

			idet = ONE/(A(1,1) * A(2,2) - A(1,2) * A(2,1))
			Gamma(1:2,3) = ZERO
			Gamma(1,1) = A(2,2) * idet
			Gamma(1,2) = - A(1,2) * idet
			Gamma(2,1) = - A(2,1) * idet
			Gamma(2,2) = A(1,1) * idet
			Gamma(3,1) = idet * ( A(2,1)*A(3,2) - A(3,1)*A(2,2) )
			Gamma(3,2) = idet * ( A(1,2)*A(3,1) - A(1,1)*A(3,2) )
			Gamma(3,3) = ONE
		case default
			store = matmul(R,R)
			Gamma = E + store
			if (g > 0.05_fpk) then
				store2 = matmul(store, store)
	            Gamma = Gamma + store2
			endif
			if (g > 0.5_fpk) Gamma = Gamma + matmul(store2, store)
		end select

	END SUBROUTINE Gamma_Matrix

	Subroutine Gamma_Matrix_TL( R, Gamma, g, R_TL, Gamma_TL )

		implicit none

		real(fpk), intent(in), dimension(:,:)		::	R, Gamma, R_TL
		real(fpk), intent(in)						::	g
		real(fpk), intent(out), dimension(:,:)		::	Gamma_TL

		integer ::	n
		real(fpk), dimension(size(R,1), size(R,2))	::	store, store2
		real(fpk), dimension(size(R,1), size(R,2))	::  store_TL, store2_TL

		n = size(R, 1)
		if ( (n==2) .OR. (n==3) ) then
			Gamma_TL = Matmul(Gamma, Matmul(matmul(R,R_TL)+matmul(R_TL,R),Gamma))
		else
			Gamma_TL = Matmul(Gamma, Matmul(matmul(R,R_TL)+matmul(R_TL,R),Gamma))
!			store = matmul(R,R)
!			store_TL = matmul(R,R_TL)+matmul(R_TL,R)
!			Gamma = E + store
!			Gamma_TL = E + store_TL
!			if (g > 0.05_fpk) then
!				store2 = matmul(store, store)
!				store2_TL = matmul(store,store_TL) + matmul(store_TL,store)
!	            Gamma = Gamma + store2
!				Gamma_TL = Gamma_TL + store2_TL
!			endif
!			if (g > 0.5_fpk) then
!				Gamma = Gamma + matmul(store2, store)
!				Gamma_TL = Gamma_TL + matmul(store2,store_TL) + matmul(store2_TL,store)
!			endif
		endif

	END SUBROUTINE Gamma_Matrix_TL

	Subroutine Gamma_Matrix_AD( Rt, Gammat, g, Gamma_AD, R_AD )

		implicit none

		real(fpk), intent(in), dimension(:,:)		::	Rt, Gammat, Gamma_AD
		real(fpk), intent(in)						::	g
		real(fpk), intent(inout), dimension(:,:)		::	R_AD

		integer ::	n
!		real(fpk)	:: idet
		real(fpk), dimension(size(Rt,1), size(Rt,2))	::	BB_AD

		n = size(Rt, 1)

		if ( (n==2) .OR. (n==3) ) then
	!		B = I - R^2.  The adjoint of B is straightforward; the negative of it is given by:
			BB_AD = matmul(gammat, matmul(Gamma_AD,gammat))
			R_AD = matmul(Rt, BB_AD) + matmul(BB_AD, Rt) + R_AD
		else
			! n is greater than three. Technically I should code the correct adjoint
			!  here, but I am lazy.  Just use above approximation.
			BB_AD = matmul(gammat, matmul(Gamma_AD,gammat))
			R_AD = matmul(Rt, BB_AD) + matmul(BB_AD, Rt) + R_AD
		endif
	END SUBROUTINE Gamma_Matrix_AD

FUNCTION outer_prod(a,b) result(c)
	REAL(fpk), intent(in), dimension(:) :: a, b
	REAL(fpk) :: c(size(a),size(b))
	integer :: i, j

	do j = 1, size(b)
		do i = 1, size(a)
			c(i,j) = a(i) * b(j)
		enddo
	enddo
END FUNCTION outer_prod

END MODULE SOI_doubling


      subroutine runCY_i1i2i3(i,j,i1,i2,i3,
     . f,Xtwiddle,Gtt,Gtwiddle,Shat4,Bzero3,N0)
      implicit none
C---  Expression for Eq. 5.61
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,i,j,i1,i2,i3,n,m,np
      parameter(np=2)
      double precision
     . Xtwiddle(0:np,0:np),Gtwiddle(np,np),f(np),Gtt(np,np,np,np)
      double complex Shat4(np,z3max,-2:0),Bzero3(z3max,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)
     . *(Shat4(m,z3(i1,i2,i3),ep)
     . -2d0*delta(m,i1)*Cv(czzii(z2(i2,i3))+N0,ep)
     . -2d0*delta(m,i2)*Cv(czzii(z2(i3,i1))+N0,ep)
     . -2d0*delta(m,i3)*Cv(czzii(z2(i1,i2))+N0,ep))
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4*Cv(czziii(z3(i1,i2,i3))+N0,ep-1)
      Cv(ciii(z3(i1,i2,i3))+N0,ep)=
     .  (Gtwiddle(i,j)
     . *(10*Cv(czziii(z3(i1,i2,i3))+N0,ep)+pole-Bzero3(z3(i1,i2,i3),ep))
     . +bit+Xtwiddle(0,j)*Cv(ciiii(z4(i,i1,i2,i3))+N0,ep))/Xtwiddle(i,j)

      enddo
      return
      end


      FUNCTION SEDFLUX(SMSOD1)
C
C SOLVE MASS-BALANCE EQ'S FOR NH4, NO3 & H2S/CH4 AND THEIR FLUXES.
C
      USE GLOBAL
      RSMSS = SMSOD1 / (SMO20+ 1.E-18)
C
C NH4
C
      RRNH4 = SK1NH4SM/(RSMSS+ 1.E-18)
      A11NH4 = RSMSS*SMFD1NH4 + A1NH4SM + RRNH4
      B11NH4 = RSMSS*B1NH4SM
      B22NH4 = B2NH4SM
      CALL SOLVSMBE(RSM1NH4,RSM2NH4,A11NH4,A22NH4SM,A1NH4SM,A2NH4SM,
     &    B11NH4,B22NH4)
      RJNITSM = RRNH4 * RSM1NH4
C
C NO3
C
      RRNO3 = SK1NO3SM/(RSMSS+ 1.E-18)
      A11NO3 = RSMSS + A1NO3SM + RRNO3
      B11NO3 = RJNITSM + RSMSS*B1NO3SM
      B22NO3 = B2NO3SM
      CALL SOLVSMBE(RSM1NO3,RSM2NO3,A11NO3,A22NO3SM,A1NO3SM,A2NO3SM,
     &    B11NO3,B22NO3)
      RJDENSM = RRNO3*RSM1NO3 + RK2NO3SM*RSM2NO3
C
C H2S/CH4: SMCH4S=2*SMKL12*SMCH4S
C
      ! *** SMO2JC          - Max CH4 production
      ! *** SMO2NO3*RJDENSM - Nitrification
      ! *** SMJ2H2S         - Flux of methane in oxygen equivalent units (M/L2/T)
      SMJ2H2S = MAX(SMO2JC - SMO2NO3*RJDENSM, 0.0)
      IF(SMSAL0.GT.SMCSHSCH)THEN
        RRH2S = SK1H2SSM/(RSMSS+ 1.E-18)
        SMTT1 = RSMSS*SMFD1H2S
        A11H2S = SMTT1 + A1H2SSM + RRH2S
        B11H2S = B1H2SSM
        B22H2S = B2H2SSM + SMJ2H2S
        CALL SOLVSMBE(RSM1H2S,RSM2H2S,A11H2S,A22H2SSM,A1H2SSM,A2H2SSM,
     &      B11H2S,B22H2S)
        AQJH2SSM = SMTT1*RSM1H2S
        CSODSM = RRH2S*RSM1H2S
        AQJCH4SM = 0.0
        GJCH4SM = 0.0
      ELSE
        CSODMSM = MIN( SQRT(SMCH4S*SMJ2H2S), SMJ2H2S )
        SMTT2 = SMK1CH4 / (RSMSS+ 1.E-18)
        IF(SMTT2.LT.80.0)THEN
          SMTT3 = EXP(SMTT2)
          SMSECH = 2.0 / (SMTT3 + 1.0/SMTT3)
        ELSE
          SMSECH = 0.0
        ENDIF
        AQJCH4SM = CSODMSM*SMSECH
        CSODSM = CSODMSM - AQJCH4SM
        GJCH4SM = SMJ2H2S - CSODMSM
        AQJH2SSM = 0.0
      ENDIF
      RNSODSM = SMO2NH4*RJNITSM
      SMSOD = CSODSM + RNSODSM
      SEDFLUX = SMSOD - SMSOD1
      RETURN
      END


      DOUBLE PRECISION FUNCTION DCI (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 DCI Krogh  Moved external statement up for mangle.
c>> 1996-03-30 DCI Krogh  Added external statements.
C>> 1995-11-22 DCI Krogh  Removed multiple entry for C conversion.
C>> 1995-11-03 DCI Krogh  Removed blanks in numbers for C conversion.
c>> 1994-10-20 DCI Krogh  Changes to use M77CON
c>> 1990-01-23 DCI CLL Using name DCIN for result in entry DCIN.
c>> 1989-03-14 Original W. V. Snyder at JPL
C
C     COMPUTE THE COSINE INTEGRAL OF X =
C     INTEGRAL FROM X TO INFINITY OF -(COS(T)/T) DT =
C     GAMMA + LOG(ABS(X)) + INTEGRAL FROM 0 TO X OF ((COS(T)-1)/T DT),
C     WHERE GAMMA IS EULER'S CONSTANT.
C
C     FOR ABS(X)<16, USE A CHEBYSHEV SERIES WITH ARGUMENT 2*Z*Z-1 WHERE
C     Z=X/16 TO EVALUATE (CI(X)-LOG(ABS(X))-GAMMA)/(Z*Z), THEN MULTIPLY
C     THE RESULT BY Z*Z AND ADD LOG(ABS(X)) AND GAMMA.  LOSS OF ABOUT
C     TWO DIGITS OCCURS NEAR ABS(X)=16 DUE TO CANCELLATION.
C
C     FOR ABS(X).GE.16, USE CHEBYSHEV SERIES WITH ARGUMENT 2*Z*Z-1 WHERE
C     WHERE Z=16/X ARE USED TO COMPUTE F(X)/Z AND G(X)/(Z*Z).  THEN
C     CI(X)=F(X)*SIN(X)-G(X)*COS(X).
C
C     THIS ALGORITHM YIELDS AT MOST 15 DIGITS OF PRECISION.
C
C--D replaces "?": ?CI, ?CII, ?CIN, ?CPVAL, ?ERM1
C
      EXTERNAL DCII
      DOUBLE PRECISION X, DCII
      DCI = DCII(.true., X)
      end
C
      DOUBLE PRECISION FUNCTION DCIN (X)
      EXTERNAL DCII
      DOUBLE PRECISION X, DCII
      DCIN = DCII(.false., X)
      end
c
      DOUBLE PRECISION FUNCTION DCII (LDCI, X)
      LOGICAL LDCI
      INTEGER ERRLEV
      PARAMETER (ERRLEV=0)
      EXTERNAL DCPVAL
      DOUBLE PRECISION C(23), DCPVAL, F(13), G(13), GAMMA,X, Z,ZW
      parameter(GAMMA = 0.577215664901533D0)
      DATA C/
     1 + 0.5D0,                  + 0.5D0,
     2 +14.992589367813409D0, -19.386124096607770D0,
     3 +12.741870869758071D0, - 8.107903970562531D0,
     4 + 4.862022348500627D0, - 2.497505088539025D0,
     5 + 1.008660787358110D0, - 0.312080924825428D0,
     6 + 0.074678255294576D0, - 0.014110865253535D0,
     7 + 0.002152046752074D0, - 0.000270212331184D0,
     8 + 0.000028416945498D0, - 0.000002540125611D0,
     9 + 0.000000195437144D0, - 0.000000013084020D0,
     A + 0.000000000769379D0, - 0.000000000040066D0,
     B + 0.000000000001861D0, - 0.000000000000078D0,
     C + 0.000000000000003D0/
      DATA F/
     1 + 0.5D0,                  + 0.5D0,
     2 + 0.062263729028927D0, - 0.000233756041393D0,
     3 + 0.000002453755677D0, - 0.000000058670317D0,
     4 + 0.000000002356196D0, - 0.000000000136096D0,
     5 + 0.000000000010308D0, - 0.000000000000964D0,
     6 + 0.000000000000107D0, - 0.000000000000014D0,
     7 + 0.000000000000002D0/
      DATA G/
     1 + 0.5D0,                  + 0.5D0,
     2 + 0.003862856096703D0, - 0.000042644182622D0,
     3 + 0.000000724995950D0, - 0.000000023468225D0,
     4 + 0.000000001169202D0, - 0.000000000079604D0,
     5 + 0.000000000006875D0, - 0.000000000000717D0,
     6 + 0.000000000000087D0, - 0.000000000000012D0,
     7 + 0.000000000000002D0/
C
      IF (LDCI) then
         IF (X.LE.0.0) THEN
            CALL DERM1('DCI',1,ERRLEV,'Argument not positive','X',X,'.')
C        Provide a value in case the error message processor returns.
            DCII = 0.0
         ELSE IF (X.LT.16.0) THEN
            Z = X/16.0
            ZW = Z*Z
            DCII = LOG(X) - ZW*DCPVAL(C,20,ZW) + GAMMA
         ELSE
            Z = 16.0/X
            ZW = Z*Z
            DCII = Z*(DCPVAL(F,10,ZW)*SIN(X) - Z*DCPVAL(G,10,ZW)*COS(X))
         END IF
      ELSE
C
C     Evaluate the entire function
C     Cin(x) = Integral from 0 to x of ((cos(t) - 1) / t) dt.
C
         IF (ABS(X).LT.16.0) THEN
            Z = X/16.0
            ZW = Z*Z
            DCII = ZW*DCPVAL(C,20,ZW)
         ELSE
            Z = 16.0/X
            ZW = Z*Z
            DCII = LOG(ABS(X)) + GAMMA -
     1         Z*(DCPVAL(F,10,ZW)*SIN(X) - Z*DCPVAL(G,10,ZW)*COS(X))
         END IF
      END IF
      RETURN
      END


      SUBROUTINE MB3OYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                   TAU, DWORK, ZWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute a rank-revealing QR factorization of a complex general
C     M-by-N matrix  A,  which may be rank-deficient, and estimate its
C     effective rank using incremental condition estimation.
C
C     The routine uses a truncated QR factorization with column pivoting
C                                   [ R11 R12 ]
C        A * P = Q * R,  where  R = [         ],
C                                   [  0  R22 ]
C     with R11 defined as the largest leading upper triangular submatrix
C     whose estimated condition number is less than 1/RCOND.  The order
C     of R11, RANK, is the effective rank of A.  Condition estimation is
C     performed during the QR factorization process.  Matrix R22 is full
C     (but of small norm), or empty.
C
C     MB3OYZ  does not perform any scaling of the matrix A.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     A       (input/output) COMPLEX*16 array, dimension ( LDA, N )
C             On entry, the leading M-by-N part of this array must
C             contain the given matrix A.
C             On exit, the leading RANK-by-RANK upper triangular part
C             of A contains the triangular factor R11, and the elements
C             below the diagonal in the first  RANK  columns, with the
C             array TAU, represent the unitary matrix Q as a product
C             of  RANK  elementary reflectors.
C             The remaining  N-RANK  columns contain the result of the
C             QR factorization process used.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of A, which
C             is defined as the order of the largest leading triangular
C             submatrix R11 in the QR factorization with pivoting of A,
C             whose estimated condition number is less than 1/RCOND.
C             0 <= RCOND <= 1.
C             NOTE that when SVLMAX > 0, the estimated rank could be
C             less than that defined above (see SVLMAX).
C
C     SVLMAX  (input) DOUBLE PRECISION
C             If A is a submatrix of another matrix B, and the rank
C             decision should be related to that matrix, then SVLMAX
C             should be an estimate of the largest singular value of B
C             (for instance, the Frobenius norm of B).  If this is not
C             the case, the input value SVLMAX = 0 should work.
C             SVLMAX >= 0.
C
C     RANK    (output) INTEGER
C             The effective (estimated) rank of A, i.e., the order of
C             the submatrix R11.
C
C     SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
C             The estimates of some of the singular values of the
C             triangular factor R:
C             SVAL(1): largest singular value of R(1:RANK,1:RANK);
C             SVAL(2): smallest singular value of R(1:RANK,1:RANK);
C             SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1),
C                      if RANK < MIN( M, N ), or of R(1:RANK,1:RANK),
C                      otherwise.
C             If the triangular factorization is a rank-revealing one
C             (which will be the case if the leading columns were well-
C             conditioned), then SVAL(1) will also be an estimate for
C             the largest singular value of A, and SVAL(2) and SVAL(3)
C             will be estimates for the RANK-th and (RANK+1)-st singular
C             values of A, respectively.
C             By examining these values, one can confirm that the rank
C             is well defined with respect to the chosen value of RCOND.
C             The ratio SVAL(1)/SVAL(2) is an estimate of the condition
C             number of R(1:RANK,1:RANK).
C
C     JPVT    (output) INTEGER array, dimension ( N )
C             If JPVT(i) = k, then the i-th column of A*P was the k-th
C             column of A.
C
C     TAU     (output) COMPLEX*16 array, dimension ( MIN( M, N ) )
C             The leading  RANK  elements of TAU contain the scalar
C             factors of the elementary reflectors.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension ( 2*N )
C
C     ZWORK   COMPLEX*16 array, dimension ( 3*N-1 )
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     The routine computes a truncated QR factorization with column
C     pivoting of A,  A * P = Q * R,  with  R  defined above, and,
C     during this process, finds the largest leading submatrix whose
C     estimated condition number is less than 1/RCOND, taking the
C     possible positive value of SVLMAX into account.  This is performed
C     using the LAPACK incremental condition estimation scheme and a
C     slightly modified rank decision test.  The factorization process
C     stops when  RANK  has been determined.
C
C     The matrix Q is represented as a product of elementary reflectors
C
C        Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n).
C
C     Each H(i) has the form
C
C        H = I - tau * v * v'
C
C     where tau is a complex scalar, and v is a complex vector with
C     v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
C     A(i+1:m,i), and tau in TAU(i).
C
C     The matrix P is represented in jpvt as follows: If
C        jpvt(j) = i
C     then the jth column of P is the ith canonical unit vector.
C
C     REFERENCES
C
C     [1] Bischof, C.H. and P. Tang.
C         Generalizing Incremental Condition Estimation.
C         LAPACK Working Notes 32, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-132,
C         May 1991.
C
C     [2] Bischof, C.H. and P. Tang.
C         Robust Incremental Condition Estimation.
C         LAPACK Working Notes 33, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-133,
C         May 1991.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998.
C     Complex version: V. Sima, Research Institute for Informatics,
C     Bucharest, Nov. 2008.
C
C     REVISIONS
C
C     V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion.
C
C     KEYWORDS
C
C     Eigenvalue problem, matrix operations, unitary transformation,
C     singular values.
C
C    ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                     CONE  = ( 1.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      COMPLEX*16         A( LDA, * ), TAU( * ), ZWORK( * )
      DOUBLE PRECISION   DWORK( * ), SVAL( 3 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, ISMAX, ISMIN, ITEMP, J, MN, PVT
      COMPLEX*16         AII, C1, C2, S1, S2
      DOUBLE PRECISION   SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2, TOLZ
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DZNRM2
      EXTERNAL           DLAMCH, DZNRM2, IDAMAX
C     .. External Subroutines ..
      EXTERNAL           XERBLA, ZLAIC1, ZLARF, ZLARFG, ZSCAL, ZSWAP
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DCONJG, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN
         INFO = -5
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -6
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB3OYZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      MN = MIN( M, N )
      IF( MN.EQ.0 ) THEN
         RANK = 0
         SVAL( 1 ) = ZERO
         SVAL( 2 ) = ZERO
         SVAL( 3 ) = ZERO
         RETURN
      END IF
C
      TOLZ  = SQRT( DLAMCH( 'Epsilon' ) )
      ISMIN = 1
      ISMAX = ISMIN + N
C
C     Initialize partial column norms and pivoting vector. The first n
C     elements of DWORK store the exact column norms.
C
      DO 10 I = 1, N
         DWORK( I ) = DZNRM2( M, A( 1, I ), 1 )
         DWORK( N+I ) = DWORK( I )
         JPVT( I ) = I
   10 CONTINUE
C
C     Compute factorization and determine RANK using incremental
C     condition estimation.
C
      RANK = 0
C
   20 CONTINUE
      IF( RANK.LT.MN ) THEN
         I = RANK + 1
C
C        Determine ith pivot column and swap if necessary.
C
         PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 )
C
         IF( PVT.NE.I ) THEN
            CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
            ITEMP = JPVT( PVT )
            JPVT( PVT ) = JPVT( I )
            JPVT( I )   = ITEMP
            DWORK( PVT )   = DWORK( I )
            DWORK( N+PVT ) = DWORK( N+I )
         END IF
C
C        Save A(I,I) and generate elementary reflector H(i)
C        such that H(i)'*[A(i,i);*] = [*;0].
C
         IF( I.LT.M ) THEN
            AII = A( I, I )
            CALL ZLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
         ELSE
            TAU( M ) = CZERO
         END IF
C
         IF( RANK.EQ.0 ) THEN
C
C           Initialize; exit if matrix is zero (RANK = 0).
C
            SMAX = ABS( A( 1, 1 ) )
            IF ( SMAX.EQ.ZERO ) THEN
               SVAL( 1 ) = ZERO
               SVAL( 2 ) = ZERO
               SVAL( 3 ) = ZERO
               RETURN
            END IF
            SMIN = SMAX
            SMAXPR = SMAX
            SMINPR = SMIN
            C1 = CONE
            C2 = CONE
         ELSE
C
C           One step of incremental condition estimation.
C
            CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, A( 1, I ),
     $                   A( I, I ), SMINPR, S1, C1 )
            CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, A( 1, I ),
     $                   A( I, I ), SMAXPR, S2, C2 )
         END IF
C
         IF( SVLMAX*RCOND.LE.SMAXPR ) THEN
            IF( SVLMAX*RCOND.LE.SMINPR ) THEN
               IF( SMAXPR*RCOND.LE.SMINPR ) THEN
C
C                 Continue factorization, as rank is at least RANK.
C
                  IF( I.LT.N ) THEN
C
C                    Apply H(i)' to A(i:m,i+1:n) from the left.
C
                     AII = A( I, I )
                     A( I, I ) = CONE
                     CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
     $                           DCONJG( TAU( I ) ), A( I, I+1 ), LDA,
     $                           ZWORK( 2*N+1 ) )
                     A( I, I ) = AII
                  END IF
C
C                 Update partial column norms.
C
                  DO 30 J = I + 1, N
                     IF( DWORK( J ).NE.ZERO ) THEN
                        TEMP = ABS( A( I, J ) ) / DWORK( J )
                        TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO)
                        TEMP2 = TEMP*( DWORK( J ) / DWORK( N+J ) )**2
                        IF( TEMP2.LE.TOLZ ) THEN
                           IF( M-I.GT.0 ) THEN
                              DWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 )
                              DWORK( N+J ) = DWORK( J )
                           ELSE
                              DWORK( J )   = ZERO
                              DWORK( N+J ) = ZERO
                           END IF
                        ELSE
                           DWORK( J ) = DWORK( J )*SQRT( TEMP )
                        END IF
                     END IF
   30             CONTINUE
C
                  DO 40 I = 1, RANK
                     ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 )
                     ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 )
   40             CONTINUE
C
                  ZWORK( ISMIN+RANK ) = C1
                  ZWORK( ISMAX+RANK ) = C2
                  SMIN = SMINPR
                  SMAX = SMAXPR
                  RANK = RANK + 1
                  GO TO 20
               END IF
            END IF
         END IF
      END IF
C
C     Restore the changed part of the (RANK+1)-th column and set SVAL.
C
      IF ( RANK.LT.N ) THEN
         IF ( I.LT.M ) THEN
            CALL ZSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 )
            A( I, I ) = AII
         END IF
      END IF
      IF ( RANK.EQ.0 ) THEN
         SMIN = ZERO
         SMINPR = ZERO
      END IF
      SVAL( 1 ) = SMAX
      SVAL( 2 ) = SMIN
      SVAL( 3 ) = SMINPR
C
      RETURN
C *** Last line of MB3OYZ ***
      END


      SUBROUTINE  JACROB (ESQ   ,HGT   ,TIME  ,USAT  ,USUN  ,RHO)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       USAT(3)      ,USUN(3)
C
C.......................................................................
C
C  VERSION OF 20 JULY 1976
C
C   PURPOSE
C      JACROB FURNISHES ATMOSPHERIC DENSITY USING JACCHIA'S
C      1971 ATMOSPHERIC MODEL AS MODIFIED BY ROBERTS IN 1971.
C      COMPUTATIONS PERFORMED ARE TIME DEFINITION, EXOSPHERIC
C      TEMPERATURE, CORRECTIONS TO THE ATMOSPHERIC DENSITY, AND
C      ASSESSMENT AS TO WHICH HEIGHT RANGE TO USE IN COMPUTING THE
C      ATMOSPHERIC DENSITY.
C
C   REFERENCES
C      JACCHIA, L. J., REVISED STATIC MODELS OF THE THERMOSPHERE AND
C        EXOSPHERE WITH EMPIRICAL TEMPERATURE PROFILES, S.A.O., SPECIAL
C        REPORT NO. 332, MAY 5,1971.
C      ROBERTS, C. E., JR., AN ANALYTICAL MODEL FOR UPPER ATMOSPHERE
C        DENSITIES BASED UPON JACCHIA'S 1970 MODELS, CELESTIAL MECHANICS
C        4,(1971).
C
C    COMMON BLOCKS NEEDED
C       NONE
C
C    CALLING SEQUENCE EXPLANATION
C
C       VARIABLE       I/O     DESCRIPTION
C       --------       ---     -----------------------------------------
C       ESQ             I      ECCENTRICITY OF THE CENTRAL BODY SQUARED
C       HGT             I      SPACECRAFT HEIGHT (KM)
C       IERR            I      ERROR RETURN CODE FROM JACCWF
C       TIME            I      CURRENT TIME (FULL A.1 JULIAN DATE)
C       USAT(3)         I      UNIT POSITION VECTOR OF THE SPACECRAFT
C       USUN(3)         I      UNIT POSITION VECTOR OF THE SUN
C       RHO             O      ATMOSPHERIC DENSITY
C
C   JACROB IS CALLED FROM SUBROUTINE DRAG
C
C   SUBROUTINES AND FUNCTIONS REQUIRED
C     HIALT  - COMPUTES RHO AT ALTITUDES ABOVE 125 KM.
C     JACCWF - RETURNS GEOMAGNETIC INDEX AND EXOSPHERIC TEMPERATURE
C     LOWALT - COMPUTES RHO AT ALTITUDES BETWEEN 90 KM AND 125 KM
C
C.......................................................................
C
C                   INITIALIZE NECESSARY PARAMETERS
C
      DATA   DTR   /1.745329251994330D-2/
      DATA   TWOPI /6.283185307179586D0/
      DATA   PI    /3.141592653589793D0/
C
C                   MINIMUM HEIGHT IN KILOMETERS
      DATA   ZJ0   /90.D0/
C                   DENSITY AT MINIMUM HEIGHT IN GM/CM**3
      DATA   RHOZ  /3.46D-9/
C                   TEMPERATURE AT MINIMUM HEIGHT IN DEGREES KELVIN
      DATA   T0    /183.D0/
C
      IF (HGT .GE. ZJ0)  GO TO 10
C
C                   SPACECRAFT IS AT OR BELOW MINIMUM HEIGHT
      RHO = RHOZ
      GO TO 90
C
   10 IF (HGT .LT. 3000.D0)  GO TO 20
C
C                   THERE IS NO ATMOSPHERE ABOVE 3000 KM
C
      RHO = 0.D0
      GO TO 999
C
C                   CALCULATE SATELLITE GEODETIC LATITUDE
C
   20 D1  = DSQRT (USAT(1)**2 + USAT(2)**2)
      PHJ = DATAN (USAT(3)/(D1*(1.D0 - ESQ)))
C
C                   CALCULATE SUN HOUR ANGLE
C
      D2  = DSQRT (USUN(1)**2  +  USUN(2)**2)
      CX  = USUN(1) * USAT(1)  +  USUN(2) * USAT(2)
      TH  = DARCOS (CX/(D1*D2))
      HC  = USUN(1)*USAT(2)  -  USUN(2)*USAT(1)
      HCJ = TH / DTR  *  HC / DABS(HC)
C
C                  OBTAIN TEMPERATURE AND MAGNETIC VALUE AT CURRENT TIME
C     ...........
      CALL JACCWF (TIME   ,TEMP  ,MAG)
C     ...........
C
C                  COMPUTE THE DIURNAL EXOSPHERIC TEMPERATURE -- DL
C
      DEL0   = DATAN2 (USUN(3),D2)
      Q      = (HCJ + 43.D0) * DTR
      TAU    = (HCJ - 37.D0 + 6.D0   *DSIN(Q)) * DTR
      IF (TAU .LT. -PI)  TAU = TAU  +  TWOPI
      IF (TAU .GT.  PI)  TAU = TAU  -  TWOPI
      TAU    = .5D0 * TAU
      TH22   = ( DSIN (.5D0 * DABS (PHJ+DEL0) ) ) ** 2.2
      UN22   = ( DCOS (.5D0 * DABS (PHJ-DEL0) ) ) ** 2.2
      CSTAU3 = DCOS(TAU)**3
      DL     = TEMP * (1.D0 + .3D0 * (TH22 + (UN22 - TH22) * CSTAU3))
C
C                  GEOMAGNETIC  ACTIVITY
C
C   GEOMAGNETIC DISTURBANCES INFLUENCE THE ATMOSPHERIC DENSITY WITH A
C   TIME LAG OF 6.7 HOURS.  THE STORED VALUES ARE 10 TIMES THE ACTUAL
C   VALUES.
C
      TP1 = (MAG * 3  + 5) / 10
      TP1 = TP1 / 3.D0
C
C   THE GEOMAGNETIC TEMPERATURE CONTRIBUTION (DTG)  AND
C   THE BASE 10 LOGARITHM OF THE CONTRIBUTION TO RHO FROM GEOMAGNETIC
C   INFLUENCES ARE HANDLED DIFFERENTLY ABOVE AND BELOW 200KM.
C
      IF (HGT .LT. 200.D0)  GO TO 30
C
      DTG    = 28.D0 * TP1  +  .03D0 * DEXP(TP1)
      DL10RG = 0.D0
      GO TO 40
C
   30 DTG    = 14.D0  * TP1  +  .02D0  * DEXP(TP1)
      DL10RG = .012D0 * TP1  +  1.2D-5 * DEXP(TP1)
C
C   EXOSPHERIC TEMPERATURE IS THE TOTAL TEMPERATURE DUE TO DIURNAL AND
C   GEOMAGNETIC EFFECTS
C
   40 TINF = DL + DTG
C
C   SEMI-ANNUAL DENSITY VARIATION IS ADDED ON TO THE GEOMAGNETIC -- BOTH
C   IN BASE 10 LOGARITHMS
C
      PHI    = (TIME - 2436204.5D0) / 365.2422D0
      TSA    = TWOPI * PHI  +  6.035D0
      TSA    = PHI + .09544D0*((.5D0 + .5D0*DSIN(TSA))**1.65D0 - .5D0)
      B1     = TWOPI * TSA  +  4.137D0
      B2     = TWOPI * TSA * 2.D0  +  4.259D0
      GT     = .02835D0 + (.3817D0 + .17829D0*DSIN(B1)) * DSIN(B2)
      FZ     = (.5876D-6*HGT**2.331D0+.06328D0)*DEXP(-.002868D0*HGT)
      DL10RG = DL10RG  +  FZ * GT
C
C   SEASONAL LATITUDE VARIATION OF THE LOWER THERMOSPHERE IS ALSO ADDED
C   IN TO THE LOGARITHM OF DENSITY
C
      ZM90 = HGT - ZJ0
C
C                    HGT .GT. 440 GIVES UNDERFLOWS.
C
      IF (HGT .LT. 440.D0)  GO TO 50
C
      DL10RL = 0.D0
      GO TO 60
C
   50 EXPR = .014D0 * DEXP (-1.3D-3*ZM90**2) * DSIN (TWOPI*PHI+1.72D0)
      DL10RL = DSIN(PHJ)
      DL10RL = DL10RL * DABS(DL10RL) * EXPR * ZM90
C
   60 DL10RG = 10.D0 ** (DL10RG + DL10RL)
C
C                     INFLECTION POINT TEMPERATURE
C
      TX =371.6673D0+.0518806D0*TINF-294.3505D0*DEXP(TINF*(-.0021622D0))
C
C   THE OTHER CONTRIBUTIONS ARE CALCULATED BY SUBROUTINES HIALT OR
C   LOWALT, AS APPROPRIATE, AND ADDED INTO THE LOGARITHM OF RHO.
C
      IF (HGT .GT. 125.D0) GO TO 70
C
C          ......
      CALL LOWALT (HGT   ,RHOZ  ,TINF  ,TX    ,T0    ,ZJ0   ,RHO   )
C          ......
C
      GO TO 80
C
C          .....
   70 CALL HIALT (DEL0  ,HGT   ,PHJ   ,TINF  ,TX    ,T0    ,ZJ0   ,RHO)
C          .....
C
   80 RHO = RHO * DL10RG
C
C                      CONVERT RHO FROM CGS TO MKS UNITS.
C
   90 RHO = RHO*1.D12
C
C
  999 RETURN
      END


      SUBROUTINE GEO_DEFS
     &          (map_projection,map_lat,map_lon,map_size)

c***********************************************************************
c                   subroutine geo_defs
c***********************************************************************

c  Program Source:  Naval Ocean Systems Center - Code 542

c  Date:
c     01 Mar 1995

c  Function:
c     This subroutine sets up parameters for geographic displays.

c     Projection    LAT(1) LON(1) LAT(2) LON(2) SIZE(1) SIZE(2)
c     rectangular   lat1   lon1   lat2   lon2   size x  size y
c     mercator      lat1   lon1   lat2   lon2   size x  size y
c     gnomonic      lat0   lon0   range  N/A    size x  size y
c     azimuthal     lat0   lon0   range  N/A    size x  size y
c     orthographic  lat0   lon0   range  N/A    size x  size y
c                   stereographic

c     Latitudes and longitudes in degrees
c     Sign convention is + for N/E and - for S/W

c  Parameters passed:
c     map_projection[s  ] projection indicator;
c                         ='azim':  Azimuthal equidistant
c                         ='gnom':  Gnomonic
c                         ='merc':  Mercator
c                         ='orth':  Orthographic
c                         ='rect':  linear in longitude and latitude

c     map_lat       [r,2] latitude  bounds; deg North;

c     map_lon       [r,2] longitude bounds; deg West;

c     map_size      [r,2] lengths of map axes; inches;

c                         See table above for special handling for
c                         MAP_PROJECTION='azim', 'gnom' and 'ortho'.

c  Parameters returned:

c  Common blocks referenced:
c     geo$data

c  Functions and subroutines referenced:
c     abs
c     atan
c     cos
c     max
c     min
c     sin
c     sqrt
c     tan

c     geo_coord
c     lwpc_error
c     str_upper

c  References:

c  Change History:

c     18 Dec 1997   Added stereographic projection.

c*******************!***************************************************

      IMPLICIT NONE

c     Map parameters
      include      'lwpc_geo.cmn'

      character*(*) map_projection
      real          map_lat     (2)
      real          map_lon     (2)
      real          map_size    (2)

      character*200 error_msg
      integer       inside
      real          br
      real          crclt
      real          dtr
      real          geo_brng
      real          geo_rng
      real          geo_x1
      real          geo_x2
      real          geo_y1
      real          geo_y2
      real          lat
      real          lon
      real          plt_x1
      real          plt_x2
      real          plt_y1
      real          plt_y2
      real          rclt
      real          rlng
      real          srclt
      real          tmp

      data          dtr/0.01745329252/

c     Set values in LWPC map common
      geo_projection=map_projection

      geo_size_x=map_size(1)
      geo_size_y=map_size(2)

c     Store parameter for map selection
      geo_prjctn=geo_projection
      call STR_UPPER (geo_prjctn,0,0)

      SELECT CASE( geo_prjctn )

      CASE( 'A','G','O','S' )

c        Azimuthal Equidistant, Gnomonic, Orthographic or Stereographic
         geo_center_lat=map_lat(1)
         geo_center_lon=map_lon(1)
         geo_range _max=map_lat(2)

c        Ensure that the longitude is +/- 180
         if (geo_center_lon .lt. -180.) then
            geo_center_lon=MOD(geo_center_lon,360.)+360.
         else
     &   if (geo_center_lon .gt. 180.) then
            geo_center_lon=MOD(geo_center_lon,360.)-360.
         end if

         geo_clt0=(90.-geo_center_lat)*dtr
         geo_cclt0=COS(geo_clt0)
         geo_sclt0=SIN(geo_clt0)
         geo_lng0=geo_center_lon*dtr

c        Scaling
         SELECT CASE( geo_prjctn )

         CASE( 'A' )

            geo_rng_max=MIN(geo_range_max,10000.)/6366.

            geo_scale_y=.5*MAX(geo_size_x,geo_size_y)/geo_rng_max

c           Scaling is chosen to force a circular presentation
            geo_scale_x=geo_scale_y

            geo_origin_x=.5*geo_size_x
            geo_origin_y=.5*geo_size_y

c           Adjust range max to include the corners
            tmp=SQRT((.5*geo_size_x)**2+(.5*geo_size_y)**2)/geo_scale_y

            geo_rng_max=MIN(19999.,INT(tmp*6366./1000.+.99)*1000.)/6366.

         CASE( 'G' )

c           Limit range max to practical value
            geo_rng_max=MIN(geo_range_max,8000.)/6366.

            if (geo_center_lat .gt. 0.) then

               call GEO_COORD
     &             (geo_center_lat-9.*geo_rng_max*6.366,geo_center_lon,
     &              geo_rng,geo_brng,geo_x1,geo_y1,plt_x1,plt_y1)
            else

               call GEO_COORD
     &             (geo_center_lat+9.*geo_rng_max*6.366,geo_center_lon,
     &              geo_rng,geo_brng,geo_x1,geo_y1,plt_x1,plt_y1)
            end if

            geo_scale_y=.5*MAX(geo_size_x,geo_size_y)/ABS(geo_y1)

c           Scaling is chosen to force a circular presentation
            geo_scale_x=geo_scale_y

            geo_origin_x=.5*geo_size_x
            geo_origin_y=.5*geo_size_y

c           Adjust range max to include the corners
            inside=1
            tmp=geo_rng_max*6366.
            do while (inside .gt. 0)

               inside=0
               if (tmp .lt. 10000.) then

                  geo_rng_max=tmp/6366.

                  do br=0.,180.,10.

                     geo_brng=br*dtr
                     geo_rng=geo_rng_max

                     call RECVR2
     &                   (geo_lng0,geo_clt0,
     &                    geo_cclt0,geo_sclt0,
     &                    geo_brng,geo_rng,
     &                    rlng,rclt,crclt,srclt)

                     lat=90.-rclt/dtr
                     lon=rlng/dtr

                     call GEO_COORD
     &                   (lat,lon,
     &                    geo_rng,geo_brng,geo_x1,geo_y1,plt_x1,plt_y1)

                     if (plt_x1 .ge.         0. .and.
     &                   plt_x1 .le. geo_size_x .and.
     &                   plt_y1 .ge.         0. .and.
     &                   plt_y1 .le. geo_size_y) inside=inside+1
                  end do
                  tmp=tmp+1000.
               end if
            end do

         CASE( 'O' )

c           Limit range max to practical value
            geo_rng_max=MIN(geo_range_max,10000.)/6366.

            geo_scale_y=.5*MAX(geo_size_x,geo_size_y)/SIN(geo_rng_max)

c           Scaling is chosen to force a circular presentation
            geo_scale_x=geo_scale_y

            geo_origin_x=.5*geo_size_x
            geo_origin_y=.5*geo_size_y

c           Adjust range max to include the corners
            tmp=SQRT((.5*geo_size_x)**2+(.5*geo_size_y)**2)/geo_scale_y

            if (tmp .ge. 1.) then

               geo_rng_max=10000./6366.
            else

               geo_rng_max=INT(ASIN(tmp)*6366./1000.+.99)*1000./6366.
            end if

         CASE( 'S' )

c           Limit range max to practical value
            geo_rng_max=MIN(geo_range_max,10000.)/6366.

            tmp=SIN(geo_rng_max)/(1.+COS(geo_rng_max))
            geo_scale_y=.5*MAX(geo_size_x,geo_size_y)/(2.*tmp)

c           Scaling is chosen to force a circular presentation
            geo_scale_x=geo_scale_y

            geo_origin_x=.5*geo_size_x
            geo_origin_y=.5*geo_size_y

c           Adjust range max to include the corners
            inside=1
            tmp=geo_rng_max*6366.
            do while (inside .gt. 0)

               inside=0
               if (tmp .lt. 10000.) then

                  geo_rng_max=tmp/6366.

                  do br=0.,180.,10.

                     geo_brng=br*dtr
                     geo_rng=geo_rng_max

                     call RECVR2
     &                   (geo_lng0,geo_clt0,
     &                    geo_cclt0,geo_sclt0,
     &                    geo_brng,geo_rng,
     &                    rlng,rclt,crclt,srclt)

                     lat=90.-rclt/dtr
                     lon=rlng/dtr

                     call GEO_COORD
     &                   (lat,lon,
     &                    geo_rng,geo_brng,geo_x1,geo_y1,plt_x1,plt_y1)

                     if (plt_x1 .ge.         0. .and.
     &                   plt_x1 .le. geo_size_x .and.
     &                   plt_y1 .ge.         0. .and.
     &                   plt_y1 .le. geo_size_y) inside=inside+1
                  end do
                  tmp=tmp+1000.
               end if
            end do

         END SELECT

      CASE( 'M','R' )

c        Mercator or Rectangular

c        Define some working values
         geo_corner1_lat=map_lat(1)
         geo_corner1_lon=map_lon(1)
         geo_corner2_lat=map_lat(2)
         geo_corner2_lon=map_lon(2)

         if (geo_corner2_lon .ge. geo_corner1_lon)

     &      geo_corner2_lon=geo_corner2_lon-360.

         if (geo_corner1_lon .eq. -180. .and.
     &       geo_corner2_lon .eq. -540.) then

c           Correct this special (ambiguous) case
            geo_corner1_lon= 180.
            geo_corner2_lon=-180.
         end if

c        Scaling
         geo_scale_x=1.
         geo_scale_y=1.

         geo_origin_x=0.
         geo_origin_y=0.

         SELECT CASE( geo_prjctn )

         CASE( 'M' )

            geo_clt0=0.

            call GEO_COORD
     &          (geo_corner1_lat,geo_corner1_lon,
     &           geo_rng,geo_brng,geo_x1,geo_y1,plt_x1,plt_y1)

            geo_clt0=geo_y1

            call GEO_COORD
     &          (geo_corner2_lat,geo_corner2_lon,
     &           geo_rng,geo_brng,geo_x2,geo_y2,plt_x2,plt_y2)

            geo_scale_x=geo_size_x/(geo_x2-geo_x1)
            geo_scale_y=geo_size_y/ geo_y2

            call GEO_COORD
     &          (geo_corner1_lat,geo_corner1_lon,
     &           geo_rng,geo_brng,geo_x1,geo_y1,plt_x1,plt_y1)

            call GEO_COORD
     &          (geo_corner2_lat,geo_corner2_lon,
     &           geo_rng,geo_brng,geo_x2,geo_y2,plt_x2,plt_y2)

         CASE( 'R' )

            call GEO_COORD
     &          (geo_corner1_lat,geo_corner1_lon,
     &           geo_rng,geo_brng,geo_x1,geo_y1,plt_x1,plt_y1)

            call GEO_COORD
     &          (geo_corner2_lat,geo_corner2_lon,
     &           geo_rng,geo_brng,geo_x2,geo_y2,plt_x2,plt_y2)

            geo_scale_x=geo_size_x/(geo_x2-geo_x1)
            geo_scale_y=geo_size_y/(geo_y2-geo_y1)

            call GEO_COORD
     &          (geo_corner1_lat,geo_corner1_lon,
     &           geo_rng,geo_brng,geo_x1,geo_y1,plt_x1,plt_y1)

            call GEO_COORD
     &          (geo_corner2_lat,geo_corner2_lon,
     &           geo_rng,geo_brng,geo_x2,geo_y2,plt_x2,plt_y2)

         END SELECT

         geo_origin_x=-plt_x1
         geo_origin_y=-plt_y1

      CASE DEFAULT

         write(error_msg,
     &       '(''[GEO_DEFS]:'',1x,
     &         ''projection name: '',a,1x,
     &         ''not recognized'')') map_projection
         call LWPC_ERROR('ERROR',error_msg)

      END SELECT

      RETURN
      END      ! GEO_DEFS


module dgfem_kernel_module
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! This module contains subroutines for solving the within cell equations
! using the LD method
!
! LD: psi(x) = 1 + x + y + z
!
! ** 4  DoFs per cell
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
implicit none

real(kind=8),allocatable  ::  tmass(:,:),tstiffx(:,:),tstiffy(:,:),tstiffz(:,:),&
                              tfacexO(:,:),tfaceyO(:,:),tfacezO(:,:),           &
                              tfacexI(:,:),tfaceyI(:,:),tfacezI(:,:),           &
                              tfsx(:,:),tfsy(:,:),tfsz(:,:)
!
contains

! LD Subroutine's

subroutine ld_kernel(del,sigt,omega,face_psi,vecx)
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   ! This subroutine solves the ld (linear discontinuous)
   ! equations for a single mesh cell. For performance
   ! purposes MATHEMATICA solved equations are used.
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   ! Arguments

     real(kind=8) :: del(3)           ! vector of cell dimensions dx,dy,dz
     real(kind=8) :: sigt             ! total cross sections
     real(kind=8) :: omega(3)         ! direction cosines
     real(kind=8) :: vecx(4)          ! on input:  vector of length nl containing source moments
                                      ! on output: vector of length nl containing angular flux moments
     real(kind=8) :: face_psi(4,3)    ! on input: inflow fluxes in the 3 inflow faces, on output: outflow fluxes on the three outflow faces

   ! Local Variables

     real(kind=8) :: a11,a22,a33,a44,&
                     a12,a13,a14
     real(kind=8) :: b1,b2,b3,b4
     real(kind=8) :: cm,cmu,ceta,cxi,vol
     real(kind=8) :: delx,dely,delz
     real(kind=8) :: third
     real(kind=8) :: den
     integer :: i,j

   ! Step 1: Assign values to aij

     delx  = del(1)
     dely  = del(2)
     delz  = del(3)
     third = 1.0d0 / 3.0d0
     vol   = delx*dely*delz
     cm    = vol*sigt
     cmu   = dely*delz*omega(1)
     ceta  = delx*delz*omega(2)
     cxi   = delx*dely*omega(3)
     a11   = cm + cmu + ceta + cxi
     a22   = third * ( cm + cmu + ceta ) + cxi
     a33   = third * ( cm + cmu + cxi  ) + ceta
     a44   = third * ( cm + cxi + ceta ) + cmu
     a12   = cxi
     a13   = ceta
     a14   = cmu

   ! Step 2: Build right hand side

     b1 =  vol      *vecx(1) - face_psi(1,1) - face_psi(1,2) - face_psi(1,3)
     b2 =  third*vol*vecx(2) - face_psi(2,1) - face_psi(2,2) - face_psi(2,3)
     b3 =  third*vol*vecx(3) - face_psi(3,1) - face_psi(3,2) - face_psi(3,3)
     b4 =  third*vol*vecx(4) - face_psi(4,1) - face_psi(4,2) - face_psi(4,3)

   ! Step 3: Solve linear system of equations using precomputed solution from
   ! Mathematica in terms of matrix entries aij.

     den     = a14**2*a22*a33 + (a13**2*a22 + (a12**2 + a11*a22)*a33)*a44
     vecx(1) = -(a12*a33*a44*b2) + a22*(a33*a44*b1 - a13*a44*b3 - a14*a33*b4)
     vecx(1) = vecx(1) / den
     vecx(2) = (a14**2*a33 + (a13**2 + a11*a33)*a44)*b2 + a12*(a33*a44*b1 - &
               a13*a44*b3 - a14*a33*b4)
     vecx(2) = vecx(2) / den
     vecx(3) = (a14**2*a22 + (a12**2 + a11*a22)*a44)*b3 + a13*(a22*a44*b1 - &
               a12*a44*b2 - a14*a22*b4)
     vecx(3) = vecx(3) / den
     vecx(4) = a14*(a22*a33*b1 - a12*a33*b2 - a13*a22*b3) + (a13**2*a22 +   &
               (a12**2 + a11*a22)*a33)*b4
     vecx(4) = vecx(4) / den

   ! Step 4: Compute outflow fluxes by multiplying vecx with the edge matrices.

     face_psi=0.0d0

     ! in x-direction

       face_psi(1,1) = -cmu * ( vecx(1) + vecx(4) )
       face_psi(2,1) = -third*cmu*vecx(2)
       face_psi(3,1) = -third*cmu*vecx(3)
       face_psi(4,1) = -face_psi(1,1)

     ! in y-direction

       face_psi(1,2) = -ceta * ( vecx(1) + vecx(3) )
       face_psi(2,2) = -third*ceta*vecx(2)
       face_psi(3,2) = -face_psi(1,2)
       face_psi(4,2) = -third*ceta*vecx(4)

     ! in x-direction

       face_psi(1,3) = -cxi * ( vecx(1) + vecx(2) )
       face_psi(2,3) = -face_psi(1,3)
       face_psi(3,3) = -third*cxi*vecx(3)
       face_psi(4,3) = -third*cxi*vecx(4)

   ! --- The end ---

end subroutine

! SOLVER_COMPLETE_DENSE SUBROUTINES ("DENSE")

subroutine complete_kernel_dense(nl,del,sigt,omega,face_psi,vecx)
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   ! This subroutine solves the dgfem (complete family)
   ! equations for a single mesh cell.
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   ! Arguments

     integer :: nl                    ! vector of cell indices, degrees of freedom/cell = (lambda+1)^3
     real(kind=8) :: del(3)           ! vector of cell dimensions dx,dy,dz
     real(kind=8) :: sigt             ! total cross sections
     real(kind=8) :: omega(3)         ! direction cosines
     real(kind=8) :: vecx(nl)         ! on input:  vector of length nl containing source moments
                                      ! on output: vector of length nl containing angular flux moments
     real(kind=8) :: face_psi(nl,3)   ! on input: inflow fluxes in the 3 inflow faces, on output: outflow fluxes on the three outflow faces

   ! Local Variables

     real(kind=8) :: T(nl,nl)
     real(kind=8) :: delx,dely,delz
     real(kind=8) :: cm,csm,cfx,cfy,cfz,csx,csy,csz
     integer :: ipiv(nl),info
     integer :: i,j

   ! Step 1: Contruct matrix T

     delx = del(1)
     dely = del(2)
     delz = del(3)
     cm   = delx * dely * delz
     csm  = sigt*cm
     cfx  = omega(1) * dely * delz
     cfy  = omega(2) * delx * delz
     cfz  = omega(3) * delx * dely
     csx  = -cfx
     csy  = -cfy
     csz  = -cfz

     T = cfx * tfsx + cfy * tfsy + cfz * tfsz
     do i=1,nl
        T(i,i) = T(i,i) + csm*tmass(i,i)
        vecx(i)= cm*tmass(i,i)*vecx(i)
     end do

   ! Step 2: Build right hand side

     vecx = vecx - face_psi(:,1) - face_psi(:,2) - face_psi(:,3)

   ! Step 3: Solve linear system of equations

     call dgesv(nl,1,T,nl,ipiv,vecx,nl,info)

   ! Step 4: Compute outflow fluxes by multiplying vecx with the edge matrices.
   !         BLAS-2 subroutines are used because they are faster than matmul.
   !         The factors in front of the inflow edge
   !         matrices for the NEXT cell happen to be equal to the stiffness matrix
   !         factors. This is not bug.

     face_psi=0.0d0

     ! in x-direction
     call dgemv('N',nl,nl,csx,tfacexI,nl,vecx,1,0.d0,face_psi(:,1),1)
!!     face_psi(:,1) = csx * matmul(tfacexI,vecx)

     ! in y-direction
     call dgemv('N',nl,nl,csy,tfaceyI,nl,vecx,1,0.d0,face_psi(:,2),1)
!!     face_psi(:,2) = csy * matmul(tfaceyI,vecx)

     ! in x-direction
     call dgemv('N',nl,nl,csz,tfacezI,nl,vecx,1,0.d0,face_psi(:,3),1)
!!     face_psi(:,3) = csz * matmul(tfacezI,vecx)

   ! --- The end ---

end subroutine

subroutine lagrange_kernel_dense(nl,del,sigt,omega,face_psi,vecx)
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   ! This subroutine solves the dgfem (lagrange family)
   ! equations for a single mesh cell.
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   ! Arguments

     integer :: nl                    ! vector of cell indices, degrees of freedom/cell = (lambda+1)^3
     real(kind=8) :: del(3)           ! vector of cell dimensions dx,dy,dz
     real(kind=8) :: sigt             ! total cross sections
     real(kind=8) :: omega(3)         ! direction cosines
     real(kind=8) :: vecx(nl)         ! on input:  vector of length nl containing source moments
                                      ! on output: vector of length nl containing angular flux moments
     real(kind=8) :: face_psi(nl,3)   ! on input: inflow fluxes in the 3 inflow faces, on output: outflow fluxes on the three outflow faces

   ! Local Variables

     real(kind=8) :: T(nl,nl),mass(nl,nl)
     real(kind=8) :: delx,dely,delz
     real(kind=8) :: cm,csm,cfx,cfy,cfz,csx,csy,csz
     integer :: ipiv(nl),info
     integer :: i,j

   ! Step 1: Contruct matrix T

     delx = del(1)
     dely = del(2)
     delz = del(3)
     cm   = delx * dely * delz
     csm  = sigt*cm
     cfx  = omega(1) * dely * delz
     cfy  = omega(2) * delx * delz
     cfz  = omega(3) * delx * dely
     csx  = -cfx
     csy  = -cfy
     csz  = -cfz

     T = cfx * tfsx + cfy * tfsy + cfz * tfsz
     do i=1,nl
        T(i,i) = T(i,i) + csm*tmass(i,i)
        vecx(i)= cm*tmass(i,i)*vecx(i)
     end do

   ! Step 2: Build right hand side

     vecx = vecx - face_psi(:,1) - face_psi(:,2) - face_psi(:,3)

   ! Step 3: Solve linear system of equations

     call dgesv(nl,1,T,nl,ipiv,vecx,nl,info)

   ! Step 4: Compute outflow fluxes by multiplying vecx with the edge matrices.
   !         BLAS-2 subroutines are used because they are faster than matmul.
   !         The factors in front of the inflow edge
   !         matrices for the NEXT cell happen to be equal to the stiffness matrix
   !         factors. This is not bug.

     face_psi=0.0d0

     ! in x-direction
     call dgemv('N',nl,nl,csx,tfacexI,nl,vecx,1,0.d0,face_psi(:,1),1)
!!     face_psi(:,1) = csx * matmul(tfacexI,vecx)

     ! in y-direction
     call dgemv('N',nl,nl,csy,tfaceyI,nl,vecx,1,0.d0,face_psi(:,2),1)
!!     face_psi(:,2) = csy * matmul(tfaceyI,vecx)

     ! in x-direction
     call dgemv('N',nl,nl,csz,tfacezI,nl,vecx,1,0.d0,face_psi(:,3),1)
!!     face_psi(:,3) = csz * matmul(tfacezI,vecx)

   ! --- The end ---

end subroutine

subroutine build_tmats_complete(lmbd)
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   ! This subroutines allocates and pre-computes the
   ! templates of the mass,stiffness and face matrices.
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   ! Arguments

     integer :: lmbd

   ! Local variables

     integer :: ix,iy,iz,jx,jy,jz,i,j

   ! Allocate and initialize matrix templates

     j = (lmbd+3)*(lmbd+2)*(lmbd+1)/6
     allocate( tmass(j,j) )
     allocate( tstiffx(j,j),tstiffy(j,j),tstiffz(j,j) )
     allocate( tfacexO(j,j),tfaceyO(j,j),tfacezO(j,j) )
     allocate( tfacexI(j,j),tfaceyI(j,j),tfacezI(j,j) )
     allocate( tfsx(j,j),tfsy(j,j),tfsz(j,j) )

     tmass=0.0d0;tstiffx=0.0d0;tstiffy=0.0d0;tstiffz=0.0d0
     tfacexO=0.0d0;tfaceyO=0.0d0;tfacezO=0.0d0
     tfacexI=0.0d0;tfaceyI=0.0d0;tfacezI=0.0d0

   ! Fill matrix templates

     do jx=0,lmbd
       do jy=0,lmbd-jx
         do jz=0,lmbd-jx-jy
           do ix=0,lmbd
             do iy=0,lmbd-ix
               do iz=0,lmbd-ix-iy

                  ! compute position in flattened form

                   i = iz+1-iy*(-3+2*ix+iy-2*lmbd)/2+ix*(11+ix**2-3*ix*(2+lmbd)+3*lmbd*(4+lmbd))/6
                   j = jz+1-jy*(-3+2*jx+jy-2*lmbd)/2+jx*(11+jx**2-3*jx*(2+lmbd)+3*lmbd*(4+lmbd))/6

                  ! mass matrix

                   if(ix.eq.jx .and. iy.eq.jy .and. iz.eq.jz) then
                      tmass(i,j)  = 1.0d0 / real( (2*ix+1)*(2*iy+1)*(2*iz+1) ,8)
                   end if

                  ! stiffness matrix in x, condition for iy, jy, ix and jz is
                  ! self-explaining, the last two conditions arise from the sum
                  ! in PhD notes.

                    if(iy.eq.jy .and. iz.eq.jz .and. jx.le.ix-1  .and. mod(jx+ix+1,2).eq.0) then
                      tstiffx(i,j)  = 2.0d0 / real( (2*iy+1)*(2*iz+1) ,8)
                    end if

                  ! stiffness matrix in y

                    if(ix.eq.jx .and. iz.eq.jz .and. jy.le.iy-1  .and. mod(jy+iy+1,2).eq.0) then
                      tstiffy(i,j)  = 2.0d0 / real( (2*ix+1)*(2*iz+1) ,8)
                    end if

                  ! stiffness matrix in z

                    if(ix.eq.jx .and. iy.eq.jy .and. jz.le.iz-1  .and. mod(jz+iz+1,2).eq.0) then
                      tstiffz(i,j)  = 2.0d0 / real( (2*ix+1)*(2*iy+1) ,8)
                    end if

                  ! face matrices on the west/east faces (normal to x-axis)

                    if(iy.eq.jy .and. iz.eq.jz) then
                      ! outflow face
                      tfacexO(i,j)  = 1.0d0 / real( (2*iy+1)*(2*iz+1) ,8)
                      ! inflow face
                      tfacexI(i,j)  = (-1.0d0)**(ix) / real( (2*iy+1)*(2*iz+1) ,8)
                    end if

                  ! face matrices on the south/north faces (normal to y-axis)

                    if(ix.eq.jx .and. iz.eq.jz) then
                      ! outflow face
                      tfaceyO(i,j)  = 1.0d0 / real( (2*ix+1)*(2*iz+1) ,8)
                      ! inflow face
                      tfaceyI(i,j)  = (-1.0d0)**(iy) / real((2*ix+1)*(2*iz+1) ,8)
                    end if

                  ! face matrices on the bottom/top faces (normal to z-axis)

                    if(ix.eq.jx .and. iy.eq.jy) then
                      ! outflow face
                      tfacezO(i,j)  = 1.0d0 / real( (2*ix+1)*(2*iy+1) ,8)
                      ! inflow face
                      tfacezI(i,j)  = (-1.0d0)**(iz) / real((2*ix+1)*(2*iy+1) ,8)
                    end if

               end do
             end do
           end do
         end do
       end do
     end do

   ! Compute tfsx, tfsy, tfsz

     tfsx = tfacexO - tstiffx
     tfsy = tfaceyO - tstiffy
     tfsz = tfacezO - tstiffz

end subroutine

subroutine build_tmats_lagrange(lmbd)
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   ! This subroutines allocates and pre-computes the
   ! templates of the mass,stiffness and face matrices.
   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   ! Arguments

     integer :: lmbd

   ! Local variables

     integer :: ix,iy,iz,jx,jy,jz,i,j

   ! Allocate and initialize matrix templates

     j = (lmbd+1)**3
     allocate( tmass(j,j) )
     allocate( tstiffx(j,j),tstiffy(j,j),tstiffz(j,j) )
     allocate( tfacexO(j,j),tfaceyO(j,j),tfacezO(j,j) )
     allocate( tfacexI(j,j),tfaceyI(j,j),tfacezI(j,j) )
     allocate( tfsx(j,j),tfsy(j,j),tfsz(j,j) )

     tmass=0.0d0;tstiffx=0.0d0;tstiffy=0.0d0;tstiffz=0.0d0
     tfacexO=0.0d0;tfaceyO=0.0d0;tfacezO=0.0d0
     tfacexI=0.0d0;tfaceyI=0.0d0;tfacezI=0.0d0

   ! Fill matrix templates

     do jx=0,lmbd
       do jy=0,lmbd
         do jz=0,lmbd
           do ix=0,lmbd
             do iy=0,lmbd
               do iz=0,lmbd

                  ! compute position in flattened form

                   i = iz+1+(lmbd+1)*iy+(lmbd+1)**2*ix
                   j = jz+1+(lmbd+1)*jy+(lmbd+1)**2*jx

                  ! mass matrix

                   if(ix.eq.jx .and. iy.eq.jy .and. iz.eq.jz) then
                      tmass(i,j)  = 1.0d0 / real( (2*ix+1)*(2*iy+1)*(2*iz+1) ,8)
                   end if

                  ! stiffness matrix in x, condition for iy, jy, ix and jz is
                  ! self-explaining, the last two conditions arise from the sum
                  ! in PhD notes.

                    if(iy.eq.jy .and. iz.eq.jz .and. jx.le.ix-1  .and. mod(jx+ix+1,2).eq.0) then
                      tstiffx(i,j)  = 2.0d0 / real( (2*iy+1)*(2*iz+1) ,8)
                    end if

                  ! stiffness matrix in y

                    if(ix.eq.jx .and. iz.eq.jz .and. jy.le.iy-1  .and. mod(jy+iy+1,2).eq.0) then
                      tstiffy(i,j)  = 2.0d0 / real( (2*ix+1)*(2*iz+1) ,8)
                    end if

                  ! stiffness matrix in z

                    if(ix.eq.jx .and. iy.eq.jy .and. jz.le.iz-1  .and. mod(jz+iz+1,2).eq.0) then
                      tstiffz(i,j)  = 2.0d0 / real( (2*ix+1)*(2*iy+1) ,8)
                    end if

                  ! face matrices on the west/east faces (normal to x-axis)

                    if(iy.eq.jy .and. iz.eq.jz) then
                      ! outflow face
                      tfacexO(i,j)  = 1.0d0 / real( (2*iy+1)*(2*iz+1) ,8)
                      ! inflow face
                      tfacexI(i,j)  = (-1.0d0)**(ix) / real( (2*iy+1)*(2*iz+1) ,8)
                    end if

                  ! face matrices on the south/north faces (normal to y-axis)

                    if(ix.eq.jx .and. iz.eq.jz) then
                      ! outflow face
                      tfaceyO(i,j)  = 1.0d0 / real( (2*ix+1)*(2*iz+1) ,8)
                      ! inflow face
                      tfaceyI(i,j)  = (-1.0d0)**(iy) / real((2*ix+1)*(2*iz+1) ,8)
                    end if

                  ! face matrices on the bottom/top faces (normal to z-axis)

                    if(ix.eq.jx .and. iy.eq.jy) then
                      ! outflow face
                      tfacezO(i,j)  = 1.0d0 / real( (2*ix+1)*(2*iy+1) ,8)
                      ! inflow face
                      tfacezI(i,j)  = (-1.0d0)**(iz) / real((2*ix+1)*(2*iy+1) ,8)
                    end if

               end do
             end do
           end do
         end do
       end do
     end do

   ! Compute tfsx, tfsy, tfsz

     tfsx = tfacexO - tstiffx
     tfsy = tfaceyO - tstiffy
     tfsz = tfacezO - tstiffz

end subroutine

subroutine clean_complete_kernel
  ! cleaning not needed?
   if( allocated(tmass) )   deallocate(tmass)
   if( allocated(tstiffx) ) deallocate(tstiffx)
   if( allocated(tstiffy) ) deallocate(tstiffy)
   if( allocated(tstiffz) ) deallocate(tstiffz)
   if( allocated(tfacexO) ) deallocate(tfacexO)
   if( allocated(tfaceyO) ) deallocate(tfaceyO)
   if( allocated(tfacezO) ) deallocate(tfacezO)
   if( allocated(tfacexI) ) deallocate(tfacexI)
   if( allocated(tfaceyI) ) deallocate(tfaceyI)
   if( allocated(tfacezI) ) deallocate(tfacezI)
   if( allocated(tfsx))     deallocate(tfsx)
   if( allocated(tfsy))     deallocate(tfsy)
   if( allocated(tfsz))     deallocate(tfsz)
end subroutine

subroutine clean_lagrange_kernel
   if( allocated(tmass) )   deallocate(tmass)
   if( allocated(tstiffx) ) deallocate(tstiffx)
   if( allocated(tstiffy) ) deallocate(tstiffy)
   if( allocated(tstiffz) ) deallocate(tstiffz)
   if( allocated(tfacexO) ) deallocate(tfacexO)
   if( allocated(tfaceyO) ) deallocate(tfaceyO)
   if( allocated(tfacezO) ) deallocate(tfacezO)
   if( allocated(tfacexI) ) deallocate(tfacexI)
   if( allocated(tfaceyI) ) deallocate(tfaceyI)
   if( allocated(tfacezI) ) deallocate(tfacezI)
   if( allocated(tfsx))     deallocate(tfsx)
   if( allocated(tfsy))     deallocate(tfsy)
   if( allocated(tfsz))     deallocate(tfsz)
end subroutine

end module


c gmm01f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
c  subroutine cofxuds0.f returns the two classes of vector
c  (axial) translation coefficients for a given combination of
c  (m,n,m,v) and a given dimensionless translation distance kd
cu uses subroutine gid0.f
      subroutine cofxuds0(nmax,m,n,v,sja,sya,A,B,Aj,Bj)

      implicit double precision (a-h,o-z)
      include 'gmm01f.par'
      parameter (ni0=np*(np+1)*(2*np+1)/3+np*np)
      parameter (ng0=np*(2*np**3+10*np**2+19*np+5)/6)

      integer v,p,qmax
      double precision sja(0:n+v+1),sya(0:n+v+1)
      complex*16 A,B,Aj,Bj,signz
      common/ig0/iga0(ni0)
      common/g0/ga0(ng0)
      common/cofmnv0/cof0(ni0)
      fa(m,p)=dble(-2*m*p*(p-1))
      fb(n,v,p)=dble(p*p-(n+v+1)*(n+v+1))
     +            *dble(p*p-(n-v)*(n-v))/dble(4*p*p-1)
      if(iabs(m).gt.n.or.iabs(m).gt.v) then
         write(6,*) '|m|>n or v in subroutine cofxuds0.f'
         stop
      endif
      A=0.d0
      B=0.d0
      Aj=0.d0
      Bj=0.d0
      call gid0(nmax,m,n,v,id)
      c=cof0(id)
      ig=iga0(id)
      nv2=v*(v+1)+n*(n+1)
      signz=dcmplx(0.d0,1.d0)**(n+v)
      p=n+v+2
      qmax=min(n,v)
      do i=1,qmax+1
         p=p-2
         cp=dble(nv2-p*(p+1))*ga0(ig+i)
         sj=sja(p)
         sy=sya(p)
         A=A+dcmplx(sj,sy)*signz*cp
         Aj=Aj+sj*signz*cp
         signz=-signz
      enddo
      A=A*c
      Aj=Aj*c
      if(m.eq.0) return
      signz=dcmplx(0.d0,1.d0)**(n+v+1)
      p=n+v
      do 20 i=1,qmax
         p=p-2
         signz=-signz
         if(i.eq.1) then
                cp=dble(2*p+3)*fa(m,p+3)
                cp=cp*ga0(ig+1)/dble((p+3)*(p+2))
                goto 21
             endif
             if(i.eq.qmax) then
                if(p.eq.0) goto 22
                nv2=p*(p+1)
                cp=dble(2*p+3)*fa(m,p+1)
                cp=-cp*ga0(ig+i+1)/dble(nv2)
                goto 21
             endif
 22      c4=fa(m,p+2)
             cp=-dble((p+1)*(p+2))*fb(n,v,p+2)*ga0(ig+i)
         cp=cp+dble((p+2)*(p+1))*fb(n,v,p+1)*ga0(ig+i+1)
         cp=cp*dble(2*p+3)/c4
 21      sj=sja(p+1)
         sy=sya(p+1)
         B=B+dcmplx(sj,sy)*signz*cp
         Bj=Bj+sj*signz*cp
 20   continue
      B=B*c
      Bj=Bj*c
      return
      end


      SUBROUTINE MC01XD( ALPHA, BETA, GAMMA, DELTA, EVR, EVI, EVQ,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the roots of the polynomial
C
C         P(t) = ALPHA + BETA*t + GAMMA*t^2 + DELTA*t^3 .
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     ALPHA   (input) DOUBLE PRECISION
C     BETA    (input) DOUBLE PRECISION
C     GAMMA   (input) DOUBLE PRECISION
C     DELTA   (input) DOUBLE PRECISION
C             The coefficients of the polynomial P.
C
C     EVR     (output) DOUBLE PRECISION array, DIMENSION at least 3
C     EVI     (output) DOUBLE PRECISION array, DIMENSION at least 3
C     EVQ     (output) DOUBLE PRECISION array, DIMENSION at least 3
C             On output, the kth root of P will be equal to
C             (EVR(K) + i*EVI(K))/EVQ(K) if EVQ(K) .NE. ZERO. Note that
C             the quotient may over- or underflow. If P has a degree d
C             less than 3, then 3-d computed roots will be infinite.
C             EVQ(K) >= 0.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, DIMENSION (LDWORK)
C             On exit, if LDWORK = -1 on input, then DWORK(1) returns
C             the optimal value of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.  LDWORK >= 42.
C
C             If LDWORK = -1, an optimal workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
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             > 0:  if INFO = j, 1 <= j <= 6, an error occurred during
C                   the call to one of the LAPACK Library routines DGGEV
C                   or DGEEV (1 <= j <= 3). If INFO < 3, the values
C                   returned in EVR(K), EVI(K), and EVQ(K) should be
C                   correct for K = INFO+1,...,3.
C
C     METHOD
C
C     A matrix pencil is built, whose eigenvalues are the roots of the
C     given polynomial, and they are computed using the QZ algorithm.
C     However, when the ratio between the largest and smallest (in
C     magnitude) polynomial coefficients is relatively big, and either
C     ALPHA or DELTA has the largest magnitude, then a standard
C     eigenproblem is solved using the QR algorithm, and EVQ(I) are set
C     to 1, for I = 1,2,3.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable.
C
C     CONTRIBUTORS
C
C     M. Slowik, Institut fur Mathematik, TU Berlin, Dec. 2004.
C     P. Benner, Fakultat fur Mathematik, TU Chemnitz, Dec. 2004.
C     V. Sima, Research Institute for Informatics, Bucharest, Nov. 2005.
C
C     REVISIONS
C
C     V. Sima, Jan. 2013, Dec. 2013.
C
C     KEYWORDS
C
C     Eigenvalues, equivalence transformation, generalized real Schur
C     form, orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TEN
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 1.0D1 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDWORK
      DOUBLE PRECISION  ALPHA, BETA, DELTA, GAMMA
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), EVI(3), EVQ(3), EVR(3)
C     .. Local Scalars ..
      INTEGER           I, J, M2POS, NMIN, WRKPOS
      DOUBLE PRECISION  MAXC, MINC, VAR
C     .. External Subroutines ..
      EXTERNAL          DGEEV, DGGEV, DLADIV, DLASET, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      NMIN = 42
      IF ( LDWORK.EQ.-1 ) THEN
         CALL DGEEV( 'N', 'N', 3, DWORK, 3, EVR, EVI, DWORK, 1, DWORK,
     $               1, DWORK, -1, INFO )
         CALL DGGEV( 'N', 'N', 3, DWORK, 3, DWORK, 3, EVR, EVI, EVQ,
     $               DWORK, 1, DWORK, 1, DWORK(2), -1, INFO )
         DWORK(1) = MAX( NMIN, 9+INT( DWORK(1) ), 18+INT( DWORK(2) ) )
         RETURN
      ELSE IF ( LDWORK.LT.NMIN ) THEN
         INFO = -9
C
C        Error return.
C
         CALL XERBLA( 'MC01XD', -INFO )
         RETURN
      END IF
C
C     Initialize DWORK positions.
C
      CALL DLASET( 'All', 18, 1, ZERO, ZERO, DWORK, 18 )
C
      M2POS  = 10
      WRKPOS = 19
C
C     Specify the different cases.
C
      IF ( ABS( ALPHA ).GT.ABS( BETA ) ) THEN
         I = 0
         EVR(1) = ALPHA
      ELSE
         I = 1
         EVR(1) = BETA
      END IF
C
      IF ( ABS( GAMMA ).GT.ABS( DELTA ) ) THEN
         J = 2
         EVR(2) = GAMMA
      ELSE
         J = 3
         EVR(2) = DELTA
      END IF
C
      IF ( ABS( EVR(2) ).GT.ABS( EVR(1) ) ) THEN
         I = J
         MAXC = ABS( EVR(2) )
      ELSE
         MAXC = ABS( EVR(1) )
      END IF
C
      MINC = MIN( ABS( ALPHA ), ABS( BETA ),
     $            ABS( GAMMA ), ABS( DELTA ) )
      IF ( MINC.GT.ZERO ) THEN
         VAR = MAXC/MINC
      ELSE
         VAR = MAXC
      END IF
C
      IF ( VAR.GT.TEN ) THEN
C
C        Large variation in the coefficients of the polynomial.
C        Generate the matrices M1 and M2 stored in DWORK.
C        If I = 0 or 3, a standard eigenvalue problem is solved,
C        since the current LAPACK generalized eigensolver does not
C        perform balancing.
C
         IF ( I.EQ.0 ) THEN
C
C           Elements of matrix M2.
C
            DWORK(1) = -BETA/ALPHA
            DWORK(2) =  ONE
            DWORK(4) = -GAMMA/ALPHA
            DWORK(6) =  ONE
            DWORK(7) = -DELTA/ALPHA
C
         ELSE IF ( I.EQ.1 ) THEN
C
C           Elements of matrix M1.
C
            DWORK(1) = -ALPHA/BETA
            DWORK(4) = -GAMMA/BETA
            DWORK(5) =  ONE
            DWORK(7) = -DELTA/BETA
            DWORK(9) =  ONE
C
C           Elements of matrix M2.
C
            DWORK(10) = ONE
            DWORK(11) = DWORK(1)
            DWORK(14) = DWORK(4)
            DWORK(15) = ONE
            DWORK(17) = DWORK(7)
C
         ELSE IF ( I.EQ.2 ) THEN
C
C           Elements of matrix M1.
C
            DWORK(2) = -ALPHA/GAMMA
            DWORK(4) =  ONE
            DWORK(5) = -BETA/GAMMA
            DWORK(8) = -DELTA/GAMMA
            DWORK(9) =  ONE
C
C           Elements of matrix M2.
C
            DWORK(10) = ONE
            DWORK(12) = DWORK(2)
            DWORK(14) = ONE
            DWORK(15) = DWORK(5)
            DWORK(18) = DWORK(8)
C
         ELSE
C
C           Elements of matrix M1.
C
            DWORK(3) = -ALPHA/DELTA
            DWORK(4) =  ONE
            DWORK(6) = -BETA/DELTA
            DWORK(8) =  ONE
            DWORK(9) = -GAMMA/DELTA
         END IF
C
C        Compute the roots of the polynomial by solving an eigenproblem
C        using the QR- or QZ-Algorithm.
C
         IF ( I.EQ.0 .OR. I.EQ.3 ) THEN
            CALL DGEEV( 'N', 'N', 3, DWORK, 3, EVR, EVI, DWORK(WRKPOS),
     $                  1, DWORK(WRKPOS), 1, DWORK(M2POS), LDWORK-9,
     $                  INFO )
            IF ( I.EQ.0 ) THEN
C
C              The roots are reciprocals of the computed eigenvalues.
C
               J = 1
C              WHILE J.LE.3-INFO
   10          CONTINUE
               IF ( J.LE.3 - INFO ) THEN
                  IF ( EVI(J).EQ.ZERO ) THEN
                     EVR(J) = ONE/EVR(J)
                     J = J + 1
                     GO TO 10
                  ELSE IF ( EVI(J).GT.ZERO ) THEN
                     CALL DLADIV( ONE, ZERO, EVR(J), EVI(J), EVR(J+1),
     $                            EVI(J+1) )
                     EVR(J) =  EVR(J+1)
                     EVI(J) = -EVI(J+1)
                     J = J + 2
                     GO TO 10
                  END IF
               END IF
C              END WHILE 10
            END IF
            EVQ(1) = ONE
            EVQ(2) = ONE
            EVQ(3) = ONE
         ELSE
            CALL DGGEV( 'N', 'N', 3, DWORK, 3, DWORK(M2POS), 3, EVR,
     $                  EVI, EVQ, DWORK(WRKPOS), 1, DWORK(WRKPOS), 1,
     $                  DWORK(WRKPOS), LDWORK-18, INFO )
         END IF
C
      ELSE
C
C        Small variation in the coefficients of the polynomial.
C        Generate the matrices M1 and M2 stored in DWORK.
C
         IF ( I.EQ.0 ) THEN
C
C           Elements of matrix M1.
C
            DWORK(1) = ALPHA
            DWORK(5) = ALPHA
            DWORK(9) = ALPHA
C
C           Elements of matrix M2.
C
            DWORK(10) = -BETA
            DWORK(11) =  ALPHA
            DWORK(13) = -GAMMA
            DWORK(15) =  ALPHA
            DWORK(16) = -DELTA
C
         ELSE IF ( I.EQ.1 ) THEN
C
C           Elements of matrix M1.
C
            DWORK(1) = -ALPHA
            DWORK(4) = -GAMMA
            DWORK(5) =  BETA
            DWORK(7) = -DELTA
            DWORK(9) =  BETA
C
C           Elements of matrix M2.
C
            DWORK(10) =  BETA
            DWORK(11) = -ALPHA
            DWORK(14) = -GAMMA
            DWORK(15) =  BETA
            DWORK(17) = -DELTA
C
         ELSE IF ( I.EQ.2 ) THEN
C
C           Elements of matrix M1.
C
            DWORK(2) = -ALPHA
            DWORK(4) =  GAMMA
            DWORK(5) = -BETA
            DWORK(8) = -DELTA
            DWORK(9) =  GAMMA
C
C           Elements of matrix M2.
C
            DWORK(10) =  GAMMA
            DWORK(12) = -ALPHA
            DWORK(14) =  GAMMA
            DWORK(15) = -BETA
            DWORK(18) = -DELTA
C
         ELSE
C
C           Elements of matrix M1.
C
            DWORK(3) = -ALPHA
            DWORK(4) =  DELTA
            DWORK(6) = -BETA
            DWORK(8) =  DELTA
            DWORK(9) = -GAMMA
C
C           Elements of matrix M2.
C
            DWORK(10) = DELTA
            DWORK(14) = DELTA
            DWORK(18) = DELTA
         END IF
C
C        Compute the roots of the polynomial by solving an eigenproblem
C        using the QZ-Algorithm.
C
         CALL DGGEV( 'N', 'N', 3, DWORK, 3, DWORK(M2POS), 3, EVR, EVI,
     $               EVQ, DWORK(WRKPOS), 1, DWORK(WRKPOS), 1,
     $               DWORK(WRKPOS), LDWORK-18, INFO )
      END IF
C
      RETURN
C *** Last line of MC01XD ***
      END


c
c-----------------------------------------------------------------------
c subroutine:  fft842
c fast fourier transform for n=2**m
c complex input
c-----------------------------------------------------------------------
c
      subroutine fft842(in, n, x, y)
c
c this program replaces the vector z=x+iy by its  finite
c discrete, complex fourier transform if in=0.  the inverse transform
c is calculated for in=1.  it performs as many base
c 8 iterations as possible and then finishes with a base 4 iteration
c or a base 2 iteration if needed.
c
c the subroutine is called as subroutine fft842 (in,n,x,y).
c the integer n (a power of 2), the n real location array x, and
c the n real location array y must be supplied to the subroutine.
c
      dimension x(2), y(2), l(15)
      common /con2/ pi2, p7
      equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)),
     *    (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)),
     *    (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)),
     *    (l1,l(15))
c
c
c iw is a machine dependent write device number
c
      iw = i1mach(2)
c
      pi2 = 8.*atan(1.)
      p7 = 1./sqrt(2.)
      do 10 i=1,15
        m = i
        nt = 2**i
        if (n.eq.nt) go to 20
  10  continue
      write (iw,9999)
9999  format (35h n is not a power of two for fft842)
      stop
  20  n2pow = m
      nthpo = n
      fn = nthpo
      if (in.eq.1) go to 40
      do 30 i=1,nthpo
        y(i) = -y(i)
  30  continue
  40  n8pow = n2pow/3
      if (n8pow.eq.0) go to 60
c
c radix 8 passes,if any.
c
      do 50 ipass=1,n8pow
        nxtlt = 2**(n2pow-3*ipass)
        lengt = 8*nxtlt
        call r8tx(nxtlt, nthpo, lengt, x(1), x(nxtlt+1), x(2*nxtlt+1),
     *      x(3*nxtlt+1), x(4*nxtlt+1), x(5*nxtlt+1), x(6*nxtlt+1),
     *      x(7*nxtlt+1), y(1), y(nxtlt+1), y(2*nxtlt+1), y(3*nxtlt+1),
     *      y(4*nxtlt+1), y(5*nxtlt+1), y(6*nxtlt+1), y(7*nxtlt+1))
  50  continue
c
c is there a four factor left
c
  60  if (n2pow-3*n8pow-1) 90, 70, 80
c
c go through the base 2 iteration
c
c
  70  call r2tx(nthpo, x(1), x(2), y(1), y(2))
      go to 90
c
c go through the base 4 iteration
c
  80  call r4tx(nthpo, x(1), x(2), x(3), x(4), y(1), y(2), y(3), y(4))
c
  90  do 110 j=1,15
        l(j) = 1
        if (j-n2pow) 100, 100, 110
 100    l(j) = 2**(n2pow+1-j)
 110  continue
      ij = 1
      do 130 j1=1,l1
      do 130 j2=j1,l2,l1
      do 130 j3=j2,l3,l2
      do 130 j4=j3,l4,l3
      do 130 j5=j4,l5,l4
      do 130 j6=j5,l6,l5
      do 130 j7=j6,l7,l6
      do 130 j8=j7,l8,l7
      do 130 j9=j8,l9,l8
      do 130 j10=j9,l10,l9
      do 130 j11=j10,l11,l10
      do 130 j12=j11,l12,l11
      do 130 j13=j12,l13,l12
      do 130 j14=j13,l14,l13
      do 130 ji=j14,l15,l14
        if (ij-ji) 120, 130, 130
 120    r = x(ij)
        x(ij) = x(ji)
        x(ji) = r
        fi = y(ij)
        y(ij) = y(ji)
        y(ji) = fi
 130    ij = ij + 1
      if (in.eq.1) go to 150
      do 140 i=1,nthpo
        y(i) = -y(i)
 140  continue
      go to 170
 150  do 160 i=1,nthpo
        x(i) = x(i)/fn
        y(i) = y(i)/fn
 160  continue
 170  return
      end


C (C) Copr. 1986-92 Numerical Recipes Software ,2:-5K#R..
      SUBROUTINE twofft(data1,data2,fft1,fft2,n)
      INTEGER*4 n
      REAL*4    data1(n),data2(n)
      COMPLEX*8 fft1(n),fft2(n)
CU    USES four1
      INTEGER*4 j,n2
      COMPLEX*8 h1,h2,c1,c2
      c1 = cmplx(0.5,0.0)
      c2 = cmplx(0.0,-0.5)
      do j=1,n
        fft1(j)=cmplx(data1(j),data2(j))
      enddo
      call four1(fft1,n,1)
      fft1(1)=cmplx(real(fft1(1)),0.0)
      fft2(1)=cmplx(imag(fft1(1)),0.0)
      n2=n+2
      do j=2,n/2+1
        h1=c1*(fft1(j)+conjg(fft1(n2-j)))
        h2=c2*(fft1(j)-conjg(fft1(n2-j)))
        fft1(j)=h1
        fft1(n2-j)=conjg(h1)
        fft2(j)=h2
        fft2(n2-j)=conjg(h2)
      enddo
      return
      END