*
*
      SUBROUTINE PSSQPSUBTST( WKNOWN, JOBZ, UPLO, N, THRESH, ABSTOL, A,
     $                        COPYA, Z, IA, JA, DESCA, WIN, WNEW,
     $                        IPREPAD, IPOSTPAD, WORK, LWORK, LWORK1,
     $                        RESULT, TSTNRM, QTQNRM, NOUT )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     November 15, 1997
*
*     .. Scalar Arguments ..
      LOGICAL            WKNOWN
      CHARACTER          JOBZ, UPLO
      INTEGER            IA, IPOSTPAD, IPREPAD, JA, LWORK, LWORK1, N,
     $                   NOUT, RESULT
      REAL               ABSTOL, QTQNRM, THRESH, TSTNRM
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      REAL               A( * ), COPYA( * ), WIN( * ), WNEW( * ),
     $                   WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  PSSQPSUBTST calls PSSYEV and then tests the output of
*  PSSYEV
*  If JOBZ = 'V' then the following two tests are performed:
*     |AQ -QL| / (abstol + eps * norm(A) ) < N*THRESH
*     |QT * Q - I| / eps * norm(A) < N*THRESH
*  If WKNOWN then
*     we check to make sure that the eigenvalues match expectations
*     i.e. |WIN - WNEW(1+IPREPAD)| / (eps * |WIN|) < THRESH
*     where WIN is the array of eigenvalues as computed by
*     PSSYEV when eigenvectors are requested
*
*  Arguments
*  =========
*
*     NP = the number of rows local to a given process.
*     NQ = the number of columns local to a given process.
*
*  WKNOWN  (global input) INTEGER
*          .FALSE.:  WIN does not contain the eigenvalues
*          .TRUE.:   WIN does contain the eigenvalues
*
*  JOBZ    (global input) CHARACTER*1
*          Specifies whether or not to compute the eigenvectors:
*          = 'N':  Compute eigenvalues only.
*          = 'V':  Compute eigenvalues and eigenvectors.
*          Must be 'V' on first call to PSSQPSUBTST
*
*  UPLO    (global input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          symmetric matrix A is stored:
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (global input) INTEGER
*          Size of the matrix to be tested.  (global size)
*
*  THRESH  (global input) REAL
*          A test will count as "failed" if the "error", computed as
*          described below, exceeds THRESH.  Note that the error
*          is scaled to be O(1), so THRESH should be a reasonably
*          small multiple of 1, e.g., 10 or 100.  In particular,
*          it should not depend on the precision (single vs. double)
*          or the size of the matrix.  It must be at least zero.
*
*  ABSTOL  (global input) REAL
*          The absolute tolerance for the eigenvalues. An
*          eigenvalue is considered to be located if it has
*          been determined to lie in an interval whose width
*          is "abstol" or less. If "abstol" is less than or equal
*          to zero, then ulp*|T| will be used, where |T| is
*          the 1-norm of the matrix.
*
*  A       (local workspace) REAL array
*          global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
*          A is distributed in a block cyclic manner over both rows
*          and columns.
*          See PSSYEV for a description of block cyclic layout.
*          The test matrix, which is then modified by PSSYEV
*          A has already been padded front and back, use A(1+IPREPAD)
*
*  COPYA   (local input) REAL array, dimension(N*N)
*          COPYA holds a copy of the original matrix A
*          identical in both form and content to A
*
*  Z       (local workspace) REAL array, dim (N*N)
*          Z is distributed in the same manner as A
*          Z contains the eigenvector matrix
*          Z is used as workspace by the test routines
*          PSSEPCHK and PSSEPQTQ.
*          Z has already been padded front and back, use Z(1+IPREPAD)
*
*  IA      (global input) INTEGER
*          On entry, IA specifies the global row index of the submatrix
*          of the global matrix A, COPYA and Z to operate on.
*
*  JA      (global input) INTEGER
*          On entry, IA specifies the global column index of the submat
*          of the global matrix A, COPYA and Z to operate on.
*
*  DESCA   (global/local input) INTEGER array of dimension 8
*          The array descriptor for the matrix A, COPYA and Z.
*
*  WIN     (global input) REAL array, dimension (N)
*          If .not. WKNOWN, WIN is ignored on input
*          Otherwise, WIN() is taken as the standard by which the
*          eigenvalues are to be compared against.
*
*  WNEW    (global workspace) REAL array, dimension (N)
*          The eigenvalues as computed by this call to PSSYEV.
*          WNEW has already been padded front and back,
*          use WNEW(1+IPREPAD)
*
*  WORK    (local workspace) REAL array, dimension (LWORK)
*          WORK has already been padded front and back,
*          use WORK(1+IPREPAD)
*
*  LWORK   (local input) INTEGER
*          The actual length of the array WORK after padding.
*
*
*  LWORK1  (local input) INTEGER
*          The amount of real workspace to pass to PSSYEV
*
*  RESULT  (global output) INTEGER
*          The result of this call to PSSYEV
*          RESULT = -3   =>  This process did not participate
*          RESULT = 0    =>  All tests passed
*          RESULT = 1    =>  ONe or more tests failed
*
*  TSTNRM  (global output) REAL
*          |AQ- QL| / (ABSTOL+EPS*|A|)*N
*
*  QTQNRM  (global output) REAL
*          |QTQ -I| / N*EPS
*
*     .. Parameters ..
*
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DT_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DT_ = 1,
     $                   CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                   RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      REAL               FIVE, NEGONE, PADVAL, ZERO
      PARAMETER          ( PADVAL = 13.5285E+0, FIVE = 5.0E+0,
     $                   NEGONE = -1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IAM, INFO, ISIZESUBTST, ISIZESYEVX,
     $                   ISIZETST, J, EIGS, MINSIZE, MQ, MYCOL, MYROW,
     $                   NP, NPCOL, NPROW, NQ, RESAQ, RESQTQ,
     $                   SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
     $                   SIZEQTQ, SIZESUBTST, SIZESYEV, SIZESYEVX,
     $                   SIZETMS, SIZETST, SIZESYEVD, ISIZESYEVD
      REAL               EPS, EPSNORMA, ERROR, MAXERROR, MINERROR,
     $                   NORMWIN, SAFMIN
*     ..
*     .. Local Arrays ..
      INTEGER            DESCZ( DLEN_ ), ITMP( 2 ),
     $                   IWORK( 2 )
*     ..
*     .. External Functions ..
*
      LOGICAL            LSAME
      INTEGER            NUMROC
      REAL               PSLAMCH, PSLANSY
      EXTERNAL           LSAME, NUMROC, PSLAMCH, PSLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DESCINIT, IGAMN2D, IGAMX2D,
     $                   PSCHEKPAD, PSELSET, PSFILLPAD, PSLASIZESQP,
     $                   PSSEPCHK, PSSEPQTQ, PSSYEV, SGAMN2D, SGAMX2D,
     $                   SLACPY, SLBOOT, SLTIMER
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, MOD
*     ..
*     .. Executable Statements ..
*       This is just to keep ftnchek happy
      IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DT_*LLD_*MB_*M_*NB_*N_*
     $    RSRC_.LT.0 )RETURN
      CALL PSLASIZESQP( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
     $                  SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
     $                  SIZECHK, SIZESYEVX, ISIZESYEVX, SIZESYEV,
     $                  SIZESYEVD, ISIZESYEVD, SIZESUBTST, ISIZESUBTST,
     $                  SIZETST, ISIZETST )
*
      TSTNRM = NEGONE
      QTQNRM = NEGONE
      EPS = PSLAMCH( DESCA( CTXT_ ), 'Eps' )
      SAFMIN = PSLAMCH( DESCA( CTXT_ ), 'Safe min' )
*
      NORMWIN = SAFMIN / EPS
      IF( N.GE.1 )
     $   NORMWIN = MAX( ABS( WIN( 1+IPREPAD ) ),
     $                  ABS( WIN( N+IPREPAD ) ), NORMWIN )
*
*     Make sure that we aren't using information from previous calls
*
      DO 10 I = 1, LWORK1, 1
         WORK( I+IPREPAD ) = 14.3E+0
   10 CONTINUE
*
      DO 30 I = 1, N
         WNEW( I+IPREPAD ) = 3.14159E+0
   30 CONTINUE
*
      DO 40 I = 1, 2
         IWORK( I ) = 0
   40 CONTINUE
*
      IF( LSAME( JOBZ, 'N' ) ) THEN
         EIGS = 0
      ELSE
         EIGS = N
      END IF
*
*
      CALL DESCINIT( DESCZ, DESCA( M_ ), DESCA( N_ ), DESCA( MB_ ),
     $               DESCA( NB_ ), DESCA( RSRC_ ), DESCA( CSRC_ ),
     $               DESCA( CTXT_ ), DESCA( LLD_ ), INFO )
*
      CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
      IAM = 1
      IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $   IAM = 0
*
*     If this process is not involved in this test, bail out now
*
      RESULT = -3
      IF( MYROW.GE.NPROW .OR. MYROW.LT.0 )
     $   GO TO 150
      RESULT = 0
*
      NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
      NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
      MQ = NUMROC( EIGS, DESCA( NB_ ), MYCOL, 0, NPCOL )
*
*     Find the amount of workspace needed with or without eigenvectors.
*
      CALL PSLASIZESYEV( JOBZ, N, DESCA, MINSIZE )
*
      CALL SLACPY( 'A', NP, NQ, COPYA, DESCA( LLD_ ), A( 1+IPREPAD ),
     $             DESCA( LLD_ ) )
*
      CALL PSFILLPAD( DESCA( CTXT_ ), NP, NQ, A, DESCA( LLD_ ), IPREPAD,
     $                IPOSTPAD, PADVAL )
*
      CALL PSFILLPAD( DESCZ( CTXT_ ), NP, MQ, Z, DESCZ( LLD_ ), IPREPAD,
     $                IPOSTPAD, PADVAL+1.0E+0 )
*
      CALL PSFILLPAD( DESCA( CTXT_ ), N, 1, WNEW, N, IPREPAD, IPOSTPAD,
     $                PADVAL+2.0E+0 )
*
      CALL PSFILLPAD( DESCA( CTXT_ ), LWORK1, 1, WORK, LWORK1, IPREPAD,
     $                IPOSTPAD, PADVAL+4.0E+0 )
*
*     Make sure that PSSYEV does not cheat (i.e. use answers
*     already computed.)
*
      DO 60 I = 1, N, 1
         DO 50 J = 1, EIGS, 1
            CALL PSELSET( Z( 1+IPREPAD ), I, J, DESCA, 13.0E+0 )
   50    CONTINUE
   60 CONTINUE
*
      CALL SLBOOT
      CALL SLTIMER( 1 )
      CALL SLTIMER( 6 )
      CALL PSSYEV( JOBZ, UPLO, N, A( 1+IPREPAD ), IA, JA, DESCA,
     $             WNEW( 1+IPREPAD ), Z( 1+IPREPAD ), IA, JA, DESCA,
     $             WORK( 1+IPREPAD ), LWORK1, INFO )
      CALL SLTIMER( 6 )
      CALL SLTIMER( 1 )
*
      IF( THRESH.LE.0 ) THEN
         RESULT = 0
      ELSE
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSYEV-A', NP, NQ, A,
     $                   DESCA( LLD_ ), IPREPAD, IPOSTPAD, PADVAL )
*
         CALL PSCHEKPAD( DESCZ( CTXT_ ), 'PSSYEV-Z', NP, MQ, Z,
     $                   DESCZ( LLD_ ), IPREPAD, IPOSTPAD,
     $                   PADVAL+1.0E+0 )
*
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSYEV-WNEW', N, 1, WNEW, N,
     $                   IPREPAD, IPOSTPAD, PADVAL+2.0E+0 )
*
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSYEV-WORK', LWORK1, 1,
     $                   WORK, LWORK1, IPREPAD, IPOSTPAD,
     $                   PADVAL+4.0E+0 )
*
*     Check INFO
*
*
*     Make sure that all processes return the same value of INFO
*
         ITMP( 1 ) = INFO
         ITMP( 2 ) = INFO
*
         CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
     $                 -1, -1, 0 )
         CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1, 1,
     $                 1, -1, -1, 0 )
*
*
         IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = * )
     $         'Different processes return different INFO'
            RESULT = 1
         ELSE IF( INFO.NE.0 ) THEN
            IF( IAM.EQ.0 ) THEN
               WRITE( NOUT, FMT = 9999 )INFO
               IF( INFO.EQ.(N+1) )
     $            WRITE( NOUT, FMT = 9994 )
               RESULT = 1
            END IF
         ELSE IF( INFO.EQ.14 .AND. LWORK1.GE.MINSIZE ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9996 )INFO
            RESULT = 1
         END IF
