! =======================================================================
! Graph module
! =======================================================================
module GraphMod
    implicit none

    integer, private, parameter :: MAXROW = 20
    integer, private, parameter :: MAXCOL = 75
    real, private :: xl, xr, yd, yu     ! first, last, down, up: global

contains

    ! -------------------------------------------------------------------
    ! General graphing routine: arguments described in text
    ! -------------------------------------------------------------------
    subroutine grapher(x, y, symbol, title)
        integer i, j
        real, intent(in) :: x(:), y(:)
        character(len=*), intent(in) :: symbol, title   ! assumed length
        character(1) Point(MAXROW, MAXCOL)
        character(10) fmtstr

        write(fmtstr, '("(" I2, "A1)")') MAXCOL         ! internal file
        Point = " "                                     ! all blanks initially
        ! Really should check whether axes lies in range
        Point(1:MAXROW, xscale(0.0)) = ":"              ! y-axis
        Point(yscale(0.0), 1:MAXCOL) = "-"              ! x-axis

        do i=1, size(x)
            Point(yscale(y(i)), xscale(x(i))) = symbol  ! y is "row"
        end do

        print '(A80 /)', title
        print fmtstr, ((Point(i, j), j=1, MAXCOL), i=1, MAXROW) ! by rows

    end subroutine grapher

    ! ---------------------------------------------------------------------
    ! Imports graphers limits to be available as globals
    ! ---------------------------------------------------------------------
    subroutine setwindow(xmin, xmax, ymin, ymax)
        real :: xmin, xmax, ymin, ymax
        xl = xmin
        xr = xmax
        yu = ymax
        yd = ymin
    end subroutine setwindow

    ! ---------------------------------------------------------------------
    ! Scales x-coordinate to a column on the screen
    ! ---------------------------------------------------------------------
    integer function xscale(x)
        real :: x
        xscale = nint((x - xl)*(MAXCOL -1)/(xr - xl) + 1)
    end function xscale

    ! --------------------------------------------------------------------
    ! Scales y-coordinate to a row on the screen
    ! --------------------------------------------------------------------
    integer function yscale(y)
        real :: y
        yscale = nint((y-yu) * (MAXROW -1)/(yd - yu) + 1)
    end function yscale

end module GraphMod

! ---------------------------------------------------------------------
! Matrix module
! ---------------------------------------------------------------------
module Matrix
    implicit none
    private

    public :: matrix_mult
    public :: operator(.x.)

    interface operator(.x.)
        module procedure MatTimesMat, MatTimesVector
    end interface

contains

    ! ---------------------------------------------------------------------
    ! Multiplies A (n x m) by B(m x p) and returns product in C (n x p)
    ! Performs no checks on shapes of A and B
    ! ---------------------------------------------------------------------
    subroutine matrix_mult(A, B, C)
        real, dimension(:, :) :: A, B, C
        integer :: i, j, M, N, P

        N = size(A, 1)
        M = size(A, 2)
        P = size(B, 2)

        do i=1, N
            do j=1, P
                C(i, j) = sum(A(i, 1:M) * B(1:M, j))
            end do
        end do
    end subroutine matrix_mult

    ! MatTimesMat
    function MatTimesMat(A, B)
        real, dimension(:, :), intent(in) :: A, B
        real, dimension(size(A, 1), size(B, 2)) :: MatTimesMat

        MatTimesMat = matmul(A, B)
    end function MatTimesMat

    ! MatTimesVector
    function MatTimesVector(A, X)
        real, dimension(:, :), intent(in) :: A
        real, dimension(:), intent(in) :: X
        real, dimension(size(A, 1)) :: MatTimesVector

        MatTimesVector = matmul(A, X)

    end function MatTimesVector
end module Matrix


c=======================================================================
c
c     subroutine LOGRLACK
c
c     Log h-returns for prices matrix
c
c           r(t+h) = log[price(t+h)/price(t)] for t = 1,...,n-h
c
c     Take into account of missing data (lack of data),
c     with historical data structure
c
c     X(n,p) = | x(1,1), ..., x(1,p) |
c              | x(2,1), ..., -1000  |
c              | x(3,1), ..., x(3,p) |
c              |   .   , ...,   .    |
c              |   .   , ...,   .    |
c              | x(n,1), ..., x(n,p) |
c
c     where x(2,p) = -1000 denote a missing return
c
c-----------------------------------------------------------------------
      SUBROUTINE logrlack ( n, p, X, h, R, info )
c-----------------------------------------------------------------------
c
c     INPUT :
c            n      : number of prices (n > h)                   integer
c            p      : number of assets (p >= 1)                  integer
c            X      : assets price (n*p)                          double
c            h      : horizon (h > 0)                            integer
c
c     OUTPUT :
c            R      : log-returns ( n-h * p)                      double
c            info   : diagnostic argument                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, h, info
      DOUBLE PRECISION X(n,*), R(*)
c
c     local variables
      INTEGER ipri, jpri, k, nl
      DOUBLE PRECISION missing, price, eps
      PARAMETER ( eps = 1.E-30 )
c
c     intrinsic functions
      INTRINSIC log
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      missing = -1000
      nl   = n - h
      k    = 1
c
c     test the number of points
      IF (n .le. h) THEN
        info = -2
        RETURN
      ENDIF
c
c     log return(s)
      DO jpri = 1,p
         DO ipri = 1,nl
            price = X(ipri,jpri)
            IF ((price .LT. eps) .AND. (price .GT. missing)) THEN
               info = -103
               RETURN
            ENDIF
            IF ((X(ipri +h,jpri) .GT. missing).AND.(price .GT. missing))
     &      THEN
                R(k) = log( X(ipri + h,jpri) / price )
            ELSE
                R(k) = -1000
            ENDIF
            k = k + 1
         ENDDO
      ENDDO
c
      RETURN
      END


*     MB05OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
      INTEGER          NDIAG
      PARAMETER        ( NDIAG = 9 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( 2*NMAX+NDIAG+1 )+NDIAG )
*     .. Local Scalars ..
      DOUBLE PRECISION DELTA
      INTEGER          I, IDIG, INFO, IWARN, J, MDIG, N
      CHARACTER*1      BALANC
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK)
      INTEGER          IWORK(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB05OD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DELTA, BALANC
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Find the exponential of the real defective matrix A*DELTA.
         CALL MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG,
     $                IWORK, DWORK, LDWORK, IWARN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 )
     $         WRITE ( NOUT, FMT = 99993 ) IWARN
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) MDIG, IDIG
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB05OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB05OD = ',I2)
99997 FORMAT (' The solution matrix E = exp(A*DELTA) is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' Minimal number of accurate digits in the norm of E =',
     $       I4,/' Number of accurate digits in the norm of E',/'     ',
     $       '            at 95 per cent confidence interval =',I4)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (' IWARN on exit from MB05OD = ',I2)
      END


      MODULE LES3D_DATA
      DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:) ::
     >             P, T, H
      DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:,:) ::
     >             HF
      DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:,:,:) ::
     >             Q
      END MODULE LES3D_DATA
      USE LES3D_DATA
      DO K = 1, KMAX - 1
         DO J = 1, JMAX - 1
            DO I = 1, I2
               T(I,J,K) = (EI - HF(I,J,K,1)) / HF(I,J,K,3)
            ENDDO
            P(1:I2,J,K) = Q(1:I2,J,K,1,M) * HF(1:I2,J,K,4) * T(1:I2,J,K)
            IF(ISGSK .EQ. 1) H(1:I2,J,K) =
     >                   (Q(1:I2,J,K,5,M) + P(1:I2,J,K))
         END DO
      ENDDO
      END


	REAL FUNCTION
     .	MHPOWERFCN(n_prime,bigt,c_prime,m_prime,
     .					theta_prime,pi_arg,alpha,corrected)
	USE MSIMSL
	IMPLICIT NONE

	INTEGER ARRAYSIZE
	PARAMETER (ARRAYSIZE=20)

	real n_prime
	real bigt
	real c_prime(arraysize)
	real m_prime(arraysize)
	real theta_prime
	real pi_arg(arraysize)
	real alpha
	integer corrected

	REAL pi_prime(ARRAYSIZE)

	real n
	real theta
	real c(arraysize)
	real m(arraysize)

	real suma, sumb, sumc
	real bign
	real lambda(arraysize)
	real rho(arraysize)
	real pi(arraysize,2)
	real delta(arraysize)
	real pi_bar(arraysize)
	real bigw1(arraysize)
	real bigw2(arraysize)
	real bigw3(arraysize)
	real phi(arraysize)

	real z1ma2, sum1, sum2, sigma_squared_cb
	real z_u, z_lu, power_u
	real z_c, z_lc, power_c

	INTEGER i
