C$Procedure      CHBFIT ( Chebyshev fit )

      SUBROUTINE CHBFIT ( FUNC, LEFT, RIGHT, N, WORK, COEFFS )
      IMPLICIT NONE

C$ Abstract
C
C     Return the Chebyshev coefficients for a Chebyshev expansion
C     of a specified function.
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     None.
C
C$ Keywords
C
C     INTERPOLATION
C     MATH
C     POLYNOMIAL
C
C$ Declarations

      INTEGER               MAXSIZ
      PARAMETER           ( MAXSIZ = 25 )

      DOUBLE PRECISION      FUNC
      EXTERNAL              FUNC

      DOUBLE PRECISION      LEFT
      DOUBLE PRECISION      RIGHT
      INTEGER               N
      DOUBLE PRECISION      WORK   ( * )
      DOUBLE PRECISION      COEFFS ( * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     MAXSIZ     P   Maximum number of terms in expansion.
C     FUNC       I   Function to be approximated.
C     LEFT       I   Left endpoint of approximation interval.
C     RIGHT      I   Right endpoint of approximation interval.
C     N          I   Number of terms in Chebyshev expansion.
C     WORK       I   Work space array of dimension N.
C     COEFFS     O   Coefficients of Chebyshev expansion.
C
C$ Detailed_Input
C
C     FUNC           is the function to be approximated.  FUNC must
C                    accept a single, double precision input argument
C                    and must return a double precision value.  FUNC
C                    should be declared EXTERNAL in the caller of this
C                    routine.
C
C     LEFT,
C     RIGHT          are, respectively, the left and right endpoints
C                    of the interval on which the input function is
C                    to be approximated.
C
C     N              is the number of terms in the desired Chebyshev
C                    expansion.  The degree of the highest-order
C                    Chebyshev polynomial in the expansion is N-1.
C
C     WORK           is a work space array of dimension N.
C
C
C$ Detailed_Output
C
C     COEFFS         is an array containing the coefficients of
C                    the N-term Chebyshev expansion of the input
C                    function.
C
C                    Let
C
C                       T (x)   =  cos ( j arccos(x) )
C                        j
C
C                    be the Chebyshev polynomial of degree j; then
C                    COEFFS are computed such that the expansion
C
C                        N
C                       ___
C                       \    COEFFS(j)  T   (x)
C                       /__              j-1
C
C                       j=1
C
C                    is the Chebyshev expansion of F(Y) on the
C                    interval [-1,1], where
C
C                       F(Y) =  FUNC(X)
C
C                    and
C
C                               X  -  (LEFT+RIGHT)/2
C                       Y    =  ---------------------
C                                 (LEFT-RIGHT) / 2
C
C                    The coefficients computed by this routine are
C                    compatible with the SPICELIB routines CHBINT,
C                    CHBVAL, and CHBDER.
C
C                    See the $Particulars section for further details
C                    on the specification of this routine.
C
C$ Parameters
C
C     MAXSIZ         is the maximum number of terms in the Chebyshev
C                    expansion.  This is the maximum allowed value of
C                    N.
C
C$ Exceptions
C
C     1)  If N is less than 1, the error SPICE(INVALIDSIZE) is
C         signaled.  The function will return the value 0.D0.
C
C     2)  If N is greater than MAXSIZ, the error SPICE(INVALIDSIZE) is
C         signaled.  The function will return the value 0.D0.
C
C     3)  This routine does not attempt to ward off or diagnose
C         arithmetic overflows.
C
C     4)  If the endpoints LEFT and RIGHT are not in strictly
C         increasing order, the error SPICE(INVALIDENDPTS)
C         is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The coefficient set produced by this routine is described below:
C
C        Let
C
C           x ,    k = 1, ... , N
C            k
C
C        be the roots of the Chebyshev polynomial
C
C           T (x)   =  cos ( N arccos(x) )
C            N
C
C        These roots are
C
C           cos ( (k-1/2)*PI/N ),    k = 1, ..., N.
C
C
C        For a function f(x) defined on the closed
C        interval [-1,1], the N-term Chebyshev expansion
C        is
C
C            N
C           ___
C           \    C  T   (x)
C           /__   j  j-1
C
C           j=1
C
C        where
C                         N
C                        ___
C           C  =  (2/N)  \   f(x ) T   (x ),  j = 2, ...,N,
C            j           /__    k   j-1  k
C
C                        k=1
C
C                         N
C                        ___
C           C  =  (1/N)  \   f(x )
C            1           /__    k
C
C                        k=1
C
C
C        The definition of
C
C           C
C            1
C
C        used differs from that used in reference [1];
C        our value is half theirs, and yields the simpler
C        expression for the expansion of f(x) shown above.
C
C        When the function f(x) to be approximated is
C        defined on the interval [LEFT,RIGHT], the mapping
C
C                     x  -  (LEFT+RIGHT)/2
C           y(x)  =  ---------------------
C                       (LEFT-RIGHT) / 2
C
C        can be used to define a new function F such that
C        F(y) = f(x).  F has domain [-1,1] and hence admits
C        a Chebyshev expansion.
C
C        In this routine, the above mapping is used to
C        transform the domain of the input function to the
C        interval [-1,1].
C
C
C$ Examples
C
C     1)  Recover coefficients from a function whose Chebyshev
C         expansion is known.  Suppose
C
C            f(x) = 1*T (x) + 2*T (x) + 3*T (x) + 4*T (x).
C                      0         1         2         3
C
C         The following small program produces the Chebyshev
C         coefficients of f:
C
C
C                  PROGRAM TSTCHB
C                  IMPLICIT NONE
C            C
C            C     Test Chebyshev fitting for a simple function.
C            C
C                  INTEGER               NCOEFF
C                  PARAMETER           ( NCOEFF = 4 )
C
C                  DOUBLE PRECISION      FUNC
C                  EXTERNAL              FUNC
C
C                  DOUBLE PRECISION      COEFFS ( NCOEFF )
C                  DOUBLE PRECISION      WORK   ( NCOEFF )
C                  INTEGER               I
C
C
C                  CALL CHBFIT ( FUNC,   -1.D0,  1.D0,
C                 .              NCOEFF,  WORK,  COEFFS )
C
C                  WRITE (*,*) 'Coefficients follow:'
C
C                  DO I = 1, NCOEFF
C                     WRITE (*,*) 'DEGREE: ', I-1, ' = ', COEFFS(I)
C                  END DO
C
C                  END
C
C
C                  DOUBLE PRECISION FUNCTION FUNC ( X )
C                  IMPLICIT NONE
C            C
C            C     Return
C            C
C            C        f(x) = 1*T (x) + 2*T (x) + 3*T (x) + 4*T (x).
C            C                  0         1         2         3
C            C
C                  DOUBLE PRECISION      X
C
C                  INTEGER               NCOEFF
C                  PARAMETER           ( NCOEFF = 4 )
C
C                  DOUBLE PRECISION      CP  ( NCOEFF )
C                  DOUBLE PRECISION      X2S ( 2 )
C                  INTEGER               I
C
C                  DO I = 1, NCOEFF
C                     CP(I) =  DBLE(I)
C                  END DO
C
C                  X2S(1) = 0.D0
C                  X2S(2) = 1.D0
C
C                  CALL CHBVAL ( CP, NCOEFF-1, X2S, X, FUNC )
C                  END
C
C$ Restrictions
C
C     1)  Maximum number of terms in the expansion is limited by the
C         parameter MAXSIZ.
C
C$ Literature_References
C
C     [1]  "Numerical Recipes---The Art of Scientific Computing" by
C           William H. Press, Brian P. Flannery, Saul A. Teukolsky,
C           William T. Vetterling (see section 5.6).
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SUPPORT Version 2.0.0, 14-SEP-2007 (NJB)
C
C        Now pre-computes Chebyvshev polynomial values.  Maximum
C        number of terms in the expansion is limited by the
C        parameter MAXSIZ.
C
C-    SUPPORT Version 1.0.0, 16-JUN-1996 (NJB)
C
C-&

C$ Index_Entries
C
C     fit Chebyshev expansion to a function
C     determine Chebyshev coefficients of a function
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      PI
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               MAX2
      PARAMETER           ( MAX2    = MAXSIZ * MAXSIZ )

      INTEGER               MAX3
      PARAMETER           ( MAX3    = MAXSIZ * MAX2   )

C
C     Local variables
C
      DOUBLE PRECISION      ARG
      DOUBLE PRECISION      MIDPT
      DOUBLE PRECISION      RADIUS
      DOUBLE PRECISION      RTAB   ( MAXSIZ, MAXSIZ )
      DOUBLE PRECISION      TTAB   ( MAXSIZ, MAXSIZ, MAXSIZ )
      DOUBLE PRECISION      X

      INTEGER               I
      INTEGER               J
      INTEGER               K

      LOGICAL               PASS1

C
C     Saved variables
C
      SAVE                  PASS1
      SAVE                  RTAB
      SAVE                  TTAB

C
C     Initial values
C
      DATA                  PASS1 / .TRUE. /

C
C     Check in only if an error is detected.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     Make sure the requested expansion order is not too large.
C
      IF ( N .GT. MAXSIZ ) THEN

         CALL CHKIN  ( 'CHBFIT'                                   )
         CALL SETMSG ( 'The requested expansion order # exceeds ' //
     .                 'the maximum supported order #.'           )
         CALL ERRINT ( '#',  N                                    )
         CALL ERRINT ( '#',  MAXSIZ                               )
         CALL ERRINT ( '#',  N                                    )
         CALL SIGERR ( 'SPICE(INVALIDSIZE)'                       )
         CALL CHKOUT ( 'CHBFIT'                                   )
         RETURN

      END IF

C
C     No data, no interpolation.
C
      IF ( N .LT. 1 ) THEN

         CALL CHKIN  ( 'CHBFIT'                              )
         CALL SETMSG ( 'Array size must be positive; was #.' )
         CALL ERRINT ( '#',  N                               )
         CALL SIGERR ( 'SPICE(INVALIDSIZE)'                  )
         CALL CHKOUT ( 'CHBFIT'                              )
         RETURN

      END IF

C
C     Make sure the input interval is OK.
C
      IF ( LEFT .GE. RIGHT ) THEN

         CALL CHKIN  ( 'CHBFIT'                                 )
         CALL SETMSG ( 'Left endpoint = #; right endpoint = #.' )
         CALL ERRDP  ( '#',  LEFT                               )
         CALL ERRDP  ( '#',  RIGHT                              )
         CALL SIGERR ( 'SPICE(INVALIDENDPTS)'                   )
         CALL CHKOUT ( 'CHBFIT'                                 )
         RETURN

      END IF

      IF ( PASS1 ) THEN
C
C        On the first pass, compute a table of roots of all
C        Cheby polynomials from degree 1 to degree N.  The Ith
C        column of the table contains roots of the Ith polynomial.
C
         CALL CLEARD ( MAX2, RTAB )

         DO I = 1, MAXSIZ

            DO K = 1, I

               RTAB(K,I) =  DCOS (  PI() * ( K - .5D0 ) / I  )

            END DO

         END DO

C
C        Also compute a table of Chebyshev function values.  For
C        each expansion size J from 1 to N, we compute the values
C        of
C
C           T   (x ) ... T   ( x )
C            0    1       0     J
C
C                    .
C                    .
C                    .
C
C           T   (x ) ... T   ( x )
C            J-1  1       J-1   J
C
C        where
C
C           x
C            K
C
C        is the Kth root of
C
C           T
C            J
C
C        In our 3-dimensional table, the (K,I,J) entry is the value
C        of
C
C           T    ( x  )
C            I-1    K
C
C        where
C
C           x
C            K
C
C        is the Kth root of
C
C           T
C            J
C

         CALL CLEARD ( MAX3, TTAB )

         DO J = 1, MAXSIZ
C
C           Compute Cheby values needed to implement an expansion
C           of size J.
C
            DO I = 1, J
C
C              Compute values of
C
C                 T
C                  I-1
C
C              on the roots of
C
C                 T
C                  J
C
C
               DO K = 1, J
C
C                 Evaluate
C
C                    T
C                     I-1
C
C                 at the Kth root of
C
C                    T
C                     J
C
                  ARG          =  PI() * ( K - .5D0 ) / J

                  TTAB(K,I,J)  =  DCOS ( (I-1) * ARG )

               END DO

            END DO

         END DO

         PASS1 = .FALSE.

      END IF

C
C     Find the transformation parameters.
C
      MIDPT  =  ( RIGHT + LEFT ) / 2.D0
      RADIUS =  ( RIGHT - LEFT ) / 2.D0

C
C     Compute the input function values at the transformed Chebyshev
C     roots.
C
      DO K = 1, N

         X       =  RADIUS * RTAB(K,N)   +   MIDPT
         WORK(K) =  FUNC(X)

      END DO

C
C     Compute the coefficients.
C
      DO J = 1, N

         COEFFS(J) =  0.D0

         DO K = 1, N

            COEFFS(J) =  WORK(K) * TTAB(K,J,N)   +  COEFFS(J)

         END DO

         COEFFS(J) = 2.D0 * COEFFS(J) / N

      END DO

C
C     Scale the zero-order coefficient to simplify the form of the
C     Chebyshev expansion.
C
      COEFFS(1) = COEFFS(1) * 0.5D0

      RETURN
      END


      FUNCTION FUNDEN(SAL,SED,TEM)
      REAL::FUNDEN,SSG,SDEN,SSTMP,SAL,TTMP,TEM,RHTMP,RHO,SED
C **  FUNDEN CALCULATED DENSITY AS A FUNTION OF SAL,TEM,AND SED
C CHANGE RECORD
C      IMPLICIT REAL*8 (A-H,O-Z)
C
      SSG=2.5
      SDEN=1./2500000.
