module vallado
! based on http://www.smad.com/vallado/

use assert, only : wp

implicit none
private

  real(wp), parameter :: pi = 4._wp * atan(1.0_wp)

  type,public :: time
     integer :: year, month, day, hour, minute
     real(wp) :: second
  end type

public:: toGST, toJulian, toLST, radec2azel, azel2radec
contains

elemental subroutine azel2radec(az,el,lat,lon,jd, ra,decl)
! convert azimuth, elevation to right ascension, declination
!
! inputs
! ------
! az, el: azimuth, elevation (degrees)
! lat, lon: geodetic latitude, longitude (degrees)
! jd: julian date (decimal)
!
! outputs
! -------
! ra, decl: right ascension, declination (degrees)

  real(wp), value :: az,el,lat,lon
  real(wp), intent(in) :: jd ! Julian Date
  real(wp), intent(out) :: ra, decl

  real(wp) :: lst, lha, sinv, cosv

  az = radians(az)
  el = radians(el)
  lat = radians(lat)
  lon = radians(lon)

  Decl = ASIN(SIN(El)*SIN(lat) + &
              COS(el)*COS(lat)*COS(Az) )

  Sinv = -(SIN(az)*COS(el)*COS(lat)) / &
          (COS(lat)*COS(Decl))

  Cosv = (SIN(el) - SIN(lat)*SIN(decl)) / &
         (COS(lat)*COS(Decl))

  LHA  = ATAN2(Sinv,Cosv)
  lst = toLST(Lon, JD)

  ra = modulo(degrees(LST - LHA), 360._wp)
  decl = degrees(decl)

end subroutine azel2radec

elemental SUBROUTINE radec2azel(ra,Decl,lat,lon,jd, Az,El)
! convert right ascension, declination to azimuth, elevation
!
! inputs
! ------
! ra, decl: right ascension, declination (degrees)
! lat, lon: geodetic latitude, longitude (degrees)
! jd: julian date (decimal)
!
! outputs
! -------
! az, el: azimuth, elevation (degrees)

  REAL(wp), value :: ra,Decl,lat, lon
  real(wp), intent(in) :: jd
  real(wp), intent(out) :: Az,El
  REAL(wp) :: Sinv, Cosv, LHA

  lat = radians(lat)
  lon = radians(lon)
  ra = radians(ra)
  decl = radians(decl)

  LHA = toLST(Lon, JD) - ra

  El = ASIN( SIN(Decl)*SIN(lat) + &
              COS(Decl)*COS(lat)*COS(LHA) )

  Sinv = -SIN(LHA)*COS(Decl)*COS(lat) / &
        (COS(el)*COS(lat))

  Cosv = ( SIN(Decl)-SIN(el)*SIN(lat) ) / &
         (COS(el)*COS(lat))

  Az = modulo(degrees(ATAN2(Sinv,Cosv)), 360._wp)
  el = degrees(el)

END subroutine radec2azel

elemental real(wp) function toLST(Lon, JD) result(LST)
! Julian Date => local sidereal time
!
! inputs
! ------
! lon: geodetic longitude (radians)
! jd: Julian Date (decimal)

  REAL(wp), intent(in) :: Lon, JD

  LST = Lon + toGST(jd)

  LST = modulo(LST, 2*pi )

END function toLST

elemental real(wp) function toJulian(t) result(jd)
! Gregorian date, time => Julian Date
!
! inputs
! ------
! time: Gregorian user-defined type
!
! output
! -----
! JD: Julian Date

  type(time), intent(in) :: t
  real(wp) :: B, y, m

  y = t%year
  m = t%month

  IF ( M <= 2 ) THEN
    Y = y - 1
    M = m + 12
  ENDIF

  B = 2 - INT(Y*0.01_wp) + INT(INT(Y*0.01_wp)*0.25_wp)

  JD= INT( 365.25_wp*(Y + 4716) ) + &
      INT( 30.6001_wp*(M+1) ) + &
      t%day + B - 1524.5_wp + &
      ( (t%second/60.0_wp + t%minute ) / 60.0_wp + t%hour ) / 24.0_wp

END function toJulian

elemental real(wp) FUNCTION toGST(JD) result(GST)
! Julian Date => to Greenwich Sidereal Time
!
! inputs
! ------
! JD: Julian Date (decimal)
!
! output
! ------
! GST: Greenwich Sidereal Time (decimal)

  real(wp), intent(in) :: JD
  real(wp) :: TUT1

  TUT1= ( JD - 2451545._wp ) / 36525._wp
  gst = -6.2e-6_wp*TUT1**3 + &
              0.093104_wp*TUT1**2 + &
             (876600._wp*3600._wp + 8640184.812866_wp)*TUT1 + &
              67310.54841_wp

  gst = modulo(radians(gst) / 240._wp, 2*pi) ! 360/86400 = 1/240, to deg, to rad

end function toGST

elemental real(wp) function degrees(rad)
    real(wp), intent(in) :: rad

    degrees = 180._wp / pi * rad
end function degrees

elemental real(wp) function radians(deg)
    real(wp), intent(in) :: deg

    radians = pi / 180._wp * deg
end function radians

end module


C$Procedure PLTEXP ( Plate expander )

      SUBROUTINE PLTEXP ( IVERTS, DELTA, OVERTS )

C$ Abstract
C
C     Expand a triangular plate by a specified amount. The expanded
C     plate is co-planar with, and has the same orientation as, the
C     original. The centroids of the two plates coincide.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     DSK
C
C$ Keywords
C
C     MATH
C     GEOMETRY
C     TOPOGRAPHY
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      IVERTS ( 3, 3 )
      DOUBLE PRECISION      DELTA
      DOUBLE PRECISION      OVERTS ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     IVERTS     I   Vertices of the plate to be expanded.
C     DELTA      I   Fraction by which the plate is to be expanded.
C     OVERTS     O   Vertices of the expanded plate.
C
C$ Detailed_Input
C
C     IVERTS     is an array containing three vertices of a triangular
C                plate. Each vertex is a three-dimensional vector. The
C                elements
C
C                   IVERTS(J,I), J = 1, 3
C
C                are, respectively, the X, Y, and Z components of the
C                Ith vertex.
C
C
C     DELTA      is a fraction by which the plate is to be scaled.
C                Scaling is done so that the scaled plate has the
C                following properties:
C
C                   -  it is co-planar with the input plate
C
C                   -  its centroid coincides with that of the input
C                      plate
C
C                   -  its sides remain parallel to the corresponding
C                      sides of the input plate
C
C                   -  the distance of each vertex from the centroid is
C                      (1+DELTA) times the corresponding distance for
C                      the input plate
C
C$ Detailed_Output
C
C     OVERTS     is an array containing three vertices of the triangular
C                plate resulting from scaling the input plate.
C
C                If CTROID is the centroid (the average of the vertices)
C                of the input plate, then the Ith vertex of OVERTS
C
C                   OVERTS(J,I), J = 1, 3
C
C                is equal to
C
C                   CTROID(J) + (1+DELTA)*( IVERTS(J,I) - CTROID(J) ),
C
C                   J = 1, 3
C
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine supports "greedy" ray-plate intercept algorithms.
C     Such algorithms attempt to ensure that false negatives---in which
C     an intersection is not found due to round-off error---do not
C     occur. In such an algorithm, the plate of interest is expanded
C     slightly before the intersection test is performed.
C
C$ Examples
C
C     The numerical results shown for these examples may differ across
C     platforms. The results depend on the SPICE kernels used as input
C     (if any), the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     1) Expand an equilateral triangle that lies in the plane
C
C           { (x,y,z) : z = 7 }
C
C        Use an expansion fraction of 1.D0; this doubles the size of
C        the plate.
C
C        Example code begins here.
C
C
C              PROGRAM EX1
C              IMPLICIT NONE
C
C              DOUBLE PRECISION      DELTA
C              DOUBLE PRECISION      IVERTS ( 3, 3 )
C              DOUBLE PRECISION      OVERTS ( 3, 3 )
C              DOUBLE PRECISION      S
C
C              INTEGER               I
C
C              S = SQRT(3.D0)/2
C
C              CALL VPACK (    S,  -0.5D0,  7.D0, IVERTS(1,1) )
C              CALL VPACK ( 0.D0,    1.D0,  7.D0, IVERTS(1,2) )
C              CALL VPACK (   -S,  -0.5D0,  7.D0, IVERTS(1,3) )
C
C              DELTA = 1.D0
C
C              CALL PLTEXP ( IVERTS, DELTA, OVERTS )
C
C              WRITE (*,*) ' '
C              WRITE (*,*) 'Vertices of input plate: '
C
C              WRITE (*, '(1X,A,3(3E20.12))' ) ' I1 = ',
C             .          (IVERTS(I,1), I = 1, 3)
C              WRITE (*, '(1X,A,3(3E20.12))' ) ' I2 = ',
C             .          (IVERTS(I,2), I = 1, 3)
C              WRITE (*, '(1X,A,3(3E20.12))' ) ' I3 = ',
C             .          (IVERTS(I,3), I = 1, 3)
C
C              WRITE (*,*) ' '
C              WRITE (*,*) 'Vertices of output plate: '
C
C              WRITE (*, '(1X,A,3(3E20.12))' ) ' O1 = ',
C             .          (OVERTS(I,1), I = 1, 3)
C              WRITE (*, '(1X,A,3(3E20.12))' ) ' O2 = ',
C             .          (OVERTS(I,2), I = 1, 3)
C              WRITE (*, '(1X,A,3(3E20.12))' ) ' O3 = ',
C             .          (OVERTS(I,3), I = 1, 3)
C              WRITE (*,*) ' '
C              END
C
C
C     When this program was executed on a PC/Linux/gfortran/64-bit
C     platform, the output was:
C
C
C     Vertices of input plate:
C      I1 =   0.866025403784E+00 -0.500000000000E+00  0.700000000000E+01
C      I2 =   0.000000000000E+00  0.100000000000E+01  0.700000000000E+01
C      I3 =  -0.866025403784E+00 -0.500000000000E+00  0.700000000000E+01
C
C     Vertices of output plate:
C      O1 =   0.173205080757E+01 -0.100000000000E+01  0.700000000000E+01
C      O2 =   0.000000000000E+00  0.200000000000E+01  0.700000000000E+01
C      O3 =  -0.173205080757E+01 -0.100000000000E+01  0.700000000000E+01
C
C
C     Note that the height of the plate is unchanged, but the vectors
C     from the centroid to the vertices have doubled in length.
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 29-FEB-2016 (NJB)
C
C        Based on original version 28-MAY-2014 (NJB)
C
C-&

C$ Index_Entries
C
C     expand triangular plate
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      SCLCTR ( 3 )
      DOUBLE PRECISION      D
      DOUBLE PRECISION      S

C
C     Compute the centroid of the input vertices. Scale the centroid
C     by DELTA, since we'll only use the scaled form.
C
C     Unroll all loops to avoid loop overhead.
C
      D = DELTA / 3.D0

      SCLCTR(1) = D * ( IVERTS(1,1) + IVERTS(1,2) + IVERTS(1,3) )
      SCLCTR(2) = D * ( IVERTS(2,1) + IVERTS(2,2) + IVERTS(2,3) )
      SCLCTR(3) = D * ( IVERTS(3,1) + IVERTS(3,2) + IVERTS(3,3) )

C
C     Compute the offsets of the vertices from the centroid CTROID;
C     scale each offset by (1+DELTA). The Ith expanded vertex is
C
C        CTROID + (1+DELTA) * ( IVERTS(*,I) - CTROID )
C
C     which can be re-written as
C
C        ( (1+DELTA) * IVERTS(*,I) )  -  ( DELTA * CTROID )
C
C     or
C
C        ( (1+DELTA) * IVERTS(*,I) )  -  SCLCTR
C
C
C
      S = 1.D0 + DELTA

      OVERTS(1,1) = ( S * IVERTS(1,1) ) - SCLCTR(1)
      OVERTS(2,1) = ( S * IVERTS(2,1) ) - SCLCTR(2)
      OVERTS(3,1) = ( S * IVERTS(3,1) ) - SCLCTR(3)

      OVERTS(1,2) = ( S * IVERTS(1,2) ) - SCLCTR(1)
      OVERTS(2,2) = ( S * IVERTS(2,2) ) - SCLCTR(2)
      OVERTS(3,2) = ( S * IVERTS(3,2) ) - SCLCTR(3)

      OVERTS(1,3) = ( S * IVERTS(1,3) ) - SCLCTR(1)
      OVERTS(2,3) = ( S * IVERTS(2,3) ) - SCLCTR(2)
      OVERTS(3,3) = ( S * IVERTS(3,3) ) - SCLCTR(3)

      END


Let Nat = forall A. (A -> A) -> A -> A in
let Z: Nat = Lambda A. lambda f: A -> A. lambda x: A. x in
let S: Nat -> Nat = lambda n: Nat. Lambda A. lambda f: A -> A. lambda x: A. f (n [A] f x) in
let add: Nat -> Nat -> Nat = lambda n: Nat. lambda m: Nat. n [Nat] S m in
let mult: Nat -> Nat -> Nat = lambda n: Nat. lambda m: Nat. n [Nat] (add m) Z in
let two: Nat = mult (S Z) (S (S Z)) in
two


        SUBROUTINE FBRUS(N,X,Y,F,RPAR,IPAR)