*
         IF( RESULT.EQ.0 .OR. INFO.GT.N ) THEN
*
*     Make sure that different processes return the same eigenvalues.
*     This is a more exhaustive check that provided by PSSYEV.
*
            DO 70 I = 1, N
               WORK( I ) = WNEW( I+IPREPAD )
               WORK( I+N ) = WNEW( I+IPREPAD )
 70         CONTINUE
*
            CALL SGAMN2D( DESCA( CTXT_ ), 'a', ' ', N, 1, WORK, N, 1,
     $                    1, -1, -1, 0 )
            CALL SGAMX2D( DESCA( CTXT_ ), 'a', ' ', N, 1,
     $                    WORK( 1+N ), N, 1, 1, -1, -1, 0 )
*
            DO 80 I = 1, N
*
               IF( ABS( WORK( I )-WORK( N+I ) ).GT.ZERO ) THEN
                  IF( IAM.EQ.0 )
     $                 WRITE( NOUT, FMT = 9995 )
                  RESULT = 1
                  GO TO 90
               END IF
 80         CONTINUE
 90         CONTINUE
         END IF
*
         CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1,
     $                 -1, -1, 0 )
*
*     Compute eps * norm(A)
*
         IF( N.EQ.0 ) THEN
            EPSNORMA = EPS
         ELSE
            EPSNORMA = PSLANSY( 'I', UPLO, N, COPYA, IA, JA, DESCA,
     $                 WORK )*EPS
         END IF
*
*     Note that a couple key variables get redefined in PSSEPCHK
*     as described by this table:
*
*     PSSEPTST name         PSSEPCHK name
*     -------------         -------------
*     COPYA                 A
*     Z                     Q
*     A                     C
*
*
         IF( LSAME( JOBZ, 'V' ) ) THEN
*
*     Perform the |AQ - QE| test
*
            CALL PSFILLPAD( DESCA( CTXT_ ), SIZECHK, 1, WORK, SIZECHK,
     $                      IPREPAD, IPOSTPAD, 4.3E+0 )
*
            RESAQ = 0
*
            CALL PSSEPCHK( N, N, COPYA, IA, JA, DESCA,
     $                     MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
     $                     Z( 1+IPREPAD ), IA, JA, DESCZ,
     $                     A( 1+IPREPAD ), IA, JA, DESCA,
     $                     WNEW( 1+IPREPAD ), WORK( 1+IPREPAD ),
     $                     SIZECHK, TSTNRM, RESAQ )
*
            CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSEPCHK-WORK', SIZECHK, 1,
     $                      WORK, SIZECHK, IPREPAD, IPOSTPAD, 4.3E+0 )
*
            IF( RESAQ.NE.0 ) THEN
               RESULT = 1
               WRITE( NOUT, FMT = 9993 )
            END IF
*
*     Perform the |QTQ - I| test
*
            CALL PSFILLPAD( DESCA( CTXT_ ), SIZEQTQ, 1, WORK, SIZEQTQ,
     $                      IPREPAD, IPOSTPAD, 4.3E+0 )
*
            RESQTQ = 0
*
            CALL PSSEPQTQ( N, N, THRESH, Z( 1+IPREPAD ), IA, JA, DESCZ,
     $                     A( 1+IPREPAD ), IA, JA, DESCA,
     $                     IWORK( 1 ), IWORK( 1 ), WORK( 1 ),
     $                     WORK( IPREPAD+1 ), SIZEQTQ, QTQNRM, INFO,
     $                     RESQTQ )
*
            CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSEPQTQ-WORK', SIZEQTQ, 1,
     $                      WORK, SIZEQTQ, IPREPAD, IPOSTPAD, 4.3E+0 )
*
            IF( RESQTQ.NE.0 ) THEN
               RESULT = 1
               WRITE( NOUT, FMT = 9992 )
            END IF
*
            IF( INFO.NE.0 ) THEN
               IF( IAM.EQ.0 )
     $              WRITE( NOUT, FMT = 9998 )INFO
               RESULT = 1
            END IF
         END IF
*
*     Check to make sure that we have the right eigenvalues
*
         IF( WKNOWN .AND. N.GT.0 ) THEN
*
*     Find the largest difference between the computed
*     and expected eigenvalues
*
            MINERROR = NORMWIN
            MAXERROR = 0
*
            DO 140 I = 1, N
               ERROR = ABS( WIN( I+IPREPAD )-WNEW( I+IPREPAD ) )
               MAXERROR = MAX( MAXERROR, ERROR )
 140        CONTINUE
            MINERROR = MIN( MAXERROR, MINERROR )
*
            IF( MINERROR.GT.NORMWIN*FIVE*THRESH*EPS ) THEN
               IF( IAM.EQ.0 )
     $              WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
               RESULT = 1
            END IF
         END IF
      END IF
*
*     All processes should report the same result
*
      CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1, -1,
     $              -1, 0 )
*
  150 CONTINUE
*
*
      RETURN
*
 9999 FORMAT( 'PSSYEV returned INFO=', I7 )
 9998 FORMAT( 'PSSEPQTQ in PSSQPSUBTST returned INFO=', I7 )
 9997 FORMAT( 'PSSQPSUBTST minerror =', D11.2, ' normwin=', D11.2 )
 9996 FORMAT( 'PSSYEV returned INFO=', I7,
     $      ' despite adequate workspace' )
 9995 FORMAT( 'Different processes return different eigenvalues' )
 9994 FORMAT( 'Heterogeneity detected by PSSYEV' )
 9993 FORMAT( 'PSSYEV failed the |AQ -QE| test' )
 9992 FORMAT( 'PSSYEV failed the |QTQ -I| test' )
*
*     End of PSSQPSUBTST
*
      END


program grid_testdriver

use phys_consts, only: wp
use meshobj_dipole, only : dipolemesh

implicit none (type, external)

integer, parameter :: lq=1024,lp=1024, lphi = 8
real(wp) :: q(lq), p(lp), phi(lphi)
real(wp), dimension(2) :: qlims=[-0.5851937,0.5851937], plims=[1.2053761,1.5820779], philim=[-6, 6]

real(wp), dimension(:,:), allocatable :: r,theta,qtest,ptest,errq,errp
real(wp) :: maxerrq,maxerrp
integer :: iq,ip,irepeat, i
type(dipolemesh) :: x     ! dummy object to allow us to access methods for coodinate conversion

allocate(r(lq,lp))
allocate(theta,qtest,ptest,errq,errp, mold=r)

! define a grid
q=[(qlims(1) + (qlims(2)-qlims(1))/lq*(i-1), i=1,lq)]
p=[(plims(1) + (plims(2)-plims(1))/lp*(i-1), i=1,lp)]
phi = [(philim(1) + (philim(2)-philim(1))/lphi*(i-1), i=1,lphi)]

! initialize object so we can call its type-bound procedures
call x%set_coords(q,p,phi,p,phi)
call x%init()

! test the conversion of a set of grid points
do irepeat=1,3    ! do mulitple times as would be require for a full grid generation (to compare times against scripts)
  call x%calc_rtheta_2D(q,p,r,theta)
end do

! now convert back to dipole coords so we can check
call x%calc_qp_2D(r,theta,qtest,ptest)

! now compute errors for each conversion that has been done
do iq=1,lq
  do ip=1,lp
    errq(iq,ip)=qtest(iq,ip)-q(iq)
    errp(iq,ip)=ptest(iq,ip)-p(ip)
  end do
end do

! provide some indication to the call program as to whether this test passed or not
maxerrq=maxval(abs(errq))
maxerrp=maxval(abs(errp))
print*, ' Test system size:  ',lq,lp
print*, ' Maximum error in computed q and p:  ',maxerrq,maxerrp
if (maxerrq>1e-6_wp .or. maxerrp>1e-6_wp) error stop ' Excessive error in coordinate conversion!'

end program grid_testdriver


      DOUBLE PRECISION FUNCTION DL7SVX(P, L, X, Y)
C
C  ***  ESTIMATE LARGEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER P
      DOUBLE PRECISION L(1), X(P), Y(P)