C
C **  DENSITY AT GIVEN VALUES OF SAL AND TEM
C
      SSTMP=SAL
      TTMP=TEM
      RHTMP=999.842594+6.793952E-2*TTMP-9.095290E-3*TTMP*TTMP
     &    +1.001685E-4*TTMP*TTMP*TTMP-1.120083E-6*TTMP*TTMP*TTMP*TTMP
     &    +6.536332E-9*TTMP*TTMP*TTMP*TTMP*TTMP
      RHO=RHTMP+SSTMP*(0.824493-4.0899E-3*TTMP+7.6438E-5*TTMP*TTMP
     &    -8.2467E-7*TTMP*TTMP*TTMP+5.3875E-9*TTMP*TTMP*TTMP*TTMP)
     &    +SQRT(SSTMP)*SSTMP*(-5.72466E-3+1.0227E-4*TTMP
     &    -1.6546E-6*TTMP*TTMP)+4.8314E-4*SSTMP*SSTMP
C
C **  CORRECTION FOR SEDIMENT
C
      RHO=RHO*( (1.-SDEN*SED)+(SSG-1.)*SDEN*SED )
C
C **  RETURN DENSITY
C
      FUNDEN=RHO
      RETURN
      END


subroutine imc_update

    use imc_global_bcon_data, only: t0
    use imc_global_mat_data,  only: gamma, bee
    use imc_global_mesh_data, only: sigma_p, temp, beta, fleck, xsize, temp0, dx
    use imc_global_phys_data, only: x15pi4, pi, c, h, a
    use imc_global_time_data, only: step, dt

    implicit none

    write(*,'(/,A)')    '-------------------------------------------------------------------------------'
    write(*,'(A,I4,A)') 'Update step (',step,')'
    write(*,'(A)')      '-------------------------------------------------------------------------------'

    ! Calculate Planck mean opacity for the mesh
    ! ------------------------------------------

    ! In general do this every time-step because sigma can be temperature-dependent
    ! There is a factor gamma missing that is problem-dependent (assumed = 1 here)

    sigma_p(:) = x15pi4 * gamma * temp(:)**(-3)

    write(*,'(/,A)') 'Planck mean opacity (Fleck & Cummings 1971 Eqn 4.7)'
    write(*,'(4(ES16.8,1X))') 8.d0 * pi * gamma / (c**3 * h**3 * a * temp(:)**3)
    write(*,'(A)') 'Planck mean opacity (Wollaber 2008 Eqn 2.21)'
    write(*,'(4(ES16.8,1X))') sigma_p(:)
    write(*,'(A)') '...These should match...'
    write(*,'(A)') '...These should decrease as T^3...'

    ! Calculate beta for the mesh
    ! ---------------------------

    beta(:) = 4.d0 * a * (temp(:)**3) / bee

    write(*,'(/,A)') 'Beta (non-linearity factor) (Fleck & Cummings 1971 Eqn 1.6)'
    write(*,'(4(ES16.8,1X))') beta
    write(*,'(A)') '...This should increase as T^3...'

    ! Fleck
    ! -----

    fleck(:) = 1.d0 / (1.d0 + beta(:) * c * dt * sigma_p(:))

    write(*,'(/,A)') 'Fleck factor (Fleck & Cummings 1971 Eqn 4.1d)'
    write(*,'(10(F6.3,1X))') fleck
    write(*,'(A)') '...This should be constant (for a given timestep length)...'
    write(*,'(A,F10.8,A)') '...This should equal ', &
        (1.d0 / (1.d0 + (32.d0 * pi * gamma / (c**3 * h**3 * bee)) * c * dt)), &
        '...'
    write(*,'(/,A,F6.3, A)') 'Slab thickness       = ', xsize, ' cm'
    write(*,'(A,F6.3, A)') 'Boundary source temp = ', t0, ' keV'
    write(*,'(A,F6.3)') 'Material gamma/D     = ', gamma
    write(*,'(A,F6.3, A)') 'Sigma at nu = 3 keV  = ', gamma / (3.d0**3), ' cm^-1'
    !write(*,'(A,F6.3)') 'Sigma at nu = 3 keV  = ', &
    !    & gamma * (1.d0 - exp(-3. / 0.001)) / (3.d0**3), ' cm^-1'
    write(*,'(A,F6.3)') 'Spatial step         = ', dx
    write(*,'(A,F6.3, A)') 'Time step            = ', (dt / 1.d-08), ' sh'
    write(*,'(/,A)') 'Initial temperature (keV):'
    write(*,'(10(F6.3,1X))') temp0
    write(*,'(/,A)') 'Scattering fraction (%):'
    write(*,'(10(F4.1,1X))') 100.d0 * (1.d0 - fleck(:))

end subroutine imc_update


*
*     -------------------------------------------------------------
*      N I N E 0
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
*                                                                  *
*     |  J1/2  J2/2  J3/2 |                                        *
*     |  L1/2  L2/2  L3/2 |                                        *
*     |  K1/2  K2/2    0  |                                        *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vilnius,  Lithuania                             March 1995   *
*
      SUBROUTINE NINE0(J1,J2,J3,L1,L2,L3,K1,K2,K3,AA)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      IF(J1.EQ.0) THEN
        CALL SIXJ(L2,K2,J2,K3,L3,L1,0,A)
        B=DBLE((J2+1)*(L1+1))
        IFA=K2+J2+L3+L1
      ELSEIF(J2.EQ.0) THEN
        CALL SIXJ(L3,K3,J3,K1,L1,L2,0,A)
        B=DBLE((J3+1)*(L2+1))
        IFA=K3+J3+L1+L2
      ELSEIF(J3.EQ.0) THEN
        CALL SIXJ(L1,K1,J1,K2,L2,L3,0,A)
        B=DBLE((J1+1)*(L3+1))
        IFA=K1+J1+L2+L3
      ELSEIF(L1.EQ.0) THEN
        CALL SIXJ(K2,J2,L2,J3,K3,K1,0,A)
        B=DBLE((L2+1)*(K1+1))
        IFA=J2+L2+K3+K1
      ELSEIF(L2.EQ.0) THEN
        CALL SIXJ(K3,J3,L3,J1,K1,K2,0,A)
        B=DBLE((L3+1)*(K2+1))
        IFA=J3+L3+K1+K2
      ELSEIF(L3.EQ.0) THEN
        CALL SIXJ(K1,J1,L1,J2,K2,K3,0,A)
        B=DBLE((L1+1)*(K3+1))
        IFA=J1+L1+K2+K3
      ELSEIF(K1.EQ.0) THEN
        CALL SIXJ(J2,J3,J1,L3,L2,K2,0,A)
        B=DBLE((J1+1)*(K2+1))
        IFA=J3+J1+L2+K2
      ELSEIF(K2.EQ.0) THEN
        CALL SIXJ(J3,J1,J2,L1,L3,K3,0,A)
        B=DBLE((J2+1)*(K3+1))
        IFA=J1+J2+L3+K3
      ELSEIF(K3.EQ.0) THEN
        CALL SIXJ(J1,J2,J3,L2,L1,K1,0,A)
        B=DBLE((J3+1)*(K1+1))
        IFA=J2+J3+L1+K1
      ELSE
        A=ZERO
        B=ONE
      ENDIF
      AA=A/DSQRT(B)
      IF(MOD(IFA,4).NE.0)AA=-AA
      RETURN
      END


module m_da_maooam
  use m_mt, only : eigen, inv
  implicit none

  private
  public :: etkf
  public :: etkf2

  !integer,parameter :: nx = 20
  !integer,parameter :: nyo = 20
  !integer,parameter :: nx = 36
  !integer,parameter :: nyo = 36
  !integer,parameter :: kitermax = 500
  real(8),parameter :: epsG   = 1.d-2

contains

subroutine etkf( nx, nyo, nn, xb, lyo, yo, erro, infl, xa, xam, fnum )
  implicit none
! passed args
  integer,    intent(in   ) :: nx	! dim of model space
  integer,    intent(in   ) :: nyo	! dim of obs space
  integer,    intent(in   ) :: nn	! dim of ens size
  integer,    intent(in   ) :: fnum
  real(8), intent(in   ) :: xb(nx,nn)
  logical,    intent(in   ) :: lyo(nyo)
  real(8), intent(in   ) :: yo(nyo)
  real(8), intent(in   ) :: erro(nyo)
  real(8), intent(in   ) :: infl
  real(8), intent(  out) :: xa(nx,nn)
  real(8), intent(  out) :: xam(nx)
! local vars
  integer :: nyo_use
  real(8),allocatable :: dyb(:,:)
  real(8),allocatable :: ybm(:)
  real(8),allocatable :: erro_use(:)
  real(8),allocatable :: yo_ybm(:)
  real(8),allocatable :: gain(:,:)
  real(8) :: xbm(nx)
  real(8) :: invSPa(nn,nn), SPa(nn,nn) ! Pa in ensemble space
  real(8),allocatable :: C(:,:)
  real(8) :: eigval(nn), eigvect(nn,nn)
  integer :: np
  real(8) :: wam(nn), Wa(nn,nn)
  real(8) :: dxb(nx,nn)
  integer :: ierr
  integer :: i, j, k

  nyo_use = 0
! calculate mean yb and perturbation matrix Yb
  do i = 1, nyo
     if ( lyo(i) ) then
        nyo_use = nyo_use + 1
     else
        !write(6,*) "skip obs: iob =", i, ", yo(iob)=", yo(i)
     endif
  enddo
  allocate( dyb(nyo_use,nn) )
  allocate( ybm(nyo_use), yo_ybm(nyo_use), erro_use(nyo_use) )

  k = 0
  do i = 1, nyo
     if ( lyo(i) ) then
        k           = k + 1
        dyb(k,:)    = xb(i,:)
        ybm(k)      = SUM(dyb(k,:))/nn
        dyb(k,:)    = dyb(k,:) - ybm(k)
        yo_ybm(k)   = yo(i) - ybm(k)
        erro_use(k) = erro(i)
        !print*, "k, erro, yo, ybm=", k, erro_use(k), yo(i), ybm(k)
        !pause
     endif
  enddo

! calculate mean xb
  do i = 1, nx
     xbm(i) = SUM(xb(i,:))/nn
  enddo

  allocate( C(nn,nyo_use) )

! C=(Yb)^T * R^-1
  do j = 1, nyo_use
     C(:,j) = dyb(j,:)/(erro_use(j)**2)
  enddo
! invSPa = [(k-1)I+C*Yb]
  invSPa = MATMUL( C, dyb )
  do k = 1, nn
     invSPa(k,k) = invSPa(k,k)+(nn-1)/infl
  enddo
! let A=invSPa, where A=Q*V*Q^T
! so A^-1=Q*V^-1*Q^T
  call eigen( nn, invSPa, eigvect, eigval)
  !if ( ierr/=0 .or. np/=nn ) then
  !   write(6,*) "[warning] lorenz63_letkf: fail to find nn (+) eigenvetor"
  !   xam = xbm
  !   xa = xb
  !   return
  !endif
  do k = 1, nn
     SPa(:,k) = eigvect(:,k)/eigval(k)
  enddo
  SPa = MATMUL( SPa, TRANSPOSE(eigvect) )
  ! Wa = [(k-1)SPa]^1/2
  !    = [(k-1)A^-1]^1/2
  !    = [ Q*(k-1)V^-1*Q^T ]^1/2
  !    = [ Q*sqrt((k-1)/V)*Q^T ]
  do k = 1, nn
     Wa(:,k) = eigvect(:,k)*SQRT( (nn-1)/eigval(k) )
  enddo
  Wa = MATMUL( Wa, TRANSPOSE(eigvect) )
  ! wam = SPa * C *( yo -ybm )
  wam = MATMUL( C, yo_ybm )
  wam = MATMUL( SPa, wam )  !!!
  ! Wa = Wa + wam
  do k = 1, nn
     Wa(:,k) = Wa(:,k) + wam(:)
  enddo

  do i = 1, nx
     ! xam = xbm + Xb*wam
     dxb(i,:) = xb(i,:)-xbm(i)
     xam(i) = xbm(i) + SUM(dxb(i,:)*wam(:))

     do k = 1, nn
        xa(i,k) = xbm(i) + SUM(dxb(i,:)*Wa(:,k))
     enddo
  enddo

  ! write gain matrix
  allocate(gain(nx,nyo))
  gain = MATMUL(SPa,C)
  gain = MATMUL(dxb,gain)
  do i = 1,nx
    write(fnum,*) gain(i,:)
  enddo

endsubroutine

subroutine etkf2( nx, nyo, nn, xb, lyo, yo, erro, infl, xa, xam )
  implicit none
! passed args
  integer, intent(in) :: nx
  integer, intent(in) :: nyo
  integer,    intent(in   ) :: nn
  real(8), intent(in   ) :: xb(nx,nn)
  logical,    intent(in   ) :: lyo(nyo)
  real(8), intent(in   ) :: yo(nyo)
  real(8), intent(in   ) :: erro(nyo)
  real(8), intent(in   ) :: infl
  real(8), intent(  out) :: xa(nx,nn)
  real(8), intent(  out) :: xam(nx)
! local vars
  integer :: nyo_use
  real(8),allocatable :: dyb(:,:)
  real(8),allocatable :: ybm(:)
  real(8),allocatable :: erro_use(:)
  real(8),allocatable :: yo_ybm(:)
  real(8) :: xbm(nx)
  real(8) :: invSPa(nn,nn), SPa(nn,nn) ! Pa in ensemble space
  real(8),allocatable :: C(:,:)
  real(8) :: eigval(nn), eigvect(nn,nn)
  integer :: np
  real(8) :: wam(nn), Wa(nn,nn)
  real(8) :: dxb(nn)
  integer :: ierr
  integer :: i, j, k

  nyo_use = 0