!
!  Code
!
!
!  Copy pi to localpi
!
	DO I=1,bigt
		pi_prime(I)=pi_arg(I)
	END DO

	if (theta_prime.gt.1) then
		n=n_prime
		theta=theta_prime
		do i=1,bigt
			c(i)=c_prime(i)
			m(i)=m_prime(i)
			pi(i,2)=pi_prime(i)
		end do
	else
		suma=0
		do i=1,bigt
			suma=suma+(c_prime(i)*m_prime(i))
		end do
		sumb=0
		do i=1,bigt
			sumb=sumb+(c_prime(i)*(1.+m_prime(i)))
		end do
		n=n_prime*(-1.+sumb)
		theta=1./theta_prime
		do i=1,bigt
			c(i)=(c_prime(i)*m_prime(i))/suma
			m(i)=1./m_prime(i)
			pi(i,2)=theta_prime*pi_prime(i)/
     .			((theta_prime*pi_prime(i))+(1.-pi_prime(i)))
		end do
	end if

	if (n.lt.001) then
	    MHPOWERFCN=0
		return
	end if

	sumc=0
	do i=1,bigt
		sumc=sumc+(c(i)*(1+m(i)))
	end do

	bign=n*sumc

	do i=1,bigt
		lambda(i)=(n*c(i)*(1.+m(i)))/bign
		rho(i)=1./(1.+m(i))
		pi(i,1)=(theta*pi(i,2))/((theta*pi(i,2))+1.-pi(i,2))
		delta(i)=pi(i,1)-pi(i,2)
		pi_bar(i)=rho(i)*pi(i,1) + (1.-rho(i))*pi(i,2)
		bigw1(i)=lambda(i)*rho(i)*(1.-rho(i))
		bigw2(i)=(1.-rho(i))*pi(i,1)*(1.-pi(i,1))
		bigw3(i)=rho(i)*pi(i,2)*(1.-pi(i,2))
		phi(i)=(pi_bar(i)*(1.-pi_bar(i))) +
     .		(delta(i)**2*rho(i)*(1.-rho(i))/(bign*lambda(i)-1.))
	end do

	z1ma2=ANORIN(1.-alpha/2.)

	sum1=0
	do i=1,bigt
		sum1=sum1+(bigw1(i)*delta(i))
	end do

	sum2=0
	do i=1,bigt
		sum2=sum2+(bigw1(i)*phi(i))
	end do

	sigma_squared_cb=0
	do i=1,bigt
		sigma_squared_cb=sigma_squared_cb+(bigw1(i)*(bigw2(i)+bigw3(i)))
	end do

	IF (CORRECTED.EQ.0) THEN
		z_u=  (sqrt(bign)*sum1-z1ma2*sqrt(sum2))/sqrt(sigma_squared_cb)
		z_lu=(-sqrt(bign)*sum1-z1ma2*sqrt(sum2))/sqrt(sigma_squared_cb)
		power_u=ANORDF(z_u)+ANORDF(z_lu)
		MHPOWERFCN=power_u
	ELSE IF (CORRECTED.EQ.1) THEN
		z_c=  ((sqrt(bign)*sum1-z1ma2*sqrt(sum2))-(0.5/sqrt(bign)))/
     .										sqrt(sigma_squared_cb)
		z_lc=((-sqrt(bign)*sum1-z1ma2*sqrt(sum2))-(0.5/sqrt(bign)))/
     .										sqrt(sigma_squared_cb)
		power_c=ANORDF(z_c)+ANORDF(z_lc)
		MHPOWERFCN=power_c
	ELSE
	    MHPOWERFCN=-999
	END IF

	if (MHPOWERFCN.gt.0.999) then
	    MHPOWERFCN=1.0
	end if

 	RETURN
	END


      SUBROUTINE MB03WA( WANTQ, WANTZ, N1, N2, A, LDA, B, LDB, Q, LDQ,
     $                   Z, LDZ, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To swap adjacent diagonal blocks A11*B11 and A22*B22 of size
C     1-by-1 or 2-by-2 in an upper (quasi) triangular matrix product
C     A*B by an orthogonal equivalence transformation.
C
C     (A, B) must be in periodic real Schur canonical form (as returned
C     by SLICOT Library routine MB03XP), i.e., A is block upper
C     triangular with 1-by-1 and 2-by-2 diagonal blocks, and B is upper
C     triangular.
C
C     Optionally, the matrices Q and Z of generalized Schur vectors are
C     updated.
C
C         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)',
C         Z(in) * B(in) * Q(in)' = Z(out) * B(out) * Q(out)'.
C
C     This routine is largely based on the LAPACK routine DTGEX2
C     developed by Bo Kagstrom and Peter Poromaa.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     WANTQ   LOGICAL
C             Indicates whether or not the user wishes to accumulate
C             the matrix Q as follows:
C             = .TRUE. :  The matrix Q is updated;
C             = .FALSE.:  the matrix Q is not required.
C
C     WANTZ   LOGICAL
C             Indicates whether or not the user wishes to accumulate
C             the matrix Z as follows:
C             = .TRUE. :  The matrix Z is updated;
C             = .FALSE.:  the matrix Z is not required.
C
C     Input/Output Parameters
C
C     N1      (input) INTEGER
C             The order of the first block A11*B11. N1 = 0, 1 or 2.
C
C     N2      (input) INTEGER
C             The order of the second block A22*B22. N2 = 0, 1 or 2.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C             (LDA,N1+N2)
C             On entry, the leading (N1+N2)-by-(N1+N2) part of this
C             array must contain the matrix A.
C             On exit, the leading (N1+N2)-by-(N1+N2) part of this array
C             contains the matrix A of the reordered pair.
C
C     LDA     INTEGER
C             The leading dimension of the array A. LDA >= MAX(1,N1+N2).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,N1+N2)
C             On entry, the leading (N1+N2)-by-(N1+N2) part of this
C             array must contain the matrix B.
C             On exit, the leading (N1+N2)-by-(N1+N2) part of this array
C             contains the matrix B of the reordered pair.
C
C     LDB     INTEGER
C             The leading dimension of the array B. LDB >= MAX(1,N1+N2).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension
C             (LDQ,N1+N2)
C             On entry, if WANTQ = .TRUE., the leading
C             (N1+N2)-by-(N1+N2) part of this array must contain the
C             orthogonal matrix Q.
C             On exit, the leading (N1+N2)-by-(N1+N2) part of this array
C             contains the updated matrix Q. Q will be a rotation
C             matrix for N1=N2=1.
C             This array is not referenced if WANTQ = .FALSE..
C
C     LDQ     INTEGER
C             The leading dimension of the array Q. LDQ >= 1.
C             If WANTQ = .TRUE., LDQ >= N1+N2.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension
C             (LDZ,N1+N2)
C             On entry, if WANTZ = .TRUE., the leading
C             (N1+N2)-by-(N1+N2) part of this array must contain the
C             orthogonal matrix Z.
C             On exit, the leading (N1+N2)-by-(N1+N2) part of this array
C             contains the updated matrix Z. Z will be a rotation
C             matrix for N1=N2=1.
C             This array is not referenced if WANTZ = .FALSE..
C
C     LDZ     INTEGER
C             The leading dimension of the array Z. LDZ >= 1.
C             If WANTZ = .TRUE., LDZ >= N1+N2.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  the transformed matrix (A, B) would be
C                   too far from periodic Schur form; the blocks are
C                   not swapped and (A,B) and (Q,Z) are unchanged.
C
C     METHOD
C
C     In the current code both weak and strong stability tests are
C     performed. The user can omit the strong stability test by changing
C     the internal logical parameter WANDS to .FALSE.. See ref. [2] for
C     details.
C
C     REFERENCES
C
C     [1] Kagstrom, B.
C         A direct method for reordering eigenvalues in the generalized
C         real Schur form of a regular matrix pair (A,B), in M.S. Moonen
C         et al (eds.), Linear Algebra for Large Scale and Real-Time
C         Applications, Kluwer Academic Publ., 1993, pp. 195-218.
C
C     [2] Kagstrom, B., and Poromaa, P.
C         Computing eigenspaces with specified eigenvalues of a regular
C         matrix pair (A, B) and condition estimation: Theory,
C         algorithms and software, Numer. Algorithms, 1996, vol. 12,
C         pp. 369-407.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, May 2008 (SLICOT version of the HAPACK routine DTGPX2).
C
C     KEYWORDS
C
C     Eigenvalue, periodic Schur form, reordering
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   TEN
      PARAMETER          ( TEN = 1.0D+01 )
      INTEGER            LDST
      PARAMETER          ( LDST = 4 )
      LOGICAL            WANDS
      PARAMETER          ( WANDS = .TRUE. )
C     .. Scalar Arguments ..
      LOGICAL            WANTQ, WANTZ
      INTEGER            INFO, LDA, LDB, LDQ, LDZ, N1, N2
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL            DTRONG, WEAK
      INTEGER            I, LINFO, M
      DOUBLE PRECISION   BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS,
     $                   F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
C     .. Local Arrays ..
      INTEGER            IWORK( LDST )
      DOUBLE PRECISION   AI(2), AR(2), BE(2), DWORK(32), IR(LDST,LDST),
     $                   IRCOP(LDST,LDST), LI(LDST,LDST),
     $                   LICOP(LDST,LDST), S(LDST,LDST),
     $                   SCPY(LDST,LDST), T(LDST,LDST), TAUL(LDST),
     $                   TAUR(LDST), TCPY(LDST,LDST)
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASET,
     $                   DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, DROT,
     $                   DSCAL, MB03YT, SB04OW
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
C
C     .. Executable Statements ..
C
      INFO = 0
C
C     Quick return if possible.
C     For efficiency, the arguments are not checked.
C
      IF ( N1.LE.0 .OR. N2.LE.0 )
     $   RETURN
      M = N1 + N2
C
      WEAK = .FALSE.
      DTRONG = .FALSE.
C
C     Make a local copy of selected block.
C
      CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, LI, LDST )
      CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, IR, LDST )
      CALL DLACPY( 'Full', M, M, A, LDA, S, LDST )
      CALL DLACPY( 'Full', M, M, B, LDB, T, LDST )
C
C     Compute threshold for testing acceptance of swapping.
C
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      DSCALE = ZERO
      DSUM = ONE
      CALL DLACPY( 'Full', M, M, S, LDST, DWORK, M )
      CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM )
      CALL DLACPY( 'Full', M, M, T, LDST, DWORK, M )
      CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM )
      DNORM = DSCALE*SQRT( DSUM )
      THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
C
      IF ( M.EQ.2 ) THEN
C
C        CASE 1: Swap 1-by-1 and 1-by-1 blocks.
C
C        Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
C        using Givens rotations and perform the swap tentatively.
C
         F =  S(2,2)*T(2,2) - T(1,1)*S(1,1)
         G = -S(2,2)*T(1,2) - T(1,1)*S(1,2)
         SB = ABS( T(1,1) )
         SA = ABS( S(2,2) )
         CALL DLARTG( F, G, IR(1,2), IR(1,1), DDUM )
         IR(2,1) = -IR(1,2)
         IR(2,2) =  IR(1,1)
         CALL DROT( 2, S(1,1), 1, S(1,2), 1, IR(1,1), IR(2,1) )
         CALL DROT( 2, T(1,1), LDST, T(2,1), LDST, IR(1,1), IR(2,1) )
         IF( SA.GE.SB ) THEN
            CALL DLARTG( S(1,1), S(2,1), LI(1,1), LI(2,1), DDUM )
         ELSE
            CALL DLARTG( T(2,2), T(2,1), LI(1,1), LI(2,1), DDUM )
            LI(2,1) = -LI(2,1)
         END IF
         CALL DROT( 2, S(1,1), LDST, S(2,1), LDST, LI(1,1), LI(2,1) )
         CALL DROT( 2, T(1,1), 1, T(1,2), 1, LI(1,1), LI(2,1) )
         LI(2,2) =  LI(1,1)
         LI(1,2) = -LI(2,1)
C
C        Weak stability test:
C           |S21| + |T21| <= O(EPS * F-norm((S, T))).
C
         WS = ABS( S(2,1) ) + ABS( T(2,1) )
         WEAK = WS.LE.THRESH
         IF ( .NOT.WEAK )
     $      GO TO 50
C
         IF ( WANDS ) THEN
C
C           Strong stability test:
C             F-norm((A-QL'*S*QR, B-QR'*T*QL)) <= O(EPS*F-norm((A,B))).
C
            CALL DLACPY( 'Full', M, M, A, LDA, DWORK(M*M+1), M )
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  LI, LDST, S, LDST, ZERO, DWORK, M )
            CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE,
     $                  DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M )
            DSCALE = ZERO
            DSUM = ONE
            CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM )
C
            CALL DLACPY( 'Full', M, M, B, LDB, DWORK(M*M+1), M )
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  IR, LDST, T, LDST, ZERO, DWORK, M )
            CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE,
     $                  DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M )
            CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM )
            SS = DSCALE*SQRT( DSUM )
            DTRONG = SS.LE.THRESH
            IF( .NOT.DTRONG )
     $         GO TO 50
         END IF
C
C        Update A and B.
C
         CALL DLACPY( 'All', M, M, S, LDST, A, LDA )
         CALL DLACPY( 'All', M, M, T, LDST, B, LDB )
C
C        Set  N1-by-N2 (2,1) - blocks to ZERO.
C
         A(2,1) = ZERO
         B(2,1) = ZERO
C
C        Accumulate transformations into Q and Z if requested.
C
         IF ( WANTQ )
     $      CALL DROT( 2, Q(1,1), 1, Q(1,2), 1, LI(1,1), LI(2,1) )
         IF ( WANTZ )
     $      CALL DROT( 2, Z(1,1), 1, Z(1,2), 1, IR(1,1), IR(2,1) )
C
C        Exit with INFO = 0 if swap was successfully performed.
C
         RETURN
C
      ELSE
C
C        CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
C                and 2-by-2 blocks.
C
C        Solve the periodic Sylvester equation
C                 S11 * R - L * S22 = SCALE * S12
C                 T11 * L - R * T22 = SCALE * T12
C        for R and L. Solutions in IR and LI.
C
         CALL DLACPY( 'Full', N1, N2, T(1,N1+1), LDST, LI, LDST )
         CALL DLACPY( 'Full', N1, N2, S(1,N1+1), LDST, IR(N2+1,N1+1),
     $                LDST )
         CALL SB04OW( N1, N2, S, LDST, S(N1+1,N1+1), LDST,
     $                IR(N2+1,N1+1), LDST, T, LDST, T(N1+1,N1+1), LDST,
     $                LI, LDST, SCALE, IWORK, LINFO )
         IF ( LINFO.NE.0 )
     $      GO TO 50
C
C        Compute orthogonal matrix QL:
C
C                    QL' * LI = [ TL ]
C                               [ 0  ]
C        where
C                    LI =  [      -L              ].
C                          [ SCALE * identity(N2) ]
C
         DO 10 I = 1, N2
            CALL DSCAL( N1, -ONE, LI(1,I), 1 )
            LI(N1+I,I) = SCALE
   10    CONTINUE
         CALL DGEQR2( M, N2, LI, LDST, TAUL, DWORK, LINFO )
         CALL DORG2R( M, M, N2, LI, LDST, TAUL, DWORK, LINFO )
C
C        Compute orthogonal matrix RQ:
C
C                    IR * RQ' =   [ 0  TR],
C
C         where IR = [ SCALE * identity(N1), R ].
C
         DO 20 I = 1, N1
            IR(N2+I,I) = SCALE
   20    CONTINUE
         CALL DGERQ2( N1, M, IR(N2+1,1), LDST, TAUR, DWORK, LINFO )
         CALL DORGR2( M, M, N1, IR, LDST, TAUR, DWORK, LINFO )
C
C        Perform the swapping tentatively:
C
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, LI,
     $               LDST, S, LDST, ZERO, DWORK, M )
         CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, DWORK,
     $               M, IR, LDST, ZERO, S, LDST )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, IR,
     $               LDST, T, LDST, ZERO, DWORK, M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK, M, LI, LDST, ZERO, T, LDST )
         CALL DLACPY( 'All', M, M, S, LDST, SCPY, LDST )
         CALL DLACPY( 'All', M, M, T, LDST, TCPY, LDST )
         CALL DLACPY( 'All', M, M, IR, LDST, IRCOP, LDST )
         CALL DLACPY( 'All', M, M, LI, LDST, LICOP, LDST )