C ------ BRUSSELATOR WITH DIFFUSION IN D2 ----
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        COMMON /COUNT / NFCN
        COMMON/TRANS/ALF,NS,NSSQ,NSNSM1,NSM1SQ
        NFCN=NFCN+1
C ---- CONSTANTS FOR INHOMOGENITY ---
        ANS=NS
        RADSQ=0.1D0**2
        IF(X.GE.1.1D0)THEN
         BET=5.00D0
        ELSE
         BET=0.00D0
        END IF
C ------- GRANDE BOUCLE -----
      DO I=1,NSSQ
C ------- LEFT NEIGHBOUR ---
         IF(MOD(I,NS).EQ.1)THEN
            ULEFT=Y(I+NS-1)
            VLEFT=Y(NSSQ+I+NS-1)
         ELSE
            ULEFT=Y(I-1)
            VLEFT=Y(NSSQ+I-1)
         END IF
C ------- RIGHT NEIGHBOUR ---
         IF(MOD(I,NS).EQ.0)THEN
            URIGHT=Y(I-NS+1)
            VRIGHT=Y(NSSQ+I-NS+1)
         ELSE
            URIGHT=Y(I+1)
            VRIGHT=Y(NSSQ+I+1)
         END IF
C ------- LOWER NEIGHBOUR ---
         IF(I.LE.NS)THEN
            ULOW=Y(I+NSNSM1)
            VLOW=Y(NSSQ+I+NSNSM1)
         ELSE
            ULOW=Y(I-NS)
            VLOW=Y(NSSQ+I-NS)
         END IF
C ------- UPPER NEIGHBOUR ---
         IF(I.GT.NSNSM1)THEN
            UUP=Y(I-NSNSM1)
            VUP=Y(NSSQ+I-NSNSM1)
         ELSE
            UUP=Y(I+NS)
            VUP=Y(NSSQ+I+NS)
         END IF
C ------ LA DERIVEE --------
         UIJ=Y(I)
         VIJ=Y(I+NSSQ)
         F(I)=1.D0+UIJ*UIJ*VIJ-4.4D0*UIJ
     &        +ALF*NSSQ*(ULEFT+URIGHT+ULOW+UUP-4.D0*UIJ)
         F(I+NSSQ)=3.4D0*UIJ - UIJ*UIJ*VIJ
     &        +ALF*NSSQ*(VLEFT+VRIGHT+VLOW+VUP-4.D0*VIJ)
C ----- INHOMOGENITE ----
         IY=(I-1)/NS+1
         IX=I-(IY-1)*NS
         YY=IY/ANS
         XX=IX/ANS
         IF(((XX-0.3D0)**2+(YY-0.6D0)**2).LE.RADSQ)THEN
           F(I)=F(I)+BET
         END IF
      END DO
      RETURN
      END
C
        SUBROUTINE JBRUS(N,X,Y,DFY,LDFY,RPAR,IPAR)
C --- IN THE CASE THAT  DC_DECSOL_2D.F  IS USED, NO JACOBIAN
C --- HAS TO BE SPECIFIED. THEREFORE THIS DUMMY SUBROUTINE
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION Y(N),DFY(LDFY,N)
c
          return
c
        END
C
        SUBROUTINE JBRUSF(N,X,Y,DFY,LDFY,RPAR,IPAR)
C --- JACOBIAN OF BRUSS-2D (FULL)
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION Y(N),DFY(LDFY,N)
        COMMON/TRANS/ALF,NS,NSSQ,NSNSM1,NSM1SQ
        FAC=ALF*NSSQ
         DO I=1,N
            DO J=1,N
               DFY(I,J)=0.0D0
            END DO
            DFY(I,I)=-FAC*4.0D0
         END DO
         DO I=1,N
            IL=I-1
            IF (MOD(I,NS).EQ.1) IL=I-1+NS
            DFY(I,IL)=FAC
            IR=I+1
            IF (MOD(I,NS).EQ.0) IR=I+1-NS
            DFY(I,IR)=FAC
            IU=I+NS
            IF (I.GT.NS*(NS-1).AND.I.LE.NS*NS) IU=I-NS*(NS-1)
            IF (I.GT.NS*(2*NS-1)) IU=I-NS*(NS-1)
            DFY(I,IU)=FAC
            ID=I-NS
            IF (I.LE.NS) ID=I+NS*(NS-1)
            IF (I.LE.NS*(NS+1).AND.I.GT.NS*NS) ID=I+NS*(NS-1)
            DFY(I,ID)=FAC
         END DO
      RETURN
      END


module equation_solvers
  use utils, only: fp,ip
  !use hamiltonians ! To fix compilation bug with fclass
  use fclass

  abstract interface
     subroutine nonlin_solver(f,x0,x,tol_in,maxiter_in,status,dx_in)
       use fclass
       use utils
       implicit none
       class(fd),intent(in) :: f
       complex(fp), dimension(:),intent(in) :: x0
       complex(fp), dimension(:),intent(out) :: x
       real(fp),optional,intent(in) :: tol_in
       integer(ip),optional,intent(in) :: maxiter_in
       integer(ip),optional,intent(out) :: status
       real(fp),optional,intent(in) :: dx_in
     end subroutine nonlin_solver
  end interface
contains
  ! Solves the equation f(x) - x = 0, i.e. it does not have the standard form.
  subroutine picard_iteration(f,x0,x,tol_in,maxiter_in,status,dx_in)
    implicit none
    class(fd),intent(in) :: f
    complex(fp), dimension(:),intent(in) :: x0
    complex(fp), dimension(size(x0)),intent(out) :: x
    real(fp),optional,intent(in) :: tol_in
    integer(ip),optional,intent(in) :: maxiter_in
    real(fp) :: delta,tol
    complex(fp),dimension(size(x0)) :: xn
    integer(ip) :: maxiter,niter
    integer(ip),optional,intent(out) :: status
    integer(ip) :: status_temp
    real(fp),optional,intent(in) :: dx_in

    if(present(tol_in)) then
       tol = tol_in
    else
       tol = 1.0_fp
    end if

    if(present(maxiter_in)) then
       maxiter = maxiter_in
    else
       maxiter = 5000
    end if

    delta = huge(1.0_fp)
    xn = x0
    x = xn
    niter = 0

    do
       if(delta < tol) then
          !write(*,*) 'niter', niter,', delta',delta
          status_temp = 0
          exit ! We are done
       end if
       if(niter > maxiter) then
          !write(*,*) 'Warning, maximum number of iterations reached in picard solver. Required tolerance not reached.'
          status_temp = 1
          exit
       endif
       call f%value_at(0.0_fp,xn,x)
       delta = real(sqrt(sum((x - xn)*conjg(x-xn))))
       xn = x
       niter = niter+1
    end do
    if(present(status)) then
       status = status_temp
    end if
  end subroutine picard_iteration
!------------------------------------------------------------!
  subroutine quasi_newton(f,x0,x,tol_in,maxiter_in,status,dx_in)
    use linfuncs
    implicit none
    class(fd),intent(in) :: f
    complex(fp), dimension(:),intent(in) :: x0
    complex(fp), dimension(size(x0)),intent(out) :: x
    real(fp),optional,intent(in) :: tol_in
    integer(ip),optional,intent(in) :: maxiter_in
    real(fp),optional,intent(in) :: dx_in
    integer(ip),optional,intent(out) :: status
    real(fp) :: delta,tol,dx
    complex(fp),dimension(size(x0)) :: xn
    integer(ip) :: maxiter,niter
    integer(ip) :: status_temp,status_dgesv
    real(fp),dimension(2*size(x0),2*size(x0)) :: J
    real(fp),dimension(2*size(x0)) :: b
    real(fp),dimension(2*size(x0)) :: bt
    complex(fp),dimension(size(x0)) :: fx
    integer(ip),dimension(2*size(x0)) :: ipiv

    if(present(tol_in)) then
       tol = tol_in
    else
       tol = 1.0_fp
    end if

    if(present(maxiter_in)) then
       maxiter = maxiter_in
    else
       maxiter = 100
    end if

    if(present(dx_in)) then
       dx = dx_in
    else
       dx = 0.1_fp
    endif

    xn = x0
    x = x0

    delta = huge(1.0_fp)
    niter = 0
    do
       if(delta < tol) then
          !write(*,*) 'niter', niter,', delta',delta
          status_temp = 0
          exit ! We are done
       end if

       if(niter > maxiter) then
          write(*,*) 'Warning, maximum number of iterations reached in quasi newton. Required tolerance not reached.'
          !write(*,*) 'niter', niter,', delta',delta
          status_temp = 1
          exit
       endif
       call f%value_at(0.0_fp,xn,fx)
       b(1:size(x0)) = -real(fx)
       b((size(x0)+1):(2*size(x0))) = -aimag(fx)
       bt = b
       J = jacobian_approximation_complex(f,x,dx)
       !SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
       call dgesv(size(2*x0),1,J,size(2*x0),ipiv,b,size(2*x0),status_dgesv)
       !write(*,*) b
       if(status_dgesv .ne. 0) then
          status_temp = 2
          write(*,*) 'dgesv could not find solution to the system of equations in quasi-newton. Status:', status_dgesv
          !call print_matrix(J)
          !write(*,*) b
          exit
       endif
       x = xn + b(1:size(x0)) + (0.0_fp,1.0_fp)*b((1+size(x0)):(2*size(x0)))
       !delta = real(sqrt(sum((x - xn)*conjg(x-xn))))
       delta = sqrt(sum((matmul(J,b) - bt)**2))
       xn = x
       niter = niter+1
       !call print_matrix(J)
       write(*,*) delta
       write(*,*) b
       !write(*,*) x
    end do
    if(present(status)) then
       status = status_temp
    end if
end subroutine quasi_newton
!------------------------------------------------------------!
subroutine quasi_newton_real(f,x0,x,tol_in,maxiter_in,status,dx_in)
  use linfuncs
  implicit none
  class(fd),intent(in) :: f
  complex(fp), dimension(:),intent(in) :: x0
  complex(fp), dimension(size(x0)),intent(out) :: x
  real(fp),optional,intent(in) :: tol_in
  integer(ip),optional,intent(in) :: maxiter_in
  real(fp),optional,intent(in) :: dx_in
  integer(ip),optional,intent(out) :: status
  real(fp) :: delta,tol,dx
  complex(fp),dimension(size(x0)) :: xn
  integer(ip) :: maxiter,niter
  integer(ip) :: status_temp,status_dgesv
  real(fp),dimension(size(x0),size(x0)) :: J
  real(fp),dimension(size(x0)) :: b
  real(fp),dimension(size(x0)) :: bt
  complex(fp),dimension(size(x0)) :: fx
  integer(ip),dimension(size(x0)) :: ipiv

  if(present(tol_in)) then
       tol = tol_in
    else
       tol = 1.0_fp
    end if

    if(present(maxiter_in)) then
       maxiter = maxiter_in
    else
       maxiter = 100
    end if

    if(present(dx_in)) then
       dx = dx_in
    else
       dx = 0.1_fp
    endif

    xn = x0
    x = x0

    delta = huge(1.0_fp)
    niter = 0
    do
       if(delta < tol) then
          !write(*,*) 'niter', niter,', delta',delta
          status_temp = 0
          exit ! We are done
       end if

       if(niter > maxiter) then
          write(*,*) 'Warning, maximum number of iterations reached in quasi-newton. Required tolerance not reached.'
          !write(*,*) 'niter', niter,', delta',delta
          status_temp = 1
          exit
       endif
       call f%value_at(0.0_fp,xn,fx)
       b = -real(fx)
       !write(*,*) 'b:', b
       !b((size(x0)+1):(2*size(x0))) = -aimag(fx)
       bt = b ! need a copy because dgesv destroys the original b
       call jacobian_approximation_real(f,x,dx,J)
       !call print_matrix(J)
       !SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
       call dgesv(size(x0),1,J,size(x0),ipiv,b,size(x0),status_dgesv)
       !write(*,*) 'dgesv result:', b
       if(status_dgesv .ne. 0) then
          status_temp = 2
          write(*,*) 'dgesv could not find solution to the system of equations in quasi-newton. Status:', status_dgesv
          !call print_matrix(J)
          !write(*,*) b
          exit
       endif
       x = xn + b
       !delta = real(sqrt(sum((x - xn)*conjg(x-xn))))
       delta =sum(real(b)**2)
       !delta = sqrt(sum((matmul(J,b) - bt)**2))

       xn = x
       niter = niter+1
       !write(*,*) 'niter',niter
       !call print_matrix(J)
       !write(*,*) delta
       !write(*,*) b
       !write(*,*) x
    end do
    if(present(status)) then
       status = status_temp
    end if
  end subroutine quasi_newton_real