! calculate mean yb and perturbation matrix Yb
  do i = 1, nyo
     if ( lyo(i) ) then
        nyo_use = nyo_use + 1
     else
        write(6,*) "skip obs: iob =", i, ", yo(iob)=", yo(i)
     endif
  enddo
  allocate( dyb(nyo_use,nn) )
  allocate( ybm(nyo_use), yo_ybm(nyo_use), erro_use(nyo_use) )

  k = 0
  do i = 1, nyo
     if ( lyo(i) ) then
        k           = k + 1
        dyb(k,:)    = xb(i,:)
        ybm(k)      = SUM(dyb(k,:))/nn
        dyb(k,:)    = dyb(k,:) - ybm(k)
        yo_ybm(k)   = yo(i) - ybm(k)
        erro_use(k) = erro(i)
        !print*, "k, erro, yo, ybm=", k, erro_use(k), yo(i), ybm(k)
        !pause
     endif
  enddo

! calculate mean xb
  do i = 1, nx
     xbm(i) = SUM(xb(i,:))/nn
  enddo

  allocate( C(nn,nyo_use) )

! C=(Yb)^T * R^-1
  do j = 1, nyo_use
     C(:,j) = dyb(j,:)/(erro_use(j)**2)
  enddo
! invSPa = [(k-1)I+C*Yb]
  invSPa = MATMUL( C, dyb )
  do k = 1, nn
     invSPa(k,k) = invSPa(k,k)+(nn-1)/infl
  enddo
! let A=invSPa, where A=Q*V*Q^T
! so A^-1=Q*V^-1*Q^T
  call eigen( nn, invSPa, eigvect, eigval)
  !if ( ierr/=0 .or. np/=nn ) then
  !   write(6,*) "[warning] lorenz63_letkf: fail to find nn (+) eigenvetor"
  !   xam = xbm
  !   xa = xb
  !   return
  !endif
  do k = 1, nn
     SPa(:,k) = eigvect(:,k)/eigval(k)
  enddo
  SPa = MATMUL( SPa, TRANSPOSE(eigvect) )
  ! Wa = [(k-1)SPa]^1/2
  !    = [(k-1)A^-1]^1/2
  !    = [ Q*(k-1)V^-1*Q^T ]^1/2
  !    = [ Q*sqrt((k-1)/V)*Q^T ]
  do k = 1, nn
     Wa(:,k) = eigvect(:,k)*SQRT( (nn-1)/eigval(k) )
  enddo
  Wa = MATMUL( Wa, TRANSPOSE(eigvect) )
  ! wam = SPa * C *( yo -ybm )
  wam = MATMUL( C, yo_ybm )
  wam = MATMUL( SPa, wam )  !!!
  ! Wa = Wa + wam
  do k = 1, nn
     Wa(:,k) = Wa(:,k) + wam(:)
  enddo

  do i = 1, nx
     ! xam = xbm + Xb*wam
     dxb = xb(i,:)-xbm(i)
     xam(i) = xbm(i) + SUM(dxb(:)*wam(:))

     do k = 1, nn
        xa(i,k) = xbm(i) + SUM(dxb(:)*Wa(:,k))
     enddo
  enddo

endsubroutine

endmodule


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mnspde : splder test program                       cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(7),y(42),t(20),c(20),wrk(20),d(6)
      integer i,ier,j,k,k1,l,m,n,nk1,nu
      real ai
c  set up the points where the spline derivatives will be evaluated.
      m = 7
      x(1) = 0.
      ai = 0.5e-01
      do 10 i=2,m
        x(i) = x(i-1)+ai
        ai = ai+0.5e-01
  10  continue
      x(m) = 0.1e+01
c  main loop for the different spline degrees.
      do 70 k=1,5
        k1 = k+1
c  n denotes the total number of knots.
        n = 2*k1+4
c  set up the knots of the spline
        j = n
c  the boundary knots
        do 20 i=1,k1
          t(i) = 0.
          t(j) = 0.1e+01
          j = j-1
  20    continue
c  the interior knots
        t(k1+1) = 0.1e+0
        t(k1+2) = 0.3e+0
        t(k1+3) = 0.4e+0
        t(k1+4) = 0.8e+0
c  generate the b-spline coefficients.
        nk1 = n-k1
        do 30 i=1,nk1
          ai = i
          c(i) = 0.1e-01*ai*(ai-0.5e01)
  30    continue
c  evaluate the spline derivatives.
        j = 1
        do 40 i=1,k1
c  nu denotes the order of the derivative
          nu = i-1
          call splder(t,n,c,k,nu,x,y(j),m,wrk,ier)
          j = j+m
  40    continue
c  print the results.
        write(6,900) k
        write(6,905)
        write(6,910) (t(i),i=1,n)
        write(6,915)
        write(6,920) (c(i),i=1,nk1)
        write(6,925) (i,i=1,5)
        write(6,930)
        do 60 i=1,m
          j = i
          do 50 l=1,k1
            d(l) = y(j)
            j = j+m
  50      continue
          write(6,935) i,x(i),(d(l),l=1,k1)
  60    continue
  70  continue
      stop
c  format statements.
 900  format(25h0degree of the spline k =,i2)
 905  format(1x,21hposition of the knots)
 910  format(5x,15f5.1)
 915  format(1x,21hb-spline coefficients)
 920  format(5x,8f9.5)
 925  format(21x,5(i4,8x))
 930  format(1x,1hi,6h  x(i),3x,8hs(x(i)) ,5(4x,8hs (x(i))))
 935  format(1x,i1,f6.2,6e12.4)
      end


      DOUBLE PRECISION FUNCTION CAUCHY(NN,PT,Q)                         CAUC3760
C CAUCHY COMPUTES A LOWER BOUND ON THE MODULI OF THE ZEROS OF A
C POLYNOMIAL - PT IS THE MODULUS OF THE COEFFICIENTS.
      DOUBLE PRECISION Q(NN),PT(NN),X,XM,F,DX,DF,
     *   DABS,DEXP,DLOG
      PT(NN) = -PT(NN)
C COMPUTE UPPER ESTIMATE OF BOUND.
      N = NN-1
      X = DEXP( (DLOG(-PT(NN)) - DLOG(PT(1)))/FLOAT(N) )
      IF (PT(N).EQ.0.0D0) GO TO 20
C IF NEWTON STEP AT THE ORIGIN IS BETTER, USE IT.
          XM = -PT(NN)/PT(N)
          IF (XM.LT.X) X=XM
C CHOP THE INTERVAL (0,X) UNITL F LE 0.
   20 XM = X*.1D0
      F = PT(1)
      DO 30 I = 2,NN
          F = F*XM+PT(I)
   30 CONTINUE
      IF (F.LE. 0.0D0) GO TO 40
          X = XM
          GO TO 20
   40 DX = X
C DO NEWTON ITERATION UNTIL X CONVERGES TO TWO DECIMAL PLACES.
   50 IF (DABS(DX/X) .LE. .005D0) GO TO 70
          Q(1) = PT(1)
          DO 60 I = 2,NN
               Q(I) = Q(I-1)*X+PT(I)
   60     CONTINUE
          F = Q(NN)
          DF = Q(1)
          DO 65 I = 2,N
               DF = DF*X+Q(I)
   65     CONTINUE
          DX = F/DF
          X = X-DX
          GO TO 50
   70 CAUCHY = X
      RETURN
      END


	SUBROUTINE GCYLLM ( mproj, msppj, np, xl, yl, polat, polon,
     +			    rotat, sclmcd, swchxy, dlat, dlon, iret )
C************************************************************************
C* GCYLLM								*
C* 									*
C* This subroutine converts a location from linear intermediate		*
C* coordinates to latitude-longitude coordinates for cylindrical	*
C* projections.								*
C*									*
C* Note that the only case implemented is the case with the u-axis at	*
C* the equator.  The general case is achieved via coordinate rotation.  *
C* Therefore, this routine remains simple.				*
C*									*
C* SWCHXY is a flag for a 90 degree rotation of the linear coordinates  *
C* to develop a transverse projection with the y-axis oriented south to	*
C* north.								*
C*									*
C* GCYLLM  ( MPROJ,MSPPJ, NP, XL, YL, POLAT, POLON, ROTAT, SCLMCD,	*
C*           SWCHXY, DLAT, DLON, IRET )					*
C* 									*
C* Input parameters:							*
C*	MPROJ		INTEGER		Projection class		*
C*	MSPPJ		INTEGER		Projection type			*
C*	NP		INTEGER		Number of points		*
C* 	XL (NP)		REAL		X coordinates			*
C* 	YL (NP)		REAL		Y-coordinates			*
C*	POLAT		REAL		Not used			*
C*	POLON		REAL		Central longitude 		*
C*	ROTAT		REAL		Not used			*
C*	SCLMCD		REAL		Scaling for MCD			*
C*	SWCHXY		LOGICAL		Flag to rotate x,y		*
C* 									*
C* Output parameters:							*
C* 	DLAT (NP)	REAL		Latitudes			*
C* 	DLON (NP)	REAL		Longitudes			*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 7/84	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 1/88	Fixed CED rounding at pole		*
C* M. desJardins/GSFC	 1/88	Fixed missing data			*
C* M. desJardins/GSFC	 6/88	Cleaned up				*
C* K. Brill/EMC		 3/96	Changes for general rotation		*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		xl (*), yl (*), dlat (*), dlon (*)
	LOGICAL		swchxy
C*
	PARAMETER	( EPS = .00001 )
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = NORMAL
        hlfpin = -HALFPI - EPS
        hlfpip = HALFPI + EPS
C
C*	Loop through all the points.
C
	DO  i = 1, np
C
C*	  Check for missing data.
C
	  IF  ( ( ERMISS ( xl (i) ) ) .or. ( ERMISS ( yl (i) ) ) )  THEN
	    dlat (i) = RMISSD
	    dlon (i) = RMISSD
	  ELSE
C
C*	    Rotate x,y if necessary.
C
	    IF ( swchxy ) THEN
		xx = yl (i)
		yy = -xl (i)
	    ELSE
		xx = xl (i)
		yy = yl (i)
	    END IF
C*
	    rlat = RMISSD
	    rlon = xx
C
C*	    Compute internal projection angle.
C
C*	    Cylindrical equidistant projection.
C
	    IF ( mproj .eq. MPCEQU ) THEN
		IF  ( ( yy .ge. hlfpin ) .and.
     +		      ( yy .le. hlfpip ) )  THEN
		    rlat = yy
		END IF
C
C*	    Mercator projection.
C
	      ELSE IF  ( mproj .eq. MPCMER ) THEN
		rlat = HALFPI - ACOS ( TANH ( yy ) )
C
C*	    Modified cylindrical equidistant.
C
	      ELSE IF  ( mproj .eq. MPCMCD )  THEN
		IF  ( ( yy .ge. hlfpin ) .and.
     +		      ( yy .le. hlfpip ) )  THEN
		    rlat = yy / sclmcd
		END IF
	    END IF
C
C*	    Convert from radians to degrees.
C
	    IF  ( .not. ERMISS ( rlat ) )  THEN
		dlat (i) = rlat * RTD
		dlon (i) = ( rlon + polon ) * RTD
	      ELSE
		dlat (i) = RMISSD
		dlon (i) = RMISSD
	    END IF
	  END IF
	END DO
C*
	RETURN
	END


module problem
    use spin_system
    use types
    use eigen
    use constants
    use utils
    use callbacks
    ! implement the task for the assignment
    implicit none

    type, extends(VectorFunctor) :: HeisenbergHamiltonianOperator

    contains
        procedure :: eval => VectorMatrixMult
    end type

private