C
C        Triangularize the B-part by a QR factorization.
C        Apply transformation (from left) to A-part, giving S.
C
         CALL DGEQR2( M, M, T, LDST, TAUR, DWORK, LINFO )
         CALL DORM2R( 'Right', 'No Transpose', M, M, M, T, LDST, TAUR,
     $                S, LDST, DWORK, LINFO )
         CALL DORM2R( 'Left', 'Transpose', M, M, M, T, LDST, TAUR,
     $                IR, LDST, DWORK, LINFO )
C
C        Compute F-norm(S21) in BRQA21. (T21 is 0.)
C
         DSCALE = ZERO
         DSUM = ONE
         DO 30 I = 1, N2
            CALL DLASSQ( N1, S(N2+1,I), 1, DSCALE, DSUM )
   30    CONTINUE
         BRQA21 = DSCALE*SQRT( DSUM )
C
C        Triangularize the B-part by an RQ factorization.
C        Apply transformation (from right) to A-part, giving S.
C
         CALL DGERQ2( M, M, TCPY, LDST, TAUL, DWORK, LINFO )
         CALL DORMR2( 'Left', 'No Transpose', M, M, M, TCPY, LDST,
     $                TAUL, SCPY, LDST, DWORK, LINFO )
         CALL DORMR2( 'Right', 'Transpose', M, M, M, TCPY, LDST,
     $                TAUL, LICOP, LDST, DWORK, LINFO )
C
C        Compute F-norm(S21) in BQRA21. (T21 is 0.)
C
         DSCALE = ZERO
         DSUM = ONE
         DO 40 I = 1, N2
            CALL DLASSQ( N1, SCPY(N2+1,I), 1, DSCALE, DSUM )
   40    CONTINUE
         BQRA21 = DSCALE*SQRT( DSUM )
C
C        Decide which method to use.
C          Weak stability test:
C             F-norm(S21) <= O(EPS * F-norm((S, T)))
C
         IF ( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN
            CALL DLACPY( 'All', M, M, SCPY, LDST, S, LDST )
            CALL DLACPY( 'All', M, M, TCPY, LDST, T, LDST )
            CALL DLACPY( 'All', M, M, IRCOP, LDST, IR, LDST )
            CALL DLACPY( 'All', M, M, LICOP, LDST, LI, LDST )
         ELSE IF ( BRQA21.GE.THRESH ) THEN
            GO TO 50
         END IF
C
C        Set lower triangle of B-part to zero
C
         CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST )
C
         IF ( WANDS ) THEN
C
C           Strong stability test:
C              F-norm((A-QL*S*QR', B-QR*T*QL')) <= O(EPS*F-norm((A,B)))
C
            CALL DLACPY( 'All', M, M, A, LDA, DWORK(M*M+1), M )
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  LI, LDST, S, LDST, ZERO, DWORK, M )
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, -ONE,
     $                  DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M )
            DSCALE = ZERO
            DSUM = ONE
            CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM )
C
            CALL DLACPY( 'All', M, M, B, LDB, DWORK(M*M+1), M )
            CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $                  IR, LDST, T, LDST, ZERO, DWORK, M )
            CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE,
     $                  DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M )
            CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM )
            SS = DSCALE*SQRT( DSUM )
            DTRONG = ( SS.LE.THRESH )
            IF( .NOT.DTRONG )
     $         GO TO 50
C
         END IF
C
C        If the swap is accepted ("weakly" and "strongly"), apply the
C        transformations and set N1-by-N2 (2,1)-block to zero.
C
         CALL DLASET( 'All', N1, N2, ZERO, ZERO, S(N2+1,1), LDST )
C
C        Copy (S,T) to (A,B).
C
         CALL DLACPY( 'All', M, M, S, LDST, A, LDA )
         CALL DLACPY( 'All', M, M, T, LDST, B, LDB )
         CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, T, LDST )
C
C        Standardize existing 2-by-2 blocks.
C
         CALL DLASET( 'All', M, M, ZERO, ZERO, DWORK, M )
         DWORK(1) = ONE
         T(1,1) = ONE
         IF ( N2.GT.1 ) THEN
            CALL MB03YT( A, LDA, B, LDB, AR, AI, BE, DWORK(1), DWORK(2),
     $                   T(1,1), T(2,1) )
            DWORK(M+1) = -DWORK(2)
            DWORK(M+2) = DWORK(1)
            T(N2,N2) = T(1,1)
            T(1,2) = -T(2,1)
         END IF
         DWORK(M*M) = ONE
         T(M,M) = ONE
C
         IF ( N1.GT.1 ) THEN
            CALL MB03YT( A(N2+1,N2+1), LDA, B(N2+1,N2+1), LDB, TAUR,
     $                   TAUL, DWORK(M*M+1), DWORK(N2*M+N2+1),
     $                   DWORK(N2*M+N2+2), T(N2+1,N2+1), T(M,M-1) )
            DWORK(M*M) = DWORK(N2*M+N2+1)
            DWORK(M*M-1 ) = -DWORK(N2*M+N2+2)
            T(M,M) = T(N2+1,N2+1)
            T(M-1,M) = -T(M,M-1)
         END IF
C
         CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE,
     $               DWORK, M, A(1,N2+1), LDA, ZERO, DWORK(M*M+1), N2 )
         CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, A(1,N2+1), LDA )
         CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE,
     $               T(1,1), LDST, B(1,N2+1), LDB, ZERO,
     $               DWORK(M*M+1), N2 )
         CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, B(1,N2+1), LDB )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, LI,
     $               LDST, DWORK, M, ZERO, DWORK(M*M+1), M )
         CALL DLACPY( 'All', M, M, DWORK(M*M+1), M, LI, LDST )
         CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE,
     $               A(1,N2+1), LDA, T(N2+1,N2+1), LDST, ZERO,
     $               DWORK(M*M+1), M )
         CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, A(1,N2+1), LDA )
         CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE,
     $               B(1,N2+1), LDB, DWORK(N2*M+N2+1), M, ZERO,
     $               DWORK(M*M+1), M )
         CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, B(1,N2+1), LDB )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, T,
     $               LDST, IR, LDST, ZERO, DWORK, M )
         CALL DLACPY( 'All', M, M, DWORK, M, IR, LDST )
C
C        Accumulate transformations into Q and Z if requested.
C
         IF( WANTQ ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, Q,
     $                  LDQ, LI, LDST, ZERO, DWORK, M )
            CALL DLACPY( 'All', M, M, DWORK, M, Q, LDQ )
         END IF
C
         IF( WANTZ ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, Z,
     $                  LDZ, IR, LDST, ZERO, DWORK, M )
            CALL DLACPY( 'Full', M, M, DWORK, M, Z, LDZ )
C
         END IF
C
C        Exit with INFO = 0 if swap was successfully performed.
C
         RETURN
C
      END IF
C
C     Exit with INFO = 1 if swap was rejected.
C
   50 CONTINUE
C
      INFO = 1
      RETURN
C *** Last line of MB03WA ***
      END


      subroutine conv(omega,xsec,ne1,vicorr)
c     multiply xsec by theta(omega-efermi) and
c     convolute xsec(omega) with  xloss/((omega-omega0)**2+xloss**2)/pi
c     the result is xsec0(omega0)

      implicit double precision (a-h, o-z)
      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'
      dimension  omega(nex)
      complex*16 xsec(nex), xsec0(nex), xsecdx

      complex*16 conv1
      external conv1

      do ie = 1,ne1
         xsec0(ie) = 0.0d0
         omega0 = omega(ie)
c        Add one more point to correct for the finite grid
c        at large energies. Use linear interpolation.
         dx = max( omega(ne1) - omega(ne1-1), 50*vicorr)
         xlast = omega(ne1)+dx
         dx = dx / ( omega(ne1) - omega(ne1-1))
         xsecdx = xsec(ne1)+ (xsec(ne1)-xsec(ne1-1)) * dx

c        first interval
         do i = 1, ne1-1
            xsec0(ie) = xsec0(ie) +
     1      conv1(omega(i),omega(i+1),xsec(i),xsec(i+1),omega0,vicorr)
         enddo
c        last interval
         xsec0(ie) = xsec0(ie) +
     1   conv1(omega(ne1),xlast,xsec(ne1),xsecdx,omega0,vicorr)
         xsec0(ie) = xsec0(ie) /real(pi)
      enddo
      do ie = 1, ne1
         xsec(ie) = xsec0(ie)
      enddo
      return
      end

      complex*16 function conv1(x1,x2,y1,y2,x0,xloss)
c     convolution of function 1/(omega-omega0-i*xloss)/pi
c     makes linear interpolation for function between x1,x2 and
c     takes advantage that the integral can be taken analytically.
      implicit double precision (a-h, o-z)
      complex*16  y1, y2, t, coni,dum, a, b
      parameter (coni = (0.d0,1.d0))

      d = (x2-x1) / 2.d0
      a = dble(y2-y1) / 2.d0
      b = dble(y2+y1) / 2.d0
      t = d / ( (x1+x2)/2 - x0 - coni*xloss )
      if (abs(t) .ge. 0.1) then
         dum = 2.d0*a + (b - a/t) * log((1+t)/(1-t))
      else
         dum = 2.d0*b*(t+t**3 / 3.d0) - 2.d0/3.d0 * a*t**2
      endif
      conv1 = dimag (dum)

      d = (x2-x1) / 2.d0
      a = dimag(y2-y1) / 2.d0
      b = dimag(y2+y1) / 2.d0
      t = d / ( (x1+x2)/2 - x0 - coni*xloss )
      if (abs(t) .ge. 0.1) then
         dum = 2.d0*a + (b - a/t) * log((1+t)/(1-t))
      else
         dum = 2.d0*b*(t+t**3 / 3.d0) - 2.d0/3.d0 * a*t**2
      endif
      conv1 = conv1 + coni* dimag( dum)

      return
      end


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, xp, yp, zp
      integer blockno
      integer*8 cont, get_context

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

      integer example
      common /example_comm/ example

      double precision beta, theta(2)
      common /annulus_comm/ beta, theta

      double precision init_radius
      common /initradius_comm/ init_radius

      double precision x0, y0, r0, r, rc,th

      cont = get_context()

      call fclaw2d_map_c2m(cont,
     &      blockno,xc,yc,xp,yp,zp)

      if (example .ne. 2) then
c         # Annular or horizontal flow
          rc = (1 + beta)/2.d0
          th = pi2*(0.25 + 1.d0/32.d0)
          x0 = rc*cos(th)
          y0 = rc*sin(th)
      elseif (example .eq. 2) then
c         # Vertical flow
          th = pi/2
          rc = beta + (1-beta)*0.5625d0
          x0 = rc*cos(th)
          y0 = rc*sin(th)
      endif

      r = sqrt((xp - x0)**2 + (yp-y0)**2)
      r0 = init_radius
      fdisc = r - r0

      end


module prop

  implicit none

contains

  subroutine step(disp, model_padded, dt, dx, num_steps,   &
      nx_padded, source_len, source, num_pad)

    integer, intent (in) :: nx_padded
    integer, intent (in) :: source_len
    real, intent (in out), dimension (:, :) :: disp
    real, intent (in), dimension (:) :: model_padded
    real, intent (in) :: dt
    real, intent (in) :: dx
    real, intent (in), dimension (:)  :: source
    integer, intent (in) :: num_steps
    integer, intent (in) :: num_pad

    integer :: s
    integer :: i
    integer :: sx
    real :: f_xx

    sx = num_pad+1

    do s = 2, num_steps + 1
    do i = 9, nx_padded - 8
    f_xx = (                                                           &
      -735*disp(i-8, s)+15360*disp(i-7, s)                             &
      -156800*disp(i-6, s)+1053696*disp(i-5, s)                        &
      -5350800*disp(i-4, s)+22830080*disp(i-3, s)                      &
      -94174080*disp(i-2, s)+538137600*disp(i-1, s)                    &
      -924708642*disp(i+0, s)                                          &
      +538137600*disp(i+1, s)-94174080*disp(i+2, s)                    &
      +22830080*disp(i+3, s)-5350800*disp(i+4, s)                      &
      +1053696*disp(i+5, s)-156800*disp(i+6, s)                        &
      +15360*disp(i+7, s)-735*disp(i+8, s))/(302702400*dx**2)
    disp(i, s+1) = (model_padded(i)**2 * dt**2 * f_xx + 2 * disp(i, s) - disp(i, s-1))
    end do

    if (s-1 <= source_len) then
      disp(sx, s+1) = disp(sx, s+1) + (model_padded(sx)**2 * dt**2       &
        * source(s-1))
    end if

    end do

  end subroutine step