!------------------------------------------------------------!
subroutine spectral_real(f,x0,x,tol_in,maxiter_in,status,dx_in)
  use linfuncs
  implicit none
  class(fd),intent(in) :: f
  complex(fp), dimension(:),intent(in) :: x0
  complex(fp), dimension(:),intent(out) :: x
  real(fp),optional,intent(in) :: tol_in
  integer(ip),optional,intent(in) :: maxiter_in
  real(fp),optional,intent(in) :: dx_in
  integer(ip),optional,intent(out) :: status
  real(fp) :: delta,tol,dx
  integer(ip) :: maxiter,niter,status_temp
  complex(fp),dimension(size(x0)) :: xn,sn
  complex(fp),dimension(size(x0)) :: fn,yn,fn1
  real(fp) :: alpha
  integer(ip) :: c1,c2

  if(present(tol_in)) then
     tol = tol_in
  else
     tol = 1.0_fp
  end if

  if(present(maxiter_in)) then
     maxiter = maxiter_in
  else
     maxiter = 100
  end if

  if(present(dx_in)) then
     dx = dx_in
  else
     dx = 0.1_fp
  endif

  xn = x0
  x = x0

  !write(*,*) 'x0', x0
  delta = huge(1.0_fp)
  niter = 0

  do
     !call system_clock(c1)
     if(niter .eq. 0) then
        call f%value_at(0.0_fp,xn,fn1)
        alpha = min(1.0_fp,1.0_fp/sqrt(real(sum(conjg(fn1)*fn1))))
        if(isnan(alpha)) then
           delta = 0.0_fp ! sum(fn* *fn) = 0
        endif

        !write(*,*) 'x0',x0
        !write(*,*) 'fn1',fn1
     end if

      if(delta < tol) then
         status_temp = 0
         write(*,*) 'niter', niter,', delta',delta
         exit ! we are done
      end if

      if(niter > maxiter) then
         write(*,*) 'Warning, maximum number of iterations reached in spectral solver. Required tolerance not reached.'
         status_temp = 1
         exit
      endif

      x = xn - alpha*fn1
      delta = sqrt(real(sum(conjg(fn1)*fn1)))

      sn = x - xn

      xn = x
      fn = fn1

      call f%value_at(0.0_fp,x,fn1)
      yn = fn1 - fn
      alpha = real(sum(conjg(sn)*sn))/real(sum(conjg(sn)*yn))
      !alpha = real(sum(conjg(sn)*yn))/real(sum(conjg(yn)*yn))
      niter = niter + 1
      !write(*,*) 'niter', niter,', delta',delta,', alpha',alpha
      ! write(*,*) 'sn^T*sn',real(sum(conjg(sn)*sn)), ', sn^T*yn', real(sum(conjg(sn)*yn))
      ! write(*,*) 'x',x
      ! write(*,*) 'fn1',fn1
      !call system_clock(c2)
      !write(*,*) 'Duration of one iteration in spectral_real',c2-c1,'ms.'
   end do
    if(present(status)) then
       status = status_temp
    end if
end subroutine spectral_real
!------------------------------------------------------------!
! Finds the roots of equation f(x) = 0 by using the quasi-newton method, by approximating the Jacobian using the Broyden formula. The Jacobian is not fully calculated, but it is updated during every iteration. Consumes more memory than the spectral method.
subroutine broyden_real(f,x0,x,tol_in,maxiter_in,status,dx_in)
  use linfuncs
  implicit none
  class(fd),intent(in) :: f
  complex(fp), dimension(:),intent(in) :: x0
  complex(fp), dimension(size(x0)),intent(out) :: x
  real(fp),optional,intent(in) :: tol_in
  integer(ip),optional,intent(in) :: maxiter_in
  real(fp),optional,intent(in) :: dx_in
  integer(ip),optional,intent(out) :: status
  real(fp) :: delta,tol,dx,delta_x
  integer(ip) :: maxiter,niter,status_temp,status_dgesv
  complex(fp),dimension(size(x0)) :: xn
  complex(fp),dimension(size(x0)) :: fn,fn1
  real(fp),dimension(size(x0),size(x0)) :: J,Jt
  real(fp),dimension(size(x0)) :: bn
  integer(ip),dimension(size(x0)) :: ipiv
  integer(ip) :: c1,c2

  if(present(tol_in)) then
     tol = tol_in
  else
     tol = 1.0_fp
  end if

  if(present(maxiter_in)) then
     maxiter = maxiter_in
  else
     maxiter = 100
  end if

  if(present(dx_in)) then
     dx = dx_in
  else
     dx = 0.1_fp
  endif

  xn = x0
  x = x0

  !write(*,*) 'x0', x0
  delta = huge(1.0_fp)
  niter = 0

  !J = get_eye(size(x0))
  call jacobian_diagonal_real(f,xn,dx,J)
  call f%value_at(0.0_fp,xn,fn)
  !call print_matrix(J)
  !bn = -real(fn)
  delta = sqrt(sum(bn*bn))

  do
     if(delta < tol) then
        write(*,*) 'niter', niter,', delta',delta
        status_temp = 0
        exit ! We are done
     end if
     if(niter > maxiter) then
        write(*,*) 'Warning, maximum number of iterations reached in quasi-newton. Required tolerance not reached.'
        !write(*,*) 'niter', niter,', delta',delta
        status_temp = 1
        exit
     endif
     !write(*,*) 'niter', niter,', delta',delta
     Jt = J
     bn = -real(fn)
     call dgesv(size(x0),1,Jt,size(x0),ipiv,bn,size(x0),status_dgesv)
     if(status_dgesv .ne. 0) then
        status_temp = 2
        write(*,*) 'dgesv could not find solution to the system of equations in quasi-newton. Status:', status_dgesv
        !call print_matrix(J)
        !write(*,*) bn
        exit
     endif

     x = xn + bn
     call f%value_at(0.0_fp,x,fn1)
     !write(*,*) 'J before'
     !call print_matrix(J)
     !write(*,*) 'addition'
     !call print_matrix(matmul(reshape(fn1 - fn - matmul(J,bn),[size(x0),1]),reshape(bn,[1,size(x0)]))/sum(bn**2))
     !write(*,*) 'sum bn',sum(bn**2)
     J = J + matmul(reshape(fn1 - fn - matmul(J,bn),[size(x0),1]),reshape(bn,[1,size(x0)]))/sum(bn**2)
     !write(*,*) 'J after'
     !call print_matrix(J)
     !write(*,*) 'bn',bn
     !write(*,*) 'fn1',fn1
     !write(*,*) 'fn',fn
     !write(*,*) 'fn1-fn - J*bn',reshape(fn1 - fn - matmul(J,bn),[size(x0),1])
     !write(*,*) 'bn^T',reshape(bn,[1,size(x0)])
     delta = sqrt(real(sum(conjg(fn1)*fn1)))
     !delta_x = sqrt(sum(bn*bn))
     !write(*,*) bn
     !write(*,*) x
     fn = fn1
     xn = x
     niter = niter+1
     !call print_matrix(J)
     !write(*,*) 'x:',x
     !write(*,*) 'bn',bn
     !write(*,*) 'J:'
     !call print_matrix(J)
  end do
  if(present(status)) then
     status = status_temp
  end if
end subroutine broyden_real

  !#############################################
  ! This function calculates the Jacobian of the given function at x using dx as the step in difference. Works only for time independent functions f.
function jacobian_approximation_complex(f,x,dx) result(J)
  use linfuncs
  use fclass
  implicit none
  class(fd),intent(in) :: f
  complex(fp),dimension(:),intent(in) :: x
  real(fp),intent(in) :: dx
  real(fp),dimension(size(x)*2,size(x)*2) :: J
  integer(ip) :: ii,jj,nn,kk
  complex(fp),dimension(size(x)) :: fxdx,fx
  complex(fp),dimension(size(x)) :: zv
  J = 0.0_fp
  nn = size(x)
  call f%value_at(0.0_fp,x,fx) ! Makes the calculation at t=0
  !write(*,*) 'fx:',fx
  do ii=1,nn
     do jj=1,2
        zv = (0.0_fp,0.0_fp) ! This is not very efficient
        zv(ii) = (0.0_fp,1.0_fp)**(jj-1)*dx
        write(*,*) 'zv(ii):',zv(ii)
        call f%value_at(0.0_fp,x+zv,fxdx)

        !write(*,*) 'fxdx:',fxdx
        ! Calculates the difference, and takes either the real or the imaginary part of it.
        fxdx = (fxdx - fx)/dx
        !J(((nn*(jj-1)+1)):(nn*jj),ii) = real((0.0_fp,1.0_fp)**(jj-1)*(fxdx - fx)/dx)
        J(((nn*(jj-1)+1)):(nn*jj),ii) = real(fxdx)
        J(((nn*(jj-1)+1)):(nn*jj),nn+ii) = aimag(fxdx)

        if(jj .eq. 1) then
           write(*,*) 'Changing the ',ii,':th real element. The effect is:'
             do kk=1,nn
                write(*,*) real(fxdx(kk)) + (0.0_fp,1.0_fp)*aimag(fxdx(kk))
             end do

          else
             write(*,*) 'Changing the ',ii,':th imag element. The effect is:'
             do kk=1,nn
                write(*,*) real(fxdx(kk)) + (0.0_fp,1.0_fp)*aimag(fxdx(kk))
             end do
          endif
          !call print_matrix(J)
          !write(*,*) (0.0_fp,1.0_fp)**(jj-1)*(fxdx - fx)/dx
          !write(*,*) ((nn*(jj-1)+1)), ':',(nn*jj)
          !call print_matrix(J)
       end do
    end do
  end function jacobian_approximation_complex
  !#############################################
  subroutine jacobian_approximation_real(f,x,dx,J)
    use linfuncs
    use fclass
    implicit none
    class(fd),intent(in) :: f
    complex(fp),dimension(:),intent(in) :: x
    real(fp),intent(in) :: dx
    real(fp),dimension(size(x),size(x)),intent(out) :: J
    integer(ip) :: ii,jj,nn,kk
    complex(fp),dimension(size(x)) :: fxdx,fx
    complex(fp),dimension(size(x)) :: zv
    J = 0.0_fp
    nn = size(x)
    !write(*,*) 'Entering function.'
    call f%value_at(0.0_fp,x,fx) ! Makes the calculation at t=0
    !write(*,*) 'x',x
    !write(*,*) 'fx:',fx
    do ii=1,nn
       zv = (0.0_fp,0.0_fp) ! This is not very efficient
       zv(ii) = dx
       !write(*,*) 'zv(ii):',zv(ii)
       !write(*,*) 'x+zv',x+zv
       call f%value_at(0.0_fp,x+zv,fxdx)

       !write(*,*) 'fxdx:',fxdx
       ! Calculates the difference, and takes either the real or the imaginary part of it.
       fxdx = (fxdx - fx)/dx
       !write(*,*) 'fxdx',real(fxdx)
       !J(((nn*(jj-1)+1)):(nn*jj),ii) = real((0.0_fp,1.0_fp)**(jj-1)*(fxdx - fx)/dx)
       J(:,ii) = real(fxdx)
       !write(*,*) 'J(:,ii)',J(:,ii)
       ! write(*,*) 'Changing the ',ii,':th real element. The effect is:'
       ! do kk=1,nn
       !    write(*,*) real(fxdx(kk))
       ! end do

       !call print_matrix(J)
       !write(*,*) (0.0_fp,1.0_fp)**(jj-1)*(fxdx - fx)/dx
       !write(*,*) ((nn*(jj-1)+1)), ':',(nn*jj)
    end do
  end subroutine jacobian_approximation_real

  !#############################################
  subroutine jacobian_diagonal_real(f,x,dx,J)
    use linfuncs
    use fclass
    implicit none
    class(fd),intent(in) :: f
    complex(fp),dimension(:),intent(in) :: x
    real(fp),intent(in) :: dx
    real(fp),dimension(size(x),size(x)),intent(out) :: J
    integer(ip) :: nn,ii
    complex(fp),dimension(size(x)) :: fx,fxdx
    complex(fp),dimension(size(x)) :: zv

    !zv = (0.0_fp,0.0_fp)
    nn = size(x)
    J = 0.0_fp
    call f%value_at(0.0_fp,x,fx) ! Makes the calculation at t=0
    zv = dx
    call f%value_at(0.0_fp,x+zv,fxdx)

    !write(*,*) 'fxdx:',fxdx
    ! Calculates the difference, and takes either the real or the imaginary part of it.
    fxdx = (fxdx - fx)/dx
    !write(*,*) 'fxdx',real(fxdx)
    do ii=1,nn
       J(ii,ii) = real(fxdx(ii))
    end do
  end subroutine jacobian_diagonal_real