public prob1, VectorMatrixMult
contains

    function VectorMatrixMult(this,x) result(fx)
        class(HeisenbergHamiltonianOperator) :: this
        real(dp),intent(in) :: x(:)
        real(dp),dimension(:), allocatable :: fx
        allocate(fx(BasisDimension))
        call OperateHamiltonian(x, fx)
    end function VectorMatrixMult

    subroutine prob1
        type(HeisenbergHamiltonianOperator) :: op
        real(dp)  :: Energy
        real(dp),allocatable,dimension(:) :: StateVector,NewStateVector
        integer :: NumSites
        integer :: FileH

        open(newunit=FileH,file="out.txt",status="replace")

        do NumSites = 4,16,2
            call InitSpinSystem(NumSites)

            if(allocated(StateVector))deallocate(StateVector)
            allocate(StateVector(BasisDimension))
            call random_number(StateVector)
            print *, "====================="
            print *,"Starting lanczos"
            print *,"Numero de sitios: ",NumSites
            print *, "BasisDimension:",BasisDimension

            call lanczos(BasisDimension,StateVector,op,Energy,StateVector)

            !normalize
            StateVector = StateVector /norm2(StateVector)

            call prob1c(BasisDimension,StateVector,NumSites)

            ! NewStateVector = StateVector

            print *,NumSites,Energy,Energy/NumSites
            ! print *, "State Vector", StateVector

            !check diagonalization
            ! call OperateHamiltonian(StateVector,NewStateVector)
            ! print *, "NewStateVector",NewStateVector/StateVector

            write (FileH,*) NumSites,Energy,Energy/NumSites

            call ComputeCorrelation(NumSites, StateVector)
        enddo

        contains
            subroutine ComputeCorrelation(N,state)
                real(dp) :: state(:)
                integer,intent(in)  :: N !num sites
                real(dp),allocatable :: correlation(:),aux(:)
                integer :: l
                integer :: CORRELATION_UNIT
                allocate(correlation(0:N))

                open(newunit = CORRELATION_UNIT, file="correlation"//str(N)//".dat",status="replace")
                do l = 0,N-1
                    aux = state
                    call OperateSz(aux,l)
                    call OperateSz(aux,0)
                    correlation(l) = dot_product(aux,state)

                    write (CORRELATION_UNIT,*) l,correlation(l)

                enddo
                call ComputeStructureFactor(N, correlation)
                close(CORRELATION_UNIT)

            end subroutine ComputeCorrelation

            subroutine ComputeStructureFactor(N, correlation)
                implicit none
                integer,intent(in) :: N
                real(dp) :: correlation(N)
                real(dp) :: Rl(N)
                real(dp) :: q
                integer :: i
                complex :: img_number = (0.0,1.0)
                complex(dp) :: S(N)
                integer :: STRUCTURE_UNIT

                open(newunit = STRUCTURE_UNIT, file= "structure"//str(N)//".dat",status="replace")

                print *,"Structure factor, N = " , N
                print *, "q", "                     S(q)"
                Rl = (/ (i, i=0,N-1)/)
                do i=0,N-1
                    q = 2 * pi * i/N;
                    S(i + 1) =  sum( exp(- img_number * q * Rl)*correlation)
                    print*, q, S(i+1)
                    write (STRUCTURE_UNIT,*) q, REALPART(S(i+1)), IMAGPART(S(i+1))
                enddo
                close(STRUCTURE_UNIT)

            end subroutine ComputeStructureFactor

            subroutine prob1c(N,GroundState,Sites)
                implicit none
                integer,intent(in) :: N,Sites
                real(dp) :: GroundState(N)
                real(dp) :: ExitedState(N), FinalState(N)
                integer :: i,j
                type(HeisenbergHamiltonianOperator) :: op
                real(dp) :: StartTime, EndTime, TimeStep, TimePoints(100)
                real(dp) :: EvolutionPoints(100)
                integer :: EVOLUTION_UNIT

                open(newunit=EVOLUTION_UNIT, file="evolution"//str(Sites)//".dat",status="replace");

                StartTime = 0;
                EndTime = 0.5
                TimeStep = 0.005
                ! apply operator $S^z_{q=\pi}$
                ExitedState = GroundState
                do i=0,Sites-1
                    call OperateSz(ExitedState,i)
                    ExitedState = ExitedState*(-1)**i
                enddo
                ! now i have the excited state i must
                TimePoints = [(StartTime + i*TimeStep,i=0,100-1)]

                call LanczosTimeEvolution(N,GroundState,ExitedState, TimePoints,op,EvolutionPoints)
                print *,"Writing evolution to a file"
                do i=1,100
                    write(EVOLUTION_UNIT,*) TimePoints(i),EvolutionPoints(i)
                enddo
                close(EVOLUTION_UNIT)

            end subroutine prob1c

    end subroutine prob1

end module problem


      FUNCTION betacf(a,b,x)
      INTEGER MAXIT
      REAL betacf,a,b,x,EPS,FPMIN
      PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30)
      INTEGER m,m2
      REAL aa,c,d,del,h,qab,qam,qap
      qab=a+b
      qap=a+1.
      qam=a-1.
      c=1.
      d=1.-qab*x/qap
      if(abs(d).lt.FPMIN)d=FPMIN
      d=1./d
      h=d
      do 11 m=1,MAXIT
        m2=2*m
        aa=m*(b-m)*x/((qam+m2)*(a+m2))
        d=1.+aa*d
        if(abs(d).lt.FPMIN)d=FPMIN
        c=1.+aa/c
        if(abs(c).lt.FPMIN)c=FPMIN
        d=1./d
        h=h*d*c
        aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2))
        d=1.+aa*d
        if(abs(d).lt.FPMIN)d=FPMIN
        c=1.+aa/c
        if(abs(c).lt.FPMIN)c=FPMIN
        d=1./d
        del=d*c
        h=h*del
        if(abs(del-1.).lt.EPS)goto 1
11    continue
      pause 'a or b too big, or MAXIT too small in betacf'
1     betacf=h
      return
      END

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


module find_fit_module

!! This module contains a general function find_fit() for a nonlinear least
!! squares fitting. The function can fit any nonlinear expression to any data.

use minpack_module, only: wp, lmdif1

implicit none

private

abstract interface
    function expr_f(x, pars) result(y)
        import :: wp
        implicit none
        real(wp), intent(in) :: x(:)
        real(wp), intent(in) :: pars(:)
        real(wp) :: y(size(x))
    end function expr_f
end interface

public :: find_fit

contains

subroutine find_fit(data_x, data_y, expr, pars)
! Fits the (data_x, data_y) arrays with the function expr(x, pars).
! The user can provide any nonlinear function 'expr' depending on any number of
! parameters 'pars' and it must return the evaluated expression on the
! array 'x'. The arrays 'data_x' and 'data_y' must have the same
! length.
real(wp), intent(in) :: data_x(:)
real(wp), intent(in) :: data_y(:)
procedure(expr_f) :: expr
real(wp), intent(inout) :: pars(:)

real(wp) :: tol, fvec(size(data_x))
integer :: iwa(size(pars)), info, m, n
real(wp), allocatable :: wa(:)

tol = sqrt(epsilon(1.0_wp))
m = size(fvec)
n = size(pars)
allocate(wa(m*n + 5*n + m))
call lmdif1(fcn, m, n, pars, fvec, tol, info, iwa, wa, size(wa))
if (info /= 1) error stop "failed to converge"

contains

    subroutine fcn(m, n, x, fvec, iflag)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(inout) :: iflag
    real(wp), intent(in) :: x(n)
    real(wp), intent(out) :: fvec(m)
    fvec(1) = iflag ! Suppress compiler warning
    fvec = data_y - expr(data_x, x)
    end subroutine fcn

end subroutine find_fit

end module find_fit_module

program example_primes

!! Find a nonlinear fit of the form `a*x*log(b + c*x)` to a list of primes.

use find_fit_module, only: find_fit
use minpack_module, only: wp
use iso_fortran_env, only: nwrite => output_unit

implicit none

real(wp) :: pars(3)
real(wp), parameter :: y(*) = real([2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, &
                                    37, 41, 43, 47, 53, 59, 61, 67, 71], wp)
integer :: i
pars = [1.0_wp, 1.0_wp, 1.0_wp]
call find_fit([(real(i, wp), i=1,size(y))], y, expression, pars)

write(nwrite, '(1p,5x,a/(5x,3e15.7))') 'pars: ',pars

contains

function expression(x, pars) result(y)
real(wp), intent(in) :: x(:)
real(wp), intent(in) :: pars(:)
real(wp) :: y(size(x))
real(wp) :: a, b, c
a = pars(1)
b = pars(2)
c = pars(3)
y = a*x*log(b + c*x)
end function expression

end program example_primes


	   subroutine utmtodeg(utmzone,i,j,x0,y0,gsize,lat,lon)
	   IMPLICIT NONE
	   integer i,j
	   real x0,y0,x,y,gsize
	   integer utmzone,zone
	   real lat,lon
           real sa,inv_flattening,sb
	   real e2,e2cuadrada,c
	   real S,v,a,a1,a2,j2,j4,j6
	   real alfa,beta,gama
	   real bm,b,nab,senoheps
	   real epsi,eps,pi
	   real delt,ta0
	   x=x0+(j-1)*gsize
	   y=y0-(i-1)*gsize
           sa = 6378137.
           inv_flattening = 298.257223563;
           sb = sa - (sa / inv_flattening)
           e2=(((sa**2)-(sb**2))**0.5)/sb
           e2cuadrada= (e2**2)
           c=(sa**2)/sb
           x=x-500000
	   if (utmzone.lt.0) then
	   y=y-10000000
	   zone=-utmzone
	   else
	   zone=utmzone
	   endif
           S=((zone*6.)-183.)
	   lat=Y/(6366197.724*0.9996);
           v=(c/((1.+(e2cuadrada*(cos(lat))**2)))**0.5)*0.9996;
           a=x/v
	   a1=sin(2*lat)
	   a2=a1*(cos(lat))**2
	   j2=lat+(a1/2)
	   j4=((3.*j2)+a2)/4.
	   j6=((5.*j4)+(a2*(cos(lat))**2))/3.
	   alfa=(3./4.)*e2cuadrada
	   beta=(5./3.)*alfa**2
	   gama=(35./27.)*alfa**3;
           bm=0.9996*c*(lat-alfa*j2+beta*j4-gama*j6)
           b=(y-bm)/v;
           epsi=((e2cuadrada*a**2)/2.)*(cos(lat))**2
           eps=a*(1.-(epsi/3.))
           nab=(b*(1.-epsi))+lat
           senoheps=(exp(eps)-exp(-eps))/2
	   delt=atan(senoheps/(cos(nab)))
	   ta0=atan(cos(delt)*tan(nab))
	   pi=atan(1.)*4.
           lon=(delt*(180./pi))+s
           lat=(lat+(1+e2cuadrada*(cos(lat)**2)-(3./2.)*e2cuadrada*sin(lat)*cos(lat)*(ta0-lat))*(ta0-lat))*(180./pi)
c	   write(6,*) utmzone,x,y,lon,lat
	   return
	   end


      SUBROUTINE TB04AD( ROWCOL, N, M, P, A, LDA, B, LDB, C, LDC, D,
     $                   LDD, NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1,
     $                   LDUCO2, TOL1, TOL2, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find the transfer matrix T(s) of a given state-space
C     representation (A,B,C,D). T(s) is expressed as either row or
C     column polynomial vectors over monic least common denominator
C     polynomials.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     ROWCOL  CHARACTER*1
C             Indicates whether the transfer matrix T(s) is required
C             as rows or columns over common denominators as follows:
C             = 'R':  T(s) is required as rows over common denominators;
C             = 'C':  T(s) is required as columns over common
C                     denominators.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation, i.e. the
C             order of the original state dynamics matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading NR-by-NR part of this array contains
C             the upper block Hessenberg state dynamics matrix A of a
C             transformed representation for the original system: this
C             is completely controllable if ROWCOL = 'R', or completely
C             observable if ROWCOL = 'C'.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M),
C             if ROWCOL = 'R', and (LDB,MAX(M,P)) if ROWCOL = 'C'.
C             On entry, the leading N-by-M part of this array must
C             contain the original input/state matrix B; if
C             ROWCOL = 'C', the remainder of the leading N-by-MAX(M,P)
C             part is used as internal workspace.
C             On exit, the leading NR-by-M part of this array contains
C             the transformed input/state matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original state/output matrix C; if
C             ROWCOL = 'C', the remainder of the leading MAX(M,P)-by-N
C             part is used as internal workspace.
C             On exit, the leading P-by-NR part of this array contains
C             the transformed state/output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,P)   if ROWCOL = 'R';
C             LDC >= MAX(1,M,P) if ROWCOL = 'C'.
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M),
C             if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'.
C             The leading P-by-M part of this array must contain the
C             original direct transmission matrix D; if ROWCOL = 'C',
C             this array is modified internally, but restored on exit,
C             and the remainder of the leading MAX(M,P)-by-MAX(M,P)
C             part is used as internal workspace.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P)   if ROWCOL = 'R';
C             LDD >= MAX(1,M,P) if ROWCOL = 'C'.
C
C     NR      (output) INTEGER
C             The order of the transformed state-space representation.
C
C     INDEX   (output) INTEGER array, dimension (porm), where porm = P,
C             if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'.
C             The degrees of the denominator polynomials.
C
C     DCOEFF  (output) DOUBLE PRECISION array, dimension (LDDCOE,N+1)
C             The leading porm-by-kdcoef part of this array contains
C             the coefficients of each denominator polynomial, where
C             kdcoef = MAX(INDEX(I)) + 1.
C             DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of
C             the I-th denominator polynomial, where K = 1,2,...,kdcoef.
C
C     LDDCOE  INTEGER
C             The leading dimension of array DCOEFF.
C             LDDCOE >= MAX(1,P) if ROWCOL = 'R';
C             LDDCOE >= MAX(1,M) if ROWCOL = 'C'.
C
C     UCOEFF  (output) DOUBLE PRECISION array, dimension
C             (LDUCO1,LDUCO2,N+1)
C             If ROWCOL = 'R' then porp = M, otherwise porp = P.
C             The leading porm-by-porp-by-kdcoef part of this array
C             contains the coefficients of the numerator matrix U(s).
C             UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
C             of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef;
C             if ROWCOL = 'R' then iorj = I, otherwise iorj = J.
C             Thus for ROWCOL = 'R', U(s) =
C             diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...).
C
C     LDUCO1  INTEGER
C             The leading dimension of array UCOEFF.
C             LDUCO1 >= MAX(1,P) if ROWCOL = 'R';
C             LDUCO1 >= MAX(1,M) if ROWCOL = 'C'.
C
C     LDUCO2  INTEGER
C             The second dimension of array UCOEFF.
C             LDUCO2 >= MAX(1,M) if ROWCOL = 'R';
C             LDUCO2 >= MAX(1,P) if ROWCOL = 'C'.
C
C     Tolerances
C
C     TOL1    DOUBLE PRECISION
C             The tolerance to be used in determining the i-th row of
C             T(s), where i = 1,2,...,porm. If the user sets TOL1 > 0,
C             then the given value of TOL1 is used as an absolute
C             tolerance; elements with absolute value less than TOL1 are
C             considered neglijible. If the user sets TOL1 <= 0, then
C             an implicitly computed, default tolerance, defined in
C             the SLICOT Library routine TB01ZD, is used instead.
C
C     TOL2    DOUBLE PRECISION
C             The tolerance to be used to separate out a controllable
C             subsystem of (A,B,C). If the user sets TOL2 > 0, then
C             the given value of TOL2 is used as a lower bound for the
C             reciprocal condition number (see the description of the
C             argument RCOND in the SLICOT routine MB03OD);  a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL2 is considered to be of full rank.  If the user sets
C             TOL2 <= 0, then an implicitly computed, default tolerance,
C             defined in the SLICOT Library routine TB01UD, is used
C             instead.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N+MAX(M,P))
C             On exit, if INFO = 0, the first nonzero elements of
C             IWORK(1:N) return the orders of the diagonal blocks of A.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1, N*(N + 1) + MAX(N*MP + 2*N + MAX(N,MP),
C                                       3*MP, PM)),
C             where MP = M, PM = P, if ROWCOL = 'R';
C                   MP = P, PM = M, if ROWCOL = 'C'.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The method for transfer matrices factorized by rows will be
C     described here: T(s) factorized by columns is dealt with by
C     operating on the dual of the original system.  Each row of
C     T(s) is simply a single-output relatively left prime polynomial
C     matrix representation, so can be calculated by applying a
C     simplified version of the Orthogonal Structure Theorem to a
C     minimal state-space representation for the corresponding row of
C     the given system. A minimal state-space representation is obtained
C     using the Orthogonal Canonical Form to first separate out a
C     completely controllable one for the overall system and then, for
C     each row in turn, applying it again to the resulting dual SIMO
C     (single-input multi-output) system. Note that the elements of the
C     transformed matrix A so calculated are individually scaled in a
C     way which guarantees a monic denominator polynomial.
C
C     REFERENCES
C
C     [1] Williams, T.W.C.
C         An Orthogonal Structure Theorem for Linear Systems.
C         Control Systems Research Group, Kingston Polytechnic,
C         Internal Report 82/2, 1982.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, March 1998.
C     Supersedes Release 3.0 routine TB01QD.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Controllability, dual system, minimal realization, orthogonal
C     canonical form, orthogonal transformation, polynomial matrix,
C     transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         ROWCOL
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1,
     $                  LDUCO2, LDWORK, M, N, NR, P
      DOUBLE PRECISION  TOL1, TOL2