end module prop


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION CLRX (KAPPAA, K, KAPPAB)
!                                                                      *
!   The value of CLRX is the 3-j symbol:                               *
!                                                                      *
!                    ( JA        K        JB  )                        *
!                    ( 1/2       0       -1/2 )                        *
!                                                                      *
!   The  K'S are kappa angular quantum numbers. The formula is taken   *
!   from D M Brink and G R Satchler, <Angular Momentum>, second edi-   *
!   tion (Oxford: Clarendon press, 1968), p 138.   The logarithms of   *
!   the first  MFACT  factorials must be available in  COMMON/FACTS/   *
!   for this program to function correctly. Note that  N!  is stored   *
!   in FACT(N+1)                                                       *
!                                                                      *
!   No subroutines called.                                             *
!                                                                      *
!   Written by Farid A Parpia, at Oxford   Last updated: 06 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:46:52   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE FACTS_C
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: KAPPAA, K, KAPPAB
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: KA, KB, KAPKB, KABKP, KAMKB, KBMKA
      REAL(DOUBLE) :: EXPTRM
!-----------------------------------------------
!
!
!   Determine the absolute values of the kappas
!
      KA = ABS(KAPPAA)
      KB = ABS(KAPPAB)
!
!   Perform the triangularity check
!
      IF (ABS(KA - KB)<=K .AND. KA+KB-1>=K) THEN
!
!   Triangularity satisfied; compute the 3j coefficient
!
!   Begin with the logarithm of the square of the leading term
!
         EXPTRM = -LOG(DBLE(KA*KB))
!
!   Compute the logarithm of the square root of the leading term
!   and the factorial part that doesn't depend on the parity of
!   KA+KB+K (the delta factor)
!
         KAPKB = KA + KB
         KABKP = KAPKB + K
         KAMKB = KA - KB
         KBMKA = KB - KA
         EXPTRM = 0.5D00*(EXPTRM + GAM(KAPKB-K)+GAM(KAMKB+K+1)+GAM(KBMKA+K+1)-&
            GAM(KABKP+1))
!
!   The remainder depends on the parity of KA+KB+K
!
         IF (MOD(KABKP,2) == 0) THEN
!
!   Computation for even parity case
!
!   Include the phase factor: a minus sign if necessary
!
            IF (MOD(3*KABKP/2,2) == 0) THEN
               CLRX = 1.0D00
            ELSE
               CLRX = -1.0D00
            ENDIF
!
!   Include the contribution from the factorials
!
            EXPTRM = EXPTRM + GAM((KABKP+2)/2) - GAM((KAPKB-K)/2) - GAM((KAMKB+&
               K+2)/2) - GAM((KBMKA+K+2)/2)
!
         ELSE
!
!   Computation for odd parity case
!
!   Include the phase factor: a minus sign if necessary
!
            IF (MOD((3*KABKP - 1)/2,2) == 0) THEN
               CLRX = 1.0D00
            ELSE
               CLRX = -1.0D00
            ENDIF
!
!   Include the contribution from the factorials
!
            EXPTRM = EXPTRM + GAM((KABKP+1)/2) - GAM((KAPKB-K+1)/2) - GAM((&
               KAMKB+K+1)/2) - GAM((KBMKA+K+1)/2)
!
         ENDIF
!
!   Final assembly
!
         CLRX = CLRX*EXP(EXPTRM)
!
      ELSE
!
!   Triangularity violated; set the coefficient to zero
!
         CLRX = 0.0D00
!
      ENDIF
!
      RETURN
!
      END FUNCTION CLRX


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYSPEN
C...Calculates real and imaginary part of Spence function; see
C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.

      DOUBLE PRECISION FUNCTION PYSPEN(XREIN,XIMIN,IREIM)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Commonblocks.
      include 'inc/pydat1'

C...Local array and data.
      DIMENSION B(0:14)
      DATA B/
     &1.000000D+00,        -5.000000D-01,         1.666667D-01,
     &0.000000D+00,        -3.333333D-02,         0.000000D+00,
     &2.380952D-02,         0.000000D+00,        -3.333333D-02,
     &0.000000D+00,         7.575757D-02,         0.000000D+00,
     &-2.531135D-01,         0.000000D+00,         1.166667D+00/

      XRE=XREIN
      XIM=XIMIN
      IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
        IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
        IF(IREIM.EQ.2) PYSPEN=0D0
        RETURN
      ENDIF

      XMOD=SQRT(XRE**2+XIM**2)
      IF(XMOD.LT.1D-6) THEN
        IF(IREIM.EQ.1) PYSPEN=0D0
        IF(IREIM.EQ.2) PYSPEN=0D0
        RETURN
      ENDIF

      XARG=SIGN(ACOS(XRE/XMOD),XIM)
      SP0RE=0D0
      SP0IM=0D0
      SGN=1D0
      IF(XMOD.GT.1D0) THEN
        ALGXRE=LOG(XMOD)
        ALGXIM=XARG-SIGN(PARU(1),XARG)
        SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
        SP0IM=-ALGXRE*ALGXIM
        SGN=-1D0
        XMOD=1D0/XMOD
        XARG=-XARG
        XRE=XMOD*COS(XARG)
        XIM=XMOD*SIN(XARG)
      ENDIF
      IF(XRE.GT.0.5D0) THEN
        ALGXRE=LOG(XMOD)
        ALGXIM=XARG
        XRE=1D0-XRE
        XIM=-XIM
        XMOD=SQRT(XRE**2+XIM**2)
        XARG=SIGN(ACOS(XRE/XMOD),XIM)
        ALGYRE=LOG(XMOD)
        ALGYIM=XARG
        SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
        SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
        SGN=-SGN
      ENDIF

      XRE=1D0-XRE
      XIM=-XIM
      XMOD=SQRT(XRE**2+XIM**2)
      XARG=SIGN(ACOS(XRE/XMOD),XIM)
      ZRE=-LOG(XMOD)
      ZIM=-XARG

      SPRE=0D0
      SPIM=0D0
      SAVERE=1D0
      SAVEIM=0D0
      DO 100 I=0,14
        IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
        TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
        TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
        SAVERE=TERMRE
        SAVEIM=TERMIM
        SPRE=SPRE+B(I)*TERMRE
        SPIM=SPIM+B(I)*TERMIM
  100 CONTINUE

  110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
      IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM

      RETURN
      END


!!!-----------------------------------------------------------------!!!
!  optical ray tracing in a unit sphere
!  for simulation of light scattering off an spherical particle
!
!  Ce Yi 10.2018
!
!!!-----------------------------------------------------------------!!!

module mod_optic

    !constants
    integer, parameter :: R_KD = selected_real_kind(15,307)  !real*8
    real(R_KD), parameter ::  pi=dacos(-1.0d0)

    !pos_xyz: x,y,z coordinates
    !pos_rtp: r,cos(theta),phi, spherical cooridate
    real(R_KD) ::  pos_xyz(3)=0, pos_rtp(3)=0

    !light direction: mu_x, mu_y, mu_z (cosines with the x,y,z axies)
    real(R_KD) ::  dir_cos(3)=[0,0,1]

    !material params, assuming incident light in air (m1), sphere made of water (m2)
    real(R_KD) :: n_frac(2)=[1.0d0, 1.50d0]
    !absorption cross section measured by 1/r
    real(R_KD) :: siga(2)=[0d0, 0.1d0]

    !simulation params
    !number of particles
    integer :: num_p=100000
    !number of cosine bins for counter
    integer :: n_tr=8, n_rk=50
    real(R_KD) ::  bin_size
    real(R_KD) ::  fwd_co=0.76
    real(R_KD) :: r_sph = 1.d0
    !counters arrays
    integer :: c_absorb=0, c_abs_tot=0
    integer, allocatable :: c_scatter(:), c_sca_tot(:)
    integer, allocatable :: c_tracker(:,:), c_trk_tot(:,:)

    !for debugging
    integer :: n_out=0, npsdbg=12
    integer :: nutdbg=0  !unit test index

    !polarization
    complex(kind=8) :: E_ini(3)=[(1d0,1d0),(1d0,2d0), (0d0,0d0) ]
    complex(kind=8) :: E_vec(3)=[1.0d0,1.0d0,0.0d0]
    real(R_KD) :: k_wave, w_wave
    real(R_KD) :: k_zero, c_zero
contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   subroutine GetInitPnt
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  uniformly sample a point inside a unit circle (on XY plane)
!  as the incident light beam initial intersection with the unit sphere
!  assuming incident light travelling along z+
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      real :: rval(3), rad

      pos_rtp(1)=1.0d0
      pos_rtp(2)=1.0d0  !cos(theta)
      call RANDOM_NUMBER(rval)
      pos_rtp(3)=2*pi*rval(1)-pi

      rad=rval(2)+rval(3)
      if (rad .gt. 1) rad=2d0-rad

      pos_xyz(1)=rad*dcos(pos_rtp(3))*r_sph
      pos_xyz(2)=rad*dsin(pos_rtp(3))*r_sph
      !pos_xyz(3)=-dsqrt(1.0d0-pos_xyz(1)**2-pos_xyz(2)**2)
      pos_xyz(3)=-dsqrt(r_sph**2-pos_xyz(1)**2-pos_xyz(2)**2)

      dir_cos=[0d0,0d0,1d0]

      !initialize polarization state
      k_wave =15000*(2*pi)  !cm^-1
      w_wave = 0.0d0
      E_vec=E_ini

   end subroutine GetInitPnt

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   subroutine GetFlecDir(d_n)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  calculate a unit vector pointing the reflection direction
!  Input: d_n: surface normal direction, pointing to incident light
!
!  local variables:
!     d_i: incident light, pointing to surface
!     d_flec: reflected light direction
!  global variable(s):
!     dir_cos: incident dir on input, reflected dir on output
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      implicit none
      real(R_KD), intent(in) :: d_n(3)

      real(R_KD) :: d_i(3), d_flec(3)
      real(R_KD) :: dot_ni
      integer i

      d_i=dir_cos
      dot_ni=0d0
      do i=1,3
         dot_ni=dot_ni+d_n(i)*d_i(i)
      enddo

      if (dot_ni .gt. 0) then
         write(*,"('ERROR: dot_ni is greater or equal zero in GetFlecDir:', f10.4 )") dot_ni
         write(*,"('dir_n=', 3(f8.4,x))") d_n
         write(*,"('dir_i=', 3(f8.4,x))") d_i
         stop
      endif

      d_flec=d_i(:)-2*dot_ni*d_n(:)
      dir_cos=d_flec

   end subroutine GetFlecDir

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   subroutine GetFracDir(d_n,r_n,IsTir)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  calculate a unit vector pointing the refraction direction
!  Input: d_n(3): surface normal direction, pointing to incident light
!         r_n : ratio of refraction index n1/n2, where n1 is incident medium
!  Output:
!         IsTir: logical, true if total internal reflection,
!                 if not present, assuming false always
!  local variables
!         d_i(3): incident light, pointing to surface
!         d_frac(3): refractioned light direction if IsTir=false
!                    reflectioned direction if IsTir=true
!  global variable(s)
!         dir_cos: incoming direction on input, refracted dir on output
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      implicit none
      real(R_KD), intent(in) :: d_n(3), r_n
      logical,optional,intent(out) :: IsTir

      real(R_KD) :: d_i(3), d_frac(3)
      real(R_KD) :: dot_ni, rv1,rv2
      integer i
      logical :: IsTir_loc=.false.

      IsTir_loc=.false.
      d_i=dir_cos
      dot_ni=0d0
      do i=1,3
         dot_ni=dot_ni+d_n(i)*d_i(i)
      enddo

      if (dot_ni .ge. 0) then
         write(*,"('ERROR: dot_ni is less or equal zero in GetFracDir')")
         stop
      endif

      rv1=dsqrt(1.0d0-dot_ni**2)
      if (rv1*r_n .gt. 1) IsTir_loc=.true.

      if (IsTir_loc) then
         call GetFlecDir(d_n)
         if (present(IsTir)) IsTir=IsTir_loc
         return
      endif

      d_frac=r_n*d_i(:)-(r_n*dot_ni+dsqrt(1d0-(r_n*rv1)**2))*d_n(:)
      dir_cos=d_frac

   end subroutine GetFracDir

   logical function IsFlec(d_n,r_n)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  input:
!     d_n: surface normal dir, pointing to the side of incident light
!     r_n: refaction index ratio n1/n2
!  local variables:
!     d_i: incident dir, k axis for incident light
!     d_s: s axis in local coordiate (s p k) where k is light moving dir
!          perpendicular to incident plane,
!          remains unchanged after reflection/refraction
!     d_p: p axis in local coordiate (s p k) for incident light
!          o the incident plane
!     d_pp: aka p', p axis for ougoing light
!
!  global variable:
!     dir_cos: incident dir on input, aka k
!              outgoing dir on output, aka k'
!
!  References:
!     Fresnel equation:  https://en.wikipedia.org/wiki/Fresnel_equations
!     Polarization tracking:
!          Garam Yun et al, Three-dimensional polarization ray-tracing
!          calculus I: definition and diattenuation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      implicit none
      real(R_KD), intent(in) :: d_n(3) ,r_n

      real(R_KD) :: d_i(3), d_s(3), d_p(3), d_pp(3)
      real, parameter :: rflec(2)=[0.1,0.8]
      real rv1, prob_r
      complex (kind=8) :: csp(2),cv1
      integer i
      real(R_KD) :: r_cos, r_sin2, rsp(2), tsp(2),E2_sp(3)
      complex (kind=8) :: E_sp(2)

      d_i=dir_cos
      ! calculate reflection rate for s, p components
      r_cos=0d0
      do i=1, 3
         r_cos=r_cos+d_n(i)*d_i(i)
      enddo
      r_sin2=(1.0d0-r_cos*r_cos)

      rv1=1.0-r_sin2*r_n**2
      cv1=zsqrt(complex(rv1,0.0d0))

      rv1=-r_n*r_cos
      csp(1)=(rv1-cv1)/(rv1+cv1)
      rsp(1)=zabs(csp(1))**2

      !rv1=-r_cos/r_n
      rv1=-r_cos
      cv1=cv1*r_n
      csp(2)=(cv1-rv1)/(cv1+rv1)
      rsp(2)=zabs(csp(2))**2

      !refraction
      do i=1,2
         tsp(i)=1.0d0-rsp(i)
      enddo

      !incident light global to local coordiate transformation
      !local cooridate (s p k)
      call vec_x_prod(d_i, d_n,d_s)
      d_s=d_s/vec_mag(d_s)

      call vec_x_prod(d_i, d_s, d_p)
      d_p=d_p/vec_mag(d_p)

      E_sp=0d0
      do i=1,3
         E_sp(1)=E_sp(1)+d_s(i)*E_vec(i)
         E_sp(2)=E_sp(2)+d_p(i)*E_vec(i)
      enddo

      do i=1,2
         E2_sp(i)=E_sp(i)*conjg(E_sp(i))
      enddo
      E2_sp(3)=E2_sp(1)+E2_sp(2)

      prob_r=(E2_sp(1)*rsp(1)+E2_sp(2)*rsp(2))/E2_sp(3)

      call RANDOM_NUMBER(rv1)
      IsFlec=(rv1 .le. prob_r)
      if (IsFlec) then
         call GetFlecDir(d_n)
      else
         call GetFracDir(d_n,r_n,IsFlec)
      endif

      !update E for polarization state
      call vec_x_prod(d_i, dir_cos,d_s)
      d_s=d_s/vec_mag(d_s)

      call vec_x_prod(d_i, d_s, d_p)
      d_p=d_p/vec_mag(d_p)

      call vec_x_prod(dir_cos, d_s, d_pp)
      d_pp=d_pp/vec_mag(d_p)

      E_sp=0d0
      do i=1,3
         E_sp(1)=E_sp(1)+d_s(i)*E_vec(i)
         E_sp(2)=E_sp(2)+d_p(i)*E_vec(i)
      enddo
      if (IsFlec) then
         E_sp(1:2)=E_sp(1:2)*rsp(1:2)
      else
         E_sp(1:2)=E_sp(1:2)*(1.0d0-rsp(1:2))
      endif

      do i=1,3
         E_vec(i)=d_s(i)*E_sp(1)+d_pp(i)*E_sp(2)
      enddo

      !!debug section begins: output
      if (n_out .lt. npsdbg) then
         n_out=n_out+1
         !write(*,"('cv1=', 2(ES12.5,x),' rv1=', ES12.5  )") cv1, rv1
         !write(*,"('csp(1)=',2(ES12.5,2x),'  csp(2)=', 2(ES12.5,2x) )") (realpart(csp(i)), imagpart(csp(i)), i=1,2)

         !write(*,"('r_n=',ES12.5,'  reflectance_sp=', 2(ES12.5,2x) )") r_n,rsp(1:2)
         !write(*,"('p_r=',ES12.5,'  E_sp=', 4(ES12.5,2x) )") prob_r, E_sp(1:2)
         write(*,"('polarization E=', 3('(',ES12.5,x,ES12.5,')') )") (realpart(E_vec(i)), imagpart(E_vec(i)), i=1,3)
         cv1=0d0
         do i=1,3
            cv1=cv1+E_vec(i)*dir_cos(i)
         enddo
         write(*,"('verifying  E \dot k =', 3('(',ES12.5,x,ES12.5,')') )") realpart(cv1), imagpart(cv1)

      endif
      !!debug section ends

      !if (r_n .lt. 1) then
      !   IsFlec=(rv1 .le. rflec(1) )
      !else
      !   IsFlec=(rv1 .le. rflec(2) )
      !endif

      return

   end function IsFlec

!--------------------------utilities--------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   subroutine convert_c2s(xyz,rtp)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  convert Cartesian to spherical coordinates
!  Input: xyz(3)=(x, y, z)
!  Output: rtp=(r, cos(t), phi), where -pi<phi<pi
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      real*8, intent(in) :: xyz(3)
      real*8, intent(out):: rtp(3)

      rtp=0d0

      rtp(1)=dsqrt(xyz(1)**2+xyz(2)**2+xyz(3)**2)
      if(rtp(1) .eq. 0) return

      rtp(2)=xyz(3)/rtp(1)
      rtp(3)=datan2(xyz(2),xyz(1))

   end subroutine convert_c2s

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   subroutine add_scatter(d_r, rk)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  counting outgoing light into cosine bins
!  Input: d_r: outgoing direction
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      real(R_KD) :: d_r(3)
      integer rk
      integer ibin

      ibin=int((1d0+d_r(3))/bin_size)+1
      if (ibin .gt. n_tr) ibin=n_tr
      if (ibin .lt. 1) then
         write(*,"('ERROR: in add_scatter, d_r(3)=', f10.4)") d_r(3)
      else
         c_scatter(ibin)=c_scatter(ibin)+1
      endif
      if (rk .lt. n_rk) then
         c_tracker(ibin,rk) = c_tracker(ibin,rk)+1
      else
         c_tracker(ibin,n_rk) = c_tracker(ibin,n_rk)+1
      endif

   end subroutine add_scatter

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   subroutine vec_x_prod(v1,v2,v_out)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  calculate vector cross product: v_out=v1 x v2
!  Input: v1, v2  (vectors)
!  output: v_out
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      real(R_KD),intent(in) :: v1(3), v2(3)
      real(R_KD),intent(out) :: v_out(3)

      v_out(1)= v1(2)*v2(3)-v1(3)*v2(2)
      v_out(2)= -(v1(1)*v2(3)-v1(3)*v2(1))
      v_out(3)= v1(1)*v2(2)-v1(2)*v2(1)

   end subroutine vec_x_prod

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   function  vec_mag(v1) result(mag)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  calculate magnitude of a vector
!  Input: v1, v2  (vectors)
!  output: v_out
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      implicit none
      real(R_KD),intent(in) :: v1(3)
      real(R_KD) :: mag

      integer i

      mag=0d0
      do i=1,3
         mag=mag+v1(i)**2
      enddo
      mag=dsqrt(mag)

   end function vec_mag

end module  mod_optic


cc    This module calculates the r.h.s for the KS equation
cc
cc    d/dt u = - (dx^2+ dx^4)u - u u'
cc
cc    in its form with fourier modes.
cc    I.e., the system
cc
cc    dt u_n = (n^2 q^2 - n^4 q^4) u_n
cc    - (i q n/2) sum_{n_1+n_2=n} u_{n_1} u_{n_2}
cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine FKS(ND,T,Y,F,RPAR,IPAR)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (MMM=9)
      PARAMETER (NH=2**MMM,N=2*NH)
      DIMENSION y(ND),f(ND)
      DIMENSION U(N)
        COMMON/TRANS/QQ,UZERO

c ---    copy y to u
        U(1)=UZERO
        U(2)=0.D0
        DO I=3,N
         U(I)=Y(I-2)
        END DO
        CALL REALFT(U,NH,-1)
        DO I=1,N
         U(I)=2.D0*U(I)
        END DO
C ---    SQUARE ------
        DO I=1,N
         U(I)=U(I)**2/2.D0
        END DO
C --- TRANSFORM BACK ---
        CALL REALFT(U,NH,+1)
        AN=N
        DO I=1,N
         U(I)=U(I)/AN
        END DO
      do J=1,NH-1
        DIAG=(QQ*J)**2*(1.D0-(QQ*J)**2)
        F(2*J-1)=DIAG*Y(2*J-1) +QQ*J*U(2*J+2)
        F(2*J  )=DIAG*Y(2*J  ) -QQ*J*U(2*J+1)
      enddo
      end
c--------------------------------------------------------------
      subroutine JKS(ND,x,y,dfy,ldfy,RPAR,IPAR)
      PARAMETER (MMM=9)
      PARAMETER (NH=2**MMM,N=2*NH)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION y(ND),DFY(LDFY,ND)
        COMMON/TRANS/QQ,UZERO
      do J=1,NH-1
        DIAG=(QQ*J)**2*(1.D0-(QQ*J)**2)
        DFY(1,2*J-1)=DIAG
        DFY(1,2*J  )=DIAG
      enddo
      end

      subroutine fft(xr,n,isign)
      integer n
      integer isign
      real*8  xr(2*n)
c     ***************************************************************
c     *  the fft computes the discrete fast fourier transform of a  *
c     *  sequence of n terms.                                       *
c     *  the forward fft computes                                   *
c     *       y(j)= sum (from k=0 to n-1) x(k)*exp(2*pi*i*j*k/n)    *
c     *  the backward fft computes                                  *
c     *       y(j)= sum (from k=0 to n-1) x(k)*exp(-2*pi*i*j*k/n)   *
c     *                                                             *
c     *  x     is a complex array of length n.                      *
c     *  n     is a power of 2. n<=4096.                            *
c     *  isign is the direction of the transform.if isign>=0 then   *
c     *        the fft is forward, otherwise backward.              *
c     *                                                             *
c     *  reference                                                  *
c     *  j.w.cooley, p.a.w.lewis, and p.d.welch, 'the fast fourier  *
c     *  transform and its applications', ieee trans. on education, *
c     *  vol.e-12, no.1, (march 1969),p.29.                         *
c     *  the fft is a modified version of the program described in  *
c     *  this reference.the modification is the use of a table to   *
c     *  store the roots of unity.                                  *
c     ***************************************************************
      integer maxn
      parameter(maxn=8192)
      integer i
      integer icnt,ii,iir,ijr,j,jj,k,m,ntbl
      real*8  cstore(2*maxn),dcos,dsin,datan
      real*8  pi,temp,vr1,vr2,vrr1,vrr2,wr1,wr2,xr1,xr2
      save cstore
      save ntbl
      data ntbl/0/

c     ****  store table of roots of unity ****

c     the roots of unity exp(pi*i*k/j) for j=1,2,4,..,n/2 and
c     k=0,1,2,..,j-1 are computed once and stored in a table.
c     this table is used in subsequent calls of fft with parameter
c     n <= ntbl.

      if(n.gt.maxn) then
         print *,'n too big in fft',n
         stop
      endif
      if (n.gt.ntbl) then
         ntbl=n
         pi=datan(1.0d0)*4.0d0
         j=1
         icnt=0
 10      continue
c     s=pi*(0,1)/j
         do 20 k=0,j-1
            icnt=icnt+1
            cstore(icnt+icnt-1)=dcos(k*(pi/j))
            cstore(icnt+icnt  )=dsin(k*(pi/j))
 20      continue
         j=j+j
         if (j.lt.n) go to 10
      end if

c     ****  bit reversal ****

c     the x(j) are permuted, in such a way that each new place
c     number j is the bit reverse of the original place number.

      j=1
      do 30 i=1,n
         if (i.lt.j) then
            jj=2*j
            ii=2*i
            vrr1=xr(jj-1)
            xr(jj-1)=xr(ii-1)
            xr(ii-1)=vrr1
            vrr2=xr(jj)
            xr(jj)=xr(ii)
            xr(ii)=vrr2
         end if
         m=n/2
 25      continue
         if (j.gt.m) then
            j=j-m
            m=m/2
            if (m.ge.1) go to 25
         else
            j=j+m
         end if
 30   continue