end module equation_solvers


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZARCG33 (Zomplex Auxiliary Routine Compute Givens generators 3->3)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the generator for a Givens rotation represented
! by 3 real numbers: the real and imaginary parts of a complex cosine
! and a scrictly real sine. The first column is constructed to be
! parallel with the complex vector [A,B]^T. The (3->3) refers to the
! 3 double inputs and 3 double outputs (excluding the norm).
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  AR, AI          REAL(8)
!                    real and imaginary part of the first component
!                    of the complex vector [A,B]^T
!
!  B               REAL(8)
!                    the second component of the complex vector [A,B]^T
!
! OUTPUT VARIABLES:
!
!  CR, CI          REAL(8)
!                    on exit contAIns the generators for the cosine
!                    component of the Givens rotation
!
!  S               REAL(8)
!                    on exit contAIns the generators for the sine
!                    component of the Givens rotation
!
!  NRM             REAL(8)
!                    on exit contAIns the norm of the vector [A,B]^T
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies AR is invalid
!                    INFO = -2 implies AI is invalid
!                    INFO = -3 implies B is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZARCG33(AR,AI,B,CR,CI,S,NRM,INFO)

  implicit none

  ! input variables
  integer, intent(inout) :: INFO
  real(8), intent(in) :: AR, AI, B
  real(8), intent(inout) :: CR, CI, S, NRM

  ! compute variables
  real(8) :: tar, tai, tb
  real(8) :: nar, nai, nb
  real(8), parameter :: tol = epsilon(1d0)

  ! initialize INFO
  INFO = 0

  ! check error in debug mode
  if (DEBUG) then

    ! check AR
    call DARNAN(AR,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"AR is invalid",INFO,-1)
      return
    end if
    call DARINF(AR,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"AR is invalid",INFO,-1)
      return
    end if

    ! check AI
    call DARNAN(AI,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"AI is invalid",INFO,-2)
      return
    end if
    call DARINF(AI,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"AI is invalid",INFO,-2)
      return
    end if

    ! check B
    call DARNAN(B,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"B is invalid",INFO,-3)
      return
    end if
    call DARINF(B,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"B is invalid",INFO,-3)
      return
    end if

  end if

  ! set local variables
  nar = abs(AR)
  nai = abs(AI)
  nb = abs(B)
  NRM = 1d0

  if(nar.EQ.0 .AND. nai.EQ.0 .AND. nb.EQ.0)then
    CR = 1d0
    CI = 0d0
    S = 0d0
    NRM = 0d0
  else if(nb.EQ.0 .AND. nar > nai)then
    tai = AI/AR
    NRM = sqrt(1d0 + tai*tai)
    if(AR < 0)then
      CR = -1d0/NRM
      CI = tai*CR
      S = 0d0
      NRM = -AR*NRM
    else
      CR = 1d0/NRM
      CI = tai*CR
      S = 0d0
      NRM = AR*NRM
    end if
  else if(nb.EQ.0)then
    tar = AR/AI
    NRM = sqrt(1d0 + tar*tar)
    if(AI < 0)then
      CI = -1d0/NRM
      CR = tar*CI
      S = 0d0
      NRM = -AI*NRM
    else
      CI = 1d0/NRM
      CR = tar*CI
      S = 0d0
      NRM = AI*NRM
    end if
  else if(nar >= nb .AND. nar >= nai)then
    tb = B/AR
    tai = AI/AR
    NRM = sqrt(1d0 + tb*tb + tai*tai)
    if(AR < 0)then
      CR = -1d0/NRM
      CI = tai*CR
      S = tb*CR
      NRM = -AR*NRM
    else
      CR = 1d0/NRM
      CI = tai*CR
      S = tb*CR
      NRM = AR*NRM
    end if
  else if(nai >= nb .AND. nai >= nar)then
    tb = B/AI
    tar = AR/AI
    NRM = sqrt(1d0 + tb*tb + tar*tar)
    if(AI < 0)then
      CI = -1d0/NRM
      CR = tar*CI
      S = tb*CI
      NRM = -AI*NRM
    else
      CI = 1d0/NRM
      CR = tar*CI
      S = tb*CI
      NRM = AI*NRM
    end if
  else
    tar = AR/B
    tai = AI/B
    NRM = sqrt(1d0 + tai*tai + tar*tar)
    if(B < 0)then
      S = -1d0/NRM
      CR = tar*S
      CI = tai*S
      NRM = -B*NRM
    else
      S = 1d0/NRM
      CR = tar*S
      CI = tai*S
      NRM = B*NRM
    end if
  end if

end subroutine ZARCG33


! =====================================================================
! subroutine VSHO
!
! This subroutine constructs a simple harmonic oscillator potential.
! ---------------------------------------------------------------------
      subroutine VSHO(nRP,nR,nP,x0,y0,kX,kY,R,P,V)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: x0
      double precision :: y0
      double precision :: kX
      double precision :: kY
      double precision :: R(nR)
      double precision :: P(nP)
      double precision :: V(nRP)

      integer :: i
      integer :: j
      integer :: k

      k = 0
      do j = 1, nP
         do i = 1, nR
            k = k + 1
            V(k) = 0.5d0*(kX*(R(i)*dcos(P(j))-x0))**2
            V(k) = V(k) + 0.5d0*(kY*(R(i)*dsin(P(j))-y0))**2
         enddo
      enddo

      return
      end
! =====================================================================


      PROGRAM CALCULATE	!A distance, with error propagation.
      REAL X1, Y1, X2, Y2	!The co-ordinates.
      REAL X1E,Y1E,X2E,Y2E	!Their standard deviation.
      DATA X1, Y1 ,X2, Y2 /100., 50., 200.,100./	!Specified
      DATA X1E,Y1E,X2E,Y2E/  1.1, 1.2,  2.2, 2.3/	!Values.
      REAL DX,DY,D2,D,DXE,DYE,E	!Assistants.
      CHARACTER*1 C			!I'm stuck with code page 437 instead of 850.
      PARAMETER (C = CHAR(241))		!Thus ± does not yield this glyph on a "console" screen. CHAR(241) does.
      REAL SD	!This is an arithmetic statement function.
      SD(X,P,S) = P*ABS(X)**(P - 1)*S	!SD for X**P where SD of X is S
      WRITE (6,1) X1,C,X1E,Y1,C,Y1E,	!Reveal the points
     1            X2,C,X2E,Y2,C,Y2E	!Though one could have used an array...
    1 FORMAT ("Euclidean distance between two points:"/	!A heading.
     1 ("(",F5.1,A1,F3.1,",",F5.1,A1,F3.1,")"))		!Thus, One point per line.
      DX = (X1 - X2)			!X difference.
      DXE = SQRT(X1E**2 + X2E**2)	!SD for DX, a simple difference.
      DY = (Y1 - Y2)			!Y difference.
      DYE = SQRT(Y1E**2 + Y2E**2)	!SD for DY, (Y1 - Y2)
      D2 = DX**2 + DY**2		!The distance, squared.
      DXE = SD(DX,2,DXE)		!SD for DX**2
      DYE = SD(DY,2,DYE)		!SD for DY**2
      E = SQRT(DXE**2 + DYE**2)		!SD for their sum
      D = SQRT(D2)			!The distance!
      E = SD(D2,0.5,E)			!SD after the SQRT.
      WRITE (6,2) D,C,E			!Ahh, the relief.
    2 FORMAT ("Distance",F6.1,A1,F4.2)	!Sizes to fit the example.
      END	!Enough.


module cosine_zenith

contains

subroutine calc_cosine_zenith(now_time, im, latitude, longitude, cosz, julian)

use machine , only : kind_phys
use time_utilities

implicit none

double precision    :: now_time, sec_since
integer             :: im
real, dimension(im) :: latitude, longitude
real(kind=kind_phys), dimension(im) :: cosz
real(kind=kind_phys)                :: julian
real                :: obecl, sinob, sxlong, arg, tloctim, hrang, declin
integer             :: ihour, iminute, isecond, iloc
character*19        :: now_date  ! format: yyyy-mm-dd hh:nn:ss

real, parameter :: degrad = 3.14159265/180.
real, parameter :: dpd    = 360./365.

call date_from_since("1970-01-01 00:00:00", now_time, now_date)