C     .. Array Arguments ..
      INTEGER           INDEX(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DCOEFF(LDDCOE,*), DWORK(*),
     $                  UCOEFF(LDUCO1,LDUCO2,*)
C     .. Local Scalars ..
      LOGICAL           LROCOC, LROCOR
      CHARACTER*1       JOBD
      INTEGER           I, IA, ITAU, J, JWORK, K, KDCOEF, MAXMP, MAXMPN,
     $                  MPLIM, MWORK, N1, PWORK
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          AB07MD, DLASET, DSWAP, TB01XD, TB04AY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C     .. Executable Statements ..
C
      INFO = 0
      LROCOR = LSAME( ROWCOL, 'R' )
      LROCOC = LSAME( ROWCOL, 'C' )
      MAXMP  = MAX( M, P )
      MPLIM  = MAX( 1, MAXMP )
      MAXMPN = MAX( MAXMP, N )
      N1 = MAX( 1, N )
      IF ( LROCOR ) THEN
C
C        T(s) given as rows over common denominators.
C
         PWORK = P
         MWORK = M
      ELSE
C
C        T(s) given as columns over common denominators.
C
         PWORK = M
         MWORK = P
      END IF
C
C     Test the input scalar arguments.
C
      IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.N1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.N1 ) THEN
         INFO = -8
      ELSE IF( ( LROCOC .AND. LDC.LT.MPLIM )
     $                   .OR. LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( ( LROCOC .AND. LDD.LT.MPLIM )
     $                   .OR. LDD.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN
         INFO = -16
      ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) ) THEN
         INFO = -18
      ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) ) THEN
         INFO = -19
      ELSE IF( LDWORK.LT.MAX( 1, N*( N + 1 ) +
     $                           MAX( N*MWORK + 2*N + MAX( N, MWORK ),
     $                                3*MWORK, PWORK ) ) ) THEN
         INFO = -24
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB04AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAXMPN.EQ.0 )
     $   RETURN
C
      JOBD = 'D'
      IA = 1
      ITAU  = IA + N*N
      JWORK = ITAU + N
C
      IF ( LROCOC ) THEN
C
C        Initialization for T(s) given as columns over common
C        denominators.
C
         CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                INFO )
      END IF
C
C     Initialize polynomial matrix U(s) to zero.
C
      DO 10 K = 1, N + 1
         CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, UCOEFF(1,1,K),
     $                LDUCO1 )
   10 CONTINUE
C
C     Calculate T(s) by applying the Orthogonal Structure Theorem to
C     each of the PWORK MISO subsystems (A,B,C:I,D:I) in turn.
C
      CALL TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, LDD,
     $             NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, LDUCO2,
     $             DWORK(IA), N1, DWORK(ITAU), TOL1, TOL2, IWORK,
     $             DWORK(JWORK), LDWORK-JWORK+1, INFO )
      DWORK(1) = DWORK(JWORK) + DBLE( JWORK-1 )
C
      IF ( LROCOC ) THEN
C
C        For T(s) factorized by columns, return to original (dual of
C        dual) system, and reorder the rows and columns to get an upper
C        block Hessenberg state dynamics matrix.
C
         CALL TB01XD( JOBD, N, MWORK, PWORK, IWORK(1)+IWORK(2)-1, N-1,
     $                A, LDA, B, LDB, C, LDC, D, LDD, INFO )
C
         IF ( MPLIM.NE.1 ) THEN
C
C           Also, transpose U(s) (not 1-by-1).
C
            KDCOEF = 0
C
            DO 20 I = 1, PWORK
               KDCOEF = MAX( KDCOEF, INDEX(I) )
   20       CONTINUE
C
            KDCOEF = KDCOEF + 1
C
            DO 50 K = 1, KDCOEF
C
               DO 40 J = 1, MPLIM - 1
                  CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1,
     $                        UCOEFF(J,J+1,K), LDUCO1 )
   40          CONTINUE
C
   50       CONTINUE
C
         END IF
      END IF
C
      RETURN
C *** Last line of TB04AD ***
      END


data Nat = Zero
         | S Nat

data NExpr = Val Nat
           | NAdd NExpr NExpr
           | NMul NExpr NExpr

plus :: Nat -> Nat -> Nat
plus = [<Zero,Zero,Zero>,<Zero, S Zero, S Zero>, <S Zero, Zero, S Zero>]

mul :: Nat -> Nat -> Nat
mul a b = case a[Nat] of
          Zero -> Zero
          S c -> plus b c

neval :: NExpr -> Nat
neval = [<Val (S Zero), S Zero>,
         <NAdd (Val Zero) (Val Zero), Zero>,
         <NAdd (Val (S Zero)) (Val Zero), S Zero>,
         <NAdd (NAdd (Val Zero) (Val (S Zero))) (NAdd (Val Zero) (Val Zero)), S Zero>,
         <NMul (Val Zero) (Val Zero), Zero>,
         <NMul (Val (S Zero)) (Val Zero), Zero>,
         <NMul (NAdd (Val Zero) (Val (S Zero))) (NAdd (Val (S Zero)) (Val Zero)), (S Zero)>]

main :: Unit
main = neval (NMul (Val (S (S Zero)))  (Val (S (S (S Zero)))))


module x
!Solve for x i.e. we are solving x = ( A^(-1) )*b

use inputs
use ab
implicit none

contains

subroutine T0(B0,q,T)
!^{0}T

implicit none

    !Lapack parameters.
    integer, parameter :: n = ss
    integer, parameter :: nrhs = n_theta
    integer, parameter :: lda = n
    integer, parameter :: ldb = n
    integer, parameter :: lwork = n
    integer :: info
    real, dimension(lwork) :: work
    integer, dimension(n) :: ipiv

	!q = Momentum variable.
	!T = Isospin
	!B0 = Right hand side of Ax=b. Then it gets replaced by the solution vector ^{0}T.
	real(8), intent(in) :: q
	integer, intent(in) :: T
	complex, dimension(ldb,nrhs), intent(out) :: B0

	!c1 = Counter
	!A0 = The matrix in the equation Ax=b.
	integer :: c1
	complex, dimension(:,:), allocatable :: A0

	allocate( A0(lda,n) )

	!Build the 0^A matrix
	call build_A(A0,q,T,V0)

	!Compute 1 - ^{0}A i.e. "^{0}B" in T matrix report.
	A0 = -A0
	do c1 = 1,n

		A0(c1,c1) = 1.0 + A0(c1,c1)

	enddo

	!Build right hand side vector in the equation Ax=b.
	call build_V(B0,q,T,V0)

	!Call to lapack to solve Ax=b using LU-factorization. The solution is written into B0.
	call cgesv(n,nrhs,A0,lda,ipiv,B0,ldb,info)

	deallocate(A0)

end subroutine

subroutine T1(B1,q,T)
!^{1}T

implicit none

	!Lapack parameters.
    integer, parameter :: n = ss
    integer, parameter :: nrhs = n_theta
    integer, parameter :: lda = n
    integer, parameter :: ldb = n
    integer, parameter :: lwork = n
    integer :: info
    real, dimension(lwork) :: work
    integer, dimension(n) :: ipiv

	!q = Momentum variable.
	!T = Isospin
	!B1 = Right hand side of Ax=b. Then it gets replaced by the solution vector ^{1}T.
	real(8), intent(in) :: q
	integer, intent(in) :: T
	complex, dimension(ldb,nrhs), intent(out) :: B1

	!c1 = Counter
	!A0 = The matrix in the equation Ax=b.
	integer :: c1
	complex, dimension(:,:), allocatable :: A1

	allocate( A1(lda,n) )

	!Build the 1^A matrix
	call build_A(A1,q,T,V1)

	!Compute 1 - ^{1}A i.e. "^{1}B" in T matrix report.
	A1 = -A1
	do c1 = 1,n

		A1(c1,c1) = 1.0 + A1(c1,c1)

	enddo

	!Build right hand side vector in the equation Ax=b.
	call build_V(B1,q,T,V1)

	!Call to lapack to solve Ax=b using LU-factorization. The solution is written into B1.
	call cgesv(n,nrhs,A1,lda,ipiv,B1,ldb,info)

	deallocate(A1)

end subroutine

subroutine Tnn(B66,B55,B34,B12,q,T)
!^{66}T,^{55}T,^{34}T,^{12}T

implicit none

  	!Lapack parameters.
    integer, parameter :: n = 2*ss
    integer, parameter :: nrhs = 2*n_theta
    integer, parameter :: lda = n
    integer, parameter :: ldb = n
    integer, parameter :: lwork = n
    integer :: info
    real, dimension(lwork) :: work
    integer, dimension(n) :: ipiv

	!q = Momentum variable.
	!T = Isospin
	!B66...B12 = Solution vector ^{66}T...^{12}T.
	real(8), intent(in) :: q
	integer, intent(in) :: T
	complex, dimension(ss,n_theta), intent(out) :: B66,B55,B34,B12

	!c1,c2 = Counters
	!Ann = The A matrix in the equation Ax=b.
	!Vnn = The right hand side (b matrix) in the equation Ax=b.
	!A11...A22 = Matrix entries in Ann.
	!VV11...VV22 = Matrix entries in Vnn.
	integer :: c1,c2
	complex, dimension(:,:), allocatable :: Ann
	complex, dimension(:,:), allocatable :: Vnn
	complex, dimension(:,:), allocatable :: A11
	complex, dimension(:,:), allocatable :: A12
	complex, dimension(:,:), allocatable :: A21
	complex, dimension(:,:), allocatable :: A22
	complex, dimension(:,:), allocatable :: VV11
    complex, dimension(:,:), allocatable :: VV12
    complex, dimension(:,:), allocatable :: VV21
    complex, dimension(:,:), allocatable :: VV22

	allocate( Ann(lda,n) )
	allocate( Vnn(ldb,nrhs) )

	!Build A11 and put it in Ann
	allocate( A11(ss,ss) )
	call build_A(A11,q,T,V12)
	A11 = -A11
	do c1 = 1,ss

		A11(c1,c1) = 1.0 + A11(c1,c1)

	enddo
	Ann(1:ss,1:ss) = A11
	deallocate(A11)

	!Build A22 and put it in Ann
    allocate( A22(ss,ss) )
    call build_A(A22,q,T,V34)
    A22 = -A22
    do c2 = 1,ss

        A22(c2,c2) = 1.0 + A22(c2,c2)

    enddo
	Ann( (ss + 1):2*ss, (ss + 1):2*ss ) = A22
    deallocate(A22)

	!Build A12 and put it in Ann
    allocate( A12(ss,ss) )
    call build_A(A12,q,T,V55)
    Ann( 1:ss, (ss + 1):2*ss ) = -A12
    deallocate(A12)

	!Build A21 and put it in Ann
    allocate( A21(ss,ss) )
    call build_A(A21,q,T,V66)
    Ann( (ss + 1):2*ss, 1:ss ) = -A21
    deallocate(A21)

	!Build VV11 and put it in Vnn
	allocate( VV11(ss,n_theta) )
	call build_V(VV11,q,T,V12)
	Vnn(1:ss,1:n_theta) = VV11
	deallocate(VV11)

	!Build VV12 and put it in Vnn
	allocate( VV12(ss,n_theta) )
   	call build_V(VV12,q,T,V55)
   	Vnn( 1:ss,(n_theta + 1):2*n_theta ) = VV12
   	deallocate(VV12)

	!Build VV21 and put it in Vnn
	allocate( VV21(ss,n_theta) )
   	call build_V(VV21,q,T,V66)
   	Vnn( (ss + 1):2*ss,1:n_theta ) = VV21
   	deallocate(VV21)

	!Build VV22 and put it in Vnn
   	allocate( VV22(ss,n_theta) )
   	call build_V(VV22,q,T,V34)
   	Vnn( (ss + 1):2*ss,(n_theta + 1):2*n_theta ) = VV22
   	deallocate(VV22)

	!Call to lapack to solve Ax=b using LU-factorization. The solution is written into Vnn which is then written into B12...B66.
	call cgesv(n,nrhs,Ann,lda,ipiv,Vnn,ldb,info)
	B12 = Vnn(1:ss, 1:n_theta)
	B55 = Vnn(1:ss, (n_theta + 1 ):2*n_theta )
	B66 = Vnn( (ss + 1):2*ss,1:n_theta )
	B34 = Vnn( (ss + 1):2*ss, (n_theta + 1):2*n_theta )

	deallocate(Ann)
	deallocate(Vnn)