c     ****  matrix multiplication ****

c     the roots of unity and the x(j) are multiplied.

      j=1
      icnt=0
 40   jj=j+j
      do 50 k=1,j
         icnt=icnt+1
         wr1=cstore(2*icnt-1)
         wr2=cstore(2*icnt  )
         if (isign.lt.0) wr2=-wr2

         do 50 i=k,n,jj
            iir=i+i
            ijr=(i+j)*2
            xr1=xr(ijr-1)
            xr2=xr(ijr)
            vr1=wr1*xr1
            vr1=vr1-wr2*xr2
            temp=xr(iir-1)
            xr(iir-1)=temp+vr1
            xr(ijr-1)=temp-vr1
            vr2=wr1*xr2+wr2*xr1
            temp=xr(iir)
            xr(ijr)=temp-vr2
            xr(iir)=temp+vr2
 50      continue
         j=jj
         if (j.lt.n) go to 40
       return
      end
c-----------------------------

      subroutine realft(x,n,isign)
      integer n
      integer isign
      real*8  x(2*n)

      integer i,i1,i2,i3,i4,n2p3,ppp
      real*8 c1,c2,h1r,h1i,h2r,h2i
      real*8 wr,wi,wpr,wpi,wtemp,theta,pi,dsin,datan
      real*8 x1,x2,x3,x4,uu,vv,wr0,wr1,wr2
      c1=0.5
      pi=datan(1.0D0)*4
      theta=pi/ n
      if (isign.eq.1) then
         c2 = -0.5D+00
         call fft(x,n,1)
      else
         c2=0.5D+00
         theta = -theta
      endif
      wtemp=dsin(0.5*theta)
      wpr = -2.0*wtemp*wtemp
      wpi=dsin(theta)
      wr=1.0+wpr
      wi=wpi
      n2p3=2*n+3
      do i=2,n/2
         ppp=1
         if(ppp.eq.0)then
c     ... normal code
            i1=2*i-1
            i2=i1+1
            i3=n2p3-i2
            i4=i3+1
            h1r=c1*(x(i1)+x(i3))
            h1i=c1*(x(i2)-x(i4))
            h2r = -c2*(x(i2)+x(i4))
            h2i=c2*(x(i1)-x(i3))
            x(i1)=   h1r +wr*h2r-wi*h2i
            x(i3)=   h1r -wr*h2r+wi*h2i
            x(i2)=   h1i +wr*h2i+wi*h2r
            x(i4) = -h1i +wr*h2i+wi*h2r
            wtemp=wr
            wr=wtemp*wpr-wi*wpi+wr
            wi=wi*wpr+wtemp*wpi+wi
         else
c     ... optimized for apollo
            i1=2*i-1
            i3=(n2p3-1)-i1
            x1=x(i1)
            x3=x(i3)
            h2i=c2*(x1-x3)
            uu= wi*h2i
            vv= wr*h2i
            h1r=c1*(x1+x3)
            x2=x(i1+1)
            x4=x(i3+1)
            h2r = -c2*(x2+x4)
            uu=wr*h2r-uu
            vv=wi*h2r+vv
            x(i1)=h1r+uu
            x(i3)=h1r-uu
            h1i =  c1*(x2-x4)
            x(i1+1)=   h1i+vv
            x(i3+1) = -h1i+vv
            wr0=wi*wpi
            wr1=(1+wpr)
            wi=wi*wr1
            wtemp=wr
            wr2=wtemp*wr1
            wi=wtemp*wpi+wi
            wr=wr2-wr0
         endif
      enddo
      if (isign.eq.1) then
         h1r=x(1)
         x(1) = h1r+x(2)
         x(2) = h1r-x(2)
      else
         h1r=x(1)
         x(1)=c1*(h1r+x(2))
         x(2)=c1*(h1r-x(2))
         call fft(x,n,-1)
      endif
      end


program balistica

    implicit none
    double precision, dimension(1:90) :: xmax, theta
    double precision, dimension(0:10000) :: x, y, vx, vy, t
    double precision :: g, dt, ang, vo, aux, b
    integer :: i, j

!    open(1, FILE = "variaveis.txt")

        vo = 10
        x(0) = 0
        y(0) = 0
        dt = 0.008
        g = 9.79
        b = 0.00004

!    close(1)

        do j = 1,90

            ang = 3.1415/180d0
            theta(j) = ang*j
            aux = 0
            i = 0

                do while (aux .ge. 0)

                    i = i + 1

                    vx(0) = vo*cos(ang*j)
                    vy(0) = vo*sin(ang*j)

                    t(i) = dt*i

                    vy(i) = vy(i-1) - g*t(i-1) - b*vo*dt*vy(i-1)
                    y(i) = vy(i-1)*dt + y(i-1)

                    x(i) = vx(i-1)*dt + x(i-1)
                    vx(i) = vx(i-1)

                    if (y(i) .le. 0) then
                    xmax(j) = x(i)
                    endif

                        if (y(i) .gt. 0) then
                            open(UNIT = 2, FILE = 'XY.txt')
                                write(2,*) x(i), y(i)
                        endif

                    aux = y(i)

                enddo

            open(UNIT = 3, FILE = 'Xtheta.txt')
                write(3,*) theta(j), xmax(j)

        enddo

        close(2)
        close(3)

end program


c
c
c ------------------------ moment --------------------------------
c
c
      subroutine gmoment(rad,m0,ounit)
c
c     The following coordinate system is assumed:
c     1 -> east
c     2 -> north
c     3 -> up
c
c     gmoment - routine to rotate the moment tensor into its
c              principle axes, find the greatest double couple
c              component, and resulting orientation parameters
c              for the two nodal planes.
c
c     rad(i) =>  i=1(m11);=2(m22);=3(m12);=4(m13);=5(m23).
c                =6(m33)
c
      dimension ev(3,5),v(3,3),p1(3),p2(3),rad(6)
      real*4 m(3,3),md1,md3,merr,m0
      real tv(3)
      real moment_mag, scalar_moment,isotropic
      integer ounit
      real rad2deg

c
c     initialize some variables
c
      t1=1.0e-05
      t2=1.0e-04
      nsiz=3
      s2=1.414213562
      pi=3.141593
      rad2deg = 57.29578

      write(ounit,200)

c     Store the moment tensor in 2d array

      m(1,1)=rad(1)
      m(2,2)=rad(2)
      m(3,3)=rad(6)

      m(1,2)=rad(3)
      m(2,1)=m(1,2)

      m(1,3)=rad(4)
      m(3,1)=m(1,3)

      m(2,3)=rad(5)
      m(3,2)=m(2,3)

c
c     output the Input moment tensor
      write(ounit,100)
      do 05 i=1,3
         write(ounit,101) (m(i,j),j=1,3)
05    continue
      write(ounit,*)'m0 = ',m0
c
c     remove the isotropic component
c
      isotropic = 0.333333*(rad(1)+rad(2)+rad(6))
      write(ounit,*)' '
      write(ounit,*)'Isotropic Component: ',isotropic
      m(1,1)=rad(1)-isotropic
      m(2,2)=rad(2)-isotropic
      m(3,3)=rad(6)-isotropic
      write(ounit,*) 'Subtracted out the isotropic component.'
c
c     output the moment tensor
      write(ounit,*)' '
      write(ounit,*)'The Deviatoric Moment Tensor:'
      do 10 i=1,3
         write(ounit,101) (m(i,j),j=1,3)
10    continue
c
c     compute the eigenvalues and eigenvectors of m
      call hsehld(nsiz,nsiz,m,v,ev)
c
c       make sure that the eigenvectors form a right handed
c          coordinate system v3 = v1 x v2.
c
      v(1,3)=v(2,1)*v(3,2) - v(3,1)*v(2,2)
      v(2,3)=v(3,1)*v(1,2) - v(1,1)*v(3,2)
      v(3,3)=v(1,1)*v(2,2) - v(2,1)*v(1,2)
c
c     Output the eigenvalues and eigenvectors of m
c
      write(ounit,102)
      write(ounit,101) (ev(i,1),i=1,3)
      write(ounit,103)
      do 11 i=1,3
         write(ounit,101) (v(i,j),j=1,3)
11    continue
c
c     Compute the azimuth and plunge
c
      write(ounit,*) ' '
      write(ounit,*) 'Eigenvector 1:'
      tv(1) = v(1,1)
      tv(2) = v(2,1)
      tv(3) = v(3,1)
      call getaz_plunge(tv,az,plunge)
      write(ounit,*)'Az = ',az,' Plunge = ',plunge

      write(ounit,*) 'Eigenvector 2:'
      tv(1) = v(1,2)
      tv(2) = v(2,2)
      tv(3) = v(3,2)
      call getaz_plunge(tv,az,plunge)
      write(ounit,*)'Az = ',az,' Plunge = ',plunge

      write(ounit,*) 'Eigenvector 3:'
      tv(1) = v(1,3)
      tv(2) = v(2,3)
      tv(3) = v(3,3)
      call getaz_plunge(tv,az,plunge)
      write(ounit,*)'Az = ',az,' Plunge = ',plunge
      write(ounit,*) ' '
c
c     Output the Scalar moment estimate of silver and jordan
c
      temp = (isotropic+ev(1,1))*(isotropic+ev(1,1))
      temp = temp+(isotropic+ev(2,1))*(isotropic+ev(2,1))
      temp = temp+(isotropic+ev(3,1))*(isotropic+ev(3,1))
      scalar_moment = sqrt(temp / 2.0)*m0
      moment_mag = 0.6667*log10(scalar_moment) - 10.7
      write(ounit,*) ' '
      write(ounit,*)
     &'The Total Scalar Moment (Silver&Jordan,1982) is '
      write(ounit,'(e10.3)')scalar_moment
      write(ounit,*)
     &'The Total Moment Magnitude (Kananmori(1979)) is '
      write(ounit,'(f5.1)') moment_mag

      temp = ev(1,1)*ev(1,1)
      temp = temp+ev(2,1)*ev(2,1)
      temp = temp+ev(3,1)*ev(3,1)
      scalar_moment = sqrt(temp / 2.0)*m0
      moment_mag = 0.6667*log10(scalar_moment) - 10.7

      write(ounit,*) ' '
      write(ounit,*)
     &'The Deviatoric Scalar Moment (Silver&Jordan,1982) is '
      write(ounit,'(e10.3)')scalar_moment
      write(ounit,*)
     &'The Deviatoric Moment Magnitude (Kananmori(1979)) is '
      write(ounit,'(f5.1)') moment_mag
c
c
c     Compute the percent clvd (relative to double couple)
c
      md1=(ev(1,1)/abs(ev(1,1)))*(abs(ev(1,1))+abs(ev(3,1)))/2.
      md3=(ev(3,1)/abs(ev(3,1)))*abs(md1)
      merr=abs(ev(2,1)/md1)*100.0

      tmin = abs(ev(1,1))
      if(abs(ev(2,1)) .lt. tmin) tmin = abs(ev(2,1))
      if(abs(ev(3,1)) .lt. tmin) tmin = abs(ev(3,1))

      tmax = abs(ev(1,1))
      if(abs(ev(2,1)) .gt. tmax) tmax = abs(ev(2,1))
      if(abs(ev(3,1)) .gt. tmax) tmax = abs(ev(3,1))
      epsilon = tmin / tmax

      merr = 200 * epsilon

      write(ounit,*) ' '
      write(ounit,104) md1,md3
      write(ounit,105) merr
      write(ounit,*) ' '
c
c     Compute the major double couple associated with m
c
c     calculate moment tensor elements for dislocation assuming
c       eigenvalues are +1, -1.
c
c     DM = V E V^T
c
      dm11=v(1,1)*v(1,1) - v(1,3)*v(1,3)
      dm22=v(2,1)*v(2,1) - v(2,3)*v(2,3)
      dm33=v(3,1)*v(3,1) - v(3,3)*v(3,3)
      dm12=v(1,1)*v(2,1) - v(2,3)*v(1,3)
      dm13=v(3,1)*v(1,1) - v(3,3)*v(1,3)
      dm23=v(3,1)*v(2,1) - v(3,3)*v(2,3)
c
      write(ounit,111) dm11,dm22,dm33,dm12,dm13,dm23