C     DIMENSION L(P*(P+1)/2)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C     THIS FUNCTION RETURNS A GOOD UNDER-ESTIMATE OF THE LARGEST
C     SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
C
C  ***  PARAMETER DESCRIPTION  ***
C
C  P (IN)  = THE ORDER OF L.  L IS A  P X P  LOWER TRIANGULAR MATRIX.
C  L (IN)  = ARRAY HOLDING THE ELEMENTS OF  L  IN ROW ORDER, I.E.
C             L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
C  X (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN X = (L**T)*Y IS AN
C             (UNNORMALIZED) APPROXIMATE RIGHT SINGULAR VECTOR
C             CORRESPONDING TO THE LARGEST SINGULAR VALUE.  THIS
C             APPROXIMATION MAY BE CRUDE.
C  Y (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN Y = L*X IS A
C             NORMALIZED APPROXIMATE LEFT SINGULAR VECTOR CORRESPOND-
C             ING TO THE LARGEST SINGULAR VALUE.  THIS APPROXIMATION
C             MAY BE VERY CRUDE.  THE CALLER MAY PASS THE SAME VECTOR
C             FOR X AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE X
C             OVER-WRITES Y.
C
C  ***  ALGORITHM NOTES  ***
C
C     THE ALGORITHM IS BASED ON ANALOGY WITH (1).  IT USES A
C     RANDOM NUMBER GENERATOR PROPOSED IN (4), WHICH PASSES THE
C     SPECTRAL TEST WITH FLYING COLORS -- SEE (2) AND (3).
C
C  ***  SUBROUTINES AND FUNCTIONS CALLED  ***
C
C        DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C     (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
C         AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
C         TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
C
C     (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
C         RANDOM-NUMBER GENERATORS --  AN EMPIRICAL VIEW,
C         MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
C
C     (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
C         (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
C
C     (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
C         GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
C         PP. 586-593.
C
C  ***  HISTORY  ***
C
C     DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
C
C  ***  GENERAL  ***
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IX, J, JI, JJ, JJJ, JM1, J0, PM1, PPLUS1
      DOUBLE PRECISION B, BLJI, SMINUS, SPLUS, T, YI
C
C  ***  CONSTANTS  ***
C
      DOUBLE PRECISION HALF, ONE, R9973, ZERO
C
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      DOUBLE PRECISION DD7TPR, DV2NRM
      EXTERNAL DD7TPR, DV2NRM,DV2AXY
C
      PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0)
C
C  ***  BODY  ***
C
      IX = 2
      PPLUS1 = P + 1
      PM1 = P - 1
C
C  ***  FIRST INITIALIZE X TO PARTIAL SUMS  ***
C
      J0 = P*PM1/2
      JJ = J0 + P
      IX = MOD(3432*IX, 9973)
      B = HALF*(ONE + FLOAT(IX)/R9973)
      X(P) = B * L(JJ)
      IF (P .LE. 1) GO TO 40
      DO 10 I = 1, PM1
         JI = J0 + I
         X(I) = B * L(JI)
 10      CONTINUE
C
C  ***  COMPUTE X = (L**T)*B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
C  ***  CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
C
C     DO J = P-1 TO 1 BY -1...
      DO 30 JJJ = 1, PM1
         J = P - JJJ
C       ***  DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
C       ***  THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
         IX = MOD(3432*IX, 9973)
         B = HALF*(ONE + FLOAT(IX)/R9973)
         JM1 = J - 1
         J0 = J*JM1/2
         SPLUS = ZERO
         SMINUS = ZERO
         DO 20 I = 1, J
              JI = J0 + I
              BLJI = B * L(JI)
              SPLUS = SPLUS +  ABS(BLJI + X(I))
              SMINUS = SMINUS +  ABS(BLJI - X(I))
 20           CONTINUE
         IF (SMINUS .GT. SPLUS) B = -B
         X(J) = ZERO
C        ***  UPDATE PARTIAL SUMS  ***
         CALL DV2AXY(J, X, B, L(J0+1), X)
 30      CONTINUE
C
C  ***  NORMALIZE X  ***
C
 40   T = DV2NRM(P, X)
      IF (T .LE. ZERO) GO TO 80
      T = ONE / T
      DO 50 I = 1, P
 50      X(I) = T*X(I)
C
C  ***  COMPUTE L*X = Y AND RETURN SVMAX = TWONORM(Y)  ***
C
      DO 60 JJJ = 1, P
         J = PPLUS1 - JJJ
         JI = J*(J-1)/2 + 1
         Y(J) = DD7TPR(J, L(JI), X)
 60      CONTINUE
C
C  ***  NORMALIZE Y AND SET X = (L**T)*Y  ***
C
      T = ONE / DV2NRM(P, Y)
      JI = 1
      DO 70 I = 1, P
         YI = T * Y(I)
         X(I) = ZERO
         CALL DV2AXY(I, X, YI, L(JI), X)
         JI = JI + I
 70      CONTINUE
      DL7SVX = DV2NRM(P, X)
      GO TO 999
C
 80   DL7SVX = ZERO
C
 999  RETURN
C  ***  LAST LINE OF DL7SVX FOLLOWS  ***
      END


!-----subroutine---------------------------------------------g.guidati--
!
subroutine DEFGEO
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             read airfoil and mesh coordinates
!
!.......................................................................
!               declarations
!.......................................................................
      USE TINoiseGeneric
      USE TINoiseInput
      USE TINoiseGeo
      USE TIPrecision
      USE TICoords

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: klo,khi,i
REAL(DbKi)                   :: n1,n2,nozzw,y1dum,y2dum,scp,d1y1,d1y2
REAL(DbKi)                   :: y1in(m_in),y2in(m_in),ssin(m_in),y1,y2
REAL(DbKi)                   :: d2y1in(m_in),d2y2in(m_in),y1wh,y2wh,ddss

!.......................................................................
!     Spline input coordinates
!.......................................................................

!-----read coordinates

      y1in = x_ti
      y2in = y_ti

!-----rotate coordinates
      do i=1,n_in
        y1dum =   (y1in(i)-0.25d0)*cos(alfa)+y2in(i)*sin(alfa) + 0.25d0
        y2dum = - (y1in(i)-0.25d0)*sin(alfa)+y2in(i)*cos(alfa)
	y1in(i) = y1dum
	y2in(i) = y2dum
        ssin(i) = dble(i-1)
      enddo

      call SPL_P (ssin, y1in, n_in, d2y1in)
      call SPL_P (ssin, y2in, n_in, d2y2in)

!.......................................................................
!     Re-panel the airfoil contour for flow
!.......................................................................
      do i=1, n+1
        swork(i) = dble(i-1)
      enddo

      do i=1, n
        ds(i) = swork(i+1) - swork(i)
      enddo

      do i=1,n+1

	scp = swork(i) * ssin(n_in) / swork(n+1)
	call SPL_EX  (ssin,n_in,scp,khi,klo)
	call SPL_EX1 (ssin,y1in,d2y1in,n_in,scp,yc1(i),d1y1,khi,klo)
	call SPL_EX1 (ssin,y2in,d2y2in,n_in,scp,yc2(i),d1y2,khi,klo)

        nc1(i) =  d1y2 / sqrt(d1y1**2+d1y2**2)
        nc2(i) = -d1y1 / sqrt(d1y1**2+d1y2**2)
        tc1(i) =  d1y1 / sqrt(d1y1**2+d1y2**2)
        tc2(i) =  d1y2 / sqrt(d1y1**2+d1y2**2)
!        write(20,*) real(yc1(i)),real(yc2(i)),real(nc1(i)),real(nc2(i))
      enddo

      call SPL_P (swork, yc1, n+1, d2yc1)
      call SPL_P (swork, yc2, n+1, d2yc2)

!      close(20)

!.......................................................................
!     Determine wake point at 'infinity'
!.......................................................................

      y1wh = 0.5d0 * (yc1(2) + yc1(n))
      y2wh = 0.5d0 * (yc2(2) + yc2(n))

      ddss = sqrt((yc1(1)-y1wh)**2+(yc2(1)-y2wh)**2)
      ywinf1 = yc1(1) + (yc1(1) - y1wh) /ddss * 100.
      ywinf2 = yc2(1) + (yc2(1) - y2wh) /ddss * 100.

      ywn1 =  (yc2(1)-y2wh)/ddss
      ywn2 = -(yc1(1)-y1wh)/ddss

!.......................................................................
!     Re-panel the airfoil contour for acoustics
!.......................................................................

      do i=1, na+1
	sworkat(i) = dble(i-1)
      enddo

      do i=1,na+1
        scp = sworkat(i) * dble(n) / dble(na)
        call SPL_EX  (swork,n+1,scp,khi,klo)
        call SPL_EX1 (swork,yc1,d2yc1,n+1,scp,y1,d1y1,khi,klo)
        call SPL_EX1 (swork,yc2,d2yc2,n+1,scp,y2,d1y2,khi,klo)
        yc1at(i) =  y1
        yc2at(i) =  y2
      enddo

      call SPL_PP (sworkat, yc1at, na+1, 1.0d33,1.0d33,d2yc1at)
      call SPL_PP (sworkat, yc2at, na+1, 1.0d33,1.0d33,d2yc2at)

      do i=1,na+1
        scp = sworkat(i) * dble(n) / dble(na)
        call SPL_EX  (sworkat,na+1,scp,khi,klo)
        call SPL_EX1 (sworkat,yc1at,d2yc1at,na+1,scp,y1,d1y1,khi,klo)
        call SPL_EX1 (sworkat,yc2at,d2yc2at,na+1,scp,y2,d1y2,khi,klo)
        nc1at(i) =  d1y2 / sqrt(d1y1**2+d1y2**2)
        nc2at(i) = -d1y1 / sqrt(d1y1**2+d1y2**2)
        tc1at(i) = d1y1 / sqrt(d1y1**2+d1y2**2)
        tc2at(i) = d1y2 / sqrt(d1y1**2+d1y2**2)
      enddo

!.......................................................................
!               end of subroutine
!.......................................................................
      return
!***********************************************************************
      end


      subroutine matrot1(r0,r1,lmax,dmat,dmatp)
! =====================
!
! if r1 = R * r0, dmat = D(R) and dmatp = D(R)+
!
      implicit real*8 (a-h,o-z)
!     include '../param.h'
!
      dimension r0(3),r1(3),rr(3),drot(3,3),tvec(3),tlm(4)
      complex*16 dmat(2*(lmax+1)*(lmax+1),2*(lmax+1)*(lmax+1))
      complex*16 dmatp(2*(lmax+1)*(lmax+1),2*(lmax+1)*(lmax+1))
      complex*16 cmat(2*(lmax+1)*(lmax+1),2*(lmax+1)*(lmax+1))
      complex*16 d(2*lmax+2,2*lmax+2),dz(3)
!
!     common/test/itest
!
      pi=4.d0*datan(1.d0)
      sth=dsqrt(3.d0)
!
      r0mod=0.d0
      r1mod=0.d0
      do i=1,3
        r0mod=r0mod+r0(i)*r0(i)
        r1mod=r1mod+r1(i)*r1(i)
      end do
      r0mod=dsqrt(r0mod)
      r1mod=dsqrt(r1mod)
      do i=1,3
        r0(i)=r0(i)/r0mod
        r1(i)=r1(i)/r1mod
      end do
!
! Find normal vector and angle of rotation
!
      cosphi=r0(1)*r1(1)+r0(2)*r1(2)+r0(3)*r1(3)
      if(dabs(cosphi-1.d0).lt.1.d-10) then
        phi=0.d0
        tvec(1)=r0(1)
        tvec(2)=r0(2)
        tvec(3)=r0(3)
        goto 10
      else if(dabs(cosphi+1.d0).lt.1.d-10) then
        phi=pi
        r0xy=dsqrt(r0(1)**2+r0(2)**2)
        if(r0xy.gt.1.d-10) then
          tvec(1)=-r0(2)/r0xy
          tvec(2)=r0(1)/r0xy
          tvec(3)=0.d0
        else
          tvec(1)=1.d0
          tvec(2)=0.d0
          tvec(3)=0.d0
        end if
        goto 10
      end if
      phi=dacos(cosphi)
!
! T=(R0xR1)/|R0xR1|
!
      tvec(1)=r0(2)*r1(3)-r0(3)*r1(2)
      tvec(2)=r0(3)*r1(1)-r0(1)*r1(3)
      tvec(3)=r0(1)*r1(2)-r0(2)*r1(1)
      tmod=dsqrt(tvec(1)**2+tvec(2)**2+tvec(3)**2)
      tvec(1)=tvec(1)/tmod
      tvec(2)=tvec(2)/tmod
      tvec(3)=tvec(3)/tmod
!
   10 continue
!
      if(0.gt.3) then
      write(6,'(''   r0= '',3f10.4)') r0
      write(6,'(''   r1= '',3f10.4)') r1
      write(6,'('' Normal vector: '',3f10.4)') tvec
      write(6,'('' Angle in degree:'',f10.4)') phi*180.d0/pi
      end if
!
      cosp2=dcos(phi/2.d0)
      sinp2=dsin(phi/2.d0)
      tlm(1)=cosp2
      tlm(2)=sinp2*tvec(1)
      tlm(3)=sinp2*tvec(2)
      tlm(4)=sinp2*tvec(3)
!
      call matr(tlm,lmax,dmat,dmatp)
!
! Set up matrix of rotation for spherical harmonics with l=1 and m=0
!
      call rotmat(d,trd,3,tlm,1,lmax)
      dz(1)=dconjg(d(2,3))*sth
      dz(2)=dconjg(d(2,2))*sth
      dz(3)=dconjg(d(2,1))*sth
!
!     dz(1)=d(3,2)*sth
!     dz(2)=d(2,2)*sth
!     dz(3)=d(1,2)*sth
!
      if(0.gt.3) then
      write(6,*) ' Rotation matrix for (l,m)=(1,0)'
      write(6,'(6d13.5)') dz(1),dz(2),dz(3)
      end if
!
      return
      end


include 'header.h'

program cross
  use dyn_lc
  use rebin
  implicit none

  integer              :: i, j, jj, reb_dim, o, tot_intervals
  character (len=200)  :: name_base
  logical              :: yes_no

  double precision, parameter   :: pi = acos(-1.0)
  double precision              :: bias2

  double precision, allocatable :: rc_freq_obs(:,:,:), ic_freq_obs(:,:,:)
  double precision, allocatable :: pw_freq1_obs(:,:,:), pw_freq2_obs(:,:,:)
  double precision, allocatable :: pw_freq1_ave(:),pw_freq2_ave(:),&
                                   pw2_freq1_ave(:),pw2_freq2_ave(:)
  double precision, allocatable :: rc_freq_ave(:), ic_freq_ave(:), &
                                   rc2_freq_ave(:),ic2_freq_ave(:),&
                                   rc_ic_freq_ave(:)

  double precision, allocatable :: lag_freq(:), std_rc_freq_ave(:),&
                                   std_ic_freq_ave(:), deriv_rc(:),&
                                   deriv_ic(:), error_prop(:), &
                                   coher2_freq(:), err_cohe_lag(:),&
                                   covariance(:), errA_rc_ic(:),&
                                   errA_lag(:)

!NOT power of 2 segments
  double precision, allocatable :: re_lc1(:), im_lc1(:), re_lc2(:), im_lc2(:)

  ! call set_seed(seed)

!******************************************************************

  ! call execute_command_line('ls')

!GET LIGHT CURVEs

  verbose_merge = .false.
  obs_num = 7
  max_gap_sec_init = 1
  int_len_dim = 1024

  call load_lc_lag_freq_multi2()

  ! call run_test()

  write(*,*)
  write(*,*)
  write(*,*) '-------------------------------------'
  write(*,*) 'Start the Fourier analysis'
  write(*,*)
  if(.not. allocated(rc_freq_obs )) allocate(rc_freq_obs (int_number_max, int_len_dim / 2, obs_num))
  if(.not. allocated(ic_freq_obs )) allocate(ic_freq_obs (int_number_max, int_len_dim / 2, obs_num))
  if(.not. allocated(pw_freq1_obs)) allocate(pw_freq1_obs(int_number_max, int_len_dim / 2, obs_num))
  if(.not. allocated(pw_freq2_obs)) allocate(pw_freq2_obs(int_number_max, int_len_dim / 2, obs_num))

  do o = 1, obs_num
     ! write(*,*) 'ciao ciao ', check_power2
     if (.not. check_power2) then
       if (.not. allocated(re_lc1)) allocate(re_lc1(int_len_dim / 2))
       if (.not. allocated(im_lc1)) allocate(im_lc1(int_len_dim / 2))
       if (.not. allocated(re_lc2)) allocate(re_lc2(int_len_dim / 2))
       if (.not. allocated(im_lc2)) allocate(im_lc2(int_len_dim / 2))
     endif

     do i = 1, int_number_obs(o)
        if (check_power2) then
           ! write(*,*) 'start FFT of interval ', i

           call ncperiodogram_frac_rms(lc_freq2_obs(i, :, o), lc_freq1_obs(i, :, o) , rc_freq_obs(i, :, o), ic_freq_obs(i, :, o), dt, int_len_dim) !Cross spectrum
           call   periodogram_frac_rms(lc_freq1_obs(i, :, o), pw_freq1_obs(i, :, o), dt, int_len_dim)
           call   periodogram_frac_rms(lc_freq2_obs(i, :, o), pw_freq2_obs(i, :, o), dt, int_len_dim)

           write(*,*) 'FFT done of interval ', i
        else
           call FT_not_fast(lc_freq1_obs(i, :, o), re_lc1, im_lc1, int_len_dim)
           call FT_not_fast(lc_freq2_obs(i, :, o), re_lc2, im_lc2, int_len_dim)

           !Calculate Power spectra and cross spectrum of light curves and ref band
           do jj = 1, int_len_dim / 2
              rc_freq_obs (i, jj, o) = (re_lc2(jj) * re_lc1(jj)) + (im_lc2(jj) * im_lc1(jj))
              ic_freq_obs (i, jj, o) = (im_lc2(jj) * re_lc1(jj)) - (re_lc2(jj) * im_lc1(jj))
              pw_freq1_obs(i, jj, o) = (re_lc1(jj) * re_lc1(jj)) + (im_lc1(jj) * im_lc1(jj))
              pw_freq2_obs(i, jj, o) = (re_lc2(jj) * re_lc2(jj)) + (im_lc2(jj) * im_lc2(jj))
           enddo

        endif
     enddo

     if (allocated(re_lc1)) deallocate(re_lc1)
     if (allocated(im_lc1)) deallocate(im_lc1)
     if (allocated(re_lc2)) deallocate(re_lc2)
     if (allocated(im_lc2)) deallocate(im_lc2)

  enddo

  call make_freq_array()

  write(*,*) '   Completed Fourier transforms of the segmets', int_number
  write(*,*)

  if(.not. allocated(rc_freq_ave)   ) allocate(rc_freq_ave   (int_len_dim / 2))
  if(.not. allocated(ic_freq_ave)   ) allocate(ic_freq_ave   (int_len_dim / 2))
  if(.not. allocated(rc2_freq_ave)  ) allocate(rc2_freq_ave  (int_len_dim / 2))
  if(.not. allocated(ic2_freq_ave)  ) allocate(ic2_freq_ave  (int_len_dim / 2))
  if(.not. allocated(rc_ic_freq_ave)) allocate(rc_ic_freq_ave(int_len_dim / 2))
  if(.not. allocated(pw_freq1_ave)  ) allocate(pw_freq1_ave  (int_len_dim / 2))
  if(.not. allocated(pw_freq2_ave)  ) allocate(pw_freq2_ave  (int_len_dim / 2))
  if(.not. allocated(pw2_freq1_ave) ) allocate(pw2_freq1_ave (int_len_dim / 2))
  if(.not. allocated(pw2_freq2_ave) ) allocate(pw2_freq2_ave (int_len_dim / 2))

  rc_freq_ave    = 0.d0
  ic_freq_ave    = 0.d0
  rc2_freq_ave   = 0.d0
  ic2_freq_ave   = 0.d0
  rc_ic_freq_ave = 0.d0
  pw_freq1_ave   = 0.d0
  pw_freq2_ave   = 0.d0
  pw2_freq1_ave  = 0.d0
  pw2_freq2_ave  = 0.d0

  tot_intervals  = 0

  do o = 1, obs_num

     do jj = 1, int_len_dim / 2
        do i = 1, int_number_obs(o)
           rc_freq_ave   (jj) = rc_freq_ave   (jj) + rc_freq_obs(i, jj, o)
           ic_freq_ave   (jj) = ic_freq_ave   (jj) + ic_freq_obs(i, jj, o)
           rc2_freq_ave  (jj) = rc2_freq_ave  (jj) + (rc_freq_obs(i, jj, o) * rc_freq_obs(i, jj, o))
           ic2_freq_ave  (jj) = ic2_freq_ave  (jj) + (ic_freq_obs(i, jj, o) * ic_freq_obs(i, jj, o))
           rc_ic_freq_ave(jj) = rc_ic_freq_ave(jj) + (rc_freq_obs(i, jj, o) * ic_freq_obs(i, jj, o))
           pw_freq1_ave  (jj) = pw_freq1_ave  (jj) +  pw_freq1_obs(i, jj, o)
           pw2_freq1_ave (jj) = pw2_freq1_ave (jj) + (pw_freq1_obs(i, jj, o) * pw_freq1_obs(i, jj, o))
           pw_freq2_ave  (jj) = pw_freq2_ave  (jj) +  pw_freq2_obs(i, jj, o)
           pw2_freq2_ave (jj) = pw2_freq2_ave (jj) + (pw_freq2_obs(i, jj, o) * pw_freq2_obs(i, jj, o))
        enddo
     enddo

     tot_intervals = tot_intervals + int_number_obs(o)
  enddo

  rc_freq_ave    = rc_freq_ave    / dble(tot_intervals)
  ic_freq_ave    = ic_freq_ave    / dble(tot_intervals)
  rc2_freq_ave   = rc2_freq_ave   / dble(tot_intervals)
  ic2_freq_ave   = ic2_freq_ave   / dble(tot_intervals)
  rc_ic_freq_ave = rc_ic_freq_ave / dble(tot_intervals)
  pw_freq1_ave   = pw_freq1_ave   / dble(tot_intervals)
  pw_freq2_ave   = pw_freq2_ave   / dble(tot_intervals)
  pw2_freq1_ave  = pw2_freq1_ave  / dble(tot_intervals)
  pw2_freq2_ave  = pw2_freq2_ave  / dble(tot_intervals)

  write(*,*) '   Averaging over segmets completed'
  write(*,*)

  ! do i = 1, int_number
  !    do jj = 1, int_len_dim / 2
  !       write(10,*)  freq(jj), df, rc_freq(i, jj)
  !       write(11,*)  freq(jj), df, ic_freq(i, jj)
  !    enddo
  !    write(10,*)'no no'
  !    write(11,*)'no no'
  ! enddo

  if(.not. allocated(lag_freq    )) allocate(lag_freq    (int_len_dim / 2))
  if(.not. allocated(std_rc_freq_ave  )) allocate(std_rc_freq_ave  (int_len_dim / 2))
  if(.not. allocated(std_ic_freq_ave  )) allocate(std_ic_freq_ave  (int_len_dim / 2))
  if(.not. allocated(deriv_rc    )) allocate(deriv_rc    (int_len_dim / 2))
  if(.not. allocated(deriv_ic    )) allocate(deriv_ic    (int_len_dim / 2))
  if(.not. allocated(error_prop  )) allocate(error_prop  (int_len_dim / 2))
  if(.not. allocated(coher2_freq )) allocate(coher2_freq (int_len_dim / 2))
  if(.not. allocated(err_cohe_lag)) allocate(err_cohe_lag(int_len_dim / 2))

  if(.not. allocated(covariance  )) allocate(covariance  (int_len_dim / 2))
  if(.not. allocated(errA_rc_ic  )) allocate(errA_rc_ic  (int_len_dim / 2))
  if(.not. allocated(errA_lag    )) allocate(errA_lag    (int_len_dim / 2))

   write(*,*)
   name_base = 'freq_cross_spec_real.dat'
   write(*,*) ' Name file real vs frequency: ', trim(name_base)
   write(*,*) '   The errors are calculated with the standard error on the mean '
   write(*,*)
   open(11, file=trim(name_base))
   name_base = 'freq_cross_spec_imaginary.dat'
   write(*,*) ' Name file imaginary vs frequency: ', trim(name_base)
   write(*,*) '   The errors are calculated with the standard error on the mean '
   write(*,*)
   open(12, file=trim(name_base))

   name_base = 'lag_freq_err_prop.dat'
   write(*,*) ' Name file lag vs frequency: ', trim(name_base)
   write(*,*) '    The errors are calculated with propagation error formula on the standard deviation of real and imaginary part'
   write(*,*)
   open(13, file=trim(name_base))
   name_base = 'lag_freq_err_cohe.dat'
   write(*,*) ' Name file lag vs frequency: ', trim(name_base)
   write(*,*) '   The errors are calculated with coherence formula'
   write(*,*)
   open(14, file=trim(name_base))

   write(11, *) 'skip on'
   write(11, *) 'read serr 1 2'
   write(12, *) 'skip on'
   write(12, *) 'read serr 1 2'
   write(13, *) 'skip on'
   write(13, *) 'read serr 1 2'
   write(14, *) 'skip on'
   write(14, *) 'read serr 1 2'

!lag calculation and errors
   ! int_len_dim = int_len_dim_obs(1)

   do jj = 1, int_len_dim / 2

!Errors through standard deviation on real and imaginary part
      !lag with propagation formula
      std_rc_freq_ave(jj) = sqrt((rc2_freq_ave(jj) - (rc_freq_ave(jj) * rc_freq_ave(jj)) ))  / (sqrt(dble(tot_intervals)))
      std_ic_freq_ave(jj) = sqrt((ic2_freq_ave(jj) - (ic_freq_ave(jj) * ic_freq_ave(jj)) ))  / (sqrt(dble(tot_intervals)))
      covariance(jj) = (rc_ic_freq_ave(jj) - ((rc_freq_ave(jj) * ic_freq_ave(jj))))  / dble(tot_intervals)
      ! covariance(jj) = 0.0
      deriv_rc(jj) =  (-1.d0 *  ic_freq_ave(jj) / rc_freq_ave(jj)**2) / (1 + (ic_freq_ave(jj) / rc_freq_ave(jj))**2 )
      deriv_ic(jj) =                      (1.d0 / rc_freq_ave(jj))    / (1 + (ic_freq_ave(jj) / rc_freq_ave(jj))**2 )
      error_prop(jj) = sqrt( (deriv_rc(jj)**2 * std_rc_freq_ave(jj)**2) + (deriv_ic(jj)**2 * std_ic_freq_ave(jj)**2) + (2.d0 * deriv_rc(jj) * deriv_ic(jj) * covariance(jj)) ) / (2.d0 * pi * freq(jj))

!bias term
      ! if ((obs_freq_bins(jj) * int_number) .lt. 500 ) then
      !    bias2 = ((pw_fq_en(jj, k) - P_noise_ext(k)) * P_noise_ext_ref(k) + (pw_fq_en_ref(jj, k) - P_noise_ext_ref(k)) * P_noise_ext(k) + P_noise_ext(k) * P_noise_ext_ref(k) ) / (real(obs_freq_bins(jj) * int_number))
      ! else
      !    bias2 = 0.0
      ! endif

      bias2 = 0.0

!Coherence and error on the lag with the coherence formula
      coher2_freq(jj) = (rc_freq_ave(jj)**2 + ic_freq_ave(jj)**2 - bias2) / (pw_freq1_ave(jj) * pw_freq2_ave(jj))

      err_cohe_lag(jj) = sqrt( (1.d0 - coher2_freq(jj)) / (2.d0 * coher2_freq(jj) * dble(tot_intervals) ) ) / (2.d0 * pi * freq(jj))

      ! write(10,*) jj, freq(jj), coher2_freq(jj), rc_freq_ave(jj)**2, ic_freq_ave(jj)**2, pw_freq1_ave(jj),  pw_freq2_ave(jj)

!Adam's formula real and imaginary part
         ! errA_rc_ic(jj) = sqrt (pw_freq_ave2(jj) * (pw_freq_ave1(jj, k) - ( (rc_freq_ave(jj)**2 + ic_freq_ave(jj)**2 - bias2) / (pw_freq_ave2(jj, k) - P_noise_ext_ref(k)) ) ) / (2 * real( int_number) ) )

!Adam's formula lag
         ! errA_lag(jj) = sqrt( pw_fq_en_ref(jj, k) * ( (pw_fq_en(jj, k) / (rc_fq_en(jj, k)**2 + ic_fq_en(jj, k)**2 - bias2) ) - ( 1 / (pw_fq_en_ref(jj, k) - P_noise_ext_ref(k))  ) ) / (2 *  real(obs_freq_bins(jj) * int_number)) ) / (2 * pi * relevant_freq(jj))

      write(11,*) freq(jj), df, rc_freq_ave(jj), std_rc_freq_ave(jj) !/ sqrt(real(int_number))
      write(12,*) freq(jj), df, ic_freq_ave(jj), std_ic_freq_ave(jj) !/ sqrt(real(int_number))

      lag_freq(jj) = atan2(ic_freq_ave(jj), rc_freq_ave(jj)) / (2.d0 * pi * freq(jj))

      write(13, *) freq(jj), df, lag_freq(jj), error_prop(jj)
      write(14, *) freq(jj), df, lag_freq(jj), err_cohe_lag(jj)
   enddo
   write(11, *) 'log x on'
   write(12, *) 'log x on'
   write(13, *) 'log x on'
   write(14, *) 'log x on'

   write(11, *) 'no no'
   write(12, *) 'no no'
   write(13, *) 'no no'
   write(14, *) 'no no'
   close(11)
   close(12)
   close(13)
   close(14)

    write(*,*) '   Lag and error calculation completed'
    write(*,*)

! -------------- REBIN --------------
666   continue
      if (yes_no('   Do you want to rebin the lag freq spectrum?')) then

         call rebin_lag_freq_obs(freq, rc_freq_obs, ic_freq_obs, pw_freq1_obs, pw_freq2_obs, int_number_max, int_number_obs, int_len_dim, obs_num, reb_dim)
         name_base = 'lag_freq_err_reb.qdp'
         write(*,*) '   The name the rebinned lag vs freq is ', trim(name_base)
         open(71, file = trim(name_base))
         write(71, *) 'skip on'
         write(71, *) 'read serr 1 2 3'
         do j = 1, reb_dim - 1
            write(71, *) (reb_freq(j + 1) + reb_freq(j)) * 0.5, (reb_freq(j + 1) - reb_freq(j)) * 0.5, reb_lag_freq(j), reb_err_cohe_lag(j), reb_lag_freq(j), reb_err_prop_lag(j)
         enddo
         write(71, *) 'no no'
         write(71, *) 'log x on'
         write(71, *) 'scr white'
         write(71, *) 'lw 5'
         write(71, *) 'la x Frequency [Hz]'
         write(71, *) 'la y Lag [s]'
         write(71, *) 't off'
         close(71)

      endif

      write(*,*)
      if (yes_no('   Are you satified with the rebin?')) then
      else
         goto 666
      endif

      write(*,*)
      write(*,*) '   Rebin done'
      write(*,*)
      write(*,*) '   Analysis concluded'

  end program cross


      SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve the Sylvester equation -AX + XB = C, where A and B are
C     M-by-M and N-by-N matrices, respectively, in real Schur form.
C
C     This routine is intended to be called only by SLICOT Library
C     routine MB03RD. For efficiency purposes, the computations are
C     aborted when the infinity norm of an elementary submatrix of X is
C     greater than a given value PMAX.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the matrix A and the number of rows of the
C             matrices C and X.  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix B and the number of columns of the
C             matrices C and X.  N >= 0.
C
C     PMAX    (input) DOUBLE PRECISION
C             An upper bound for the infinity norm of an elementary
C             submatrix of X (see METHOD).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,M)
C             The leading M-by-M part of this array must contain the
C             matrix A of the Sylvester equation, in real Schur form.
C             The elements below the real Schur form are not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,N)
C             The leading N-by-N part of this array must contain the
C             matrix B of the Sylvester equation, in real Schur form.
C             The elements below the real Schur form are not referenced.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix C of the Sylvester equation.
C             On exit, if INFO = 0, the leading M-by-N part of this
C             array contains the solution matrix X of the Sylvester
C             equation, and each elementary submatrix of X (see METHOD)
C             has the infinity norm less than or equal to PMAX.
C             On exit, if INFO = 1, the solution matrix X has not been
C             computed completely, because an elementary submatrix of X
C             had the infinity norm greater than PMAX. Part of the
C             matrix C has possibly been overwritten with the
C             corresponding part of X.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  an elementary submatrix of X had the infinity norm
C                   greater than the given value PMAX.
C
C     METHOD
C
C     The routine uses an adaptation of the standard method for solving
C     Sylvester equations [1], which controls the magnitude of the
C     individual elements of the computed solution [2]. The equation
C     -AX + XB = C can be rewritten as
C                                 p            l-1
C       -A  X   + X  B   = C   + sum  A  X   - sum  X  B
C         kk kl    kl ll    kl  i=k+1  ki il   j=1   kj jl
C
C     for l = 1:q, and k = p:-1:1, where A  , B  , C  , and X  , are
C                                         kk   ll   kl       kl
C     block submatrices defined by the partitioning induced by the Schur
C     form of A and B, and p and q are the numbers of the diagonal
C     blocks of A and B, respectively. So, the elementary submatrices of
C     X are found block column by block column, starting from the
C     bottom. If any such elementary submatrix has the infinity norm
C     greater than the given value PMAX, the calculations are ended.
C
C     REFERENCES
C
C     [1] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Bavely, C. and Stewart, G.W.
C         An Algorithm for Computing Reducing Subspaces by Block
C         Diagonalization.
C         SIAM J. Numer. Anal., 16, pp. 359-367, 1979.
C
C     NUMERICAL ASPECTS
C                               2      2
C     The algorithm requires 0(M N + MN ) operations.
C
C     FURTHER COMMENTS
C
C     Let
C
C            ( A   C )       ( I   X )
C        M = (       ),  Y = (       ).
C            ( 0   B )       ( 0   I )
C
C     Then
C
C         -1      ( A   0 )
C        Y  M Y = (       ),
C                 ( 0   B )
C
C     hence Y is an non-orthogonal transformation matrix which performs
C     the reduction of M to a block-diagonal form. Bounding a norm of
C     X is equivalent to setting an upper bound to the condition number
C     of the transformation matrix Y.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C     Based on the RASP routine SYLSM by A. Varga, German Aerospace
C     Center, DLR Oberpfaffenhofen.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Diagonalization, real Schur form, Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDC, M, N
      DOUBLE PRECISION  PMAX
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*)
C     .. Local Scalars ..
      INTEGER           DK, DL, I, IERR, J, K, KK, KK1, L, LL, LM1
      DOUBLE PRECISION  PNORM, SCALE
C     .. Local Arrays ..
      DOUBLE PRECISION  P(4)
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DGEMV, DLASY2
C     .. Executable Statements ..
C
C     For efficiency reasons, this routine does not check the input
C     parameters for errors.
C
      INFO = 0
C
C     Column loop indexed by L.
C
      L = 1
C     WHILE ( L.LE.N ) DO
   10 IF ( L.LE.N ) THEN
         LM1 = L - 1
         DL = 1
         IF ( L.LT.N ) THEN
            IF ( B(L+1,L).NE.ZERO )
     $         DL = 2
         ENDIF
         LL = LM1 + DL
         IF ( LM1.GT.0 ) THEN
C
C           Update one (or two) column(s) of C.
C
            IF ( DL.EQ.2 ) THEN
               CALL DGEMM( 'No transpose', 'No transpose', M, DL, LM1,
     $                     -ONE, C, LDC, B(1,L), LDB, ONE, C(1,L), LDC )
            ELSE
               CALL DGEMV( 'No transpose', M, LM1, -ONE, C, LDC, B(1,L),
     $                     1, ONE, C(1,L), 1 )
            END IF
         ENDIF
C
C        Row loop indexed by KK.
C
         KK = M
C        WHILE ( KK.GE.1 ) DO
   20    IF ( KK.GE.1 ) THEN
            KK1 = KK + 1
            DK = 1
            IF ( KK.GT.1 ) THEN
               IF ( A(KK,KK-1).NE.ZERO )
     $            DK = 2
            ENDIF
            K = KK1 - DK
            IF ( K.LT.M ) THEN
C
C              Update an elementary submatrix of C.
C
               DO 40 J = L, LL
C
                  DO 30 I = K, KK
                     C(I,J) = C(I,J) +
     $                        DDOT( M-KK, A(I,KK1), LDA, C(KK1,J), 1 )
   30             CONTINUE
C
   40          CONTINUE
C
            ENDIF
            CALL DLASY2( .FALSE., .FALSE., -1, DK, DL, A(K,K), LDA,
     $                   B(L,L), LDB, C(K,L), LDC, SCALE, P, DK, PNORM,
     $                   IERR )
            IF( SCALE.NE.ONE .OR. PNORM.GT.PMAX ) THEN
                INFO = 1
                RETURN
            END IF
            C(K,L) = -P(1)
            IF ( DL.EQ.1 ) THEN
               IF ( DK.EQ.2 )
     $            C(KK,L)  = -P(2)
            ELSE
               IF ( DK.EQ.1 ) THEN
                  C(K,LL)  = -P(2)
               ELSE
                  C(KK,L)  = -P(2)
                  C(K,LL)  = -P(3)
                  C(KK,LL) = -P(4)
               ENDIF
            ENDIF
            KK = KK - DK
            GO TO 20
         END IF
C        END WHILE 20
         L = L + DL
         GO TO 10
      END IF
C     END WHILE 10
      RETURN
C *** Last line of MB03RY ***
      END


Double Precision Function ftime1(iseed)
  Implicit Double Precision (A-H, O-Z)
  External ran1
  Parameter (hbarc=0.197327054D0)
  Common /par1/formt
  Save
  aa = hbarc/formt
  ftime1 = aa*dsqrt(1D0/ran1(iseed)-1D0)
  Return
End Function ftime1


module Brent

   use NWTC_Library
   use BEMTUncoupled
   use BEMT_Types
   implicit none
   private
   public :: BrentRoots

   contains

!
!
! http://jean-pierre.moreau.pagesperso-orange.fr/
!

! TRUE if x1*x2 negative
integer function RootBracketed(x1,x2)
  real(ReKi), intent(in) :: x1,x2
  if ((x1 > 0.and.x2 > 0).or.(x1 < 0.and.x2 < 0)) then
    RootBracketed = 0
  else
    RootBracketed = 1
  endif
END FUNCTION RootBracketed

! returns the minimum of two real numbers
real(ReKi) function Minimum(x1,x2)
  REAL(ReKi), INTENT(IN) :: x1,x2

  if (x1 < x2) then
    Minimum = x1
  else
    Minimum = x2
  end if
end Function Minimum

!*****************************************************
!*              Brent Method Function                *
!* ------------------------------------------------- *
!* The purpose is to find a real root of a real      *
!* function f(x) using Brent method.                 *
!*                                                   *
!* INPUTS:  x1,x2     : interval of root             *
!*          Tolerance : desired accuracy for root    *
!*          maxIter   : maximum number of iterations *
!*                                                   *
!* OUTPUTS: The function returns the root value      *
!*          ValueAtRoot : value of f(root)           *
!*          niter    : number of done iterations     *
!*          error    : =0, all OK                    *
!*                   : =1, no root found in interval *
!*                   : =2, no more iterations !      *
!*****************************************************
real(ReKi) function BrentRoots( x1, x2, Tolerance, maxIndIterations, valueAtRoot, niter, psi, chi0, numReIterations, airDens, mu, numBlades, rlocal, rtip, chord, theta,  AFInfo, &
                              Vx, Vy, useTanInd, useAIDrag, useTIDrag, useHubLoss, useTipLoss, hubLossConst, tipLossConst, SkewWakeMod, &
                              UA_Flag, p_UA, xd_UA, OtherState_UA, &
                              ErrStat, ErrMsg)

!TODO: Need to establish better FPP and nearzero values based on ReKi GJH 7/17/2014 DO NOT RELEASE WITHOUT FIXING THIS!!!!!!
   REAL(DbKi), PARAMETER  :: FPP = epsilon(1.0_ReKi) !1.d-6
   REAL(DbKi), PARAMETER  :: nearzero = 1.d-6

   REAL(ReKi),             INTENT(IN   ) :: x1,x2,Tolerance
   INTEGER,                INTENT(IN   ) :: maxIndIterations
   REAL(ReKi),             INTENT(  OUT) :: valueAtRoot                 ! the actual residual at resultant
   INTEGER,                INTENT(  OUT) :: niter                       ! number of iterations performed
   REAL(ReKi),             INTENT(IN   ) :: psi
   REAL(ReKi),             INTENT(IN   ) :: chi0
   INTEGER,                INTENT(IN   ) :: numReIterations
   REAL(ReKi),             INTENT(IN   ) :: airDens
   REAL(ReKi),             INTENT(IN   ) :: mu
   INTEGER,                INTENT(IN   ) :: numBlades
   REAL(ReKi),             INTENT(IN   ) :: rlocal
   REAL(ReKi),             INTENT(IN   ) :: rtip
   REAL(ReKi),             INTENT(IN   ) :: chord
   REAL(ReKi),             INTENT(IN   ) :: theta
   TYPE(AFInfoType),       INTENT(IN   ) :: AFInfo
   REAL(ReKi),             INTENT(IN   ) :: Vx
   REAL(ReKi),             INTENT(IN   ) :: Vy
   LOGICAL,                INTENT(IN   ) :: useTanInd
   LOGICAL,                INTENT(IN   ) :: useAIDrag
   LOGICAL,                INTENT(IN   ) :: useTIDrag
   LOGICAL,                INTENT(IN   ) :: useHubLoss
   LOGICAL,                INTENT(IN   ) :: useTipLoss
   REAL(ReKi),             INTENT(IN   ) :: hubLossConst
   REAL(ReKi),             INTENT(IN   ) :: tipLossConst
   INTEGER,                INTENT(IN   ) :: SkewWakeMod   ! Skewed wake model
   LOGICAL,                intent(in   ) :: UA_Flag
   TYPE(UA_ParameterType),       INTENT(IN   ) :: p_UA           ! Parameters
   TYPE(UA_DiscreteStateType),   INTENT(IN   ) :: xd_UA          ! Discrete states at Time
   TYPE(UA_OtherStateType),      INTENT(IN   ) :: OtherState_UA  ! Other/optimization states
   INTEGER(IntKi),         INTENT(  OUT) :: ErrStat       ! Error status of the operation
   CHARACTER(*),           INTENT(  OUT) :: ErrMsg        ! Error message if ErrStat /= ErrID_None

   REAL(ReKi) resultant, AA, BB, CC, DD, EE, FA, FB, FC, Tol1, PP, QQ, RR, SS, xm
   INTEGER i, done

  ErrStat = ErrID_None
  ErrMsg  = ""
  resultant = 0.0_ReKi
  BrentRoots = 0.0_ReKi
  i = 0; done = 0;
  AA = x1
  BB = x2
  FA = UncoupledErrFn(AA, psi, chi0, numReIterations, airDens, mu, numBlades, rlocal, rtip, chord, theta,  AFInfo, &
                              Vx, Vy, useTanInd, useAIDrag, useTIDrag, useHubLoss, useTipLoss, hubLossConst, tipLossConst, SkewWakeMod, &
                              UA_Flag, p_UA, xd_UA, OtherState_UA, &
                              ErrStat, ErrMsg)
  FB = UncoupledErrFn(BB, psi, chi0, numReIterations, airDens, mu, numBlades, rlocal, rtip, chord, theta, AFInfo, &
                              Vx, Vy, useTanInd, useAIDrag, useTIDrag, useHubLoss, useTipLoss, hubLossConst, tipLossConst, SkewWakeMod, &
                              UA_Flag, p_UA, xd_UA, OtherState_UA, &
                              ErrStat, ErrMsg)

  if (RootBracketed(FA,FB).eq.0) then
    ErrStat = ErrID_Warn
    ErrMsg  = 'The supplied brackets contain zero!  Cannot use root finding method!'
    return
  else
    FC = FB;
    do while (done .eq. 0 .and. i < maxIndIterations)

      if (RootBracketed(FC,FB) .eq. 0) then
        CC = AA; FC = FA; DD = BB - AA; EE = DD
      endif
      if (abs(FC) < abs(FB)) then
        AA = BB; BB = CC; CC = AA
        FA = FB; FB = FC; FC = FA
      endif
      Tol1 = 2.0 * FPP * abs(BB) + 0.5 * Tolerance
      xm = 0.5 * (CC-BB)
      if ((abs(xm) <= Tol1) .or. (abs(FA) < nearzero)) then
        ! A root has been found
        resultant = BB;
        done = 1
        valueAtRoot = UncoupledErrFn(BB, psi, chi0, numReIterations, airDens, mu, numBlades, rlocal, rtip, chord, theta,  AFInfo, &
                              Vx, Vy, useTanInd, useAIDrag, useTIDrag, useHubLoss, useTipLoss, hubLossConst, tipLossConst, SkewWakeMod, &
                              UA_Flag, p_UA, xd_UA, OtherState_UA, &
                              ErrStat, ErrMsg)
      else
        if ((abs(EE) >= Tol1) .and. (abs(FA) > abs(FB))) then
          SS = FB/ FA;
          if (abs(AA - CC) < nearzero) then
            PP = 2.0 * xm * SS;
            QQ = 1.0 - SS;
          else
            QQ = FA/FC;
            RR = FB /FC;
            PP = SS * (2.0 * xm * QQ * (QQ - RR) - (BB-AA) * (RR - 1.0));
            QQ = (QQ - 1.0) * (RR - 1.0) * (SS - 1.0);
          endif
          if (PP > nearzero) QQ = -QQ;
          PP = abs(PP);
          if ((2.0 * PP) < Minimum(3.0*xm *QQ-abs(Tol1 * QQ), abs(EE * QQ))) then
            EE = DD;  DD = PP/QQ;
          else
            DD = xm;   EE = DD;
          endif
        else
          DD = xm;
          EE = DD;
        endif
        AA = BB;
        FA = FB;
        if (abs(DD) > Tol1) then
          BB = BB + DD;
        else
          if (xm > 0) then
            BB = BB + abs(Tol1)
          else
            BB = BB - abs(Tol1)
          endif
        endif
      !----------------------------------------------------------
      ! DEBUG SECTION ONLY --------------------------------------
      !if (AA < x1 .OR. AA > x2 .OR. BB < x1 .OR. BB > x2 ) then
      !   ErrStat = ErrID_FATAL
      !   ErrMsg  = 'Cannot use root finding method!'
      !   return
      !end if
      !----------------------------------------------------------

        FB = UncoupledErrFn(BB, psi, chi0, numReIterations, airDens, mu, numBlades, rlocal, rtip, chord, theta, AFInfo, &
                              Vx, Vy, useTanInd, useAIDrag, useTIDrag, useHubLoss, useTipLoss, hubLossConst, tipLossConst, SkewWakeMod, &
                              UA_Flag, p_UA, xd_UA, OtherState_UA, &
                              ErrStat, ErrMsg)
        i=i+1
      endif
   end do
   if (i >= maxIndIterations) then
      ErrStat = ErrID_Fatal
      ErrMsg  = 'Too many iterations! No solution found to induction factor solve.'
      return
   end if

  endif
  niter = i
  BrentRoots = resultant
end function BrentRoots

end module Brent


! { dg-do compile }
! { dg-options "-O -fbounds-check -w" }
MODULE kinds
  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND ( 14, 200 )
  INTEGER, DIMENSION(:), ALLOCATABLE     :: nco,ncoset,nso,nsoset
  INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: co,coset
END MODULE kinds
MODULE ai_moments
  USE kinds
CONTAINS
  SUBROUTINE cossin(la_max,npgfa,zeta,rpgfa,la_min,&
                    lb_max,npgfb,zetb,rpgfb,lb_min,&
                    rac,rbc,kvec,cosab,sinab)
    REAL(KIND=dp), DIMENSION(ncoset(la_max),&
      ncoset(lb_max))                        :: sc, ss
    DO ipgf=1,npgfa
      DO jpgf=1,npgfb
        IF (la_max > 0) THEN
          DO la=2,la_max
            DO ax=2,la
              DO ay=0,la-ax
                sc(coset(ax,ay,az),1) = rap(1)*sc(coset(ax-1,ay,az),1) +&
                              f2 *          kvec(1)*ss(coset(ax-1,ay,az),1)
                ss(coset(ax,ay,az),1) = rap(1)*ss(coset(ax-1,ay,az),1) +&
                              f2 *          kvec(1)*sc(coset(ax-1,ay,az),1)
              END DO
            END DO
          END DO
          IF (lb_max > 0) THEN
            DO lb=2,lb_max
              ss(1,coset(0,0,lb)) = rbp(3)*ss(1,coset(0,0,lb-1)) +&
                           f2 *         kvec(3)*sc(1,coset(0,0,lb-1))
              DO bx=2,lb
                DO by=0,lb-bx
                  ss(1,coset(bx,by,bz)) = rbp(1)*ss(1,coset(bx-1,by,bz)) +&
                               f2 *           kvec(1)*sc(1,coset(bx-1,by,bz))
                END DO
              END DO
            END DO
          END IF
        END IF
       DO j=ncoset(lb_min-1)+1,ncoset(lb_max)
        END DO
      END DO
    END DO
  END SUBROUTINE cossin
  SUBROUTINE moment(la_max,npgfa,zeta,rpgfa,la_min,&
                    lb_max,npgfb,zetb,rpgfb,&
                    lc_max,rac,rbc,mab)
    REAL(KIND=dp), DIMENSION(:), INTENT(IN)  :: zeta, rpgfa
    REAL(KIND=dp), DIMENSION(:), INTENT(IN)  :: zetb, rpgfb
    REAL(KIND=dp), DIMENSION(:, :, :), &
      INTENT(INOUT)                          :: mab
    REAL(KIND=dp), DIMENSION(3)              :: rab, rap, rbp, rpc
    REAL(KIND=dp), DIMENSION(ncoset(la_max),&
      ncoset(lb_max), ncoset(lc_max))        :: s
    DO ipgf=1,npgfa
      DO jpgf=1,npgfb
        IF (rpgfa(ipgf) + rpgfb(jpgf) < dab) THEN
          DO k=1, ncoset(lc_max)-1
            DO j=nb+1,nb+ncoset(lb_max)
              DO i=na+1,na+ncoset(la_max)
                mab(i,j,k) = 0.0_dp
              END DO
            END DO
          END DO
        END IF
        rpc = zetp*(zeta(ipgf)*rac+zetb(jpgf)*rbc)
        DO l=2, ncoset(lc_max)
          lx = indco(1,l)
          l2 = 0
          IF ( lz > 0 ) THEN
            IF ( lz > 1 ) l2 = coset(lx,ly,lz-2)
          ELSE IF ( ly > 0 ) THEN
            IF ( ly > 1 ) l2 = coset(lx,ly-2,lz)
            IF ( lx > 1 ) l2 = coset(lx-2,ly,lz)
          END IF
          s(1,1,l) = rpc(i)*s(1,1,l1)
          IF ( l2 > 0 ) s(1,1,l) = s(1,1,l) + f2*REAL(ni,dp)*s(1,1,l2)
        END DO
        DO l = 1, ncoset(lc_max)
          IF ( lx > 0 ) THEN
            lx1 = coset(lx-1,ly,lz)
          END IF
          IF ( ly > 0 ) THEN
            ly1 = coset(lx,ly-1,lz)
          END IF
          IF (la_max > 0) THEN
            DO la=2,la_max
              IF ( lz1 > 0 ) s(coset(0,0,la),1,l) = s(coset(0,0,la),1,l) + &
                             f2z*s(coset(0,0,la-1),1,lz1)
              IF ( ly1 > 0 ) s(coset(0,1,az),1,l) = s(coset(0,1,az),1,l) + &
                             f2y*s(coset(0,0,az),1,ly1)
              DO ay=2,la
                s(coset(0,ay,az),1,l) = rap(2)*s(coset(0,ay-1,az),1,l) +&
                                       f2*REAL(ay-1,dp)*s(coset(0,ay-2,az),1,l)
                IF ( ly1 > 0 ) s(coset(0,ay,az),1,l) = s(coset(0,ay,az),1,l) + &
                             f2y*s(coset(0,ay-1,az),1,ly1)
              END DO
              DO ay=0,la-1
                IF ( lx1 > 0 ) s(coset(1,ay,az),1,l) = s(coset(1,ay,az),1,l) + &
                             f2x*s(coset(0,ay,az),1,lx1)
              END DO
              DO ax=2,la
                DO ay=0,la-ax
                  s(coset(ax,ay,az),1,l) = rap(1)*s(coset(ax-1,ay,az),1,l) +&
                                          f3*s(coset(ax-2,ay,az),1,l)
                  IF ( lx1 > 0 ) s(coset(ax,ay,az),1,l) = s(coset(ax,ay,az),1,l) + &
                                 f2x*s(coset(ax-1,ay,az),1,lx1)
                END DO
              END DO
            END DO
            IF (lb_max > 0) THEN
              DO j=2,ncoset(lb_max)
                DO i=1,ncoset(la_max)
                  s(i,j,l) = 0.0_dp
                END DO
              END DO
              DO la=la_start,la_max-1
                DO ax=0,la
                  DO ay=0,la-ax
                    s(coset(ax,ay,az),2,l) = s(coset(ax+1,ay,az),1,l) -&
                                           rab(1)*s(coset(ax,ay,az),1,l)
                    s(coset(ax,ay,az),4,l) = s(coset(ax,ay,az+1),1,l) -&
                                           rab(3)*s(coset(ax,ay,az),1,l)
                  END DO
                END DO
              END DO
              DO ax=0,la_max
                DO ay=0,la_max-ax
                  IF (ax == 0) THEN
                    s(coset(ax,ay,az),2,l) = rbp(1)*s(coset(ax,ay,az),1,l)
                  ELSE
                    s(coset(ax,ay,az),2,l) = rbp(1)*s(coset(ax,ay,az),1,l) +&
                                            fx*s(coset(ax-1,ay,az),1,l)
                  END IF
                  IF (lx1 > 0) s(coset(ax,ay,az),2,l) = s(coset(ax,ay,az),2,l) +&
                        f2x*s(coset(ax,ay,az),1,lx1)
                  IF (ay == 0) THEN
                    s(coset(ax,ay,az),3,l) = rbp(2)*s(coset(ax,ay,az),1,l)
                  ELSE
                    s(coset(ax,ay,az),3,l) = rbp(2)*s(coset(ax,ay,az),1,l) +&
                                            fy*s(coset(ax,ay-1,az),1,l)
                  END IF
                  IF (ly1 > 0) s(coset(ax,ay,az),3,l) = s(coset(ax,ay,az),3,l) +&
                        f2y*s(coset(ax,ay,az),1,ly1)
                  IF (az == 0) THEN
                    s(coset(ax,ay,az),4,l) = rbp(3)*s(coset(ax,ay,az),1,l)
                  ELSE
                    s(coset(ax,ay,az),4,l) = rbp(3)*s(coset(ax,ay,az),1,l) +&
                                            fz*s(coset(ax,ay,az-1),1,l)
                  END IF
                  IF (lz1 > 0) s(coset(ax,ay,az),4,l) = s(coset(ax,ay,az),4,l) +&
                        f2z*s(coset(ax,ay,az),1,lz1)
                END DO
              END DO
              DO lb=2,lb_max
                DO la=la_start,la_max-1
                  DO ax=0,la
                    DO ay=0,la-ax
                      s(coset(ax,ay,az),coset(0,0,lb),l) =&
                        rab(3)*s(coset(ax,ay,az),coset(0,0,lb-1),l)
                      DO bx=1,lb
                        DO by=0,lb-bx
                          s(coset(ax,ay,az),coset(bx,by,bz),l) =&
                            rab(1)*s(coset(ax,ay,az),coset(bx-1,by,bz),l)
                        END DO
                      END DO
                    END DO
                  END DO
                END DO
                DO ax=0,la_max
                  DO ay=0,la_max-ax
                    IF (az == 0) THEN
                      s(coset(ax,ay,az),coset(0,0,lb),l) =&
                        rbp(3)*s(coset(ax,ay,az),coset(0,0,lb-1),l) +&
                        f3*s(coset(ax,ay,az),coset(0,0,lb-2),l)
                    END IF
                    IF (lz1 > 0) s(coset(ax,ay,az),coset(0,0,lb),l) =&
                                 f2z*s(coset(ax,ay,az),coset(0,0,lb-1),lz1)
                    IF (ay == 0) THEN
                      IF (ly1 > 0) s(coset(ax,ay,az),coset(0,1,bz),l) =&
                                 f2y*s(coset(ax,ay,az),coset(0,0,bz),ly1)
                      DO by=2,lb
                        s(coset(ax,ay,az),coset(0,by,bz),l) =&
                          f3*s(coset(ax,ay,az),coset(0,by-2,bz),l)
                        IF (ly1 > 0) s(coset(ax,ay,az),coset(0,by,bz),l) =&
                                 f2y*s(coset(ax,ay,az),coset(0,by-1,bz),ly1)
                      END DO
                      s(coset(ax,ay,az),coset(0,1,bz),l) =&
                        fy*s(coset(ax,ay-1,az),coset(0,0,bz),l)
                    END IF
                    IF (ax == 0) THEN
                      DO by=0,lb-1
                        IF (lx1 > 0) s(coset(ax,ay,az),coset(1,by,bz),l) =&
                                 f2x*s(coset(ax,ay,az),coset(0,by,bz),lx1)
                      END DO
                      DO bx=2,lb
                        DO by=0,lb-bx
                          s(coset(ax,ay,az),coset(bx,by,bz),l) =&
                            f3*s(coset(ax,ay,az),coset(bx-2,by,bz),l)
                          IF (lx1 > 0) s(coset(ax,ay,az),coset(bx,by,bz),l) =&
                                 f2x*s(coset(ax,ay,az),coset(bx-1,by,bz),lx1)
                        END DO
                      END DO
                      DO by=0,lb-1
                        IF (lx1 > 0) s(coset(ax,ay,az),coset(1,by,bz),l) =&
                                 f2x*s(coset(ax,ay,az),coset(0,by,bz),lx1)
                      END DO
                      DO bx=2,lb
                        DO by=0,lb-bx
                          s(coset(ax,ay,az),coset(bx,by,bz),l) =&
                            f3*s(coset(ax,ay,az),coset(bx-2,by,bz),l)
                          IF (lx1 > 0) s(coset(ax,ay,az),coset(bx,by,bz),l) =&
                                 f2x*s(coset(ax,ay,az),coset(bx-1,by,bz),lx1)
                        END DO
                      END DO
                    END IF
                  END DO
                END DO
              END DO
            END IF
            IF (lb_max > 0) THEN
              DO lb=2,lb_max
                IF (lz1 > 0) s(1,coset(0,0,lb),l) = s(1,coset(0,0,lb),l) +&
                             f2z*s(1,coset(0,0,lb-1),lz1)
                IF (ly1 > 0) s(1,coset(0,1,bz),l) = s(1,coset(0,1,bz),l) +&
                             f2y*s(1,coset(0,0,bz),ly1)
              DO by=2,lb
                s(1,coset(0,by,bz),l) = rbp(2)*s(1,coset(0,by-1,bz),l) +&
                                       f2*REAL(by-1,dp)*s(1,coset(0,by-2,bz),l)
                IF (lx1 > 0) s(1,coset(1,by,bz),l) = s(1,coset(1,by,bz),l) +&
                             f2x*s(1,coset(0,by,bz),lx1)
              END DO
              DO bx=2,lb
                DO by=0,lb-bx
                  IF (lx1 > 0) s(1,coset(bx,by,bz),l) = s(1,coset(bx,by,bz),l) +&
                               f2x*s(1,coset(bx-1,by,bz),lx1)
                END DO
              END DO
            END DO
          END IF
        END IF
        END DO
        DO k=2,ncoset(lc_max)
          DO j=1,ncoset(lb_max)
          END DO
        END DO
      END DO
    END DO
  END SUBROUTINE moment
  SUBROUTINE diff_momop(la_max,npgfa,zeta,rpgfa,la_min,&
                    order,rac,rbc,difmab,mab_ext)
    REAL(KIND=dp), DIMENSION(:, :, :), &
      OPTIONAL, POINTER                      :: mab_ext
    REAL(KIND=dp), ALLOCATABLE, &
      DIMENSION(:, :, :)                     :: difmab_tmp
    DO imom = 1,ncoset(order)-1
      CALL adbdr(la_max,npgfa,rpgfa,la_min,&
                 difmab_tmp(:,:,2), difmab_tmp(:,:,3))
    END DO
  END SUBROUTINE diff_momop
END MODULE ai_moments
! { dg-final { cleanup-modules "ai_moments" } }


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine filter(dgdxglob,nobject,nk,nodedesi,ndesi,
     &           objectset,xo,yo,zo,x,y,z,nx,ny,nz,neighbor,r,
     &           ndesia,ndesib)
!
!     Filtering of sensitivities
!
      implicit none
!
      character*81 objectset(3,*)

      integer nobject,nk,nodedesi(*),nnodesinside,i,
     &        ndesi,j,m,neighbor(ndesi+6),nx(ndesi),
     &        ny(ndesi),nz(ndesi),istat,ndesia,ndesib
!
      real*8 dgdxglob(2,nk,nobject),xo(ndesi),yo(ndesi),zo(ndesi),
     &       x(ndesi),y(ndesi),z(ndesi),filterrad,r(ndesi+6),
     &       filterval(ndesi),nominator,denominator
!
!     Calculate filtered sensitivities
!
!     Assign filter radius (taken from first defined object function)
!
      read(objectset(2,1)(21:40),'(f20.0)',iostat=istat) filterrad
!
      do j=ndesia,ndesib
!
         call near3d_se(xo,yo,zo,x,y,z,nx,ny,nz,xo(j),yo(j),zo(j),
     &        ndesi,neighbor,r,nnodesinside,filterrad)
!
!        Calculate function value of the filterfunction (linear)
!
         if(objectset(2,1)(1:6).eq.'LINEAR') then
          do i=1,nnodesinside
               filterval(i)=filterrad-dsqrt(r(i))
            enddo
!
!        Calculate function value of the filterfunction (gauss)
!
         elseif(objectset(2,1)(1:5).eq.'GAUSS') then
            do i=1,nnodesinside
               filterval(i)=dexp(-(0.5*r(i)**2/filterrad**2))
            enddo
         endif
!
!        Calculate filtered sensitivity

         do m=1,nobject
            nominator=0.d0
            denominator=0.d0
            do i=1,nnodesinside
               nominator=nominator+filterval(i)*
     &              dgdxglob(1,nodedesi(neighbor(i)),m)
               denominator=denominator+filterval(i)
            enddo
            dgdxglob(2,nodedesi(j),m)=nominator/denominator
         enddo
      enddo
!
      return
      end


      SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
*     .. Scalar Arguments ..
      DOUBLE PRECISION DD1,DD2,DX1,DY1
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DPARAM(5)
*     ..
*
*  Purpose
*  =======
*
*     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
*     THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*
*     DY2)**T.
*     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
*     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
*
*       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
*     H=(          )    (          )    (          )    (          )
*       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
*     LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
*     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
*     VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
*
*     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
*     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
*     OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
*
*
*  Arguments
*  =========
*
*  DD1    (input/output) DOUBLE PRECISION
*
*  DD2    (input/output) DOUBLE PRECISION
*
*  DX1    (input/output) DOUBLE PRECISION
*
*  DY1    (input) DOUBLE PRECISION
*
*  DPARAM (input/output)  DOUBLE PRECISION array, dimension 5
*     DPARAM(1)=DFLAG
*     DPARAM(2)=DH11
*     DPARAM(3)=DH21
*     DPARAM(4)=DH12
*     DPARAM(5)=DH22
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
     +                 DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
      INTEGER IGO
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DABS
*     ..
*     .. Data statements ..
*
      DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
      DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
*     ..

      IF (.NOT.DD1.LT.ZERO) GO TO 10
*       GO ZERO-H-D-AND-DX1..
      GO TO 60
   10 CONTINUE
*     CASE-DD1-NONNEGATIVE
      DP2 = DD2*DY1
      IF (.NOT.DP2.EQ.ZERO) GO TO 20
      DFLAG = -TWO
      GO TO 260
*     REGULAR-CASE..
   20 CONTINUE
      DP1 = DD1*DX1
      DQ2 = DP2*DY1
      DQ1 = DP1*DX1
*
      IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40
      DH21 = -DY1/DX1
      DH12 = DP2/DP1
*
      DU = ONE - DH12*DH21
*
      IF (.NOT.DU.LE.ZERO) GO TO 30
*         GO ZERO-H-D-AND-DX1..
      GO TO 60
   30 CONTINUE
      DFLAG = ZERO
      DD1 = DD1/DU
      DD2 = DD2/DU
      DX1 = DX1*DU
*         GO SCALE-CHECK..
      GO TO 100
   40 CONTINUE
      IF (.NOT.DQ2.LT.ZERO) GO TO 50
*         GO ZERO-H-D-AND-DX1..
      GO TO 60
   50 CONTINUE
      DFLAG = ONE
      DH11 = DP1/DP2
      DH22 = DX1/DY1
      DU = ONE + DH11*DH22
      DTEMP = DD2/DU
      DD2 = DD1/DU
      DD1 = DTEMP
      DX1 = DY1*DU
*         GO SCALE-CHECK
      GO TO 100
*     PROCEDURE..ZERO-H-D-AND-DX1..
   60 CONTINUE
      DFLAG = -ONE
      DH11 = ZERO
      DH12 = ZERO
      DH21 = ZERO
      DH22 = ZERO
*
      DD1 = ZERO
      DD2 = ZERO
      DX1 = ZERO
*         RETURN..
      GO TO 220
*     PROCEDURE..FIX-H..
   70 CONTINUE
      IF (.NOT.DFLAG.GE.ZERO) GO TO 90
*
      IF (.NOT.DFLAG.EQ.ZERO) GO TO 80
      DH11 = ONE
      DH22 = ONE
      DFLAG = -ONE
      GO TO 90
   80 CONTINUE
      DH21 = -ONE
      DH12 = ONE
      DFLAG = -ONE
   90 CONTINUE
      GO TO IGO(120,150,180,210)
*     PROCEDURE..SCALE-CHECK
  100 CONTINUE
  110 CONTINUE
      IF (.NOT.DD1.LE.RGAMSQ) GO TO 130
      IF (DD1.EQ.ZERO) GO TO 160
      ASSIGN 120 TO IGO
*              FIX-H..
      GO TO 70
  120 CONTINUE
      DD1 = DD1*GAM**2
      DX1 = DX1/GAM
      DH11 = DH11/GAM
      DH12 = DH12/GAM
      GO TO 110
  130 CONTINUE
  140 CONTINUE
      IF (.NOT.DD1.GE.GAMSQ) GO TO 160
      ASSIGN 150 TO IGO
*              FIX-H..
      GO TO 70
  150 CONTINUE
      DD1 = DD1/GAM**2
      DX1 = DX1*GAM
      DH11 = DH11*GAM
      DH12 = DH12*GAM
      GO TO 140
  160 CONTINUE
  170 CONTINUE
      IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190
      IF (DD2.EQ.ZERO) GO TO 220
      ASSIGN 180 TO IGO
*              FIX-H..
      GO TO 70
  180 CONTINUE
      DD2 = DD2*GAM**2
      DH21 = DH21/GAM
      DH22 = DH22/GAM
      GO TO 170
  190 CONTINUE
  200 CONTINUE
      IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220
      ASSIGN 210 TO IGO
*              FIX-H..
      GO TO 70
  210 CONTINUE
      DD2 = DD2/GAM**2
      DH21 = DH21*GAM
      DH22 = DH22*GAM
      GO TO 200
  220 CONTINUE
      IF (DFLAG) 250,230,240
  230 CONTINUE
      DPARAM(3) = DH21
      DPARAM(4) = DH12
      GO TO 260
  240 CONTINUE
      DPARAM(2) = DH11
      DPARAM(5) = DH22
      GO TO 260
  250 CONTINUE
      DPARAM(2) = DH11
      DPARAM(3) = DH21
      DPARAM(4) = DH12
      DPARAM(5) = DH22
  260 CONTINUE
      DPARAM(1) = DFLAG
      RETURN
      END


program cj_det

  use amrex_fort_module, only : rt => amrex_real

  use actual_rhs_module
  use eos_type_module
  use eos_module
  use microphysics_module
  use network
  use runtime_init_module
  use probin_module, only: smallx
  use cj_det_module

  implicit none

  type(eos_t) :: eos_state_fuel, eos_state_ash

  real(rt) :: q_burn
  real(rt), parameter :: rho_min_fac = 0.9_rt, rho_max_fac = 10.0_rt
  integer, parameter :: npts_ad = 150

  real(rt) :: rho_min, rho_max, dlogrho, p2_shock, p2_det, D_cj, rho_cj, p_cj, cs_det
  integer :: n
  integer, parameter :: npts = 100

  integer :: lun, istatus

  ! runtime
  call runtime_init(.true.)

  call microphysics_init()

  ! set the unburned (fuel) state
  eos_state_fuel % rho = 1.e7_rt
  eos_state_fuel % T = 1.e8_rt
  eos_state_fuel % xn(:) = smallx
  eos_state_fuel % xn(1) = 1.0_rt - (nspec - 1)*smallx

  call eos(eos_input_rt, eos_state_fuel)

  ! set the ash composition
  eos_state_ash = eos_state_fuel
  eos_state_ash % xn(:) = smallx
  eos_state_ash % xn(nspec) = 1.0_rt - (nspec - 1)*smallx

  ! get the q value -- we need the change in molar fractions
  call ener_gener_rate(eos_state_ash % xn(:)/aion(:) - eos_state_fuel % xn(:)/aion(:), q_burn)

  ! store the shock adiabat and the detonation adiabat
  rho_min = rho_min_fac * eos_state_fuel % rho
  rho_max = rho_max_fac * eos_state_fuel % rho
  dlogrho = (log10(rho_max) - log10(rho_min))/(npts-1)

  ! initial guess
  eos_state_ash % T = eos_state_fuel % T

  ! now let's get the CJ velocity
  call cj_cond(eos_state_fuel, eos_state_ash, q_burn)

  ! we get this from the mass flux: rho_1 v_1 = j
  D_cj = (1.0_rt / eos_state_fuel % rho) * sqrt( &
       (eos_state_ash % p - eos_state_fuel % p) / &
       (1.0_rt/eos_state_fuel % rho - 1.0_rt/eos_state_ash % rho))

  rho_cj = eos_state_ash % rho
  p_cj = eos_state_ash % p

  ! output info along with points on the Hugoniot

  open(newunit=lun, file="hugoniot.txt", status="unknown")

  write(lun, *) "# initial rho = ", eos_state_fuel % rho
  write(lun, *) "# initial p = ", eos_state_fuel % p
  write(lun, *) "# ash rho = ", eos_state_ash % rho
  write(lun, *) "# ash p = ", eos_state_ash % p
  write(lun, *) "# CJ speed = ", D_cj

  ! test
  cs_det = sqrt(eos_state_ash % gam1 * eos_state_ash % p / eos_state_ash % rho)

  ! this checks that the slope of the Rayleigh line is rho_2 * cs_2
  !print *, eos_state_ash % rho * cs_det, eos_state_fuel % rho * D_cj

  do n = 0, npts_ad-1

     eos_state_ash % rho = 10.0_rt**(log10(rho_min) + n*dlogrho)

     call adiabat(eos_state_fuel, eos_state_ash, 0.0_rt, istatus)
     p2_shock = eos_state_ash % p

     if (istatus == -1) then
        exit
     endif

     call adiabat(eos_state_fuel, eos_state_ash, q_burn, istatus)
     p2_det = eos_state_ash % p

     if (istatus == -1) then
        exit
     endif

     write(lun, *) eos_state_ash % rho, p2_shock, p2_det

  enddo

  close(unit=lun)

end program cj_det


      subroutine fill_ip_touched_cells_sg()

      use comparttr   ,  only : n_touched_cells
      use comparttr_sg

      implicit none

      integer icell

      ip_touched_cells_sg(1) = 0
      do icell = 2, n_touched_cells
         ip_touched_cells_sg(icell) =
     1          (nxyz(icell-1,1) *
     2           nxyz(icell-1,2) *
     3           nxyz(icell-1,3))+
     4           ip_touched_cells_sg(icell-1)
      enddo

      n_touched_cells_sg_max =
     1          (nxyz(n_touched_cells,1) *
     2           nxyz(n_touched_cells,2) *
     3           nxyz(n_touched_cells,3))+
     4           ip_touched_cells_sg(n_touched_cells)
      return
      end subroutine fill_ip_touched_cells_sg


program vinay
  integer :: a = 100, b = 20
  integer :: a1 = 100, b1 = 20

  print *, a1 + a - b1  + b *  &
(3 * 4 - (a1 -a) + (b1 + b))
end program vinay


      SUBROUTINE INCLIN(X,V,XCM,VCM,ALPHA)
*
*
*       Inclination of hierarchical system.
*       -----------------------------------
*
      REAL*8  A12,A22,A1A2,FAC,ALPHA
      REAL*8  XCM(3),VCM(3),X(3,3),V(3,3),A0(3),A2(3)
*
*
*       Define inner binary I1 & I2 and outer component I3.
      I1 = 1
      I2 = 2
      I3 = 3
*
*       Evaluate scalar products of angular momenta.
      A12 = 0.0
      A22 = 0.0
      A1A2 = 0.0
      DO 20 K = 1,3
          K1 = K + 1
          IF (K1.GT.3) K1 = 1
          K2 = K1 + 1
          IF (K2.GT.3) K2 = 1
          A0(K) = (X(K1,I1) - X(K1,I2))*(V(K2,I1) - V(K2,I2))
     &          - (X(K2,I1) - X(K2,I2))*(V(K1,I1) - V(K1,I2))
          A2(K) = (X(K1,I3) - XCM(K1))*(V(K2,I3) - VCM(K2))
     &          - (X(K2,I3) - XCM(K2))*(V(K1,I3) - VCM(K1))
          A12 = A12 + A0(K)**2
          A22 = A22 + A2(K)**2
          A1A2 = A1A2 + A0(K)*A2(K)
   20 CONTINUE
*
*       Determine inclination in radians.
      FAC = A1A2/SQRT(A12*A22)
      FAC = MIN(FAC,1.0D0)
      ALPHA = ACOS(FAC)
*
      RETURN
*
      END


      SUBROUTINE powell(p,xi,n,np,ftol,iter,fret)
      INTEGER iter,n,np,NMAX,ITMAX
      REAL fret,ftol,p(np),xi(np,np),func
      EXTERNAL func
      PARAMETER (NMAX=20,ITMAX=200)
CU    USES func,linmin
      INTEGER i,ibig,j
      REAL del,fp,fptt,t,pt(NMAX),ptt(NMAX),xit(NMAX)
      fret=func(p)
      do 11 j=1,n
        pt(j)=p(j)
11    continue
      iter=0
1     iter=iter+1
      fp=fret
      ibig=0
      del=0.
      do 13 i=1,n
        do 12 j=1,n
          xit(j)=xi(j,i)
12      continue
        fptt=fret
        call linmin(p,xit,n,fret)
        if(abs(fptt-fret).gt.del)then
          del=abs(fptt-fret)
          ibig=i
        endif
13    continue
      if(2.*abs(fp-fret).le.ftol*(abs(fp)+abs(fret)))return
      if(iter.eq.ITMAX) pause 'powell exceeding maximum iterations'
      do 14 j=1,n
        ptt(j)=2.*p(j)-pt(j)
        xit(j)=p(j)-pt(j)
        pt(j)=p(j)
14    continue
      fptt=func(ptt)
      if(fptt.ge.fp)goto 1
      t=2.*(fp-2.*fret+fptt)*(fp-fret-del)**2-del*(fp-fptt)**2
      if(t.ge.0.)goto 1
      call linmin(p,xit,n,fret)
      do 15 j=1,n
        xi(j,ibig)=xi(j,n)
        xi(j,n)=xit(j)
15    continue
      goto 1
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/powell.for


SUBROUTINE clawpack46_setaux(maxmx,maxmy,mbc,mx,my, &
           xlower,ylower,dx,dy,maux,aux)

    IMPLICIT NONE
    INTEGER maxmx, maxmy, mbc,mx,my, maux
    DOUBLE PRECISION xlower,ylower, dx, dy
    DOUBLE PRECISION  aux(1-mbc:mx+mbc,1-mbc:my+mbc,maux)

    INTEGER i, j, ibc, jbc
    DOUBLE PRECISION xc, bathy_compete, b, slope, d2xzb

    DO j = 1-mbc,my+mbc
        DO i = 1-mbc,mx+mbc
            xc = xlower + (i-0.5)*dx
            call bathy_complete(xc,b,slope,d2xzb)
            aux(i,j,1) = b
            aux(i,j,2) = slope
            aux(i,j,3) = d2xzb
        end do
    enddo

    return

    do j= 1-mbc,mx+2
        do i = 2-mbc,mx+1
            aux(i,j,2) = (aux(i+1,j,1) - aux(i-1,j,1))/(2.d0*dx)
        END DO
    END DO

    do j= 2-mbc,mx+1
        do i = 1-mbc,mx+2
            aux(i,j,2) = (aux(i,j+1,1) - aux(i,j-1,1))/(2.d0*dx)
            aux(i,j,3) = (aux(i,j+1,i) - 2.d0*aux(i,j,1) + aux(i,j-1,1))/(dx*dx)
        END DO
    END DO

END SUBROUTINE CLAWPACK46_SETAUX