end subroutine

end module


subroutine waver
use fdeclarations

!Defuzzification using the weighted average method
implicit none

do i=1,z
hs(i)=max(high(i),good(i),moderate(i),poor(i),bad(i))
if (hs(i)>0) then

if (bad(i)<=0) then
xbad(i)=0
else if (bad(i)>0 .and. bad(i)<=1)then
xbad(i)=0.5
else
xbad(i)=0
end if
if (poor(i)<=0) then
xpoor(i)=0
else if (poor(i)>0 .and. poor(i)<=1)then
xpoor(i)=1.5
else
xpoor(i)=0
end if
if (moderate(i)<=0) then
xmod(i)=0
else if (moderate(i)>0 .and. moderate(i)<=1)then
xmod(i)=2.5
else
xmod(i)=0
end if
if (good(i)<=0) then
xgood(i)=0
else if (good(i)>0 .and. good(i)<=1)then
xgood(i)=3.5
else
xgood(i)=0
end if
if (high(i)<=0) then
xhigh(i)=0
else if (high(i)>0 .and. high(i)<=1)then
xhigh(i)=4.5
else
xhigh(i)=0
end if
xint(i)=xbad(i)*bad(i)+xpoor(i)*poor(i)+xmod(i)*moderate(i)+xgood(i)*good(i)+xhigh(i)*high(i)
yint(i)=bad(i)+poor(i)+moderate(i)+good(i)+high(i)
if (l==1) then
suitability(i,zz)=(xint(i)/yint(i))/5
else if (l==2) then
s(i,zz)=(xint(i)/yint(i))/5
else
suitability(i,zz)=suitability(i-1,zz)
s(i,zz)=s(i-1,zz)
end if
end if
end do

end subroutine waver


! =============================================================================
!                       Test FFT module
!
!       This unit test checks the FFT module for combined inner
!       dimensions.
! =============================================================================
program test_ft_2_3d
    use unit_test
    use constants, only : pi, twopi, f12, zero, four, two
    use inversion_utils, only : init_fft &
                              , xfactors &
                              , yfactors &
                              , xtrig    &
                              , ytrig
    use sta2dfft
    use parameters, only : update_parameters, dx, nx, ny, nz, lower, extent
    implicit none

    double precision              :: error = zero
    double precision, allocatable :: fpp(:, :, :), &
                                     fs1(:, :, :), &
                                     fs2(:, :, :), &
                                     fp1(:, :, :), &
                                     fp2(:, :, :)
    integer                       :: i, j, k
    double precision              :: x, y, z

    nx = 32
    ny = 64
    nz = 128
    lower = (/-pi, f12 * pi, zero/)
    extent = (/twopi, two * twopi, four * twopi/)

    call update_parameters

    allocate(fpp(-1:nz+1, 0:ny-1, 0:nx-1))
    allocate(fs1(0:nz, 0:nx-1, 0:ny-1))
    allocate(fs2(0:nz, 0:nx-1, 0:ny-1))
    allocate(fp1(-1:nz+1, 0:ny-1, 0:nx-1))
    allocate(fp2(-1:nz+1, 0:ny-1, 0:nx-1))

    call init_fft

    fpp = zero

    ! setup test field
    do i = 0, nx-1
        x = lower(1) + dble(i) * dx(1)
        do j = 0, ny-1
            y = lower(2) + dble(j) * dx(2)
            do k = 0, nz
                z = lower(3) + dble(k) * dx(3)
                fpp(k, j, i) = dcos(four * x) + dsin(y) + dcos(z)
            enddo
        enddo
    enddo

    fs1 = zero
    fs2 = zero

    fp1 = zero
    fp2 = zero

    ! forward FFT
    call combined_forward_fft(fpp(0:nz, :, :), fs1)

    call not_combined_forward_fft(fpp(0:nz, :, :), fs2)

    error = maxval(dabs(fs1 - fs2))

    ! backward FFT
    call combined_backward_fft(fs1, fp1(0:nz, :, :))

    call not_combined_backward_fft(fs1, fp2(0:nz, :, :))

    error = maxval(dabs(fp1 - fp2))

    call print_result_dp('Test FFT 2D transform', error, atol=dble(1.0e-15))

    contains
        subroutine combined_forward_fft(fp, fs)
            double precision, intent(in)  :: fp(0:nz, ny, nx)  !Physical
            double precision, intent(out) :: fs(0:nz, nx, ny)  !Spectral
            double precision              :: fp_copy(0:nz, ny, nx)
            integer:: kx, iy

            fp_copy = fp

             !Carry out a full x transform first:
            call forfft((nz+1) * ny, nx, fp_copy, xtrig, xfactors)

            !Transpose array:
            do kx = 1, nx
                do iy = 1, ny
                    fs(:, kx, iy) = fp_copy(:, iy, kx)
                enddo
            enddo

            !Carry out a full y transform on transposed array:
            call forfft((nz+1)*nx, ny, fs, ytrig, yfactors)
        end subroutine combined_forward_fft

        subroutine not_combined_forward_fft(fp, fs)
            double precision, intent(in)  :: fp(0:nz, ny, nx)  !Physical
            double precision, intent(out) :: fs(0:nz, nx, ny)  !Spectral
            double precision              :: fp_copy(0:nz, ny, nx)
            integer                       :: kx, iy, iz

            fp_copy = fp

            !Carry out a full x transform first:
            do iz = 0, nz
                call forfft(ny, nx, fp_copy(iz,  :,  :), xtrig, xfactors)
            enddo

            !Transpose array:
            do kx = 1, nx
                do iy = 1, ny
                    fs(:, kx, iy) = fp_copy(:, iy, kx)
                enddo
            enddo

            !Carry out a full y transform on transposed array:
            do iz = 0, nz
                call forfft(nx, ny, fs(iz,  :,  :), ytrig, yfactors)
            enddo
        end subroutine not_combined_forward_fft

        subroutine combined_backward_fft(fs, fp)
            double precision, intent(in)  :: fs(0:nz, nx, ny)  !Spectral
            double precision, intent(out) :: fp(0:nz, ny, nx)  !Physical
            double precision              :: fs_copy(0:nz, nx, ny)
            integer                       :: kx, iy

            fs_copy = fs

            !Carry out a full inverse y transform first:
            call revfft((nz+1) * nx, ny, fs_copy, ytrig, yfactors)

            !Transpose array:
            do kx = 1, nx
                do iy = 1, ny
                    fp(:, iy, kx) = fs_copy(:, kx, iy)
                enddo
            enddo

            !Carry out a full inverse x transform:
            call revfft((nz+1) * ny, nx, fp, xtrig, xfactors)
        end subroutine combined_backward_fft

        subroutine not_combined_backward_fft(fs, fp)
            double precision, intent(in)  :: fs(0:nz, nx, ny)  !Spectral
            double precision, intent(out) :: fp(0:nz, ny, nx)  !Physical
            double precision              :: fs_copy(0:nz, nx, ny)
            integer                       :: kx, iy, iz

            fs_copy = fs

            !Carry out a full inverse y transform first:
            do iz = 0, nz
                call revfft(nx, ny, fs_copy(iz, :, :), ytrig, yfactors)
            enddo

            !Transpose array:
            do kx = 1, nx
                do iy = 1, ny
                    fp(:, iy, kx) = fs_copy(:, kx, iy)
                enddo
            enddo

            !Carry out a full inverse x transform:
            do iz = 0, nz
                call revfft(ny, nx, fp(iz,  :,  :), xtrig, xfactors)
            enddo
        end subroutine not_combined_backward_fft

end program test_ft_2_3d


        subroutine HFB_ENER_comp(zro,zakapa01,zakin,zgamma,zdelta10,zEkin,zEHF,zEPa,zEHFB,NDIM)
	implicit real*8 (a-h,o-y)
	implicit complex*16 (z)

	PARAMETER (zone=(1.d0,0.d0))
	PARAMETER (zzero=(0.d0,0.d0))

	DIMENSION zro(NDIM,NDIM)
	DIMENSION zakapa01(NDIM,NDIM)
	DIMENSION zakin(NDIM,NDIM)
	DIMENSION zgamma(NDIM,NDIM)
	DIMENSION zdelta10(NDIM,NDIM)
	DIMENSION zAUX1(NDIM,NDIM)
	DIMENSION zAUX2(NDIM,NDIM)
	DIMENSION zAUX3(NDIM,NDIM)

	call ZGEMM ('n','n',NDIM,NDIM,NDIM,zone,zakin,NDIM,zro,NDIM,zzero,zAUX1,NDIM)
	call ZGEMM ('n','n',NDIM,NDIM,NDIM,zone,zgamma,NDIM,zro,NDIM,zzero,zAUX2,NDIM)
	call ZGEMM ('n','t',NDIM,NDIM,NDIM,zone,zdelta10,NDIM,zakapa01,NDIM,zzero,zAUX3,NDIM)

	zEHFB=zzero
	zEHF=zzero
	zEPa=zzero
	zEkin=zzero
        do ii=1,NDIM
         zEkin=zEkin+zAUX1(ii,ii)
	 zEHF=zEHF+.5*(zAUX2(ii,ii))
	 zEPa=zEPa+.5*(zAUX3(ii,ii))
	end do
	zEHFB=zEkin+zEHF+zEPa

        end subroutine


      SUBROUTINE TOPO_ff1(PHI,LON,ut1,TX,TY,TZ)
      IMPLICIT REAL*8(A,B,C,D,E,F,G,H,O,P,Q,R,S,T,U,V,W,X,Y,Z)
      REAL*8 LST,LON,JD

      include '../../include/astparms.for'

      parameter (R_E_AU = R_E_KM / KM_PER_AU)

!       All arguments are Real * 8
!       Input PHI = latitude in radians
!             LON = longitude in degrees (W is negative)
!             UT1 = Julian Date
!       Output TX,TY,TZ = Equatorial coordinates of point on surface of earth

      FF=1.D0
      CC=1./DSQRT(DCOS(PHI)**2+FF*DSIN(PHI)**2)
      XYG=R_E_AU*CC*DCOS(PHI)

      call sidereal_time(ut1,lon,lst)

      TX=DCOS(LST)*XYG
      TY=DSIN(LST)*XYG
      TZ=R_E_AU*CC*DSIN(PHI)*FF

      RETURN
      END


!----------------------------------------------------------------------*
! SUBROUTINE SRDPRF                                                    *
! Authors: Daniel van Kraalingen                                       *
! Date   : 15-Sept-1994, Version: 1.0                                  *
! Purpose: This subroutine calculates the absorbed flux of radiation   *
!          for shaded leaves, the direct flux absorbed by leaves and   *
!          the fraction of sunlit leaf area.                           *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning                                     units  class *
! ----   ---- -------                                     -----  ----- *
! GAID    R4  Green area index above selected height    ha leaf/       *
!                                                     ha ground I      *
! CSLV    R4  Scattering coefficient of leaves for PAR       -      I  *
! SINB    R4  Sine of solar height                           -      I  *
! ECPDF   R4  Extinction coefficient for          ha ground/ha leaf I  *
!             diffuse light                                            *
! RDPDR   R4  Instantaneous flux of direct photo-          W/m2     I  *
!             synthetically active radiation (PAR)                     *
! RDPDF   R4  Instantaneous flux of diffuse photo-         W/m2     I  *
!             synthetically active irradiation (PAR)                   *
! RAPSHL  R4  Absorbed flux for shaded leaves           W/m2 leaf   O  *
! RAPPPL  R4  Direct flux absorbed by leaves            W/m2 leaf   O  *
!             perpendicular on direct beam                             *
! FSLLA   R4  Fraction of leaf area that is sunlit           -      O  *
!                                                                      *
! Fatal error checks: none                                             *
! Warnings          : none                                             *
! Subprograms called: none                                             *
! File usage        : none                                             *
!----------------------------------------------------------------------*

      SUBROUTINE SRDPRF (GAID  , CSLV  , SINB, ECPDF, RDPDR, RDPDF, &
                         RAPSHL, RAPPPL, FSLLA)
      IMPLICIT NONE

!     Formal parameters
      REAL GAID  , CSLV  , SINB , ECPDF, RDPDR, RDPDF
      REAL RAPSHL, RAPPPL, FSLLA

!     Local parameters
      REAL TMPR1,RFLH,RFLS,ECPBL,ECPTD,RAPDFL,RAPTDL,RAPDDL,CLUSTF
      SAVE         ! TAOLI

!     Reflection of horizontal and spherical leaf angle distribution
      TMPR1 = SQRT (1. - CSLV)
      RFLH  = (1. - TMPR1) / (1. + TMPR1)
      RFLS  = RFLH * 2. / (1. + 2. * SINB)

!     Extinction coefficient for direct radiation and total direct flux
      CLUSTF = ECPDF / (0.8*TMPR1)
      ECPBL  = (0.5/SINB) * CLUSTF
      ECPTD  = ECPBL * TMPR1

!     Absorbed fluxes per unit leaf area: diffuse flux, total direct
!     flux, direct component of direct flux
      RAPDFL = (1.-RFLH) * RDPDF * ECPDF * EXP (-ECPDF * GAID)
      RAPTDL = (1.-RFLS) * RDPDR * ECPTD * EXP (-ECPTD * GAID)
      RAPDDL = (1.-CSLV) * RDPDR * ECPBL * EXP (-ECPBL * GAID)

!     Absorbed flux (J/m2 leaf/s) for shaded leaves
      RAPSHL = RAPDFL + RAPTDL - RAPDDL