c
c     rotate the pressure and tension axes to find poles of
c          p nodal planes
c
      p2(1)=(v(1,1) + v(1,3))/s2
      p2(2)=(v(2,1) + v(2,3))/s2
      p2(3)=(v(3,1) + v(3,3))/s2

      p1(1)=(-v(1,1) + v(1,3))/s2
      p1(2)=(-v(2,1) + v(2,3))/s2
      p1(3)=(-v(3,1) + v(3,3))/s2

      c1=1.0
      c2=1.0
      if(p1(3).lt.0.) c1=-1.0
      if(p2(3).lt.0.) c2=-1.0

      do 12 i=1,3
         p1(i)=p1(i)*c1
         p2(i)=p2(i)*c2
12    continue

      write(ounit,106)
      write(ounit,101) (p1(i),i=1,3)
      write(ounit,101) (p2(i),i=1,3)

c     azimuth and plunge of pole 1
c
      if(abs(p1(1)).le.t1) go to 13
      az1=atan2(p1(2),p1(1))
      go to 14

13    if(p1(2).ge.0.) az1=1.570796
      if(p1(2).lt.0.) az1=4.712389
14    if(az1.lt.0.) az1=az1 + 6.283185
      plng=sqrt(p1(1)*p1(1) + p1(2)*p1(2))
      if(plng.le.t1) go to 15
      pl1=atan2(p1(3),plng)
      go to 16
15    pl1=1.570796
16    continue

      write(ounit,107) az1*rad2deg,pl1*rad2deg
c
c     azimuth and plunge of pole #2
c
      if(abs(p2(1)).le.t1) then
         if(p2(2).ge.0.) az2=1.570796
         if(p2(2).lt.0.) az2=4.712389
      else
         az2=atan2(p2(2),p2(1))
      end if

      if(az2.lt.0.) az2=az2 + 6.283185
      plng=sqrt(p2(1)*p2(1) + p2(2)*p2(2))

      if(plng.le.t1) then
         pl2=1.570796
      else
         pl2=atan2(p2(3),plng)
      end if

      write(ounit,108) az2*rad2deg,pl2*rad2deg
c
c     Find the nodal plane angle parameters
c
      strk1=az1 - 4.712389
      if(strk1.lt.0.) strk1=strk1 + 6.283185
      strk2=az2 - 4.712389
      if(strk2.lt.0.) strk2=strk2 + 6.283185
      dip1=1.570796 - pl1
      dip2=1.570796 - pl2
c
c     Find the rake of plane #1
c
      if(dip1 .lt. t1) go to 21
        cd2sd1=cos(dip2)/sin(dip1)
        if(abs(cd2sd1).gt. 1.0) cd2sd1=1.0
        rake=asin(cd2sd1)
        merr=1000.
        do 22 j=1,4
          if(j.eq.1) rakt=rake
          if(j.eq.2) rakt= -rake + pi
          if(j.eq.3) rakt= +rake + pi
          if(j.eq.4) rakt= -rake
          call mtest(strk1,dip1,rakt,
     +               dm11,dm22,dm12,dm13,dm23,err)
          if(err.gt.merr) go to 22
          rake1=rakt
          merr=err
22     continue
c
c     Find the rake of plane #2
c
      if(dip2.lt.t1) go to 30
      cd1sd2=cos(dip1)/sin(dip2)
      if(abs(cd1sd2).gt. 1.0) cd1sd2=1.0
      rake=asin(cd1sd2)
      merr=1000.
      do 31 j=1,4
        if(j.eq.1) rakt= rake
        if(j.eq.2) rakt= -rake + pi
        if(j.eq.3) rakt= +rake + pi
        if(j.eq.4) rakt= -rake
        call mtest(strk2,dip2,rakt,dm11,dm22,dm12,dm13,dm23,err)
        if(err.gt.merr) go to 31
        rake2=rakt
        merr=err
31    continue
      go to 24
21    continue
c
c     degenerate case when dip1=0
c
      rake1=0.
      rake=v(3,1) + v(3,3)
      if(rake.gt.0.) rake2=-1.570796
      if(rake.lt.0.) rake2=+1.570796
c
      go to 24
c
30    continue
c
c     Handle the degenerate case when dip2=0
c
      rake2=0.
24    continue
      write(ounit,109)
      t3=360.0/6.283185
      dip1=dip1*t3
      rake1=rake1*t3
      strk1=strk1*t3
      dip2=dip2*t3
      rake2=rake2*t3
      strk2=strk2*t3
      if (dip1.gt.89) then
        dip1=89.00
      end if
      if (dip2.gt.89) then
        dip2=89.00
      end if
      if (rake1.gt.180) then
	rake1=rake1-360
      end if
      if (rake2.gt.180) then
	rake2=rake2-360
      end if
      write(ounit,110) strk1,dip1,rake1
      write(ounit,110) strk2,dip2,rake2
      write(ounit,201)