call calc_sec_since(now_date(1:4)//"-01-01 00:00:00", now_date, 0, sec_since)

read(now_date(12:13), *) ihour
read(now_date(15:16), *) iminute
read(now_date(18:19), *) isecond

julian = sec_since/86400.0

!-----obecl : obliquity = 23.5 degree.

obecl = 23.5*degrad
sinob = sin(obecl)

!-----calculate longitude of the sun from vernal equinox:

if(julian >= 80.) sxlong = dpd*(julian -80.)*degrad
if(julian <  80.) sxlong = dpd*(julian+285.)*degrad
arg = sinob*sin(sxlong)
declin = asin(arg)

do iloc = 1, im
  tloctim = real(ihour) + real(iminute)/60.0 + real(isecond)/3600.0 + longitude(iloc)/15.0 ! local time in hours
  tloctim = amod(tloctim+24.0, 24.0)
  hrang = 15.*(tloctim-12.)*degrad
  cosz(iloc) = sin(latitude(iloc)*degrad)*sin(declin)+cos(latitude(iloc)*degrad)*cos(declin)*cos(hrang)
end do

end subroutine calc_cosine_zenith

end module cosine_zenith


program matrix_products
    implicit none

    interface
        subroutine mat_mul_1(mat_a,mat_b,mat_c,debug)
            real*8, intent(out):: mat_c(:,:)
            real*8, intent(in):: mat_a(:,:), mat_b(:,:)
            logical:: debug
        end subroutine
    end interface

    interface
        subroutine mat_mul_2(mat_a,mat_b,mat_c,debug)
            real*8, intent(out):: mat_c(:,:)
            real*8, intent(in):: mat_a(:,:), mat_b(:,:)
            logical:: debug
        end subroutine
    end interface

    real*8, allocatable :: A(:,:), B(:,:), C(:,:), D(:,:), E(:,:)
    integer*4 :: iterations, min_N, max_N, ii, jj, kk = 1, errors, slice_size = 5
    real*4 :: start, finish
    real*4, allocatable :: timing(:,:)
    logical :: write_every_n = .False., debug = .False.

    write(*,*) "Enter the timing iterations and the range of rows the test matrices should have"
    read(*,*) iterations, min_N, max_N

    ! Validating that at least one timing iteration is performed.
    ! By construction, this also validates that the number of iterations is a positive integer.
    if (iterations .lt. 1) stop "The number of iterations should be at least one"

    ! Validating that the minimum number of rows is at least 2.
    if (min_N .lt. 2) stop "The minimum number of rows for the square matrices must be at least 2"
    ! Validating that the maximum number of rows is higher than the minimum number of rows.
    ! Applied sequentually with the validation above, this guarantees max_N is a positive integer.
    if (max_N .le. min_N) stop "The maximum number of rows for the square matrices must be higher than the minimum number of rows."

    ! Allocate the timing array.
    allocate(timing(min_N:max_N,0:3),stat=errors)
    ! Validate the allocation was successful.
    ! Most likely cause for unsuccessful allocation is lack of memory.
    ! A very wide gap between min_N and max_N may lead to this behaviour
    if (errors.ne.0) then
        write(*,*) "Unable to allocate array for timing."
        write(*,*) "Writing to file performances every_slice size steps."
        write_every_n = .True.
    else if (write_every_n .eqv. .False.) then
        kk = min_N
    end if

    ! Performing outside the earlier control in case write_every_n is initialized as .True. for debugging
    if (write_every_n) then
        deallocate(timing)
        allocate(timing(1:slice_size,0:3))
    end if

    ! Finally, validate the maximum matrix size is not too big for allocation
    ! Since we're allocating five matrices for the timing, we take as proxy a (5*max_N)x(max_N) array
    allocate(A(1:5*max_N,1:max_N), stat = errors)
    if (errors.ne.0) stop "ERROR: Allocation issues. Try a smaller upper bound for the number of rows."
    deallocate(A)

    ! Open the file to store the performance data.
    open(15,file = "performance.dat")

    ! Generating two square random matrices, from min_N x min_N to max_N x max_N
    do ii = min_N, max_N
        ! "input size"
        timing(kk,0) = ii

        ! Allocate all the matrices using the new size
        allocate(A(1:ii,1:ii))
        allocate(B(1:ii,1:ii))
        allocate(D(1:ii,1:ii))
        allocate(E(1:ii,1:ii))
        allocate(C(1:ii,1:ii))

        ! Populate the arrays with uniformly distributed values
        call random_number(A)
        call random_number(B)

        !----------------------
        !    Timing products
        !----------------------
        ! Measuring performance of the first product definition
        call cpu_time(start)
        do jj = 1, iterations
            call mat_mul_1(A,B,C,debug)
        end do
        call cpu_time(finish)
        timing(kk,1) = (finish-start)/iterations

        ! Measuring performance of the second product definition
        ! Transposing and storing before entering the timing loop
        D = transpose(B)
        E = transpose(A)
        call cpu_time(start)
        do jj = 1, iterations
            call mat_mul_2(D,E,C,debug) ! This gives us C transpose
        end do
        call cpu_time(finish)
        timing(kk,2) = (finish-start)/iterations

        ! Measuring performance of built-in product definition
        call cpu_time(start)
        do jj = 1, iterations
            C = matmul(A,B)
        end do
        call cpu_time(finish)
        timing(kk,3) = (finish-start)/iterations

        ! Release the variables for the incoming allocation
        deallocate(A)
        deallocate(B)
        deallocate(D)
        deallocate(E)
        deallocate(C)

        ! Write to file when slice_size timing rows have been reached
        ! or when we have reached the maximum number of matrix's rows.
        if (write_every_n .and. (kk .eq. slice_size .or. ii .eq. max_N)) then
            ! Write up until the collected value.
            do jj = 1, kk
                write(15,*) timing(jj,0:3)
            end do
            ! set kk to zero, so that right after the control it is set to one.
            kk = 0
        end if
        ! Increase kk, usually the same as taking ii, but handled for sliced timings.
        kk = kk + 1
    end do

    ! Write the performance measurements
    if (write_every_n .eqv. .False.) then
        do ii = min_N, max_N
            write(15,*) timing(ii,0:3)
        end do
    end if
    close(15)
    write(*,*) "Averaged timings of operations successfully computed and written to file."

end program matrix_products

!--------------------------------
! Subroutines for matrix products
!--------------------------------

subroutine mat_mul_1(mat_a,mat_b,mat_c, debug)
    implicit none
    real*8, intent(in):: mat_a(:,:), mat_b(:,:)
    real*8, intent(out) :: mat_c(:,:)
    integer*4:: M,N,O,P,ii,jj,kk
    real*8:: cumulative
    integer*4:: shape_a(2), shape_b(2)
    logical:: debug

    shape_a = shape(mat_a)
    shape_b = shape(mat_b)
    M = shape_a(1)
    N = shape_a(2)
    O = shape_b(1)
    P = shape_b(2)

    ! Validate the matrices shapes are compatible
    if (debug .and. (N .ne. O)) stop "Input matrices sizes are not compatible for multiplication"

    do ii = 1,M
        do jj = 1, P
            cumulative = 0.d0
            do kk = 1, N
                cumulative = cumulative + mat_a(ii,kk)*mat_b(kk,jj)
            end do
            mat_c(ii,jj) = cumulative
        end do
    end do

end subroutine

subroutine mat_mul_2(mat_a,mat_b, mat_c, debug)
    implicit none
    real*8, intent(in):: mat_a(:,:), mat_b(:,:)
    real*8, intent(out) :: mat_c(:,:)
    integer*4:: M,N,O,P,ii,jj,kk
    real*8:: cumulative
    integer*4:: shape_a(2), shape_b(2)
    logical:: debug

    shape_a = shape(mat_a)
    shape_b = shape(mat_b)
    M = shape_a(1)
    N = shape_a(2)
    O = shape_b(1)
    P = shape_b(2)

    ! Validate the matrices shapes are compatible
    if (debug .and. (N .ne. O)) stop "Input matrices sizes are not compatible for multiplication"

    do jj = 1,P
        do ii = 1, M
            cumulative = 0.d0
            do kk = 1, N
                cumulative = cumulative + mat_a(ii,kk)*mat_b(kk,jj)
            end do
            mat_c(ii,jj) = cumulative
        end do
    end do

end subroutine


      subroutine min_max(LEX,ximf,spmax,spmin,nmax,nmin)
!------------------------------------------------------------------
!  This is a routine to define maxima and minima from series ximf.
!  All the extrema are defined as the corresponding values of
!  ximf in spmax and spmin. All non-extrema values in spmax and
!  spmin are defined as 1.0e31.
!------------------------------------------------------------------
      implicit none

      integer, intent(in):: LEX
      real, dimension(LEX), intent(in):: ximf
      real, dimension(LEX), intent(out):: spmax, spmin
      integer, intent(out):: nmax, nmin
      integer:: i

      nmax=0
      nmin=0

      spmax(1)=ximf(1)
      spmax(LEX)=ximf(LEX)
      spmin(1)=spmax(1)
      spmin(LEX)=spmax(LEX)

      nmax=2
      nmin=2

      do i=2,LEX-1
        if(ximf(i) > ximf(i-1) .and. ximf(i) >= ximf(i+1)) then
          spmax(i) = ximf(i)
          nmax = nmax+1
        else
          spmax(i)=1.0e31
        endif
        if(ximf(i) < ximf(i-1) .and. ximf(i) <= ximf(i+1)) then
          spmin(i)=ximf(i)
          nmin=nmin+1
        else
          spmin(i)=1.0e31
        endif
      enddo

      call endmax(LEX, spmax, nmax)
      call endmin(LEX, spmin, nmin)

      end subroutine min_max

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

      subroutine endmax(LEX, temp, nmax)
!--------------------------------------------------------------------
! This is a subroutine to determine end values of the upper envolope
! using the method described in Appendix B of Wu and Huang (2009,
! AADA, Vol. 1, pp1).
!--------------------------------------------------------------------
      implicit none

      integer, intent(in) :: nmax, LEX
      real, dimension(LEX), intent(inout):: temp
      real, dimension(nmax) :: exmax, X
      integer :: I, J, lend
      real :: slope1, slope2, tmp1, tmp2

      lend=nmax

      J=1
      DO I=1, LEX
        IF( temp(I).LT.1.0E30 ) THEN
          X(J)=float(I)
          exmax(J)=temp(I)
          J=J+1
        ENDIF
      ENDDO

      if (nmax >= 4) then
        slope1=(exmax(2)-exmax(3))/(X(2)-X(3))
        tmp1=slope1*(X(1)-X(2))+exmax(2)
        if(tmp1 > exmax(1)) then
          temp(1)=tmp1
        endif

        slope2=(exmax(lend-1)-exmax(lend-2))/(X(lend-1)-X(lend-2))
        tmp2=slope2*(X(lend)-X(lend-1))+exmax(lend-1)
        if(tmp2 > exmax(lend)) then
          temp(LEX)=tmp2
        endif
      endif

      end subroutine endmax

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

      subroutine endmin(LEX, temp, nmax)
!--------------------------------------------------------------------
! This is a subroutine to determine end values of the lower envolope
! using the method described in Appendix B of Wu and Huang (2009,
! AADA, Vol. 1, pp1).
!--------------------------------------------------------------------
      implicit none

      integer, intent(in) :: nmax, LEX
      real, dimension(LEX), intent(inout):: temp
      real, dimension(nmax) :: exmax, X
      integer :: I, J, lend
      real :: slope1, slope2, tmp1, tmp2

      lend=nmax

      J=1
      DO I=1, LEX
        IF( temp(I).LT.1.0E30 ) THEN
          X(J)=float(I)
          exmax(J)=temp(I)
          J=J+1
        ENDIF
      ENDDO

      if (nmax >= 4) then
        slope1=(exmax(2)-exmax(3))/(X(2)-X(3))
        tmp1=slope1*(X(1)-X(2))+exmax(2)
        if(tmp1 < exmax(1)) then
          temp(1)=tmp1
        endif

        slope2=(exmax(lend-1)-exmax(lend-2))/(X(lend-1)-X(lend-2))
        tmp2=slope2*(X(lend)-X(lend-1))+exmax(lend-1)
        if(tmp2 < exmax(lend)) then
          temp(LEX)=tmp2
        endif
      endif

      end subroutine endmin


program complex2
complex :: x
x = (3.0, 4.0)
x = x + 4.0
print *, x
x = 2.0 + x
print *, x
x = 2.0 + x + (0.0, 3.0)
print *, x
end program


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program sph_rand
!===============================================================================
! Randomly sample a sphere.
! This program takes samples one at a time and writes them out as it goes,
! rather than allocating memory for all points at once, to save memory in case
! of very large numbers of points.
! Output is lon, lat in degrees.

   use spherical_geometry

   implicit none
   integer :: n = 100
   real(8) :: lon, lat
   character(len=250) :: arg
   integer :: i, iostat

   ! Check args and get n if necessary
   if (command_argument_count() > 1) call usage
   if (command_argument_count() == 1) then
      call get_command_argument(1, arg)
      if (arg(1:2) == '-h') call usage
      read(arg, *, iostat=iostat) n
      if (iostat /= 0) then
         write(0,'(a)') 'sph_rand: Error: Cannot get n from first argument "' &
            //trim(arg)//'"'
         call usage
      endif
   endif

   do i = 1, n
      call sg_random_point_geog(lon, lat, degrees=.true.)
      write(*,*) lon, lat
   enddo

contains

   subroutine usage
      write(0,'(a)') &
         'Usage: sph_rand (n)', &
         'Randomly take points on a sphere with uniform probability density.', &
         'If specified, first argument defines the number of points.', &
         'Output is lon, lat (degrees).'
      stop
   end subroutine usage
end program sph_rand
!-------------------------------------------------------------------------------


program main
    ! inits
    implicit none
    integer :: iterations
    integer :: sum_total = 0
    integer :: counter = 0
    real :: rand, e = 0

    real :: temp = 0
    integer :: inner_counter

    ! print no new line
    write(*,"(A)",advance="no") "Number of iterations: "
    read *, iterations

    ! main iteration loop
    do while (counter < iterations)
        temp = 0
        inner_counter = 0
        ! inner loop
        do while (temp < 1)
            call random_number(rand)
            temp = rand + temp
            inner_counter = inner_counter + 1
        end do

        sum_total = sum_total + inner_counter
        counter = counter + 1
    end do

    ! approximates e
    e = real(sum_total) / real(iterations)
    ! print e
    print *, "e = ", e
end program main


program test_model_ar2

    use forlab, only: disp, file
    use forlab, only: mean
    use fortsa_model, only: ar_init, ar_exec, &
                            ar_summary, ar_predict, &
                            ar_free
    use fortsa_model, only: yw, burg, hr
    use stdlib_error, only: error_stop
    implicit none
    integer :: i, d, L
    integer :: p, q, line_num
    real(8), allocatable :: phi(:), theta(:)
    type(file) :: infile
    real(8), allocatable :: inp(:)
    real(8) :: wmean
    real(8) :: var
        !! mean var

    p = 7
    d = 1
    q = 0

    L = 5

    infile = file('example/data/seriesA.txt')
    if (.not. infile%exist()) call error_stop('Error: file not exist, '//infile%filename)
    call infile%open()
    line_num = infile%countlines()
    allocate (inp(line_num), phi(p))

    do i = 1, line_num
        read (infile%unit, *) inp(i)
    end do

    wmean = mean(inp)
        !! forlab mean

    print *, 'AR Coefficients Using Yule Walker Algorithm : '
    call yw(inp, line_num, p, phi, var)
    call disp(phi, 'PHI : ')
    call disp(var, 'VAR : ')

    print *, 'AR Coefficients Using Burg Algorithm : '
    call burg(inp, line_num, p, phi, var)
    call disp(phi, 'PHI : ')
    call disp(var, 'VAR : ')

    p = 1
    q = 1

    deallocate (phi)
    allocate (phi(p), theta(q))
    print *, 'ARMA Coefficients Using Hannan Rissanen Algorithm : '
    call hr(inp, line_num, p, q, phi, theta, var)
    call disp(phi, 'PHI : ')
    call disp(theta, 'THETA : ')
    call disp(var, 'VAR : ')

    deallocate (inp, phi, theta)
    call infile%close()

end program test_model_ar2


      real             function SLNREL (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>>   1994-10-20 SLNREL Krogh  Changes to use M77CON
c>>   1990-11-27 SLNREL WV Snyder Initial Code.
c
c     Compute LOG(1+X).
c
c     This procedure uses approximation 2707 from Hart, et. al. when
c     1/sqrt(2) < 1+x < sqrt(2), and otherwise uses the Fortran
c     intrinsic logarithm routine.
c
c--S replaces "?": ?LNREL
      real             X
      real             P0, P1, P2, P3, P4, Q0, Q1, Q2, Q3, Z, ZSQ
      real             BOT, TOP
      parameter (P0 = +0.75040 94990 77712 22174 55611 007 E+2 )
      parameter (P1 = -0.13456 69115 05043 02353 18253 537 E+3 )
      parameter (P2 = +0.74137 19213 24860 25127 79336 47  E+2 )
      parameter (P3 = -0.12772 49755 01233 08199 84385     E+2 )
      parameter (P4 = +0.33271 08381 08768 69381 44        E00 )
      parameter (Q0 = +0.37520 47495 38856 11087 27775 374 E+2 )
      parameter (Q1 = -0.79790 28073 71500 48794 39951 583 E+2 )
      parameter (Q2 = +0.56161 26132 11825 72920 58560 36  E+2 )
      parameter (Q3 = -0.14508 68091 85808 26853 62325     E+2 )
c     parameter (Q4 = +1.0                                 E00 )
      parameter (BOT = .70710 67811 86547 52440 E0 - 1.0E0 )
      parameter (TOP = 1.4142 13562 37309 50488 E0 - 1.0E0 )
c
      if (x .lt. bot .or. x .gt. top) then
         slnrel = log(x+1.0e0)
      else
         z = x / (x+2.0e0)
         zsq = z*z
         slnrel = z * ((((p4*zsq+p3)*zsq+p2)*zsq+p1)*zsq+p0)/
     1                ((((   zsq+q3)*zsq+q2)*zsq+q1)*zsq+q0)
      end if
      return
      end


module rheology_module

   use amrex_error_module, only: amrex_abort
   use amrex_fort_module, only : rt => amrex_real
   use constant, only: half, one
   use constant, only: mu, n, tau_0, eta_0, papa_reg, fluid_model

   implicit none

contains

   real(rt) function viscosity(sr) &
         bind(C, name="viscosity")

      real(rt), value :: sr
      real(rt)        :: nu

      if (fluid_model == "newtonian") then

         ! Viscosity is constant
         viscosity = mu

      else if (fluid_model == "powerlaw") then

         ! Power-law fluid:
         !
         ! eta = mu dot(gamma)^(n-1)
         viscosity = mu * sr**(n - one)

      else if (fluid_model == "bingham") then

         ! Papanastasiou-regularised Bingham fluid:
         !
         ! eta = mu + tau_0 (1 - exp(-dot(gamma) / eps)) / dot(gamma)
         nu = sr / papa_reg
         viscosity = mu + tau_0 * expterm(nu) / papa_reg

      else if (fluid_model == "hb") then

         ! Papanastasiou-regularised Herschel-Bulkley fluid:
         !
         ! eta = (mu dot(gamma)^n + tau_0) (1 - exp(-dot(gamma) / eps)) / dot(gamma)

         nu = sr / papa_reg
         viscosity = (mu * sr**n + tau_0) * expterm(nu) / papa_reg

      else if (fluid_model == "smd") then

         ! de Souza Mendes - Dutra fluid:
         !
         ! eta = (mu dot(gamma)^n + tau_0) (1 - exp(-eta_0 dot(gamma) / tau_0)) / dot(gamma)

         nu = eta_0 * sr / tau_0
         viscosity = (mu * sr**n + tau_0) * expterm(nu) * eta_0 / tau_0

      else

         ! This should have been caught earlier, but doesn't hurt to double check
         call amrex_abort("Unknown fluid_model! Choose either newtonian, powerlaw, bingham, hb, smd")

      end if

   end function viscosity

   !
   ! Compute the exponential term:
   !
   !  ( 1 - exp(-nu) ) / nu ,
   !
   ! making sure to avoid overflow for small nu by using the exponential Taylor series
   !
   real(rt) function expterm(nu)
      real(rt), intent(in) :: nu
      ! Avoid overflow
      if (nu .lt. 1.0e-9) then
         expterm = one - half * nu + nu**2 / 6.0d0 - nu**3 / 24.0d0
      else
         expterm = (one - exp(-nu)) / nu
      end if
   end function expterm

end module rheology_module


!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine phi_fine_cg(ilevel,icount)
  use amr_commons
  use pm_commons
  use poisson_commons
  implicit none
#ifndef WITHOUTMPI
  include 'mpif.h'
#endif
  integer::ilevel,icount
  !=========================================================
  ! Iterative Poisson solver with Conjugate Gradient method
  ! to solve A x = b
  ! r  : stored in f(i,1)
  ! p  : stored in f(i,2)
  ! A p: stored in f(i,3)
  ! x  : stored in phi(i)
  ! b  : stored in rho(i)
  !=========================================================
  integer::i,idim,info,ind,iter,iskip,itermax,nx_loc
  integer::idx
  real(dp)::error,error_ini
  real(dp)::dx2,fourpi,scale,oneoversix,fact,fact2
  real(dp)::r2_old,alpha_cg,beta_cg
  real(kind=8)::r2,pAp,rhs_norm,r2_all,pAp_all,rhs_norm_all

  if(gravity_type>0)return
  if(numbtot(1,ilevel)==0)return
  if(verbose)write(*,111)ilevel

  ! Set constants
  dx2=(0.5D0**ilevel)**2
  nx_loc=icoarse_max-icoarse_min+1
  scale=boxlen/dble(nx_loc)
  fourpi=4.D0*ACOS(-1.0D0)*scale
  if(cosmo)fourpi=1.5D0*omega_m*aexp*scale
  oneoversix=1.0D0/dble(twondim)
  fact=oneoversix*fourpi*dx2
  fact2 = fact*fact

  !===============================
  ! Compute initial phi
  !===============================
   if(ilevel>levelmin)then
      call make_initial_phi(ilevel,icount)              ! Interpolate phi down
   else
      call make_multipole_phi(ilevel)            ! Fill up with simple initial guess
   endif
   call make_virtual_fine_dp(phi(1),ilevel)      ! Update boundaries
   call make_boundary_phi(ilevel)                ! Update physical boundaries

  !===============================
  ! Compute right-hand side norm
  !===============================
  rhs_norm=0.d0
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        idx=active(ilevel)%igrid(i)+iskip
        rhs_norm=rhs_norm+fact2*(rho(idx)-rho_tot)*(rho(idx)-rho_tot)
     end do
  end do
  ! Compute global norms
#ifndef WITHOUTMPI
  call MPI_ALLREDUCE(rhs_norm,rhs_norm_all,1,MPI_DOUBLE_PRECISION,MPI_SUM,&
       & MPI_COMM_WORLD,info)
  rhs_norm=rhs_norm_all
#endif
  rhs_norm=DSQRT(rhs_norm/dble(twotondim*numbtot(1,ilevel)))

  !==============================================
  ! Compute r = b - Ax and store it into f(i,1)
  ! Also set p = r and store it into f(i,2)
  !==============================================
  call cmp_residual_cg(ilevel,icount)

  !====================================
  ! Main iteration loop
  !====================================
  iter=0; itermax=10000
  error=1.0D0; error_ini=1.0D0
  do while(error>epsilon*error_ini.and.iter<itermax)

     iter=iter+1

     !====================================
     ! Compute residual norm
     !====================================
     r2=0.0d0
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,active(ilevel)%ngrid
           idx=active(ilevel)%igrid(i)+iskip
           r2=r2+f(idx,1)*f(idx,1)
        end do
     end do
     ! Compute global norm
#ifndef WITHOUTMPI
     call MPI_ALLREDUCE(r2,r2_all,1,MPI_DOUBLE_PRECISION,MPI_SUM,&
          & MPI_COMM_WORLD,info)
     r2=r2_all
#endif
     !====================================
     ! Compute beta factor
     !====================================
     if(iter==1)then
        beta_cg=0.
     else
        beta_cg=r2/r2_old
     end if
     r2_old=r2

     !====================================
     ! Recurrence on p
     !====================================
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,active(ilevel)%ngrid
           idx=active(ilevel)%igrid(i)+iskip
           f(idx,2)=f(idx,1)+beta_cg*f(idx,2)
        end do
     end do
     ! Update boundaries
     call make_virtual_fine_dp(f(1,2),ilevel)

     !==============================================
     ! Compute z = Ap and store it into f(i,3)
     !==============================================
     call cmp_Ap_cg(ilevel)

     !====================================
     ! Compute p.Ap scalar product
     !====================================
     pAp=0.0d0
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,active(ilevel)%ngrid
           idx=active(ilevel)%igrid(i)+iskip
           pAp=pAp+f(idx,2)*f(idx,3)
        end do
     end do
     ! Compute global sum
#ifndef WITHOUTMPI
     call MPI_ALLREDUCE(pAp,pAp_all,1,MPI_DOUBLE_PRECISION,MPI_SUM,&
          & MPI_COMM_WORLD,info)
     pAp=pAp_all
#endif

     !====================================
     ! Compute alpha factor
     !====================================
     alpha_cg = r2/pAp

     !====================================
     ! Recurrence on x
     !====================================
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,active(ilevel)%ngrid
           idx=active(ilevel)%igrid(i)+iskip
           phi(idx)=phi(idx)+alpha_cg*f(idx,2)
        end do
     end do

     !====================================
     ! Recurrence on r
     !====================================
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,active(ilevel)%ngrid
           idx=active(ilevel)%igrid(i)+iskip
           f(idx,1)=f(idx,1)-alpha_cg*f(idx,3)
        end do
     end do

     ! Compute error
     error=DSQRT(r2/dble(twotondim*numbtot(1,ilevel)))
     if(iter==1)error_ini=error
     if(verbose)write(*,112)iter,error/rhs_norm,error/error_ini

  end do
  ! End main iteration loop

  if(myid==1)write(*,115)ilevel,iter,error/rhs_norm,error/error_ini
  if(iter >= itermax)then
     if(myid==1)write(*,*)'Poisson failed to converge...'
  end if

  ! Update boundaries
  call make_virtual_fine_dp(phi(1),ilevel)

111 format('   Entering phi_fine_cg for level ',I2)
112 format('   ==> Step=',i5,' Error=',2(1pe10.3,1x))
115 format('   ==> Level=',i5,' Step=',i5,' Error=',2(1pe10.3,1x))

end subroutine phi_fine_cg
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine cmp_residual_cg(ilevel,icount)
  use amr_commons
  use pm_commons
  use hydro_commons
  use poisson_commons
  implicit none
  integer::ilevel,icount
  !------------------------------------------------------------------
  ! This routine computes the residual for the Conjugate Gradient
  ! Poisson solver. The residual is stored in f(i,1).
  !------------------------------------------------------------------
  integer::i,idim,igrid,ngrid,ncache,ind,iskip,nx_loc
  integer::id1,id2,ig1,ig2,ih1,ih2
  real(dp)::dx2,fourpi,scale,oneoversix,fact
  integer,dimension(1:3,1:2,1:8)::iii,jjj

  integer ,dimension(1:nvector),save::ind_grid,ind_cell
  integer ,dimension(1:nvector,0:twondim),save::igridn
  integer ,dimension(1:nvector,1:ndim),save::ind_left,ind_right
  real(dp),dimension(1:nvector,1:ndim),save::phig,phid
  real(dp),dimension(1:nvector,1:twotondim,1:ndim),save::phi_left,phi_right
  real(dp),dimension(1:nvector),save::residu

  ! Set constants
  dx2=(0.5D0**ilevel)**2
  nx_loc=icoarse_max-icoarse_min+1
  scale=boxlen/dble(nx_loc)
  fourpi=4.D0*ACOS(-1.0D0)*scale
  if(cosmo)fourpi=1.5D0*omega_m*aexp*scale
  oneoversix=1.0D0/dble(twondim)
  fact=oneoversix*fourpi*dx2

  iii(1,1,1:8)=(/1,0,1,0,1,0,1,0/); jjj(1,1,1:8)=(/2,1,4,3,6,5,8,7/)
  iii(1,2,1:8)=(/0,2,0,2,0,2,0,2/); jjj(1,2,1:8)=(/2,1,4,3,6,5,8,7/)
  iii(2,1,1:8)=(/3,3,0,0,3,3,0,0/); jjj(2,1,1:8)=(/3,4,1,2,7,8,5,6/)
  iii(2,2,1:8)=(/0,0,4,4,0,0,4,4/); jjj(2,2,1:8)=(/3,4,1,2,7,8,5,6/)
  iii(3,1,1:8)=(/5,5,5,5,0,0,0,0/); jjj(3,1,1:8)=(/5,6,7,8,1,2,3,4/)
  iii(3,2,1:8)=(/0,0,0,0,6,6,6,6/); jjj(3,2,1:8)=(/5,6,7,8,1,2,3,4/)

  ! Loop over myid grids by vector sweeps
  ncache=active(ilevel)%ngrid
  do igrid=1,ncache,nvector

     ! Gather nvector grids
     ngrid=MIN(nvector,ncache-igrid+1)
     do i=1,ngrid
        ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
     end do

     ! Gather neighboring grids
     do i=1,ngrid
        igridn(i,0)=ind_grid(i)
     end do
     do idim=1,ndim
        do i=1,ngrid
           ind_left (i,idim)=nbor(ind_grid(i),2*idim-1)
           ind_right(i,idim)=nbor(ind_grid(i),2*idim  )
           igridn(i,2*idim-1)=son(ind_left (i,idim))
           igridn(i,2*idim  )=son(ind_right(i,idim))
        end do
     end do

     ! Interpolate potential from upper level
     do idim=1,ndim
        call interpol_phi(ind_left (1,idim),phi_left (1,1,idim),ngrid,ilevel,icount)
        call interpol_phi(ind_right(1,idim),phi_right(1,1,idim),ngrid,ilevel,icount)
     end do

     ! Loop over cells
     do ind=1,twotondim
        ! Gather neighboring potential
        do idim=1,ndim
           id1=jjj(idim,1,ind); ig1=iii(idim,1,ind)
           ih1=ncoarse+(id1-1)*ngridmax
           do i=1,ngrid
              if(igridn(i,ig1)>0)then
                 phig(i,idim)=phi(igridn(i,ig1)+ih1)
              else
                 phig(i,idim)=phi_left(i,id1,idim)
              end if
           end do
           id2=jjj(idim,2,ind); ig2=iii(idim,2,ind)
           ih2=ncoarse+(id2-1)*ngridmax
           do i=1,ngrid
              if(igridn(i,ig2)>0)then
                 phid(i,idim)=phi(igridn(i,ig2)+ih2)
              else
                 phid(i,idim)=phi_right(i,id2,idim)
              end if
           end do
        end do

        ! Compute central cell index
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,ngrid
           ind_cell(i)=iskip+ind_grid(i)
        end do

        ! Compute residual using 6 neighbors potential
        do i=1,ngrid
           residu(i)=phi(ind_cell(i))
        end do
        do idim=1,ndim
           do i=1,ngrid
              residu(i)=residu(i)-oneoversix*(phig(i,idim)+phid(i,idim))
           end do
        end do
        do i=1,ngrid
           residu(i)=residu(i)+fact*(rho(ind_cell(i))-rho_tot)
        end do

        ! Store results in f(i,1)
        do i=1,ngrid
           f(ind_cell(i),1)=residu(i)
        end do

        ! Store results in f(i,2)
        do i=1,ngrid
           f(ind_cell(i),2)=residu(i)
        end do

     end do
     ! End loop over cells

  end do
  ! End loop over grids

end subroutine cmp_residual_cg
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine cmp_Ap_cg(ilevel)
  use amr_commons
  use pm_commons
  use hydro_commons
  use poisson_commons
  implicit none
  integer::ilevel
  !------------------------------------------------------------------
  ! This routine computes Ap for the Conjugate Gradient
  ! Poisson Solver and store the result into f(i,3).
  !------------------------------------------------------------------
  integer::i,idim,igrid,ngrid,ncache,ind,iskip
  integer::id1,id2,ig1,ig2,ih1,ih2
  real(dp)::oneoversix
  integer,dimension(1:3,1:2,1:8)::iii,jjj

  integer,dimension(1:nvector),save::ind_grid,ind_cell
  integer,dimension(1:nvector,0:twondim),save::igridn
  real(dp),dimension(1:nvector,1:ndim),save::phig,phid
  real(dp),dimension(1:nvector),save::residu

  ! Set constants
  oneoversix=1.0D0/dble(twondim)

  iii(1,1,1:8)=(/1,0,1,0,1,0,1,0/); jjj(1,1,1:8)=(/2,1,4,3,6,5,8,7/)
  iii(1,2,1:8)=(/0,2,0,2,0,2,0,2/); jjj(1,2,1:8)=(/2,1,4,3,6,5,8,7/)
  iii(2,1,1:8)=(/3,3,0,0,3,3,0,0/); jjj(2,1,1:8)=(/3,4,1,2,7,8,5,6/)
  iii(2,2,1:8)=(/0,0,4,4,0,0,4,4/); jjj(2,2,1:8)=(/3,4,1,2,7,8,5,6/)
  iii(3,1,1:8)=(/5,5,5,5,0,0,0,0/); jjj(3,1,1:8)=(/5,6,7,8,1,2,3,4/)
  iii(3,2,1:8)=(/0,0,0,0,6,6,6,6/); jjj(3,2,1:8)=(/5,6,7,8,1,2,3,4/)

  ! Loop over myid grids by vector sweeps
  ncache=active(ilevel)%ngrid
  do igrid=1,ncache,nvector

     ! Gather nvector grids
     ngrid=MIN(nvector,ncache-igrid+1)
     do i=1,ngrid
        ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
     end do

     ! Gather neighboring grids
     do i=1,ngrid
        igridn(i,0)=ind_grid(i)
     end do
     do idim=1,ndim
        do i=1,ngrid
           igridn(i,2*idim-1)=son(nbor(ind_grid(i),2*idim-1))
           igridn(i,2*idim  )=son(nbor(ind_grid(i),2*idim  ))
        end do
     end do

     ! Loop over cells
     do ind=1,twotondim

        ! Gather neighboring potential
        do idim=1,ndim
           id1=jjj(idim,1,ind); ig1=iii(idim,1,ind)
           ih1=ncoarse+(id1-1)*ngridmax
           do i=1,ngrid
              if(igridn(i,ig1)>0)then
                 phig(i,idim)=f(igridn(i,ig1)+ih1,2)
              else
                 phig(i,idim)=0.
              end if
           end do
           id2=jjj(idim,2,ind); ig2=iii(idim,2,ind)
           ih2=ncoarse+(id2-1)*ngridmax
           do i=1,ngrid
              if(igridn(i,ig2)>0)then
                 phid(i,idim)=f(igridn(i,ig2)+ih2,2)
              else
                 phid(i,idim)=0.
              end if
           end do
        end do

        ! Compute central cell index
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,ngrid
           ind_cell(i)=iskip+ind_grid(i)
        end do

        ! Compute Ap using neighbors potential
        do i=1,ngrid
           residu(i)=-f(ind_cell(i),2)
        end do
        do idim=1,ndim
           do i=1,ngrid
              residu(i)=residu(i)+oneoversix*(phig(i,idim)+phid(i,idim))
           end do
        end do
        ! Store results in f(i,3)
        do i=1,ngrid
           f(ind_cell(i),3)=residu(i)
        end do

     end do
     ! End loop over cells

  end do
  ! End loop over grids

end subroutine cmp_Ap_cg
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine make_initial_phi(ilevel,icount)
  use amr_commons
  use pm_commons
  use poisson_commons
  implicit none
  integer::ilevel,icount
  !
  !
  !
  integer::igrid,ncache,i,ngrid,ind,iskip,idim,ibound
  integer ,dimension(1:nvector),save::ind_grid,ind_cell,ind_cell_father
  real(dp),dimension(1:nvector,1:twotondim),save::phi_int

  ! Loop over myid grids by vector sweeps
  ncache=active(ilevel)%ngrid
  do igrid=1,ncache,nvector
     ! Gather nvector grids
     ngrid=MIN(nvector,ncache-igrid+1)
     do i=1,ngrid
        ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
     end do

     if(ilevel==1)then
        ! Loop over cells
        do ind=1,twotondim
           iskip=ncoarse+(ind-1)*ngridmax
           do i=1,ngrid
              ind_cell(i)=iskip+ind_grid(i)
           end do
           do i=1,ngrid
              phi(ind_cell(i))=0.0d0
           end do
           do idim=1,ndim
              do i=1,ngrid
                 f(ind_cell(i),idim)=0.0
              end do
           end do
        end do
        ! End loop over cells
     else
        ! Compute father cell index
        do i=1,ngrid
           ind_cell_father(i)=father(ind_grid(i))
        end do

        ! Interpolate
        call interpol_phi(ind_cell_father,phi_int,ngrid,ilevel,icount)

        ! Loop over cells
        do ind=1,twotondim
           iskip=ncoarse+(ind-1)*ngridmax
           do i=1,ngrid
              ind_cell(i)=iskip+ind_grid(i)
           end do
           do i=1,ngrid
              phi(ind_cell(i))=phi_int(i,ind)
           end do
           do idim=1,ndim
              do i=1,ngrid
                 f(ind_cell(i),idim)=0.0
              end do
           end do
        end do
        ! End loop over cells
     end if

  end do
  ! End loop over grids

end subroutine make_initial_phi
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine make_multipole_phi(ilevel)
  use amr_commons
  use pm_commons
  use poisson_commons
  implicit none
  integer::ilevel
  !
  !
  !
  integer::ibound,boundary_dir,idim,inbor
  integer::i,ncache,ivar,igrid,ngrid,ind
  integer::iskip,iskip_ref,gdim,nx_loc,ix,iy,iz
  integer,dimension(1:nvector),save::ind_grid,ind_cell

  real(dp)::dx,dx_loc,scale,fourpi,boxlen2,eps,r2
  real(dp),dimension(1:3)::skip_loc
  real(dp),dimension(1:twotondim,1:3)::xc
  real(dp),dimension(1:nvector),save::rr,pp
  real(dp),dimension(1:nvector,1:ndim),save::xx
  real(dp),dimension(1:nvector,1:ndim),save::ff

  ! Mesh size at level ilevel
  dx=0.5D0**ilevel

  ! Rescaling factors
  nx_loc=(icoarse_max-icoarse_min+1)
  skip_loc=(/0.0d0,0.0d0,0.0d0/)
  if(ndim>0)skip_loc(1)=dble(icoarse_min)
  if(ndim>1)skip_loc(2)=dble(jcoarse_min)
  if(ndim>2)skip_loc(3)=dble(kcoarse_min)
  scale=boxlen/dble(nx_loc)
  dx_loc=dx*scale
  fourpi=4.D0*ACOS(-1.0D0)
  boxlen2=boxlen**2
  eps=dx_loc

  ! Set position of cell centers relative to grid center
  do ind=1,twotondim
     iz=(ind-1)/4
     iy=(ind-1-4*iz)/2
     ix=(ind-1-2*iy-4*iz)
     if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx
     if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx
     if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx
  end do

  ! Loop over myid grids by vector sweeps
  ncache=active(ilevel)%ngrid
  do igrid=1,ncache,nvector
     ! Gather nvector grids
     ngrid=MIN(nvector,ncache-igrid+1)
     do i=1,ngrid
        ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
     end do

     ! Loop over cells
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,ngrid
           ind_cell(i)=iskip+ind_grid(i)
        end do

        if(simple_boundary)then
           ! Compute cell center in code units
           do idim=1,ndim
               do i=1,ngrid
                  xx(i,idim)=xg(ind_grid(i),idim)+xc(ind,idim)
               end do
           end do

           ! Rescale position from code units to user units
           rr(1:ngrid)=0.0d0
           do idim=1,ndim
               do i=1,ngrid
                  xx(i,idim)=(xx(i,idim)-skip_loc(idim))*scale
                  rr(i)=rr(i)+(xx(i,idim)-multipole(idim+1)/multipole(1))**2
               end do
           end do

           do i=1,ngrid
               rr(i)=max(eps,sqrt(rr(i)))       ! Cutoff
           end do

           if(ngrid>0) call phi_ana(rr,pp,ngrid)

           ! Scatter variables
           do i=1,ngrid
               phi(ind_cell(i))=pp(i)/scale
           end do

        else
           do i=1,ngrid
               phi(ind_cell(i))=0d0
           end do
        endif

        ! End loop over cells
     end do

  end do
  ! End loop over grids

end subroutine make_multipole_phi


!================================================================================
! CONSTRUCCION DE UNA CONFIGURACION INICIAL REGULAR EN CELDA TRIDIMENSIONAL SIN
! TRASLAPES
! Autor: Martin Paredes Sosa
!================================================================================

Module cte
  Implicit None
  Real, Parameter :: sigma = 1.0
  Real :: Dens, BoxL
  Integer :: N
End Module cte

Program ConfigIni
  Use cte
  Implicit None
  Real :: Dim, xij, yij, dBoxL, dist
  Real, Allocatable, Dimension(:) :: X,Y,Z  !POSICIONES DE LAS PARTICULAS
  Integer :: i, j, k                        !CONTADOR
  Integer :: N2, N3                         !PARTICULAS

  !PEDIR DENSIDAD Y NUMERO DE PARTICULAS
  Write(*,*) "INGRESE EL NUMERO DE PARTICULAS"
  Read(*,*) N
  Write(*,*) "INGRESE CONCENTRACION REDUCIDA"
  Read(*,*) Dens

  !CALCULANDO DIMENSIONES DE LA CAJA
  Dim = 3.0
  N2 =anint( N**(1.0/Dim) )
  BoxL = (1.0*N/Dens )**(1.0/Dim)
  N3 = N2*N2*N2
  Write(*,*) "LONGITUD DE LA CELDA:", BoxL
  Write(*,*) "TOTAL DE PARTICULAS EN LA CELDA COLOCADAS:", N3
  dBoxl = BoxL/N2

  Allocate( X(N2),Y(N2),Z(N2) )

  !BUSCANDO POSICIONES PARA LAS PARTICULAS POR EJE
  Colocar: Do i=1, N2

     x(i) = -(BoxL-1)/2 + dBoxL*(i-1)
     y(i) = -(BoxL-1)/2 + dBoxL*(i-1)
     z(i) = -(BoxL-1)/2 + dBoxL*(i-1)

  End Do Colocar

  !ESCRIBIENDO EN ARCHIVO
  Open (1, File = "PosPart.dat" )
  EscribirX: Do i = 1, N2
     EscribirY: Do j = 1, N2
        EScribirZ: Do k = 1, N2
           Write(1,*) x(i), y(j), z(k)
        End Do EScribirZ
     End Do EscribirY
  End Do EscribirX

  Deallocate(X,Y)
  Close(1)

End Program ConfigIni


module numeth

    !! This module contains subroutines for numerical solution
    !! of a system of linear equations

    use types
    implicit none
    save

    private
    public :: factor, solve, bfactor, bsolve

contains

    subroutine factor(a)

        !! This subroutine computes the LU-factorization of a matrix.
        !!
        !! The following assumptions are made
        !!
        !! * the matrix is square
        !! * the matrix is non-singular
        !!
        !! If the assumptions are not meet the behavior is undefined -- probably the
        !! program will crash.
        !!
        !! The LU-factorization is stored in-place, thereby replacing the original
        !! content of the given matrix.

        real(wp), dimension(:, :), intent(inout) :: a
            !! Matrix to be LU-factored

        integer :: i, j, neqn
        neqn = size(a, 1)

        do j = 2, neqn
            do i = 1, j-1
                a(j, i) = a(j, i) - dot_product(a(j, 1:i-1), a(1:i-1, i))
                a(i, j) = a(i, j) - dot_product(a(i, 1:i-1), a(1:i-1, j))
                a(j, i) = a(j, i)/a(i, i)
            end do
            a(j, j) = a(j, j) - dot_product(a(j, 1:j-1), a(1:j-1, j))
        end do
    end subroutine factor
!
!--------------------------------------------------------------------------------------------------
!
    subroutine solve(a, b)

        !! This subroutine solves the linear system of equations [M]{x} = {b}, where
        !! [a] is the LU-factoriztion of [M], as obtained from the subroutine [[factor]].
        !!
        !! The subroutine returns the solution {x} by overwriting {b}.

        real(wp), dimension(:, :), intent(in) :: a
            !! LU-factorization of system matrix
        real(wp), dimension(:), intent(inout) :: b
            !! Right-hand side to be overwritten by the computed solution

        integer :: i, neqn
        neqn = size(a, 1)

        ! Forward substitution
        do i = 2, neqn
            b(i) = b(i) - dot_product(a(i, 1:i-1), b(1:i-1))
        end do

        ! Backward substitution
        b(neqn) = b(neqn)/a(neqn, neqn)
        do i = neqn-1, 1, -1
            b(i) = (b(i) - dot_product(a(i, i+1:neqn), b(i+1:neqn)))/a(i, i)
        end do
    end subroutine solve
 !
!--------------------------------------------------------------------------------------------------
!
    subroutine bfactor(a)

        !! This subroutine computes the LU-factorization of a matrix.
        !!
        !! The following assumptions are made
        !!
        !! * the matrix is stored in banded form (rectangular matrix)
        !! * the matrix is non-singular
        !!
        !! If the assumptions are not meet the behavior is undefined -- probably the
        !! program will crash.
        !!
        !! The LU-factorization is stored in-place, thereby replacing the original
        !! content of the given matrix.

        real(wp), dimension(:, :), intent(inout) :: a
            !! Matrix in banded form to be LU-factored
        real(wp) :: c
        integer :: i, j, k, m, n, bw, neqn

        bw = size(a, 1)
        neqn = size(a, 2)

        do n = 1, neqn
            do m = 2, bw
                if (a(m, n) == 0.0_wp) cycle
                i = n+m-1
                c = a(m, n)/a(1, n)
                j = 0
                do k = m, bw
                    j = j+1
!                    print *, "ijknm", i,j,k,m,n
                    a(j, i) = a(j, i) - c*a(k, n)
                end do
                a(m, n) = c
            end do
        end do
    end subroutine bfactor
!
!--------------------------------------------------------------------------------------------------
!
    subroutine bsolve(a, b)

        !! This subroutine solves the linear system of equations [M]{x} = {b}, where
        !! [a] is the LU-factoriztion of [M], as obtained from the subroutine [[bfactor]].
        !!
        !! The subroutine returns the solution {x} by overwriting {b}.

        real(wp), dimension(:, :), intent(in) :: a
            !! LU-factorization of system matrix
        real(wp), dimension(:), intent(inout) :: b
            !! Right-hand side to be overwritten by the computed solution

        integer :: i, j, k, m, n, bw, neqn
        bw = size(a, 1)
        neqn = size(a, 2)

        do n = 1,neqn
            do j = 2, bw
                if (a(j, n) == 0.0_wp) cycle
                i = n+j-1
                b(i) = b(i)-a(j, n)*b(n)
            end do
            b(n) = b(n)/a(1, n)
        end do

        do m = 2, neqn
            n = neqn+1-m
            do j = 2, bw
                if (a(j, n) == 0.0_wp) cycle
                k = n+j-1
                b(n) = b(n)-a(j, n)*b(k)
            end do
        end do
    end subroutine bsolve

end module numeth


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pair_shrink( n, gg1, gg2, n_shrink )

!  Given a pair of concentric ellipsoids, E1 and E2, shrink E2
!  (if necessary) so that it is contained in E1.
!  E1 is defined by:  x^T * G1 * G1^T * x <= 1, where the array gg1
!  contains G1 in packed format.  Similarly for E2.

!  Method:
!  1/ transform to y-space in which E1 is the unit ball: y = G1^T * x
!  2/ in y-space, SVD of G2 is G2 = U S V^T
!  3/ modify S by S(i,i) = max( S(i,i), 1. ); number of modifications is n_shrink
!  4/ transform back

!  S.B. Pope  6/13/04

implicit none

integer, parameter        :: k_dp = kind(1.d0)
integer, intent(in)       :: n
real(k_dp), intent(in)    :: gg1((n*(n+1))/2)
real(k_dp), intent(inout) :: gg2((n*(n+1))/2)
integer, intent(out)      :: n_shrink

integer    :: i, j, k, info, lwork
real(k_dp) :: g1(n,n), g2(n,n), s(n), u(n,n), y(n), work(n*n+10*n), r, r_in

lwork    = n*n+10*n+10
n_shrink = 0

! unpack gg1 and gg2
k  = 0
g1 = 0.d0
g2 = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  g1(i,j) = gg1(k)
	  g2(i,j) = gg2(k)
   end do
end do

! transform to y-space:  y = G1^T * x;  G2y = G1^{-1} * G2
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, g1, n, g2, n )

!  find point in G2y furthest from the origin

call ellu_radii( n, g2, r_in, r )

if( r <= 1.d0 ) return  !  no modification required (G2 contained in G1)

! SVD:  G2y = U S V^T    (Note: vt is not referenceed)
call dgesvd( 'A', 'N', n, n, g2, n, s, u, n, y, n, work, lwork, info )

if( info /= 0 ) then
   write(0,*)'ell_pair_shrink: SVD failed, info = ', info
   stop
endif

!  shrink principal axes as needed
do i = 1, n
   if( s(i) < 1.d0 ) then
      s(i) = 1.d0
	  n_shrink = n_shrink + 1
   endif
end do

!  form modified G2y * G2y^T = (U * S) * (U * S)^T
do j = 1, n
   u(:,j) = u(:,j) * s(j)  ! U * S
end do

! Form Chholesky G:  G * G^T = G2y * G2y^T = (U * S) * (U * S)^T
call ellu_bbt2chol( n, u, g2 )

!  Zero upper triangle
do j = 2, n
   do i = 1, j-1
      g2(i,j) = 0.d0
   end do
end do

!  transform back to x-space:  G2 = G1 * G2y
call dtrmm( 'L', 'L', 'N', 'N', n, n, 1.d0, g1, n, g2, n )

k = 0
do j = 1, n   !  pack g2 into gg2  ensuring that the diagonal elements are non-nehative
   if( g2(j,j) >= 0.d0 ) then
      do i = j,n
         k = k + 1
	     gg2(k) = g2(i,j)
      end do
   else
      do i = j,n
         k = k + 1
	     gg2(k) = -g2(i,j)
      end do
   endif
end do

return
end subroutine ell_pair_shrink


    Program dtrsen_example

!     DTRSEN Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dgemm
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dlange, dtrsen
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: alpha, beta, norm, s, sep
      Integer :: i, ifail, info, lda, ldc, ldq, ldt, liwork, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), c(:, :), q(:, :), t(:, :), &
        wi(:), work(:), wr(:)
      Integer, Allocatable :: iwork(:)
      Logical, Allocatable :: select(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DTRSEN Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldc = n
      ldq = n
      ldt = n
      liwork = (n*n)/4
      lwork = (n*n)/2
      Allocate (a(lda,n), c(ldc,n), q(ldq,n), t(ldt,n), wi(n), work(lwork), &
        wr(n), iwork(liwork), select(n))

!     Read T, Q and the logical array SELECT from data file

      Read (nin, *)(t(i,1:n), i=1, n)
      Read (nin, *)(q(i,1:n), i=1, n)

      Read (nin, *) select(1:n)

!     Compute Q * T * Q**T to find  A
      alpha = 1._dp
      beta = 0._dp
      Call dgemm('N', 'N', n, n, n, alpha, q, ldq, t, ldt, beta, c, ldc)
      Call dgemm('N', 'T', n, n, n, alpha, c, ldc, q, ldq, beta, a, lda)

!     Print Matrix A, as computed from Q * T * Q**T
!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
        'Matrix A computed from Q*T*Q^T', ifail)

      Write (nout, *)
      Flush (nout)

!     Reorder the Schur factor T and update the matrix Q to obtain TT and QT

      Call dtrsen('Both', 'Vectors', select, n, t, ldt, q, ldq, wr, wi, m, s, &
        sep, work, lwork, iwork, liwork, info)

!     Compute (Q * T * Q^T) - (QT * TT * QT^T) and store in A,
!     i.e. the difference between reconstructed A using Schur and reordered
!          Schur decompositions.
      alpha = 1._dp
      beta = 0._dp
      Call dgemm('N', 'N', n, n, n, alpha, q, ldq, t, ldt, beta, c, ldc)
      alpha = -1._dp
      beta = 1._dp
      Call dgemm('N', 'T', n, n, n, alpha, c, ldc, q, ldq, beta, a, lda)

!     Find norm of difference matrix and print warning if it is too large
      norm = dlange('O', lda, n, a, lda, work)
      If (norm>epsilon(1.0E0_dp)**0.8_dp) Then
        Write (nout, *) 'Norm of A - (QT * TT * QT^T) is much greater than 0.'
        Write (nout, *) 'Schur factorization has failed.'
      Else
!       Print Result
        Write (nout, 100) 'Condition number estimate', &
          ' of the selected cluster of eigenvalues = ', 1.0_dp/s
        Write (nout, *)
        Write (nout, 100) 'Condition number estimate of the spec', &
          'ified invariant subspace    = ', 1.0_dp/sep
      End If

100   Format (1X, A, A, 1P, E10.2)
    End Program


      subroutine diff (v, dr, kap, cl, dx, n, vm)
c     calculate  vm(i)=(dV/dx)*r(i)*(kap+1)/cl
c     needed for c3 term to calculate j-average phase shift
c     ref. koelling,harmon j.phys.c,3107(1977). eq.14
      implicit double precision (a-h,o-z)
       include '../HEADERS/dim.h'

      complex*16 v(n), vm(n), vt(nrptx)
      double precision dr(n)
      double precision a, b, c, d, e, f, g

      do i = 1,n
         vt(i) = v(i) * dr(i)**2
      enddo

c  should be:
      a = 6.0d0
      b = 20.d0/3.0d0
      c = 1.2d0
      d = 2.45d0
      e = 7.5d0
      f = 3.75d0
      g = 1.d0/6.d0
      vm(1)=((a*vt(2) + b*vt(4) + c*vt(6)) -
     $     (d*vt(1) + e*vt(3) + f*vt(5) + g*vt(7)))/dx
      vm(2)=((a*vt(3) + b*vt(5) + c*vt(7)) -
     $     (d*vt(2) + e*vt(4) + f*vt(6) + g*vt(8)))/dx

c curently passes tests:
      vm(1)=((6.0*vt(2)+6.66666666667*vt(4)+1.2*vt(6)) -
     $     (2.45*vt(1)+7.5*vt(3)+3.75*vt(5)+.166666666667*vt(7)))/dx
      vm(2)=((6.0*vt(3)+6.66666666667*vt(5)+1.2*vt(7)) -
     $     (2.45*vt(2)+7.5*vt(4)+3.75*vt(6)+.166666666667*vt(8)))/dx

      nm2=n-2
      do i=3,nm2
         vm(i)=((vt(i-2)+8.0*vt(i+1))-(8.0*vt(i-1)+vt(i+2)))/12.0/dx
      enddo
      vm(n-1)=(vt(n)-vt(n-2))/(2.0*dx)
      vm(n)=(vt(n-2)*0.5 - 2.0*vt(n-1) + 1.5*vt(n))/dx

      do i = 1,n
         vm(i) = (vm(i)-2*vt(i))/dr(i) *(kap+1.0)/cl
      enddo
      return
      end


PROGRAM question3
    IMPLICIT NONE
    real :: x, y
    x = 90. * (3.14/180)
    y = -0.35
    print *, sin(x)
    print *, cos(x)
    print *, acos(y)
    STOP
END PROGRAM question3


C File avgerage.f90
      subroutine avg3d(avg,dataset,incavg,counter,spval,dim1,dim2,dim3)

      IMPLICIT NONE

      !input variables
      REAL*8,DIMENSION(dim1,dim2,dim3),intent(in)::dataset
      REAL*8,DIMENSION(dim1,dim2,dim3),intent(in)::incavg

      !output variables
      REAL*8,DIMENSION(dim1,dim2,dim3),intent(out)::avg

      !local variables
      INTEGER::dim1,dim2,dim3
      REAL*8::counter
      REAL*8::part1,part2,spval
      INTEGER::i,j,k

      do i=1,dim1
         do j=1,dim2
            do k=1,dim3
               if (dataset(i,j,k).lt.spval) then
                 !This is the code for performing an incremental
                 !average broken into two parts. It follows the formula:
                 !avg(I+1) = avg(I) + ((data(I+1)-avg(I))/I+1)
                 part1 = dataset(i,j,k)-incavg(i,j,k)
                 part2 = part1 / counter
                 avg(i,j,k) = incavg(i,j,k)+part2
               else
                 !This keeps the missing value in the return array
                 avg(i,j,k) = dataset(i,j,k)
               endif
            enddo
         enddo
      enddo

      return

      end

      subroutine avg2d(avg,dataset,incavg,counter,spval,dim1,dim2)

      IMPLICIT NONE

      !input variables
      REAL*8,DIMENSION(dim1,dim2),intent(in)::dataset
      REAL*8,DIMENSION(dim1,dim2),intent(in)::incavg

      !output variables
      REAL*8,DIMENSION(dim1,dim2),intent(out)::avg

      !local variables
      INTEGER::dim1,dim2
      REAL*8::counter
      REAL*8::part1,part2,spval
      INTEGER::i,j

      do i=1,dim1
         do j=1,dim2
               if (dataset(i,j).lt.spval) then
                 !This is the code for performing an incremental
                 !average broken into two parts. It follows the formula:
                 !avg(I+1) = avg(I) + ((data(I+1)-avg(I))/I+1)
                 part1 = dataset(i,j)-incavg(i,j)
                 part2 = part1 / counter
                 avg(i,j) = incavg(i,j)+part2
               else
                 !This keeps the missing value in the return array
                 avg(i,j) = dataset(i,j)
               endif
         enddo
      enddo

      return

      end