!     Direct flux absorbed by leaves perpendicular on direct beam
      RAPPPL = (1.-CSLV) * RDPDR / SINB

!     Fraction sunlit leaf area (FSLLA)
      FSLLA = CLUSTF * EXP (-ECPBL*GAID)

      RETURN
      END


$ Declare
   SUBROUTINE EllipticShapeFactorQ (a, c, Q)
!
! According to JCSS Probabilistic model code Part 3: Resistance models
!
! Parameters
   DOUBLE PRECISION, INTENT(IN)    :: a  ! Minimum value of the cyclic component of the total stress intensity
   DOUBLE PRECISION, INTENT(IN)    :: c  ! Maximum value of the cyclic component of the total stress intensity
   DOUBLE PRECISION, INTENT(OUT)   :: Q  ! Crack closure factor
!
! Declarations
   DOUBLE PRECISION                :: Rs
!
! Elliptic shape factor Q
   IF (a/c .LE. 1.D0) THEN
      Q = 1.D0 + 1.464D0*((a/c)**1.65D0)
   ELSE
      STOP 'Error calculating shape factor in Subroutine EllipticShapeFactorQ: a/c > 1'
   END IF
!
! Einde subroutine
   RETURN
   END


! Program to test the COUNT intrinsic
program intrinsic_count
   implicit none
   logical(kind=4), dimension (3, 5) :: a
   integer(kind=4), dimension (3) :: b
   integer i
   character(len=10) line

   a = .false.
   if (count(a) .ne. 0) call abort
   a = .true.
   if (count(a) .ne. 15) call abort
   a(1, 1) = .false.
   a(2, 2) = .false.
   a(2, 5) = .false.
   if (count(a) .ne. 12) call abort
   write (line, 9000) count(a)
   read (line, 9000) i
   if (i .ne. 12) call abort

   b(1:3) = count(a, 2);
   if (b(1) .ne. 4) call abort
   if (b(2) .ne. 3) call abort
   if (b(3) .ne. 5) call abort
   b = 0
   write (line, 9000) count(a,2)
   read (line, 9000) b
   if (b(1) .ne. 4) call abort
   if (b(2) .ne. 3) call abort
   if (b(3) .ne. 5) call abort

9000 format(3I3)

end program


! { dg-do run }
! PR 15957
! we used to return the wrong shape when the order parameter was used
! in reshape.
!
INTEGER, parameter :: i(2,3) = reshape ((/1,2,3,4,5,6/), (/2,3/)), &
     j(2,4) = reshape ((/1,2,3,4,5,6/), (/2,4/), (/0,0/), (/2,1/))

integer :: k(2,3), m(2,4), n(2,3), o(2,4)

k(1,:) = (/ 1, 3, 5 /)
k(2,:) = (/ 2, 4, 6 /)

m(1,:) = (/ 1, 2, 3, 4 /)
m(2,:) = (/ 5, 6, 0, 0 /)

! check that reshape does the right thing while constant folding
if (any(i /= k)) STOP 1
if (any(j /= m)) STOP 2

! check that reshape does the right thing at runtime
n = reshape ((/1,2,3,4,5,6/), (/2,3/))
if (any(n /= k)) STOP 3
o = reshape ((/1,2,3,4,5,6/), (/2,4/), (/0,0/), (/2,1/))
if (any(o /= m)) STOP 4
end


PROGRAM test_simul
!
!  Purpose:
!    To test subroutine simul, which solves a set of N linear
!    equations in N unknowns.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    06/26/02    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare parameters:
INTEGER, PARAMETER :: max_size = 10    ! Max number of eqns

! Declare variables:
INTEGER :: i, j, n, istat, error
REAL, DIMENSION(max_size,max_size) :: a
REAL, DIMENSION(max_size) :: b
CHARACTER(len=20) :: file_name

! Get the name of the disk file containing the equations.
WRITE (*,1000)
1000 FORMAT (' Enter the file name containing the eqns: ')
READ (*,'(A20)') file_name

! Open input data file.  Status is OLD because the input data must
! already exist.
OPEN ( UNIT=1, FILE=file_name, STATUS='OLD', ACTION='READ', &
       IOSTAT=istat )

! Was the OPEN successful?
fileopen: IF ( istat == 0 ) THEN
   ! The file was opened successfully, so read the number of
   ! equations in the system.
   READ (1,*) n

   ! If the number of equations is <= max_size, read them in
   ! and process them.
   size_ok: IF ( n <= max_size ) THEN
      DO i = 1, n
         READ (1,*) (a(i,j), j=1,n), b(i)
      END DO

      ! Display coefficients.
      WRITE (*,1020)
      1020 FORMAT (/,1X,'Coefficients before call:')
      DO i = 1, n
         WRITE (*,1030) (a(i,j), j=1,n), b(i)
         1030 FORMAT (1X,7F11.4)
      END DO

      ! Solve equations.
      CALL simul1 (a, b, max_size, n, error )

      ! Check for error.
      error_check: IF ( error /= 0 ) THEN

         WRITE (*,1040)
         1040 FORMAT (/1X,'Zero pivot encountered!', &
                     //1X,'There is no unique solution to this system.')

      ELSE error_check

         ! No errors. Display coefficients.
         WRITE (*,1050)
         1050 FORMAT (/,1X,'Coefficients after call:')
         DO  i = 1, n
             WRITE (*,1030) (a(i,j), j=1,n), b(i)
         END DO

         ! Write final answer.
         WRITE (*,1060)
         1060 FORMAT (/,1X,'The solutions are:')
         DO i = 1, n
            WRITE (*,1070) i, b(i)
            1070 FORMAT (3X,'X(',I2,') = ',F16.6)
         END DO

      END IF error_check
   END IF size_ok
ELSE fileopen

   ! Else file open failed.  Tell user.
   WRITE (*,1080) istat
   1080 FORMAT (1X,'File open failed--status = ', I6)

END IF fileopen
END PROGRAM


subroutine banfac ( w, nroww, nrow, nbandl, nbandu, iflag )

!*****************************************************************************80
!
!! BANFAC factors a banded matrix without pivoting.
!
!  Discussion:
!
!    BANFAC returns in W the LU-factorization, without pivoting, of
!    the banded matrix A of order NROW with (NBANDL+1+NBANDU) bands
!    or diagonals in the work array W.
!
!    Gauss elimination without pivoting is used.  The routine is
!    intended for use with matrices A which do not require row
!    interchanges during factorization, especially for the totally
!    positive matrices which occur in spline calculations.
!
!    The matrix storage mode used is the same one used by LINPACK
!    and LAPACK, and results in efficient innermost loops.
!
!    Explicitly, A has
!
!      NBANDL bands below the diagonal
!      1     main diagonal
!      NBANDU bands above the diagonal
!
!    and thus, with MIDDLE=NBANDU+1,
!    A(I+J,J) is in W(I+MIDDLE,J) for I=-NBANDU,...,NBANDL, J=1,...,NROW.
!
!    For example, the interesting entries of a banded matrix
!    matrix of order 9, with NBANDL=1, NBANDU=2:
!
!      11 12 13  0  0  0  0  0  0
!      21 22 23 24  0  0  0  0  0
!       0 32 33 34 35  0  0  0  0
!       0  0 43 44 45 46  0  0  0
!       0  0  0 54 55 56 57  0  0
!       0  0  0  0 65 66 67 68  0
!       0  0  0  0  0 76 77 78 79
!       0  0  0  0  0  0 87 88 89
!       0  0  0  0  0  0  0 98 99
!
!    would appear in the first 1+1+2=4 rows of W as follows:
!
!       0  0 13 24 35 46 57 68 79
!       0 12 23 34 45 56 67 78 89
!      11 22 33 44 55 66 77 88 99
!      21 32 43 54 65 76 87 98  0
!
!    All other entries of W not identified in this way with an
!    entry of A are never referenced.
!
!    This routine makes it possible to solve any particular linear system
!    A*X=B for X by the call
!
!      call banslv ( w, nroww, nrow, nbandl, nbandu, b )
!
!    with the solution X contained in B on return.
!
!    If IFLAG=2, then one of NROW-1, NBANDL, NBANDU failed to be nonnegative,
!    or else one of the potential pivots was found to be zero
!    indicating that A does not have an LU-factorization.  This
!    implies that A is singular in case it is totally positive.
!
!  Modified:
!
!    14 February 2007
!
!  Author:
!
!    Carl DeBoor
!
!  Reference:
!
!    Carl DeBoor,
!    A Practical Guide to Splines,
!    Springer, 2001,
!    ISBN: 0387953663,
!    LC: QA1.A647.v27.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) W(NROWW,NROW).
!    On input, W contains the "interesting" part of a banded
!    matrix A, with the diagonals or bands of A stored in the
!    rows of W, while columns of A correspond to columns of W.
!    On output, W contains the LU-factorization of A into a unit
!    lower triangular matrix L and an upper triangular matrix U
!    (both banded) and stored in customary fashion over the
!    corresponding entries of A.
!
!    Input, integer ( kind = 4 ) NROWW, the row dimension of the work array W.
!    NROWW must be at least NBANDL+1 + NBANDU.
!
!    Input, integer ( kind = 4 ) NROW, the number of rows in A.
!
!    Input, integer ( kind = 4 ) NBANDL, the number of bands of A below
!    the main diagonal.
!
!    Input, integer ( kind = 4 ) NBANDU, the number of bands of A above
!    the main diagonal.
!
!    Output, integer ( kind = 4 ) IFLAG, error flag.
!    1, success.
!    2, failure, the matrix was not factored.
!
  implicit none

  integer ( kind = 4 ) nrow
  integer ( kind = 4 ) nroww

  real ( kind = 8 ) factor
  integer ( kind = 4 ) i
  integer ( kind = 4 ) iflag
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) middle
  integer ( kind = 4 ) nbandl
  integer ( kind = 4 ) nbandu
  real ( kind = 8 ) pivot
  real ( kind = 8 ) w(nroww,nrow)

  iflag = 1

  if ( nrow < 1 ) then
    iflag = 2
    return
  end if
!
!  W(MIDDLE,*) contains the main diagonal of A.
!
  middle = nbandu + 1

  if ( nrow == 1 ) then
    if ( w(middle,nrow) == 0.0D+00 ) then
      iflag = 2
    end if
    return
  end if
!
!  A is upper triangular.  Check that the diagonal is nonzero.
!
  if ( nbandl <= 0 ) then

    do i = 1, nrow-1
      if ( w(middle,i) == 0.0D+00 ) then
        iflag = 2
        return
      end if
    end do

    if ( w(middle,nrow) == 0.0D+00 ) then
      iflag = 2
    end if

    return
!
!  A is lower triangular.  Check that the diagonal is nonzero and
!  divide each column by its diagonal.
!
  else if ( nbandu <= 0 ) then

    do i = 1, nrow-1

      pivot = w(middle,i)

      if ( pivot == 0.0D+00 ) then
        iflag = 2
        return
      end if

      do j = 1, min ( nbandl, nrow-i )
        w(middle+j,i) = w(middle+j,i) / pivot
      end do

    end do

    return

  end if
!
!  A is not just a triangular matrix.
!  Construct the LU factorization.
!
  do i = 1, nrow - 1
!
!  W(MIDDLE,I) is the pivot for the I-th step.
!
    if ( w(middle,i) == 0.0D+00 ) then
      iflag = 2
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BANFAC - Fatal error!'
      write ( *, '(a,i8)' ) '  Zero pivot encountered in column ', i
      stop
    end if
!
!  Divide each entry in column I below the diagonal by PIVOT.
!
    do j = 1, min ( nbandl, nrow-i )
      w(middle+j,i) = w(middle+j,i) / w(middle,i)
    end do
!
!  Subtract A(I,I+K)*(I-th column) from (I+K)-th column (below row I).
!
    do k = 1, min ( nbandu, nrow-i )
      factor = w(middle-k,i+k)
      do j = 1, min ( nbandl, nrow-i )
        w(middle-k+j,i+k) = w(middle-k+j,i+k) - w(middle+j,i) * factor
      end do
    end do

  end do
!
!  Check the last diagonal entry.
!
  if ( w(middle,nrow) == 0.0D+00 ) then
    iflag = 2
  end if

  return
end


module ExampleOperators
  use Precision
  use AbstractOperators
  use SimpleVectors

  private

  !! Derived type describing the 1d-Laplacian
  !! with periodic boundary conditions
  type, public, extends(abstract_operator) :: Laplacian
   contains
     procedure, public, pass :: init => init_LP
     !! procedure overrided
     procedure, public, pass :: apply =>  apply_LP
  end type Laplacian

  !! Derived type describing the 1d-Laplacian
  !! with periodic boundary conditions
  type, public, extends(abstract_operator) :: DiagonalMatrix
     real(kind=double), allocatable :: coefficients(:)
   contains
     procedure, public, pass :: init => init_DM
     procedure, public, pass :: kill => kill_DM
     !! procedure overrided
     procedure, public, pass :: apply =>  apply_DM
  end type DiagonalMatrix