c
c
100   format(1x,'Input moment tensor:')
101   format(1x,3(e10.3,5x))
102   format(/,1x,'eigenvalues of the moment tensor')
103   format(/,1x,'and associated eigenvectors (in the columns)')
104   format(1x,'double couple eigenvalues=',e10.3,5x,e10.3)
105   format(1x,'error (clvd/dc)*100=',f10.3)
106   format(1x,'pole vectors p1 and p2')
107   format(/,1x,'azimuth and plunge of pole #1;',5x,'az1=',f07.2,5x,'p
     +l1=',f07.2)
108   format(1x,'azimuth and plunge of pole #2;',5x,'az2=',f07.2,5x,'pl2
     +=',f07.2)
109   format(/,1x,'fault angle parameters',/,2x,
     +       'strike',6x,'dip',5x,'rake')
110   format(1x,3(f7.2,3x))
111   format(/,1x,'moment tensor for the major dislocation'/,
     +1x,5(f10.4,3x),/)
200   format
     +(/,1x,'--------- From Subroutine Moment ---------------',/)
201   format
     +(/,1x,'--------------------------------------------------',/)
c
c
      return
      end
c
c
c ------------------------ mtest ---------------------------------
c
      subroutine mtest(s,d,r,dm11,dm22,dm12,dm13,dm23,err)
c
c       this routine calculates the theoretical moment tensor expected
c       from values of strike,dip,rake, and compares it with the
c       observed.  rake is changed to rake + pi if the comparison
c       fails.
c
      tm11=sin(s)*sin(s)*sin(r)*sin(2.*d)+sin(2.*s)*cos(r)*sin(d)
      tm22=cos(s)*cos(s)*sin(r)*sin(2.*d)-sin(2.*s)*cos(r)*sin(d)
      tm12=-0.5*sin(2.*s)*sin(r)*sin(2.*d)-cos(2.*s)*cos(r)*sin(d)
      tm13=cos(s)*cos(r)*cos(d)+sin(s)*sin(r)*cos(2.*d)
      tm23=-cos(s)*sin(r)*cos(2.*d)+sin(s)*cos(r)*cos(d)
      err=(tm11-dm11)**2 + (tm22-dm22)**2 + (tm12-dm12)**2 +
     *  (tm13-dm13)**2 + (tm23-dm23)**2
      err=sqrt(err)
      return
      end

c
c ------------------------ getaz_plunge  ------------------------------
c
c     v(1) = east    v(2) = north   v(3) = down
c
      subroutine getaz_plunge(v,az,plunge)
      real v(3), az, plunge

      real north,south,east,west
      real pi, pi_over_2, two_pi
      integer stdout

      stdout = 6

      pi_over_2 = 1.5707963
      pi = 3.1415927
      two_pi = 6.2831853

      north = 0
      south = pi
      east = pi_over_2
      west = 3*pi_over_2

      vsmall=1.0e-06
      rad2deg = 57.29578

      if(abs(v(2)) .le. vsmall)then
        if(abs(v(1)) .gt. vsmall)then
          if(v(1) .ge. 0.0) az1=east
          if(v(1) .lt. 0.0) az1=west
        else
          az1 = 0.0
          write(stdout,*) 'Vertical vector.'
        end if
      else
        if(abs(v(1)) .le. vsmall)then
	       if(v(2) .ge. 0.0) az1=north
	       if(v(2) .lt. 0.0) az1=south
        else
            az1=pi_over_2 - atan2(v(1), v(2))
        end if
      end if

      if(az1 .lt. 0.) az1=az1 + two_pi
c
c     compute the plunge
c
      r=sqrt(v(1)*v(1) + v(2)*v(2))
c
      if(abs(v(3)) .le. vsmall)then
        pl1 = 0.0
      else
        if(r .lt. vsmall)then
          if(v(3) .gt. 0) pl1 = -pi_over2
          if(v(3) .lt. 0) pl1 = pi_over2
        else
          temp = v(3)
          pl1 = atan2(temp,r)
        end if
      end if
c
c     convert to degrees
c
      az = az1*rad2deg
      if(az .gt. 360.0) az = az - 360.0
c
      plunge = pl1*rad2deg

      if(plunge .lt. 0.0)then
        plunge = -plunge
        az = az + 180
        if(az .gt. 360.0) az = az - 360.0
      end if
c
      if(abs(plunge) .gt. 90.0)then

       if(plunge .gt. 90.0)then
        plunge = plunge - 90.0
        az = az + 180.0
        if(az .gt. 360.0) az = az - 360.0
       else if (plunge .lt. -90.0)then
        plunge = plunge + 90.0
        az = az + 180.0
         if(az .gt. 360.0) az = az - 360.0
      end if

      end if

      return
      end


      program zndrv3
c
c     Simple program to illustrate the idea of reverse communication
c     in inverse mode for a generalized complex nonsymmetric eigenvalue
c     problem.
c
c     We implement example three of ex-complex.doc in DOCUMENTS directory
c
c\Example-3
c     ... Suppose we want to solve A*x = lambda*B*x in regular mode,
c         where A and B are derived from the finite element discretization
c         of the 1-dimensional convection-diffusion operator
c                   (d^2u/dx^2) + rho*(du/dx)
c         on the interval [0,1] with zero boundary condition using
c         piecewise linear elements.
c
c     ... OP = inv[M]*A  and  B = M.
c
c     ... Use mode 2 of ZNAUPD .
c
c\BeginLib
c
c\Routines called:
c     znaupd   ARPACK reverse communication interface routine.
c     zneupd   ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     zgttrf   LAPACK tridiagonal factorization routine.
c     zgttrs   LAPACK tridiagonal solve routine.
c     dlapy2   LAPACK routine to compute sqrt(x**2+y**2) carefully.
c     zaxpy    Level 1 BLAS that computes y <- alpha*x+y.
c     dznrm2   Level 1 BLAS that computes the norm of a vector.
c     av      Matrix vector multiplication routine that computes A*x.
c     mv      Matrix vector multiplication routine that computes M*x.
c
c\Author
c     Richard Lehoucq
c     Danny Sorensen
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: ndrv3.F   SID: 2.4   DATE OF SID: 10/18/00   RELEASE: 2
c
c\Remarks
c     1. None
c
c\EndLib
c--------------------------------------------------------------------------
c
c     %-----------------------------%
c     | Define leading dimensions   |
c     | for all arrays.             |
c     | MAXN:   Maximum dimension   |
c     |         of the A allowed.   |
c     | MAXNEV: Maximum NEV allowed |
c     | MAXNCV: Maximum NCV allowed |
c     %-----------------------------%
c
      integer           maxn, maxnev, maxncv, ldv
      parameter         (maxn=256, maxnev=10, maxncv=25,
     &                   ldv=maxn )
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer           iparam(11), ipntr(14), ipiv(maxn)
      logical           select(maxncv)
      Complex*16
     &                  ax(maxn), mx(maxn), d(maxncv), resid(maxn),
     &                  v(ldv,maxncv), workd(3*maxn),
     &                  workev(2*maxncv),
     &                  workl(3*maxncv*maxncv+5*maxncv),
     &                  dd(maxn), dl(maxn), du(maxn), du2(maxn)
      Double precision
     &                  rwork(maxn), rd(maxncv,3)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character         bmat*1, which*2
      integer           ido, n, nev, ncv, lworkl, info, ierr, j,
     &                  nconv, maxitr, ishfts, mode
      Complex*16
     &                  sigma, h
      Double precision
     &                  tol
      logical           rvec
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Complex*16
     &                  zero, one
      parameter         (zero = (0.0D+0, 0.0D+0) ,
     &                   one = (1.0D+0, 0.0D+0) )
c
c     %-----------------------------%
c     | BLAS & LAPACK routines used |
c     %-----------------------------%
c
      Double precision
     &                  dznrm2 , dlapy2
      external          zaxpy , zcopy , dznrm2 , zgttrf , zgttrs ,
     &                  dlapy2
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %----------------------------------------------------%
c     | The number N is the dimension of the matrix.  A    |
c     | generalized eigenvalue problem is solved (BMAT =   |
c     | 'G').  NEV is the number of eigenvalues to be      |
c     | approximated.  The user can modify NEV, NCV, WHICH |
c     | to solve problems of different sizes, and to get   |
c     | different parts of the spectrum.  However, The     |
c     | following conditions must be satisfied:            |
c     |                    N <= MAXN,                      |
c     |                  NEV <= MAXNEV,                    |
c     |              NEV + 2 <= NCV <= MAXNCV              |
c     %----------------------------------------------------%
c
      n     = 100
      nev   = 4
      ncv   = 20
      if ( n .gt. maxn ) then
         print *, ' ERROR with _NDRV3: N is greater than MAXN '
         go to 9000
      else if ( nev .gt. maxnev ) then
         print *, ' ERROR with _NDRV3: NEV is greater than MAXNEV '
         go to 9000
      else if ( ncv .gt. maxncv ) then
         print *, ' ERROR with _NDRV3: NCV is greater than MAXNCV '
         go to 9000
      end if
      bmat  = 'G'
      which = 'LM'
      sigma = zero
c
c     %-----------------------------------------------------%
c     | The matrix M is chosen to be the symmetric tri-     |
c     | diagonal matrix with 4 on the diagonal and 1 on the |
c     | off diagonals. It is factored by LAPACK subroutine  |
c     | zgttrf .                                             |
c     %-----------------------------------------------------%
c
      h = one / dcmplx (n+1)
      do 20 j = 1, n-1
         dl(j) = one*h
         dd(j) = (4.0D+0, 0.0D+0) *h
         du(j) = one*h
  20  continue
      dd(n) = (4.0D+0, 0.0D+0) *h
c
      call zgttrf (n, dl, dd, du, du2, ipiv, ierr)
      if ( ierr .ne. 0 ) then
         print*, ' '
         print*, ' ERROR with _gttrf. '
         print*, ' '
         go to 9000
      end if
c
c     %-----------------------------------------------------%
c     | The work array WORKL is used in ZNAUPD  as           |
c     | workspace.  Its dimension LWORKL is set as          |
c     | illustrated below.  The parameter TOL determines    |
c     | the stopping criterion. If TOL<=0, machine          |
c     | precision is used.  The variable IDO is used for    |
c     | reverse communication, and is initially set to 0.   |
c     | Setting INFO=0 indicates that a random vector is    |
c     | generated in ZNAUPD  to start the Arnoldi iteration. |
c     %-----------------------------------------------------%
c
      lworkl = 3*ncv**2+5*ncv
      tol    = 0.0
      ido    = 0
      info   = 0
c
c     %---------------------------------------------------%
c     | This program uses exact shifts with respect to    |
c     | the current Hessenberg matrix (IPARAM(1) = 1).    |
c     | IPARAM(3) specifies the maximum number of Arnoldi |
c     | iterations allowed.  Mode 2 of ZNAUPD  is used     |
c     | (IPARAM(7) = 2).  All these options can be        |
c     | changed by the user. For details, see the         |
c     | documentation in ZNAUPD .                          |
c     %---------------------------------------------------%
c
      ishfts = 1
      maxitr = 300
      mode   = 2
c
      iparam(1) = ishfts
      iparam(3) = maxitr
      iparam(7) = mode
c
c     %-------------------------------------------%
c     | M A I N   L O O P (Reverse communication) |
c     %-------------------------------------------%
c
 10   continue
c
c        %---------------------------------------------%
c        | Repeatedly call the routine ZNAUPD  and take |
c        | actions indicated by parameter IDO until    |
c        | either convergence is indicated or maxitr   |
c        | has been exceeded.                          |
c        %---------------------------------------------%
c
         call znaupd  ( ido, bmat, n, which, nev, tol, resid, ncv,
     &        v, ldv, iparam, ipntr, workd, workl, lworkl,
     &        rwork, info )
c
         if (ido .eq. -1 .or. ido .eq. 1) then
c
c           %----------------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x      |
c           | The user should supply his/her own     |
c           | matrix vector routine and a linear     |
c           | system solver.  The matrix-vector      |
c           | subroutine should take workd(ipntr(1)) |
c           | as input, and the final result should  |
c           | be returned to workd(ipntr(2)).        |
c           %----------------------------------------%
c
            call av (n, workd(ipntr(1)), workd(ipntr(2)))
            call zgttrs ('N', n, 1, dl, dd, du, du2, ipiv,
     &                  workd(ipntr(2)), n, ierr)
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' ERROR with _gttrs. '
               print*, ' '
               go to 9000
            end if
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call ZNAUPD  again. |
c           %-----------------------------------------%
c
            go to 10
c
         else if ( ido .eq. 2) then
c
c           %-------------------------------------%
c           |        Perform  y <--- M*x          |
c           | The matrix vector multiplication    |
c           | routine should take workd(ipntr(1)) |
c           | as input and return the result to   |
c           | workd(ipntr(2)).                    |
c           %-------------------------------------%
c
            call mv (n, workd(ipntr(1)), workd(ipntr(2)))
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call ZNAUPD  again. |
c           %-----------------------------------------%
c
            go to 10
c
         end if
c
c     %-----------------------------------------%
c     | Either we have convergence, or there is |
c     | an error.                               |
c     %-----------------------------------------%
c
      if ( info .lt. 0 ) then
c
c        %--------------------------%
c        | Error message. Check the |
c        | documentation in ZNAUPD . |
c        %--------------------------%
c
         print *, ' '
         print *, ' Error with _naupd, info = ',info
         print *, ' Check the documentation of _naupd.'
         print *, ' '
c
      else
c
c        %-------------------------------------------%
c        | No fatal errors occurred.                 |
c        | Post-Process using ZNEUPD .                |
c        |                                           |
c        | Computed eigenvalues may be extracted.    |
c        |                                           |
c        | Eigenvectors may also be computed now if  |
c        | desired.  (indicated by rvec = .true.)    |
c        %-------------------------------------------%
c
         rvec = .true.
c
         call zneupd  ( rvec, 'A', select, d, v, ldv, sigma,
     &        workev, bmat, n, which, nev, tol, resid, ncv, v,
     &        ldv, iparam, ipntr, workd, workl, lworkl, rwork,
     &        ierr )
c
c        %----------------------------------------------%
c        | Eigenvalues are returned in the one          |
c        | dimensional array D.  The corresponding      |
c        | eigenvectors are returned in the first NCONV |
c        | (=IPARAM(5)) columns of the two dimensional  |
c        | array V if requested.  Otherwise, an         |
c        | orthogonal basis for the invariant subspace  |
c        | corresponding to the eigenvalues in D is     |
c        | returned in V.                               |
c        %----------------------------------------------%
c
         if ( ierr .ne. 0 ) then
c
c           %------------------------------------%
c           | Error condition:                   |
c           | Check the documentation of ZNEUPD . |
c           %------------------------------------%
c
            print *, ' '
            print *, ' Error with _neupd, info = ', ierr
            print *, ' Check the documentation of _neupd'
            print *, ' '
c
         else
c
            nconv = iparam(5)
            do 80 j=1, nconv
c
c              %---------------------------%
c              | Compute the residual norm |
c              |                           |
c              |  ||  A*x - lambda*M*x ||  |
c              |                           |
c              | for the NCONV accurately  |
c              | computed eigenvalues and  |
c              | eigenvectors.  (iparam(5) |
c              | indicates how many are    |
c              | accurate to the requested |
c              | tolerance)                |
c              %---------------------------%
c
               call av(n, v(1,j), ax)
               call mv(n, v(1,j), mx)
               call zaxpy (n, -d(j), mx, 1, ax, 1)
               rd(j,1) = dble (d(j))
               rd(j,2) = dimag (d(j))
               rd(j,3) = dznrm2 (n, ax, 1)
               rd(j,3) = rd(j,3) / dlapy2 (rd(j,1),rd(j,2))
  80        continue
c
c           %-----------------------------%
c           | Display computed residuals. |
c           %-----------------------------%
c
            call dmout (6, nconv, 3, rd, maxncv, -6,
     &           'Ritz values (Real, Imag) and relative residuals')
c
         end if
c
c        %------------------------------------------%
c        | Print additional convergence information |
c        %------------------------------------------%
c
         if ( info .eq. 1) then
            print *, ' '
            print *, ' Maximum number of iterations reached.'
            print *, ' '
         else if ( info .eq. 3) then
            print *, ' '
            print *, ' No shifts could be applied during implicit',
     &               ' Arnoldi update, try increasing NCV.'
            print *, ' '
         end if
c
         print *, ' '
         print *, '_NDRV3 '
         print *, '====== '
         print *, ' '
         print *, ' Size of the matrix is ', n
         print *, ' The number of Ritz values requested is ', nev
         print *, ' The number of Arnoldi vectors generated ',
     &            ' (NCV) is ', ncv
         print *, ' What portion of the spectrum: ', which
         print *, ' The number of converged Ritz values is ',
     &              nconv
         print *, ' The number of Implicit Arnoldi update',
     &            ' iterations taken is ', iparam(3)
         print *, ' The number of OP*x is ', iparam(9)
         print *, ' The convergence criterion is ', tol
         print *, ' '
c
      end if
c
 9000 continue
c
      end
c
c==========================================================================
c
c     matrix vector multiplication subroutine
c
      subroutine av (n, v, w)
      integer           n, j
      Complex*16
     &                  v(n), w(n), one, two, dd, dl, du, s, h, rho
      parameter         (one = (1.0D+0, 0.0D+0) ,
     &                   two = (2.0D+0, 0.0D+0) ,
     &                   rho = (1.0D+1, 0.0D+0) )
c
c     Compute the matrix vector multiplication y<---A*x
c     where A is the stiffness matrix formed by using piecewise linear
c     elements on [0,1].
c
      h = one / dcmplx (n+1)
      s = rho / two
      dd = two / h
      dl = -one/h - s
      du = -one/h + s
c
      w(1) =  dd*v(1) + du*v(2)
      do 10 j = 2,n-1
         w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1)
 10   continue
      w(n) =  dl*v(n-1) + dd*v(n)
      return
      end
c------------------------------------------------------------------------
      subroutine mv (n, v, w)
      integer           n, j
      Complex*16
     &                  v(n), w(n), one, four, h
      parameter         (one = (1.0D+0, 0.0D+0) ,
     &                   four = (4.0D+0, 0.0D+0) )
c
c     Compute the matrix vector multiplication y<---M*x
c     where M is the mass matrix formed by using piecewise linear elements
c     on [0,1].
c
      w(1) =  four*v(1) + one*v(2)
      do 10 j = 2,n-1
         w(j) = one*v(j-1) + four*v(j) + one*v(j+1)
 10   continue
      w(n) =  one*v(n-1) + four*v(n)
c
      h = one / dcmplx (n+1)
      call zscal (n, h, w, 1)
      return
      end


C---------------------------------------------------
      DOUBLE PRECISION FUNCTION ALNORM(X,UPPER)
      DOUBLE PRECISION X
      LOGICAL UPPER
C
C   ALGORITHM AS 66 BY I.D. HILL
C
      LOGICAL UP
      DOUBLE PRECISION Y, Z

      DOUBLE PRECISION CON, HALF, LTONE, ONE, UTZERO, ZERO
      PARAMETER (CON=1.28D0, HALF=0.5D0, LTONE=5.D0, ONE=1.D0,
     1           UTZERO=12.5D0, ZERO=0.D0)

      UP=UPPER
      Z=X
      IF(Z.GE.ZERO) GO TO 10
      UP=.NOT.UP
      Z=-Z
 10   IF(Z .LE. LTONE .OR. UP .AND. Z .LE. UTZERO) GO TO 20
      ALNORM = ZERO
      GO TO 40
 20   Y=HALF*Z*Z
      IF(Z.GT.CON) GO TO 30
      ALNORM = HALF - Z * (0.398942280444D0 - 0.399903438504D0*Y/
     1             (Y + 5.75885480458D0 - 29.8213557808D0/
     2             (Y + 2.62433121679D0 + 48.6959930692D0/
     3             (Y + 5.92885724438D0))))
      GO TO 40
 30   ALNORM = 0.398942280385D0 * EXP(-Y)/
     1             (Z - 3.8052D-8 + 1.00000615302D0/
     2             (Z + 3.98064794D-4 + 1.98615381364D0/
     3             (Z - 0.151679116635D0 + 5.29330324926D0/
     4             (Z + 4.8385912808D0 - 15.1508972451D0/
     5             (Z + 0.742380924027D0 + 30.789933034D0/
     6             (Z + 3.99019417011D0))))))
 40   IF(.NOT.UP) ALNORM = ONE - ALNORM
      END