contains

  subroutine init_LP(this, nnode)
    class(Laplacian),                intent(inout) :: this
    integer,                          intent(in   ) :: nnode

    !! the set domain/codomain operator dimension
    this%nrow = nnode
    this%ncol = nnode
    this%is_symmetric=.True.

  end subroutine init_LP

  subroutine apply_LP(this,vec_in,vec_out,ierr)
    implicit none
    class(Laplacian), intent(inout) :: this
    real(kind=double),  intent(in   ) :: vec_in(this%ncol)
    real(kind=double),  intent(inout) :: vec_out(this%nrow)
    integer,           intent(inout) :: ierr
    !local
    real :: sign=1.0d0
    integer :: i_row

    !call dcopy(this%ncol,vec_in,1,vec_out,1)
    !call dscal(this%ncol,2.0d0,vec_out,1)
    !call daxpy(this%ncol-1,sign,vec_in(2:this%ncol),1,vec_out(1:this%ncol-1),1)
    !call daxpy(this%ncol-1,sign,vec_in(1:this%ncol-1),1,vec_out(2:this%ncol),1)

    vec_out(1) = 2*vec_in(1) + sign* vec_in(2)
    do i_row=2,this%nrow-1
       vec_out(i_row) = sign* vec_in(i_row-1) + 2*vec_in(i_row) + sign* vec_in(i_row+1)
    end do
    vec_out(this%ncol) =  sign* vec_in(this%ncol-1) + 2*vec_in(this%ncol)
    ierr=0
  end subroutine apply_LP

  !! set dimensions, basic properties and allocate memory
  !! for coefficients on the diagonal
  subroutine init_DM(this, size)
    class(DiagonalMatrix),  intent(inout) :: this
    integer,                intent(in   ) :: size

    this%nrow = size
    this%ncol = size
    this%is_symmetric=.True.

    allocate(this%coefficients(size))

  end subroutine init_DM

  subroutine kill_DM(this)
    class(DiagonalMatrix),  intent(inout) :: this

    this%nrow = 0
    this%ncol = 0
    this%is_symmetric=.False.

    deallocate(this%coefficients)

  end subroutine kill_DM

  subroutine apply_DM(this,vec_in,vec_out,ierr)
    implicit none
    class(DiagonalMatrix),  intent(inout) :: this
    real(kind=double), intent(in   ) :: vec_in(this%ncol)
    real(kind=double), intent(inout) :: vec_out(this%nrow)
    integer,           intent(inout) :: ierr
    !local
    integer :: i_row

    vec_out=zero
    vec_out=this%coefficients*vec_in
    ierr=0
  end subroutine apply_DM

end module ExampleOperators


 SUBROUTINE lgst14(stran,r1,r2,lb,sname,ierr)

 ! compute log strains from C = U^2 = F^T F
 IMPLICIT NONE

 ! dummy arguments
 REAL(kind=8), INTENT (IN OUT) :: stran(3) !(IN) C, (OUT) log strains
 REAL(kind=8), INTENT (OUT) :: r1,r2, & !components of first eigevector
                               lb(2)    !eigenvalues of U
 INTEGER (kind=4), INTENT(OUT) :: ierr
 CHARACTER (len=*), INTENT(IN) :: sname

 ! local variables
 REAL (kind=8) :: c,d,r,l1,l2

 !compute auxiliar values
 c = (stran(1)+stran(2))/2d0              !center of circle
 d = (stran(1)-stran(2))/2d0              !half the difference
 r = SQRT(d**2+stran(3)**2)               !circle radius
 IF( c < r )THEN
   WRITE(55,*,ERR=9999) " Excessively distorted mesh, negative eigen-value detected"
   WRITE(55,*,ERR=9999) ' U^2 = ',stran
   WRITE(55,*,ERR=9999) ' l1 = ',c+r,' l2 = ',c-r
   WRITE(55,*,ERR=9999) ' CALLED FROM ',TRIM(sname)
   ierr = 1
   RETURN
 END IF
 !compute first eigenvector R1=(r1,r2)    R2=(-r2,r1)
 IF( r > 0d0 )THEN                       !check circle radius to avoid error
   d = ATAN2(stran(3),d)/2d0             !compute angle
   r1 = COS(d)                           !first  component of eigevector
   r2 = SIN(d)                           !second component of eigevector
 ELSE
   r1 = 1d0                              !any direction is OK
   r2 = 0d0
 END IF
 !Compute eigenvalues and principal strains
 lb(1) = SQRT(c+r)     !eigenvalues of U
 lb(2) = SQRT(c-r)
 l1 = LOG(lb(1))      !ln of principal stretches
 l2 = LOG(lb(2))
 !Compute 2-D strains with the spectral decomposition
 stran(1) = l1*r1*r1 + l2*r2*r2
 stran(2) = l1*r2*r2 + l2*r1*r1
 stran(3) = 2d0*(l1-l2)*r1*r2   !twice the strain

 RETURN
 9999 CALL runen2('')
 END SUBROUTINE lgst14


      SUBROUTINE INVOL (PX,PY,PZ, ILIM, ARX,ARY,ARZ, SIDE, PLDIST)

C  Given a 3D point and planar fill area, determine whether point
C  is within normal projection of the area, and distance of point
C  from the plane.

C  Input parameters:
C    PX,PY,PZ     : 3D point
C    ILIM         : Number of vertices of fill area
C    ARX,ARY,ARZ  : vertices of fill area

C  Output parameters:
C    SIDE         : location of point within volume -
C                 : 1 if inside, 2 if on an edge, 3 if outside
C    PLDIST       : distance of point from the plane.

      INTEGER   ILIM, INAREA, IDIM, SIDE

      REAL      PX,PY,PZ, ARX(*),ARY(*),ARZ(*)
      REAL      A,B,C,D, XN,YN,ZN, PLDIST, BEST

      IF (ILIM .LT. 3) THEN
         CALL UNMSG ('Degenerate fill area passed to INVOL.')
      ENDIF

C get plane from set of points
      CALL PTSPL (ILIM, ARX,ARY,ARZ, A,B,C,D)

C Given a point and plane-coefficients, find nearest
C point on plane and distance from plane to point.
      CALL PTPLDS (PX,PY,PZ, A,B,C,D, XN,YN,ZN, PLDIST)

C  Now project the planar points (fill area, plus the normal
C  projected point xn,yn,zn) to the "best" plane: x=0, y=0, or z=0,
C  depending on largest attitude number.
      IF (ABS(A) .GT. ABS(B)) THEN
         IDIM = 1
         BEST=ABS(A)
      ELSE
         IDIM = 2
         BEST=ABS(B)
      ENDIF

      IF (ABS(C) .GT. BEST) THEN
         IDIM = 3
      ENDIF

      IF     (IDIM .EQ. 1) THEN
C project to x=0
         SIDE = INAREA (YN,ZN, ILIM, ARY,ARZ)
      ELSEIF (IDIM .EQ. 2) THEN
C project to y=0
         SIDE = INAREA (XN,ZN, ILIM, ARX,ARZ)
      ELSE
C project to z=0
         SIDE = INAREA (XN,YN, ILIM, ARX,ARY)
      ENDIF

      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_dosint
   !
   !     integrated dos to ei
   !
   USE m_trisrt
   USE m_types

   IMPLICIT NONE

   CONTAINS
   SUBROUTINE dosint(ei,nemax,jspins,kpts,sfac,eig,ct)

      INTEGER,       INTENT(IN)  :: jspins
      REAL,          INTENT(IN)  :: ei,sfac
      TYPE(t_kpts),  INTENT(IN)  :: kpts
      INTEGER,       INTENT(IN)  :: nemax(:)
      REAL,          INTENT(IN)  :: eig(:,:,:)    !(neig,nkpt,jspins)
      REAL,          INTENT(OUT) :: ct

      INTEGER :: jspin,iBand,itria
      INTEGER :: k1,k2,k3
      INTEGER :: neig
      REAL    :: e1,e2,e3
      REAl    :: ee,e32,e31,e21,s

      s = 0.0
      DO jspin = 1,jspins
         neig = nemax(jspin)
         DO iBand = 1,neig
            DO itria = 1,kpts%ntet
               !Get the k-points and eigenvalues
               !of the current triangle
               k1 = kpts%ntetra(1,itria)
               k2 = kpts%ntetra(2,itria)
               k3 = kpts%ntetra(3,itria)
               e1 = eig(iBand,k1,jspin)
               e2 = eig(iBand,k2,jspin)
               e3 = eig(iBand,k3,jspin)
               !Sort by ascending eigenvalues
               CALL trisrt(e1,e2,e3,k1,k2,k3)
               IF (e1.LE.-9999.0) CYCLE !Not all eigenvalues available
               IF (ei.LE.e1) CYCLE !triangle not occupied
               IF (ei.GE.e3) THEN
                  s = s + kpts%voltet(itria)/kpts%ntet
               ELSEIF (ei.GT.e2) THEN
                  e31 = e3 - e1
                  e32 = e3 - e2
                  ee = e3 - ei
                  s = s + kpts%voltet(itria)/kpts%ntet &
                         * (1.0-ee*ee/ (e31*e32))
               ELSE
                  e21 = e2 - e1
                  e31 = e3 - e1
                  ee = ei - e1
                  s = s + kpts%voltet(itria)/kpts%ntet &
                         * ee*ee/ (e21*e31)
               ENDIF
            ENDDO
         ENDDO
      ENDDO

      !Take into account spin-degeneracy
!jr   ct=2.*s
!gb   ct = (2./jspins)*s
      ct = sfac * s

   END SUBROUTINE dosint
END MODULE m_dosint


      SUBROUTINE COSGEN (N,IJUMP,FNUM,FDEN,A)
      DIMENSION       A(1)
C
C
C     THIS SUBROUTINE COMPUTES REQUIRED COSINE VALUES IN ASCENDING
C     ORDER.  WHEN IJUMP .GT. 1 THE ROUTINE COMPUTES VALUES
C
C        2*COS(J*PI/L) , J=1,2,...,L AND J .NE. 0(MOD N/IJUMP+1)
C
C     WHERE L = IJUMP*(N/IJUMP+1).
C
C
C     WHEN IJUMP = 1 IT COMPUTES
C
C            2*COS((J-FNUM)*PI/(N+FDEN)) ,  J=1, 2, ... ,N
C
C     WHERE
C        FNUM = 0.5, FDEN = 0.0,  FOR REGULAR REDUCTION VALUES
C        FNUM = 0.0, FDEN = 1.0, FOR B-R AND C-R WHEN ISTAG = 1
C        FNUM = 0.0, FDEN = 0.5, FOR B-R AND C-R WHEN ISTAG = 2
C        FNUM = 0.5, FDEN = 0.5, FOR B-R AND C-R WHEN ISTAG = 2
C                                IN POISN2 ONLY.
C
C
      PI = PIMACH(DUM)
      IF (N .EQ. 0) GO TO 105
      IF (IJUMP .EQ. 1) GO TO 103
      K3 = N/IJUMP+1
      K4 = K3-1
      PIBYN = PI/FLOAT(N+IJUMP)
      DO 102 K=1,IJUMP
         K1 = (K-1)*K3
         K5 = (K-1)*K4
         DO 101 I=1,K4
            X = K1+I
            K2 = K5+I
            A(K2) = -2.*COS(X*PIBYN)
  101    CONTINUE
  102 CONTINUE
      GO TO 105
  103 CONTINUE
      NP1 = N+1
      Y = PI/(FLOAT(N)+FDEN)
      DO 104 I=1,N
         X = FLOAT(NP1-I)-FNUM
         A(I) = 2.*COS(X*Y)
  104 CONTINUE
  105 CONTINUE
      RETURN
      END


	SUBROUTINE
     .	LDELTASIZE
     .	(NTR,XBAR,SX,ALPHA,POWER,SIGMA,N,M,LAMBDA,D_LAMBDA,D_GAMMA)
!MS$ATTRIBUTES REFERENCE :: LAMBDA
!MS$ATTRIBUTES REFERENCE :: D_LAMBDA
!MS$ATTRIBUTES REFERENCE :: D_GAMMA
	USE MSIMSL
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine DIFF (see below)
C
C  Input:
C	NTR			(Integer)	Number of treatments (1 or 2)
C	XBAR(0:1)	(Real)
C	SX(0:1)		(Real)
C
C  Output:
C	LAMBDA
C
C  Notes:
C   .	This routine was written by Dale Plummer
C
C-Declarations----------------------------------------------------------
C
C  Arguments
C
	INTEGER NTR
	REAL XBAR(0:1),SX(0:1)
	REAL ALPHA,POWER,SIGMA,N,M,LAMBDA,D_LAMBDA,D_GAMMA
C
C  Functions
C
	REAL TCRVALUE
C
C  Locals
C
	REAL MYBETA,NU,DELTA,SIGR2L,SIGR2G
C
C
C-Code------------------------------------------------------------------
C
	IF (NTR.EQ.1) THEN
C
C    Number of treatments is 1.
C
C    input is ALPHA, POWER, SIGMA, and N:  '
C    result is LAMBDA
C
	    NU=N-2.
	    MYBETA=1.-POWER
C	    DELTA=(TCRVALUE(MYBETA,NU)+TCRVALUE(ALPHA/2.,NU))/SQRT(N)
	    DELTA=(TIN((1.-MYBETA),NU)+TIN((1.-ALPHA/2.),NU))/SQRT(N)
	    LAMBDA=DELTA*SIGMA/SX(0)
	ELSE IF (NTR.EQ.2) THEN
C
C    Number of treatments is 2.
C
C    input is ALPHA, POWER, SIGMA, N, and M:  '
C    result is D_LAMBDA and D_GAMMA
C
	    NU=N*(1.+M)-4.
	    MYBETA=1.-POWER
C	    DELTA=(TCRVALUE(MYBETA,NU)+TCRVALUE(ALPHA/2.,NU))/SQRT(N)
	    DELTA=(TIN((1.-MYBETA),NU)+TIN((1.-ALPHA/2.),NU))/SQRT(N)
	    SIGR2L=SIGMA**2*(1./(M*SX(0)**2)+1./SX(1)**2)
	    D_LAMBDA=DELTA*SQRT(SIGR2L)
	    SIGR2G=(SIGMA**2/M)*
     .		(1.+XBAR(0)**2/SX(0)**2+M*(1.+XBAR(1)**2/SX(1)**2))
	    D_GAMMA=DELTA*SQRT(SIGR2G)
	ELSE
	    STOP 'Bad NTR in LPOWER'
	END IF
	RETURN
	END