!=====================================================================!
! Vector datatype module that computes norm in a distributed fashion
!
! Author : Komahan Boopathy (komahan@gaech.edu)
!=====================================================================!

module vector_class

  use iso_fortran_env, only : dp => REAL64
  use opencoarrays, only : co_sum

  implicit none

  ! Everything is private to module
  private

  ! Only the datatype is exposed to public
  public :: vector

  ! Vector datatype
  type :: vector

     ! Attributes
     real(dp), allocatable :: values(:)
     integer              :: size

   contains

     ! Type-bound procedures
     procedure :: zero_values, copy_values, random_values
     procedure :: scale, axpy, axpby
     procedure :: dot, norm

  end type vector

  ! Constructor interface
  interface vector
     module procedure construct_vector
  end interface vector

contains

  ! MPI_SUM
  pure function reduce_sum(a, b)

    real(dp), intent(in) :: a, b
    real(dp) :: reduce_sum
    reduce_sum = a + b
  end function reduce_sum

  !===================================================================!
  ! Constructor for vector
  !===================================================================!

  pure type(vector) function construct_vector(size) result (this)

    integer, intent(in) :: size

    this % size = size

    allocate(this % values(this % size))

    call this % zero_values()

  end function construct_vector

  !===================================================================!
  ! Set the values of the vector as zero
  !===================================================================!

  pure subroutine zero_values(this)

    class(vector), intent(inout) :: this

    this % values = 0.0d0

  end subroutine zero_values

  !===================================================================!
  ! Copies the values of one vector into another
  !===================================================================!

  subroutine copy_values(this, a)

    class(vector), intent(inout) :: this
    type(vector), intent(in) :: a

    if (a % size .ne. this % size) &
         & stop "dimension-mismatch-for-copy"

    this % values = a % values

  end subroutine copy_values

  !===================================================================!
  ! Set random values into the vector
  !===================================================================!

  subroutine random_values(this)

    class(vector), intent(inout) :: this

    call random_number(this % values)

  end subroutine random_values

  !===================================================================!
  ! y <- y + alpha*x where alpha is a scalar
  !===================================================================!

  subroutine axpy(this, alpha, x)

    class(vector) , intent(inout) :: this
    real(dp)       , intent(in)    :: alpha
    type(vector)  , intent(in)    :: x

    this % values = this % values + alpha * x % values

  end subroutine axpy

  !===================================================================!
  ! y <- beta*y + alpha*x where alpha is a scalar
  !===================================================================!

  subroutine axpby(this, alpha, x, beta)

    class(vector) , intent(inout) :: this
    real(dp)       , intent(in)    :: alpha, beta
    type(vector)  , intent(in)    :: x

    this % values = beta * this % values + alpha * x % values

  end subroutine axpby

  !===================================================================!
  ! Scale the values by alpha: y <- alpha*y
  !===================================================================!

  subroutine scale(this, alpha)

    class(vector) , intent(inout) :: this
    real(dp)       , intent(in)    :: alpha

    this % values = alpha * this % values

  end subroutine scale

  !===================================================================!
  ! Return the dot product of this vector with another vector 'b'
  !===================================================================!

  real(dp) function dot(this, b) result(xdot)

    class(vector), intent(in) :: this
    type(vector), intent(in) :: b

    xdot = dot_product(this % values, b % values)
    call co_sum(xdot)

  end function dot

  !===================================================================!
  ! Norm of the vector
  !===================================================================!

  real(dp) function norm(this)

    class(vector), intent(in) :: this
    real(dp) :: xdot

    xdot = dot_product(this % values, this % values)
    call co_sum (xdot)
    norm = sqrt(xdot)

  end function norm

end module vector_class


    subroutine iterate_limit(func, x0, num_iters, results, n)
        external func
        double precision func
        double precision x0
        integer num_iters, n
        double precision results(n)

        integer i

        do i = 1, num_iters
            x0 = func(x0)
        enddo

        do i = 1, n
            results(i) = x0
            x0 = func(x0)
        enddo

    end subroutine iterate_limit


      real function seddia(spg,vs,kinvis,agrav)
c
c     + + + PURPOSE + + +
c
c     Function SEDDIA is the CREAMS sediment diameter routine.
c
c     Called from: SR CHNPAR
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real spg, vs, kinvis, agrav
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     spg    -
c     vs     -
c     kinvis -
c     agrav  -
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      real reb(9), cddb(9), re(9), cddre(9), rey, rtsid
      integer ifrus, itrat, j
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Real Variables
c
c     reb(9)   -
c     cddb(9)  -
c     re(9)    -
c     cddre(9) -
c     rey      -
c     rtsid    -
c
c     Integer Variables
c
c     ifrus -
c     itrat -
c     j     -
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     table
c
c     + + + DATA INITIALIZATIONS + + +
c
      data reb /0.001, 0.01, 0.1, 1.0, 10.0, 100.0, 1000.0, 10000.0,
     1    100000.0/
c
      data cddb /2.05e+07, 2.05e+05, 2.05e+03, 24.0, 0.41, 1.05e-02,
     1    4.3e-04, 4.0e-05, 4.4e-06/
c
c     + + + END SPECIFICATIONS + + +
c
c
      do 10 j = 1, 9
        re(j) = alog(reb(j))
        cddre(j) = alog(cddb(j))
   10 continue
c
      rtsid = 1.3333 * agrav * (spg-1.0) * kinvis / (vs**3)
c
      if (rtsid.le.2.0e+06) then
        rtsid = alog(rtsid)
        ifrus = 3
        itrat = 9
        call table(ifrus,itrat,re,cddre,rtsid,rey)
        rey = exp(rey)
        seddia = rey * kinvis / vs
        return
      end if
c
      seddia = sqrt(18.0*vs*kinvis/((spg-1.0)*agrav))
c
      return
      end


module Time_matrices

    use Structure
    use Matrix_op
    use Gauss

    implicit none

    type :: Time_op

      integer, dimension(:), allocatable :: dof_imposed
      integer, dimension(:), allocatable :: dof_free
      double precision, dimension(:,:), allocatable :: gauss_t ! points and weight matrix.
      double precision, dimension(:,:), allocatable :: IntT,vect_gpt ! Displacement.
      double precision, dimension(:,:), allocatable :: Q00k,Q01k,Q10k,Q11k ! Strain.
      double precision, dimension(:,:), allocatable :: I00Tr,I01Tr,I10Tr,I11Tr ! Stress.
      integer, dimension(:,:), allocatable :: IDvtc ! Plastic deformation.
      double precision, dimension(:,:), allocatable :: l,lt,lw,lwt
      double precision, dimension(:,:), allocatable :: Tmat_l, Tmat_lt, Tmat_timefunc,Tmat_timefunct
      double precision, dimension(:,:), allocatable :: valfa,valfat
      double precision, dimension(:,:), allocatable :: vwalfa,vwalfat

    end type Time_op

    type(Time_op) :: Top

    contains

    subroutine Time_op_assign(I)

      type(Input), intent(inout) :: I
      double precision, dimension(I%ngpt,1) :: waux
      double precision, dimension(I%ngpt) :: t
      double precision, dimension(I%ngpt,I%Nsft) :: IntTe
      double precision, dimension(I%Nsft,I%Nsft) :: Q00k, Q01k, Q10k, Q11k
      double precision, dimension(I%ntc-1,I%ntc-1) :: I00Tr,I01Tr,I10Tr,I11Tr
      double precision, dimension(I%ntc,I%ntc) :: I00T, I01T, I10T, I11T
      integer :: igp,iNt,ind,k,igpt
      double precision :: a,b
      integer :: elmt

      ! Vector that integrate any function in time over I=[0,Tend]
      allocate(Top%IntT(I%Tngpt,1))
      Top%gauss_t = gauss_points_weights(I%ngpt)
      do igp = 1,I%ngpt
        waux(igp,1)=(I%dt/2)*Top%gauss_t(igp,2)
      end do
      Top%IntT=kron(ones(I%NT,1),waux)

      allocate(Top%vect_gpt(1,I%Tngpt))
      a=-I%dt; b=0; ind=0
      do iNt = 1,I%NT
        a=a+I%dt;  b=b+I%dt
        do igpt = 1,I%ngpt
            ind=ind+1
            Top%vect_gpt(1,ind)=((b-a)/2)*Top%gauss_t(igpt,1) + ((b+a)/2)
        end do ! igpt
      end do! iNt

      ! Gauss points for a normalized time element:

      t = ((I%dt/2)*Top%gauss_t(:,1)+I%dt/2)

      allocate( Top%IDvtc( I%Nsft, I%NT ) )

      if ( I%Tmethod .eq. "Linear" ) then

        ! Identification matrix in time (for linear shape functions):
        Top%IDvtc = vertcat( incr(1,I%NT), incr(2,I%NT+1) )

        !                       Linear shape functions in time:

        allocate(Top%l(I%Nsft,I%ngpt))
        allocate(Top%lt(I%Nsft,I%ngpt))
        Top%l = vertcat(1-t/I%dt,t/I%dt) ! Polinomias that multiply each value of the node of each time element
        Top%lt = repmat( reshape( (/-1/I%dt, 1/I%dt/), (/2,1/) ), (/1,I%ngpt/) )

        ! Functions used to calculate the classic PGD mode:
        Top%Tmat_l = repmat(Top%l, (/1,I%NT/) )
        Top%Tmat_lt = repmat( Top%lt, (/1,I%NT/) )

        Top%valfa = Top%l
        Top%valfat = Top%lt

      else if ( I%Tmethod .eq. "Lagrange" )  then  ! Lagrange Polinomias

        do elmt=1,I%NT
          Top%IDvtc(:,elmt)= incr(2*(elmt-1)+1,2*elmt+1)
        end do

        !call show(Top%IDvtc(:,1:3))
        !stop

        allocate(Top%l(I%Nsft,I%ngpt))
        allocate(Top%lt(I%Nsft,I%ngpt))

        Top%l(1,:) = (2*t/I%dt-1)*(t/I%dt-1)
        Top%l(2,:) = 4*(t/I%dt)*(1-t/I%dt)
        Top%l(3,:) = (t/I%dt)*(2*t/I%dt-1)

        Top%lt(1,:) = ((2/I%dt)*(t/I%dt-1)+(2*t/I%dt -1)*(1/I%dt))
        Top%lt(2,:) = ((4/I%dt)*(1-t/I%dt)+(4*t/I%dt)*(-1/I%dt))
        Top%lt(3,:) = ((1/I%dt)*(2*t/I%dt -1) + (t/I%dt)*(2/I%dt))

        ! Functions used to calculate the classic PGD mode:
        Top%Tmat_l = repmat(Top%l, (/1,I%NT/) )
        Top%Tmat_lt = repmat( Top%lt, (/1,I%NT/) )

        Top%valfa = Top%l
        Top%valfat = Top%lt

      else ! Hermite

        !term1=1:2:1+2*(I.NT-1);
        !term2=2:2:2+2*(I.NT-1);
        !I.IDvtc=vertcat(term1,term2,term1+2,term2+2);

        !l=[ ( 1-(3/(dt^2))*t.^2 + (2/(dt^3))*t.^3 ); (t-(2/dt)*t.^2 + (1/(dt^2))*t.^3 ) ; ((3/(dt^2))*t.^2 + -(2/(dt^3))*t.^3 ) ; (-(1/dt)*t.^2 + (1/(dt^2))*t.^3)]; % gives the value at one point of all the shape functions.
        !lt=[(-2*(3/(dt^2))*t + 3*(2/(dt^3))*t.^2 ); (1-2*(2/dt)*t+3*(1/(dt^2))*t.^2) ; (2*(3/(dt^2))*t+-3*(2/(dt^3))*t.^2) ; (-2*(1/dt)*t+3*(1/(dt^2))*t.^2)];
        !ltt=[(-2*(3/(dt^2)) + 6*(2/(dt^3))*t) ; (-2*(2/dt) + 6*(1/(dt^2))*t) ; (2*(3/(dt^2)) + -6*(2/(dt^3))*t) ; (-2*(1/dt) + 6*(1/(dt^2))*t)];

        !l0=[( 1-(3/(dt^2))*ti.^2 + (2/(dt^3))*ti.^3) , (ti -(2/dt)*ti.^2 + (1/(dt^2))*ti.^3) , ((3/(dt^2))*ti.^2 + -(2/(dt^3))*ti.^3) , (-(1/dt)*ti.^2 + (1/(dt^2))*ti.^3)];
        !ldt=[( 1 -(3/(dt^2))*tf.^2 + (2/(dt^3))*tf.^3) , (tf -(2/dt)*tf.^2 + (1/(dt^2))*tf.^3) , ((3/(dt^2))*tf.^2 + -(2/(dt^3))*tf.^3) , (-(1/dt)*tf.^2 + (1/(dt^2))*tf.^3)];
        !lt0=[(-2*(3/(dt^2))*ti + 3*(2/(dt^3))*ti.^2) , (1 -2*(2/dt)*ti + 3*(1/(dt^2))*ti.^2) , (2*(3/(dt^2))*ti + -3*(2/(dt^3))*ti.^2) , (-2*(1/dt)*ti + 3*(1/(dt^2))*ti.^2)];
        !ltdt=[(-2*(3/(dt^2))*tf + 3*(2/(dt^3))*tf.^2) , (1 -2*(2/dt)*tf + 3*(1/(dt^2))*tf.^2) , (2*(3/(dt^2))*tf + -3*(2/(dt^3))*tf.^2) , (-2*(1/dt)*tf + 3*(1/(dt^2))*tf.^2)];

      end if

      !call show(Top%l)
      !print*, "espacio"
      !call show(Top%lt)
      !stop

      ! Calculation of the elementals matrices:
      call Elm_calc_matrices(Top%l,Top%lt,waux,Q00k,Q01k,Q10k,Q11k)

      ! %%%%%%%%%%%%%%%%  Save the differents matrix %%%%%%%%%%%%%%%%%

      Top%Q00k = Q00k
      Top%Q01k = Q01k
      Top%Q10k = Q10k
      Top%Q11k = Q11k

      !call show(Top%Q00k)
      !call show(Top%Q01k)
      !print*, "separacion:"
      !call show(Top%Q10k)
      !print*, "separacion:"
      !call show(Top%Q11k)

      !print*, "STOP AQUI"
      !stop

      ! Global matrix in time (Quasi_static calculation):

      ! % Definition of the global integral matrices of the LATIN - PGD integration steps.

      ! %% Ensamble de matrices en la matriz global.
      do k = 1,I%NT
          I00T(Top%IDvtc(:,k),Top%IDvtc(:,k)) = I00T(Top%IDvtc(:,k),Top%IDvtc(:,k)) + Q00k
          I01T(Top%IDvtc(:,k),Top%IDvtc(:,k)) = I01T(Top%IDvtc(:,k),Top%IDvtc(:,k)) + Q01k
          I10T(Top%IDvtc(:,k),Top%IDvtc(:,k)) = I10T(Top%IDvtc(:,k),Top%IDvtc(:,k)) + Q10k
          I11T(Top%IDvtc(:,k),Top%IDvtc(:,k)) = I11T(Top%IDvtc(:,k),Top%IDvtc(:,k)) + Q11k
      end do

      ! Free dofs:
      allocate( Top%dof_imposed(1)  )
      allocate( Top%dof_free(I%ntc-1)  )

      Top%dof_imposed = (/1/)
      Top%dof_free = incr(2,I%ntc)

      I00Tr = I00T(Top%dof_free,Top%dof_free)
      I01Tr = I01T(Top%dof_free,Top%dof_free)
      I10Tr = I10T(Top%dof_free,Top%dof_free)
      I11Tr = I11T(Top%dof_free,Top%dof_free)

      allocate(Top%I00Tr(I%ntc-1,I%ntc-1))
      allocate(Top%I01Tr(I%ntc-1,I%ntc-1))
      allocate(Top%I10Tr(I%ntc-1,I%ntc-1))
      allocate(Top%I11Tr(I%ntc-1,I%ntc-1))

      Top%I00Tr = I00Tr
      Top%I01Tr = I01Tr
      Top%I10Tr = I10Tr
      Top%I11Tr = I11Tr

      ! Auxiliar Vector (Passing from the nodal values of the time function to the gauss points)

      Top%Tmat_timefunc = transpose(Top%l)
      Top%Tmat_timefunct = transpose(Top%lt)

      IntTe = spread( Top%IntT(1:I%ngpt,1), 2, I%Nsft )  !reshape( Top%IntT( incr(1,I%ngpt) , 1 ), (/ I%ngpt , 1 /) )
      !print*, "INTe:"
      !call show( IntTe )
      Top%vwalfa =  transpose( IntTe*(Top%Tmat_timefunc)  )
      Top%vwalfat = transpose( IntTe*(Top%Tmat_timefunct) )

    end subroutine Time_op_assign

    subroutine Elm_calc_matrices(l,lt,waux,Q00k,Q01k,Q10k,Q11k) !result(Q00k,Q01k,Q11k)

        implicit none
        double precision, dimension(:,:) :: l, lt, waux
        double precision, dimension(:,:), allocatable :: wauxg
        double precision, dimension( size(l,1), size(l,2) )  :: lm,ltm
        double precision, dimension( size(l,2), size(l,1) ) ::  lmw, ltmw
        double precision, dimension( size(l,1), size(l,1) ) :: Q00k,Q01k,Q10k,Q11k

        allocate(wauxg( I%ngpt, I%Nsft ))
        wauxg = spread( reshape(waux, (/I%ngpt/) ) , 2, I%Nsft )

        !call show(wauxg)
        !print*, "espacio:"
        !call show(waux)
        !print*, "l:"
        !call show(l)

        !stop

        lm=l; ltm=lt
        lmw = ( wauxg*transpose(l) );  ltmw = ( wauxg*transpose(lt) )

        Q00k = matmul(lm,lmw)
        Q01k = matmul(ltm,lmw)
        Q10k = matmul(lm,ltmw)
        Q11k = matmul(ltm,ltmw)

    end subroutine Elm_calc_matrices

end module Time_matrices


subroutine fhet1(nx, ny, dx, dt, N, jfonte, ifonte, atraso, LT, cw, parq, tipo, fonte, mate)
    implicit none

    integer*8 j,i,k
    integer*8 nx,ny,jfonte,ifonte,parq,N,tipo,fonte
    real*8 dx,dt,t,atraso,LT,dt2,dx2,dy2,dy,mate(ny,nx)
    real*8 GxJ(ny,nx),GIy(ny,nx),CxJ(ny,nx),CIy(ny,nx)
    real*8 PP(ny,nx),PN(ny,nx),PL(ny,nx),cw(ny,nx),cte1,fc2
    real*8 C1,C2,C3,C4,E1
    real*8 pi
    character(30) nstr

    pi =4.D0*DATAN(1.D0)
    fc2 = (3*dsqrt(pi)*lt)**2.d0;
    E1=2.25D0*(10.D0**9.D0)
    10 format(I12)
    open(2,file='sismograma.mat')
    ! GAMMA
    do j=1,ny-1
     do i=1,nx-1
     GxJ(j,i)=0.5*(mate(J,i)+mate(J,i+1))
     GIy(j,i)=0.5*(mate(j,I)+mate(j+1,I))
     CxJ(j,i)=0.5*(cw(J,i)+cw(J,i+1))
     CIy(j,i)=0.5*(cw(j,I)+cw(j+1,I))
     enddo
    enddo
    GxJ=CxJ*CxJ/GxJ
    GIy=CIy*CIy/GIy
    !===========================

    dt2=dt*dt
    dy=dx
    dx2=dx*dx
    dy2=dx2

    PP=0;PN=0;PL=0;

    do k=1,N
    t=k*dt

     if (tipo.eq.2) then !ABC 2D

     i=nx; j=ny; PN(j,i)=PL(j,i)-cw(j-1,i)*dt/dy*(PL(j,i)-PL(j-1,i));
           j=1;  PN(j,i)=PL(j,i)+cw(j,i)*dt/dy*(PL(j+1,i)-PL(j,i));

      PP(2:ny-1,nx)=2.*PN(2:ny-1,nx)-PL(2:ny-1,nx)-CW(2:ny-1,nx-1)*dt/dx*((PN(2:ny-1,nx) &
      -PL(2:ny-1,nx))-(PN(2:ny-1,nx-1)-PL(2:ny-1,nx-1))) &
      +0.5*dt2/dy2*cw(2:ny-1,nx-1)*cw(2:ny-1,nx-1)*(PN(3:ny,nx)-2.*PN(2:ny-1,nx)+PN(1:ny-2,nx))

     i=1; j=ny; PN(j,i)=PL(j,i)-cw(j-1,i)*dt/dy*(PL(j,i)-PL(j-1,i));
          j=1;  PN(j,i)=PL(j,i)+ cw(j,i)*dt/dy*(PL(j+1,i)-PL(j,i));

      PP(2:ny-1,1)=2.*PN(2:ny-1,1)-PL(2:ny-1,1)+CW(2:ny-1,1)*dt/dx*((PN(2:ny-1,2) &
      -PL(2:ny-1,2))-(PN(2:ny-1,1)-PL(2:ny-1,1))) &
      +0.5*dt2/dy2*cw(2:ny-1,1)*cw(2:ny-1,1)*(PN(3:ny,1)-2.*PN(2:ny-1,1)+PN(1:ny-2,1))

      PP(ny,2:nx-1)=2.*PN(ny,2:nx-1)-PL(ny,2:nx-1)-CW(ny-1,2:nx-1)*dt/dy*((PN(ny,2:nx-1) &
      -PL(ny,2:nx-1))-(PN(ny-1,2:nx-1)-PL(ny-1,2:nx-1))) &
      +0.5*dt2/dx2*cw(ny-1,2:nx-1)*cw(ny-1,2:nx-1)*(PN(ny,3:nx)-2.*PN(ny,2:nx-1)+PN(ny,1:nx-2))

      PP(1,2:nx-1)=2.*PN(1,2:nx-1)-PL(1,2:nx-1)+CW(1,2:nx-1)*dt/dy*((PN(2,2:nx-1) &
      -PL(2,2:nx-1))-(PN(1,2:nx-1)-PL(1,2:nx-1))) &
      +0.5*dt2/dx2*cw(1,2:nx-1)*cw(1,2:nx-1)*(PN(1,3:nx)-2.*PN(1,2:nx-1)+PN(1,1:nx-2))

     else  !ABC 1D
       PP(1:ny,nx)=PN(1:ny,nx)-cw(1:ny,nx)*dt/dx*(PN(1:ny,nx)-PN(1:ny,nx-1))
       PP(1:ny,1)=PN(1:ny,1)+cw(1:ny,1)*dt/dx*(PN(1:ny,2)-PN(1:ny,1))
       PP(ny,1:nx)=PN(ny,1:nx)-cw(ny,1:nx)*dt/dy*(PN(ny,1:nx)-PN(ny-1,1:nx))
       PP(1,1:nx)=PN(1,1:nx)+ cw(1,1:nx)*dt/dy*(PN(2,1:nx)-PN(1,1:nx))
     endif

     do i=2,nx-1
     do j=2,ny-1
       C1=mate(j,i)*GxJ(j,i)*dt*dt/(dx*dx)
       C2=mate(j,i)*GxJ(j,i-1)*dt*dt/(dx*dx)
       C3=mate(j,i)*GIy(j,i)*dt*dt/(dy*dy)
       C4=mate(j,i)*GIy(j-1,i)*dt*dt/(dy*dy)
       PP(j,i)=2*PN(j,i)-PL(j,i)+ C1*(PN(j,i+1)-PN(j,i))-C2*(PN(j,i)-PN(j,i-1))+ C3*(PN(j+1,i)-PN(j,i))- C4*(PN(j,i)-PN(j-1,i))
     enddo
     enddo

     if (fonte.eq.1) then
       cte1=-0.25d0*pi*fc2*(t-atraso)**2.d0
       PP(jfonte,ifonte) = PP(jfonte,ifonte) + dt2*(1.d0+2.d0*cte1)*dexp(cte1)    !1/dsqrt(2*pi)
     else
     PP(jfonte,ifonte) = PP(jfonte,ifonte) + E1*dt2*((1.D0-2.D0*((pi*LT*(t-atraso))**2.D0))*exp(-((pi*LT*(t-atraso))**2.D0)))
       !PP(jfonte,ifonte) = PP(jfonte,ifonte) - dt2*dsin(2*pi*LT*t)
     endif
     PL=PN
     PN=PP

     write(2,*) PP(jfonte,:)

     if(mod(k,parq)==0) then
     write(nstr,10) k
     nstr = 'resultados/p'//trim(adjustl(nstr))//'.mat'
     open(1,file=trim(nstr))
     do i=1,ny
       write(1,*) PP(i,:)
     enddo
     close(1)
     endif

    enddo

    close(2)

    return
    end subroutine fhet1


! RUN: bbc -emit-fir %s -o - --math-runtime=llvm | FileCheck %s

      SUBROUTINE POW_WRAPPER(IN, IN2, OUT)
      DOUBLE PRECISION IN, IN2
      OUT = IN ** IN2
      RETURN
      END

! CHECK-LABEL: func @_QPpow_wrapper(
! CHECK-SAME: %{{.*}}: !fir.ref<f64>{{.*}}, %{{.*}}: !fir.ref<f64>{{.*}}, %{{.*}}: !fir.ref<f32>{{.*}}) {
! CHECK-NEXT:   %0 = fir.load %arg0 : !fir.ref<f64>
! CHECK-NEXT:   %1 = fir.load %arg1 : !fir.ref<f64>
! CHECK-NEXT:   %2 = fir.call @llvm.pow.f64(%0, %1) : (f64, f64) -> f64

      SUBROUTINE POWF_WRAPPER(IN, IN2, OUT)
      REAL IN, IN2
      OUT = IN ** IN2
      RETURN
      END

! CHECK-LABEL: func @_QPpowf_wrapper(
! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}}, %{{.*}}: !fir.ref<f32>{{.*}}, %{{.*}}: !fir.ref<f32>{{.*}}) {
! CHECK-NEXT:   %0 = fir.load %arg0 : !fir.ref<f32>
! CHECK-NEXT:   %1 = fir.load %arg1 : !fir.ref<f32>
! CHECK-NEXT:   %2 = fir.call @llvm.pow.f32(%0, %1) : (f32, f32) -> f32


program test_func_ptrs
    use procedures
    implicit none

real(kind=8) a, b, ToolMax, Xs

a = -8.0d0
b = 8.0d0
ToolMax = 0.001
call BisectionRoot(g, a, b, ToolMax, Xs)

write(*,*) Xs

end program test_func_ptrs


! { dg-do run }
! PR28354 Incorrect rounding of .99999 with f3.0 format specifier
! PR30910 ES format not quite right...
! Test case derived from PR. Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org>
  write(*,50) -0.99999
  write(*,50) 0.99999
  write(*,50) -9.0
  write(*,50) -0.99
  write(*,50) -0.999
  write(*,50) -0.999
  write(*,50) -0.59
  write(*,50) -0.49
  write(*,100) 37.99999
  write(*,100) 10345.0
  write(*,100) 333.678
  write(*,100) 333.499
  50   format(f3.0,"<")
 100   format(f8.0,"<")
  write(6,'(es6.0)') 1.0e-1
  write(*,150) -0.99999
  write(*,150) 0.99999
  write(*,150) -9.0
  write(*,150) -0.99
  write(*,150) -0.999
  write(*,150) -0.999
  write(*,150) -0.59
  write(*,150) -0.49
  write(*,200) 37.99999
  write(*,200) 10345.0
  write(*,200) 333.678
  write(*,200) 333.499
 150   format(es7.0,"<")
 200   format(es8.0,"<")
  write(*,250) -0.99999
  write(*,250) 0.99999
  write(*,250) -9.0
  write(*,250) -0.99
  write(*,250) -0.999
  write(*,250) -0.999
  write(*,250) -0.59
  write(*,250) -0.49
  write(*,300) 37.99999
  write(*,300) 10345.0
  write(*,300) 333.678
  write(*,300) 333.499
 250   format(1pe7.0,"<")
 300   format(1pe6.0,"<")
  end
! {dg-output "-1.<"
! {dg-output " 1.<"
! {dg-output "-9.<"
! {dg-output "-1.<"
! {dg-output "-1.<"
! {dg-output "-1.<"
! {dg-output "-1.<"
! {dg-output " 0.<"
! {dg-output "     38.<"
! {dg-output "  10345.<"
! {dg-output "    334.<"
! {dg-output "    333.<"
! {dg-output "1.E-01"
! {dg-output "-1.E+00<"
! {dg-output " 1.E+00<"
! {dg-output "-9.E+00<"
! {dg-output "-1.E+00<"
! {dg-output "-1.E+00<"
! {dg-output "-1.E+00<"
! {dg-output "-6.E-01<"
! {dg-output "-5.E-01<"
! {dg-output "  4.E+01<"
! {dg-output "  1.E+04<"
! {dg-output "  3.E+02<"
! {dg-output "  3.E+02<"
! {dg-output "-1.E+00<"
! {dg-output " 1.E+00<"
! {dg-output "-9.E+00<"
! {dg-output "-1.E+00<"
! {dg-output "-1.E+00<"
! {dg-output "-1.E+00<"
! {dg-output "-6.E-01<"
! {dg-output "-5.E-01<"
! {dg-output "4.E+01<"
! {dg-output "1.E+04<"
! {dg-output "3.E+02<"
! {dg-output "3.E+02<"


PROGRAM LA_CGELSD_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_GELSD, LA_GETRF
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.2,1H,,F7.2,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER  :: I, INFO, M, N, J, NRHS, RANK
   REAL(WP) :: RCOND
!  .. LOCAL ARRAYS ..
   INTEGER, ALLOCATABLE :: IPIV(:)
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), S(:)
   COMPLEX(WP), ALLOCATABLE :: A(:, :), B(:,:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MIN, MAX
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'CGELSD Example Program Results'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) M, N, NRHS
   PRINT *, 'M = ', M, ' N = ', N, ' NRHS = ', NRHS
   ALLOCATE ( A(M,N), AA(M,N), B(MAX(1,M,N),NRHS), BB(MAX(1,M,N),NRHS), &
              S(MIN(M,N)), IPIV(MIN(M,N)) )
   DO I = 1, M; READ (NIN,*) AA(I,:); ENDDO
   DO J = 1, NRHS; BB(:,J) = SUM( AA, DIM=2)*J; ENDDO
   A = AA; B=BB
   WRITE(NOUT,*) 'The matrix A'
   DO I = 1, M; WRITE (NOUT,FMT) A(I,:); ENDDO
   WRITE(NOUT,*) 'The RHS matrix B:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); ENDDO
!
   WRITE ( NOUT, * )'--------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_CGELSD LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B, RANK, S, RCOND, INFO)'
   A = AA; CALL LA_GETRF( A(1:MIN(M,N),1:MIN(M,N)), IPIV, RCOND )
   A = AA; B=BB
   CALL LA_GELSD (A, B, RANK, S, RCOND, INFO)
   WRITE(NOUT,*)'RANK, RCOND, INFO ', RANK, RCOND, INFO
   WRITE(NOUT,*) 'B & S'
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
   WRITE(NOUT,FMT) S(:)
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B(:,1), RANK, S, RCOND, INFO)'
   A = AA; B=BB; RCOND = 0.0_WP
   CALL LA_GELSD (A, B(:,1), RANK, S, RCOND, INFO)
   WRITE(NOUT,*)'RANK, RCOND, INFO ', RANK, RCOND, INFO
   WRITE(NOUT,*) 'B & S'
   WRITE (NOUT,FMT) B(:,1)
   WRITE(NOUT,FMT) S(:)
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B, INFO=INFO)'
   A = AA; B=BB;
   CALL LA_GELSD (A, B, INFO=INFO)
   WRITE(NOUT,*)'INFO = ', INFO, ', B'
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B(:,1), INFO=INFO)'
   A = AA; B=BB;
   CALL LA_GELSD (A, B(:,1), INFO=INFO)
   WRITE(NOUT,*)'INFO = ', INFO, ', B(:,1)'
   WRITE(NOUT,FMT) B(:,1)
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B, RANK, INFO=INFO)'
   A = AA; B=BB;
   CALL LA_GELSD (A, B, RANK, INFO=INFO)
   WRITE(NOUT,*)'INFO = ', INFO, ' RANK = ', RANK, ', B'
   DO J = 1, NRHS; WRITE(NOUT,FMT) B(:,J); ENDDO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B(:,1), RANK, S, INFO=INFO)'
   A = AA; B=BB;
   CALL LA_GELSD (A, B(:,1), RANK, S, INFO=INFO)
   WRITE(NOUT,*)'INFO = ', INFO, ' RANK = ', RANK, ', B(:,1) & S'
   WRITE(NOUT,FMT) B(:,1)
   WRITE(NOUT,FMT) S(:)
!
   WRITE (NOUT,*)
   A = AA; CALL LA_GETRF( A(1:MIN(M,N),1:MIN(M,N)), IPIV, RCOND )
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B, RCOND = RCOND, INFO=INFO)'
   A = AA; B=BB;
   CALL LA_GELSD (A, B, RCOND=RCOND, INFO=INFO)
   WRITE(NOUT,*)'INFO = ', INFO, ' RCOND = ', RCOND, ', B'
   DO J = 1, NRHS; WRITE(NOUT,FMT) B(:,J); ENDDO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B(:,1), S=S(1:MAX(M,N)+1), INFO=INFO)'
   A = AA; B=BB;
   CALL LA_GELSD (A, B(:,1), S=S(1:MAX(M,N)+1), INFO=INFO)
   WRITE(NOUT,*)'INFO = ', INFO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B)'
   A = AA; B=BB;
   CALL LA_GELSD (A, B)
   WRITE(NOUT,*)'B'
   DO J = 1, NRHS; WRITE(NOUT,FMT) B(:,J); ENDDO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B(:,1))'
   A = AA; B=BB;
   CALL LA_GELSD (A, B(:,1))
   WRITE(NOUT,*)'B(:,1)'
   WRITE(NOUT,FMT) B(:,1)
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A, B(MIN(M,N),:), INFO=INFO)'
   A = AA; B=BB;
   CALL LA_GELSD (A, B(MIN(M,N),:), INFO=INFO)
   WRITE(NOUT,*)'INFO = ', INFO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GELSD (A(1:N-1,:), B(:,1))'
   A = AA; B=BB;
   CALL LA_GELSD (A(1:N-1,:), B(:,1))
   WRITE(NOUT,*)'INFO = ', INFO
!
END!PROGRAM LA_CGELSD_EXAMPLE


MODULE rectangle_class
!
!   This module implements a rectangle class.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/29/06    S. J. Chapman        Original code
!
USE shape_class                  ! USE parent class
IMPLICIT NONE

! Type definition
TYPE,PUBLIC,EXTENDS(shape) :: rectangle

   ! Additional instance variables.
   REAL :: l = 0               ! Length
   REAL :: w = 0               ! Width

CONTAINS

   ! Bound procedures
   PROCEDURE,PUBLIC :: initialize => initialize_sub
   PROCEDURE,PUBLIC :: area => get_area_fn
   PROCEDURE,PUBLIC :: perimeter => get_perimeter_fn
   PROCEDURE,PUBLIC :: to_string => to_string_fn

END TYPE rectangle

! Restrict access to the actual procedure names
PRIVATE :: initialize_sub, get_area_fn, get_perimeter_fn
PRIVATE :: to_string_fn

! Now add methods
CONTAINS

   SUBROUTINE initialize_sub(this,l,w)
   !
   ! Initialize the rectangle object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(rectangle) :: this            ! Rectangle object
   REAL,INTENT(IN) :: l                ! Length
   REAL,INTENT(IN) :: w                ! Width

   ! Initialize the rectangle
   this%l = l
   this%w = w

   END SUBROUTINE initialize_sub

   REAL FUNCTION get_area_fn(this)
   !
   ! Return the area of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(rectangle) :: this             ! Rectangle object

   ! Calculate area
   get_area_fn = this%l * this%w

   END FUNCTION get_area_fn

   REAL FUNCTION get_perimeter_fn(this)
   !
   ! Return the perimeter of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(rectangle) :: this             ! Rectangle object

   ! Calculate perimeter
   get_perimeter_fn = 2 * this%l + 2 * this%w

   END FUNCTION get_perimeter_fn

   CHARACTER(len=50) FUNCTION to_string_fn(this)
   !
   ! Return the a character description of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(rectangle) :: this             ! Rectangle object

   ! Return description
   WRITE (to_string_fn,'(A,F6.2,A,F6.2)') 'Rectangle of length ', &
      this%l, ' and width ', this%w

   END FUNCTION to_string_fn

END MODULE rectangle_class


program quad_test
    use :: quad_func_interface_mod
    use :: types_mod, only : DP
    use :: quad_submod_mod, only : quad
    implicit none
    real(kind=DP), parameter :: a = -1.0_DP, b = 1.0_DP

    print *, quad(func, a, b)

contains

    function func(x) result(f)
        implicit none
        real(kind=DP), value :: x
        real(kind=DP) :: f
        f = exp(x)
    end function func

end program quad_test


program kindsize

use iso_c_binding, only: complex128=>c_double_complex, real64=>c_double, c_sizeof, real32=>c_float, complex64=>c_float_complex
implicit none

complex(real32) :: s
complex(real64) :: d
complex(complex64) :: c
complex(complex128) :: z

print '(A12,I2,I4)', 'real32',real32,storage_size(s)
print '(A12,I2,I4)', 'real64',real64,storage_size(d)
print '(A12,I2,I4)', 'complex64',complex64,storage_size(c)
print '(A12,I2,I4)', 'complex128',complex128, storage_size(z)

end program


 SUBROUTINE CPOSV1_F95( A, B, UPLO, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => SP
    USE LA_AUXMOD, ONLY: ERINFO, LSAME
    USE F77_LAPACK, ONLY: POSV_F77 => LA_POSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:)
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_POSV'
!   .. LOCAL SCALARS ..
    CHARACTER(LEN=1) :: LUPLO
    INTEGER :: LINFO, N
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; N = SIZE(A,1)
    IF( PRESENT(UPLO) )THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
!   .. TEST THE ARGUMENTS
    IF( SIZE( A, 2 ) /= N .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B ) /= N ) THEN; LINFO = -2
    ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
    ELSE IF ( N > 0 ) THEN
       CALL POSV_F77( LUPLO, N, 1, A, N, B, N, LINFO )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO )
 END SUBROUTINE CPOSV1_F95


      SUBROUTINE poldiv(u,n,v,nv,q,r)
      INTEGER n,nv
      REAL q(n),r(n),u(n),v(nv)
      INTEGER j,k
      do 11 j=1,n
        r(j)=u(j)
        q(j)=0.
11    continue
      do 13 k=n-nv,0,-1
        q(k+1)=r(nv+k)/v(nv)
        do 12 j=nv+k-1,k+1,-1
          r(j)=r(j)-q(k+1)*v(j-k)
12      continue
13    continue
      do 14 j=nv,n
        r(j)=0.
14    continue
      return
      END

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


! automdiff.f90 --
!     Module for automatic differentation:
!
!     With this module you can define a function that, when
!     evaluated returns both the value and the first derivative. The
!     independent variable should be of type AUTODERIV, as should be the
!     result.
!
!     $Id: automdiff.f90,v 1.4 2008/10/26 12:16:43 arjenmarkus Exp $
!
module automatic_differentiation_type
    use select_precision
    implicit none

    type AUTODERIV
        real(wp) :: v
        real(wp) :: dv
    end type AUTODERIV
end module automatic_differentiation_type

module automatic_differentiation
    use automatic_differentiation_type
    implicit none

    interface sin
        module procedure sin_v
    end interface

    interface cos
        module procedure cos_v
    end interface

    interface tan
        module procedure tan_v
    end interface

    interface exp
        module procedure exp_v
    end interface

    interface log
        module procedure log_v
    end interface

    interface log10
        module procedure log10_v
    end interface

    interface sqrt
        module procedure sqrt_v
    end interface

    interface asin
        module procedure asin_v
    end interface

    interface acos
        module procedure acos_v
    end interface

    interface atan
        module procedure atan_v
    end interface

    interface sinh
        module procedure sinh_v
    end interface

    interface tanh
        module procedure tanh_v
    end interface

    interface cosh
        module procedure cosh_v
    end interface

    interface operator(+)
        module procedure add_cv
        module procedure add_vc
        module procedure add_vv
    end interface

    interface operator(-)
        module procedure sub_cv
        module procedure sub_vc
        module procedure sub_vv
        module procedure usub_v  ! Unary minus!
    end interface

    interface operator(*)
        module procedure mult_cv
        module procedure mult_vc
        module procedure mult_vv
    end interface

    interface operator(/)
        module procedure div_cv
        module procedure div_vc
        module procedure div_vv
    end interface

    interface operator(**)
        module procedure expon_cv
        module procedure expon_vc
        module procedure expon_vv
        module procedure expon_vn ! x ** n
    end interface

contains

! derivvar
!     Properly initialise an independent variable
! Arguments:
!     val        Value for the variable
! Result:
!     Independent variable with value ""val" and dervative 1
!
function derivvar( val ) result( x )
    real(wp)        :: val
    type(AUTODERIV) :: x

    x%v  = val
    x%dv = 1.0_wp
end function derivvar

! sin, cos, tan, log, exp, sqrt, sinh, cosh, tanh
!     Return the sine etc. of x
! Arguments:
!     x          Variable in question
! Result:
!     The function value and its first derivative at x
! Note:
!     Variables (not constant) need to be initialised as
!     x = autoderiv(x0,1.0). Use the function derivvar
!     for convenience.
!
elemental function sin_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = sin(x%v)
    y%dv = x%dv * cos(x%v)
end function sin_v

elemental function cos_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = cos(x%v)
    y%dv = -x%dv * sin(x%v)
end function cos_v

elemental function tan_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = tan(x%v)
    y%dv = x%dv / (1.0 + y%v**2 )
end function tan_v

elemental function exp_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = exp(x%v)
    y%dv = x%dv * y%v
end function exp_v

elemental function log_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = log(x%v)
    y%dv = x%dv / x%v
end function log_v

elemental function log10_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = log10(x%v)
    y%dv = x%dv / (log(10.0) * x%v)
end function log10_v

elemental function sqrt_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = sqrt(x%v)
    y%dv = 0.5 *x%dv / y%v
end function sqrt_v

elemental function sinh_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = sinh(x%v)
    y%dv = x%dv * cosh(x%v)
end function sinh_v

elemental function cosh_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = cosh(x%v)
    y%dv = x%dv * sinh(x%v)
end function cosh_v

elemental function tanh_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = tanh(x%v)
    y%dv = x%dv * (1.0 - y%v**2)
end function tanh_v

! asin, acos, atan
!     Return the arcsine etc. of x
! Arguments:
!     x          Variable in question
! Result:
!     The function value and its first derivative at x
! Note:
!     Variables (not constant) need to be initialised as
!     x = autoderiv(x0,1.0). Use the function derivvar
!     for convenience.
!
elemental function asin_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = asin(x%v)
    y%dv = x%dv * sqrt(1.0 - x%v ** 2)
end function asin_v

elemental function acos_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = acos(x%v)
    y%dv = -x%dv * sqrt(1.0 - x%v ** 2)
end function acos_v

elemental function atan_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = atan(x%v)
    y%dv = x%dv / (1.0 + x%v ** 2)
end function atan_v

! +, -, *, /, **
!     Implementation of the arithmetic operations
! Arguments:
!     x          First operand (constant or variable)
!     y          Second operand (constant or variable)
! Result:
!     The sum, etc. and its first (total) derivative
! Note:
!     We need three versions to allow combinations
!     with constants.
!
elemental function add_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  + y%v
    z%dv = x%dv + y%dv
end function add_vv

elemental function add_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x    + y%v
    z%dv = y%dv
end function add_cv

elemental function add_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  + y
    z%dv = x%dv
end function add_vc

elemental function usub_v( x ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: z

    z%v  = -x%v
    z%dv = -x%dv
end function usub_v

elemental function sub_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  - y%v
    z%dv = x%dv - y%dv
end function sub_vv

elemental function sub_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x  - y%v
    z%dv =    - y%dv
end function sub_cv

elemental function sub_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  - y
    z%dv = x%dv
end function sub_vc

elemental function mult_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  * y%v
    z%dv = x%dv * y%v + x%v * y%dv
end function mult_vv

elemental function mult_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x * y%v
    z%dv = x * y%dv
end function mult_cv

elemental function mult_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  * y
    z%dv = x%dv * y
end function mult_vc

elemental function div_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  / y%v
    z%dv = (x%dv * y%v - x%v * y%dv) / y%v ** 2
end function div_vv

elemental function div_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x / y%v
    z%dv = -x * y%dv / y%v ** 2
end function div_cv

elemental function div_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  / y
    z%dv = x%dv / y
end function div_vc

elemental function expon_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  ** y%v
    z%dv = (y%dv * log(x%v) + y%v/x%v * x%dv ) * z%v
end function expon_vv

elemental function expon_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x ** y%v
    z%dv = y%dv * log(x) * z%v
end function expon_cv

elemental function expon_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  ** y
    z%dv = y/x%v * x%dv * z%v
end function expon_vc

elemental function expon_vn( x, n ) result( z )
    type(AUTODERIV), intent(in) :: x
    integer, intent(in)         :: n
    type(AUTODERIV)             :: z

    z%v  =            x%v ** n
    z%dv = n * x%dv * x%v ** (n-1)
end function expon_vn

! find_root
!     Find a root using Newton-Raphson
! Arguments:
!     f          Function whose root we want to find
!     xinit      Initial estimate
!     tolerance  Tolerance in finding root
!     root       Final estimate
!     found      Whether it was found or not
! Note:
!     If the iteration does not converge, we assume
!     that the iterate will grow indefinitely.
!
!     If you need a more general interface to the function,
!     consider using the implementation as a template
!
subroutine find_root( f, xinit, tolerance, root, found )
    interface
        function f(x)
            use automatic_differentiation_type
            type(AUTODERIV), intent(in) :: x
            type(AUTODERIV)             :: f
        end function
    end interface

    type(AUTODERIV), intent(in)  :: xinit
    type(AUTODERIV), intent(out) :: root
    real(wp)                     :: tolerance
    logical                      :: found

    integer                      :: iter
    integer, parameter           :: maxiter = 1000
    type(AUTODERIV)              :: fvalue

    found = .false.
    root  = xinit

    do iter = 1,maxiter

        fvalue = f(root)
        call find_root_iter( fvalue, root, tolerance, found )
        if ( found .or. abs(root%v) > huge(1.0_wp)/10.0 ) exit
    enddo

end subroutine find_root

! find_root_iter
!     Do one iteration in the Newton-Raphson method
! Arguments:
!     fvalue     Function value (plus derivative)
!     root       Current iterate
!     tolerance  Tolerance in finding root
!     found      Whether it was found or not
!
subroutine find_root_iter( fvalue, root, tolerance, found )
    type(AUTODERIV), intent(in)    :: fvalue
    type(AUTODERIV), intent(inout) :: root
    real(wp), intent(in)           :: tolerance
    logical, intent(out)           :: found

    type(AUTODERIV)                :: newroot

    newroot = root - fvalue%v / fvalue%dv
    found   = abs( newroot%v - root%v ) < tolerance
    root    = newroot

end subroutine find_root_iter

end module automatic_differentiation


*c
*c    This program modified by R. Clint Whaley to call the standard
*c    LAPACK factor & solve, for inclusion in ATLAS 6/05/00
*c
      DOUBLE PRECISION A(1001,1000),B(1000),X(1000)
      DOUBLE PRECISION TIME(6),CRAY,OPS,TOTAL,NORMA,NORMX
      DOUBLE PRECISION RESID,RESIDN,EPS,EPSLON
      DOUBLE PRECISION FTIME00
      EXTERNAL FTIME00
      INTEGER IPVT(1000)
      LDA = 1001
*
*     this program was updated on 10/12/92 to correct a
*     problem with the random number generator. The previous
*     random number generator had a short period and produced
*     singular matrices occasionally.
*
      N = 1000
      CRAY = .056
      WRITE(6,1)
    1 FORMAT(' Please send the results of this run to:'//
     $       ' Jack J. Dongarra'/
     $       ' Computer Science Department'/
     $       ' University of Tennessee'/
     $       ' Knoxville, Tennessee 37996-1300'//
     $       ' Fax: 615-974-8296'//
     $       ' Internet: dongarra@cs.utk.edu'/)
      OPS = (2.0D0*DFLOAT(N)**3)/3.0D0 + 2.0D0*DFLOAT(N)**2
*
         CALL MATGEN(A,LDA,N,B,NORMA)
*
*******************************************************************
*******************************************************************
*        you should replace the call to dgefa and dgesl
*        by calls to your linear equation solver.
*******************************************************************
*******************************************************************
*
         T1 = FTIME00()
*clint         call dgefa(a,lda,n,ipvt,info)
         CALL DGETRF(N, N, A, LDA, IPVT, INFO)
         TIME(1) = FTIME00() - T1
         T1 = FTIME00()
*clint         call dgesl(a,lda,n,ipvt,b,0)
         CALL DGETRS('NoTrans', N, 1, A, LDA, IPVT, B, MAX(1,N), INFO)
         TIME(2) = FTIME00() - T1
         TOTAL = TIME(1) + TIME(2)
*******************************************************************
*******************************************************************
*
*     compute a residual to verify results.
*
         DO 10 I = 1,N
            X(I) = B(I)
   10    CONTINUE
         CALL MATGEN(A,LDA,N,B,NORMA)
         DO 20 I = 1,N
            B(I) = -B(I)
   20    CONTINUE
         CALL DMXPY(N,B,N,LDA,X,A)
         RESID = 0.0
         NORMX = 0.0
         DO 30 I = 1,N
            RESID = DMAX1( RESID, DABS(B(I)) )
            NORMX = DMAX1( NORMX, DABS(X(I)) )
   30    CONTINUE
         EPS = EPSLON(1.0D0)
         RESIDN = RESID/( N*NORMA*NORMX*EPS )
         WRITE(6,40)
   40    FORMAT('     norm. resid      resid           machep',
     $          '         x(1)          x(n)')
         WRITE(6,50) RESIDN,RESID,EPS,X(1),X(N)
   50    FORMAT(1P5E16.8)
*
         WRITE(6,60) N
   60    FORMAT(//'    times are reported for matrices of order ',I5)
         WRITE(6,70)
   70    FORMAT(6X,'factor',5X,'solve',6X,'total',5X,'mflops',7X,'unit',
     $         6X,'ratio')
*
         TIME(3) = TOTAL
         TIME(4) = OPS/(1.0D6*TOTAL)
         TIME(5) = 2.0D0/TIME(4)
         TIME(6) = TOTAL/CRAY
         WRITE(6,80) LDA
   80    FORMAT(' times for array with leading dimension of',I4)
         WRITE(6,110) (TIME(I),I=1,6)
  110    FORMAT(6(1PE11.3))
         WRITE(6,*)' end of tests -- this version dated 10/12/92'
*
      STOP
      END
      SUBROUTINE MATGEN(A,LDA,N,B,NORMA)
      INTEGER LDA,N,INIT(4),I,J
      DOUBLE PRECISION A(LDA,1),B(1),NORMA,RAN
*
      INIT(1) = 1
      INIT(2) = 2
      INIT(3) = 3
      INIT(4) = 1325
      NORMA = 0.0
      DO 30 J = 1,N
         DO 20 I = 1,N
            A(I,J) = RAN(INIT) - .5
            NORMA = DMAX1(DABS(A(I,J)), NORMA)
   20    CONTINUE
   30 CONTINUE
      DO 35 I = 1,N
          B(I) = 0.0
   35 CONTINUE
      DO 50 J = 1,N
         DO 40 I = 1,N
            B(I) = B(I) + A(I,J)
   40    CONTINUE
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(1),INFO
      DOUBLE PRECISION A(LDA,1)
*
*     dgefa factors a double precision matrix by gaussian elimination.
*
*     dgefa is usually called by dgeco, but it can be called
*     directly with a saving in time if  rcond  is not needed.
*     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
*
*     on entry
*
*        a       double precision(lda, n)
*                the matrix to be factored.
*
*        lda     integer
*                the leading dimension of the array  a .
*
*        n       integer
*                the order of the matrix  a .
*
*     on return
*
*        a       an upper triangular matrix and the multipliers
*                which were used to obtain it.
*                the factorization can be written  a = l*u  where
*                l  is a product of permutation and unit lower
*                triangular matrices and  u  is upper triangular.
*
*        ipvt    integer(n)
*                an integer vector of pivot indices.
*
*        info    integer
*                = 0  normal value.
*                = k  if  u(k,k) .eq. 0.0 .  this is not an error
*                     condition for this subroutine, but it does
*                     indicate that dgesl or dgedi will divide by zero
*                     if called.  use  rcond  in dgeco for a reliable
*                     indication of singularity.
*
*     linpack. this version dated 08/14/78 .
*     cleve moler, university of new mexico, argonne national lab.
*
*     subroutines and functions
*
*     blas daxpy,dscal,idamax
*
*     internal variables
*
      DOUBLE PRECISION T
      INTEGER IDAMAX,J,K,KP1,L,NM1
*
*
*     gaussian elimination with partial pivoting
*
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
*
*        find l = pivot index
*
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
*
*        zero pivot implies this column already triangularized
*
         IF (A(L,K) .EQ. 0.0D0) GO TO 40
*
*           interchange if necessary
*
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
*
*           compute multipliers
*
            T = -1.0D0/A(K,K)
            CALL DSCAL(N-K,T,A(K+1,K),1)
*
*           row elimination with column indexing
*
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB)
      INTEGER LDA,N,IPVT(1),JOB
      DOUBLE PRECISION A(LDA,1),B(1)
*
*     dgesl solves the double precision system
*     a * x = b  or  trans(a) * x = b
*     using the factors computed by dgeco or dgefa.
*
*     on entry
*
*        a       double precision(lda, n)
*                the output from dgeco or dgefa.
*
*        lda     integer
*                the leading dimension of the array  a .
*
*        n       integer
*                the order of the matrix  a .
*
*        ipvt    integer(n)
*                the pivot vector from dgeco or dgefa.
*
*        b       double precision(n)
*                the right hand side vector.
*
*        job     integer
*                = 0         to solve  a*x = b ,
*                = nonzero   to solve  trans(a)*x = b  where
*                            trans(a)  is the transpose.
*
*     on return
*
*        b       the solution vector  x .
*
*     error condition
*
*        a division by zero will occur if the input factor contains a
*        zero on the diagonal.  technically this indicates singularity
*        but it is often caused by improper arguments or improper
*        setting of lda .  it will not occur if the subroutines are
*        called correctly and if dgeco has set rcond .gt. 0.0
*        or dgefa has set info .eq. 0 .
*
*     to compute  inverse(a) * c  where  c  is a matrix
*     with  p  columns
*           call dgeco(a,lda,n,ipvt,rcond,z)
*           if (rcond is too small) go to ...
*           do 10 j = 1, p
*              call dgesl(a,lda,n,ipvt,c(1,j),0)
*        10 continue
*
*     linpack. this version dated 08/14/78 .
*     cleve moler, university of new mexico, argonne national lab.
*
*     subroutines and functions
*
*     blas daxpy,ddot
*
*     internal variables
*
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,NM1
*
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
*
*        job = 0 , solve  a * x = b
*        first solve  l*y = b
*
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
*
*        now solve  u*x = y
*
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
*
*        job = nonzero, solve  trans(a) * x = b
*        first solve  trans(u)*y = b
*
         DO 60 K = 1, N
            T = DDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
*
*        now solve trans(l)*x = y
*
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
*
*     constant times a vector plus a vector.
*     uses unrolled loops for increments equal to one.
*     jack dongarra, linpack, 3/11/78.
*
      DOUBLE PRECISION DX(1),DY(1),DA
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
*
      IF(N.LE.0)RETURN
      IF (DA .EQ. 0.0D0) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
*
*        code for unequal increments or equal increments
*          not equal to 1
*
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
*
*        code for both increments equal to 1
*
*
*        clean-up loop
*
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
   50 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
*
*     forms the dot product of two vectors.
*     uses unrolled loops for increments equal to one.
*     jack dongarra, linpack, 3/11/78.
*
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
*
      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
*
*        code for unequal increments or equal increments
*          not equal to 1
*
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN
*
*        code for both increments equal to 1
*
*
*        clean-up loop
*
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     $   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END
      SUBROUTINE  DSCAL(N,DA,DX,INCX)
*
*     scales a vector by a constant.
*     uses unrolled loops for increment equal to one.
*     jack dongarra, linpack, 3/11/78.
*
      DOUBLE PRECISION DA,DX(1)
      INTEGER I,INCX,M,MP1,N,NINCX
*
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
*
*        code for increment not equal to 1
*
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        DX(I) = DA*DX(I)
   10 CONTINUE
      RETURN
*
*        code for increment equal to 1
*
*
*        clean-up loop
*
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
*
*     finds the index of element having max. dabsolute value.
*     jack dongarra, linpack, 3/11/78.
*
      DOUBLE PRECISION DX(1),DMAX
      INTEGER I,INCX,IX,N
*
      IDAMAX = 0
      IF( N .LT. 1 ) RETURN
      IDAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
*
*        code for increment not equal to 1
*
      IX = 1
      DMAX = DABS(DX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(DABS(DX(IX)).LE.DMAX) GO TO 5
         IDAMAX = I
         DMAX = DABS(DX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
*
*        code for increment equal to 1
*
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
         IF(DABS(DX(I)).LE.DMAX) GO TO 30
         IDAMAX = I
         DMAX = DABS(DX(I))
   30 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION EPSLON (X)
      DOUBLE PRECISION X
*
*     estimate unit roundoff in quantities of size x.
*
      DOUBLE PRECISION A,B,C,EPS
*
*     this program should function properly on all systems
*     satisfying the following two assumptions,
*        1.  the base used in representing dfloating point
*            numbers is not a power of three.
*        2.  the quantity  a  in statement 10 is represented to
*            the accuracy used in dfloating point variables
*            that are stored in memory.
*     the statement number 10 and the go to 10 are intended to
*     force optimizing compilers to generate code satisfying
*     assumption 2.
*     under these assumptions, it should be true that,
*            a  is not exactly equal to four-thirds,
*            b  has a zero for its last bit or digit,
*            c  is not exactly equal to one,
*            eps  measures the separation of 1.0 from
*                 the next larger dfloating point number.
*     the developers of eispack would appreciate being informed
*     about any systems where these assumptions do not hold.
*
*     *****************************************************************
*     this routine is one of the auxiliary routines used by eispack iii
*     to avoid machine dependencies.
*     *****************************************************************
*
*     this version dated 4/6/83.
*
      A = 4.0D0/3.0D0
   10 B = A - 1.0D0
      C = B + B + B
      EPS = DABS(C-1.0D0)
      IF (EPS .EQ. 0.0D0) GO TO 10
      EPSLON = EPS*DABS(X)
      RETURN
      END
      SUBROUTINE MM (A, LDA, N1, N3, B, LDB, N2, C, LDC)
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*)
*
*   purpose:
*     multiply matrix b times matrix c and store the result in matrix a.
*
*   parameters:
*
*     a double precision(lda,n3), matrix of n1 rows and n3 columns
*
*     lda integer, leading dimension of array a
*
*     n1 integer, number of rows in matrices a and b
*
*     n3 integer, number of columns in matrices a and c
*
*     b double precision(ldb,n2), matrix of n1 rows and n2 columns
*
*     ldb integer, leading dimension of array b
*
*     n2 integer, number of columns in matrix b, and number of rows in
*         matrix c
*
*     c double precision(ldc,n3), matrix of n2 rows and n3 columns
*
*     ldc integer, leading dimension of array c
*
* ----------------------------------------------------------------------
*
      DO 20 J = 1, N3
         DO 10 I = 1, N1
            A(I,J) = 0.0
   10    CONTINUE
         CALL DMXPY (N2,A(1,J),N1,LDB,C(1,J),B)
   20 CONTINUE
*
      RETURN
      END
      SUBROUTINE DMXPY (N1, Y, N2, LDM, X, M)
      DOUBLE PRECISION Y(*), X(*), M(LDM,*)
*
*   purpose:
*     multiply matrix m times vector x and add the result to vector y.
*
*   parameters:
*
*     n1 integer, number of elements in vector y, and number of rows in
*         matrix m
*
*     y double precision(n1), vector of length n1 to which is added
*         the product m*x
*
*     n2 integer, number of elements in vector x, and number of columns
*         in matrix m
*
*     ldm integer, leading dimension of array m
*
*     x double precision(n2), vector of length n2
*
*     m double precision(ldm,n2), matrix of n1 rows and n2 columns
*
* ----------------------------------------------------------------------
*
*   cleanup odd vector
*
      J = MOD(N2,2)
      IF (J .GE. 1) THEN
         DO 10 I = 1, N1
            Y(I) = (Y(I)) + X(J)*M(I,J)
   10    CONTINUE
      ENDIF
*
*   cleanup odd group of two vectors
*
      J = MOD(N2,4)
      IF (J .GE. 2) THEN
         DO 20 I = 1, N1
            Y(I) = ( (Y(I))
     $             + X(J-1)*M(I,J-1)) + X(J)*M(I,J)
   20    CONTINUE
      ENDIF
*
*   cleanup odd group of four vectors
*
      J = MOD(N2,8)
      IF (J .GE. 4) THEN
         DO 30 I = 1, N1
            Y(I) = ((( (Y(I))
     $             + X(J-3)*M(I,J-3)) + X(J-2)*M(I,J-2))
     $             + X(J-1)*M(I,J-1)) + X(J)  *M(I,J)
   30    CONTINUE
      ENDIF
*
*   cleanup odd group of eight vectors
*
      J = MOD(N2,16)
      IF (J .GE. 8) THEN
         DO 40 I = 1, N1
            Y(I) = ((((((( (Y(I))
     $             + X(J-7)*M(I,J-7)) + X(J-6)*M(I,J-6))
     $             + X(J-5)*M(I,J-5)) + X(J-4)*M(I,J-4))
     $             + X(J-3)*M(I,J-3)) + X(J-2)*M(I,J-2))
     $             + X(J-1)*M(I,J-1)) + X(J)  *M(I,J)
   40    CONTINUE
      ENDIF
*
*   main loop - groups of sixteen vectors
*
      JMIN = J+16
      DO 60 J = JMIN, N2, 16
         DO 50 I = 1, N1
            Y(I) = ((((((((((((((( (Y(I))
     $             + X(J-15)*M(I,J-15)) + X(J-14)*M(I,J-14))
     $             + X(J-13)*M(I,J-13)) + X(J-12)*M(I,J-12))
     $             + X(J-11)*M(I,J-11)) + X(J-10)*M(I,J-10))
     $             + X(J- 9)*M(I,J- 9)) + X(J- 8)*M(I,J- 8))
     $             + X(J- 7)*M(I,J- 7)) + X(J- 6)*M(I,J- 6))
     $             + X(J- 5)*M(I,J- 5)) + X(J- 4)*M(I,J- 4))
     $             + X(J- 3)*M(I,J- 3)) + X(J- 2)*M(I,J- 2))
     $             + X(J- 1)*M(I,J- 1)) + X(J)   *M(I,J)
   50    CONTINUE
   60 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION RAN( ISEED )
*
*     modified from the LAPACK auxiliary routine 10/12/92 JD
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
*     ..
*
*  Purpose
*  =======
*
*  DLARAN returns a random real number from a uniform (0,1)
*  distribution.
*
*  Arguments
*  =========
*
*  ISEED   (input/output) INTEGER array, dimension (4)
*          On entry, the seed of the random number generator; the array
*          elements must be between 0 and 4095, and ISEED(4) must be
*          odd.
*          On exit, the seed is updated.
*
*  Further Details
*  ===============
*
*  This routine uses a multiplicative congruential method with modulus
*  2**48 and multiplier 33952834046453 (see G.S.Fishman,
*  'Multiplicative congruential random number generators with modulus
*  2**b: an exhaustive analysis for b = 32 and a partial analysis for
*  b = 48', Math. Comp. 189, pp 331-344, 1990).
*
*  48-bit integers are stored in 4 integer array elements with 12 bits
*  per element. Hence the routine is portable across machines with
*  integers of 32 bits or more.
*
*     .. Parameters ..
      INTEGER            M1, M2, M3, M4
      PARAMETER          ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      INTEGER            IPW2
      DOUBLE PRECISION   R
      PARAMETER          ( IPW2 = 4096, R = ONE / IPW2 )
*     ..
*     .. Local Scalars ..
      INTEGER            IT1, IT2, IT3, IT4
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MOD
*     ..
*     .. Executable Statements ..
*
*     multiply the seed by the multiplier modulo 2**48
*
      IT4 = ISEED( 4 )*M4
      IT3 = IT4 / IPW2
      IT4 = IT4 - IPW2*IT3
      IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3
      IT2 = IT3 / IPW2
      IT3 = IT3 - IPW2*IT2
      IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2
      IT1 = IT2 / IPW2
      IT2 = IT2 - IPW2*IT1
      IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 +
     $      ISEED( 4 )*M1
      IT1 = MOD( IT1, IPW2 )
*
*     return updated seed
*
      ISEED( 1 ) = IT1
      ISEED( 2 ) = IT2
      ISEED( 3 ) = IT3
      ISEED( 4 ) = IT4
*
*     convert 48-bit integer to a real number in the interval (0,1)
*
      RAN = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
     $         ( DBLE( IT4 ) ) ) ) )
      RETURN
*
*     End of RAN
*
      END


      SUBROUTINE GPWG1C  (B,E,EIG,IFLAG)
C
C     DOUBLE PRECISION VERSION, BY G.CHAN/SPERRY    8/86
C
C     IFLAG=0 MEANS RUN OK
C     IFLAG=1 MEANS NO SOLUTION IN 20 ITERATIONS
C
      DOUBLE PRECISION  E(3,3),EP(3,3),B(3,3),BP(3,3),EIG(3)
      DOUBLE PRECISION  DETB,EPSIL,BMAX,R,S,C,T
C
      DETB = 0.0D0
      DO 5 I = 1,3
      DO 5 J = 1,3
      DETB = DETB+B(I,J)*B(I,J)
    5 CONTINUE
      EPSIL = DSQRT(DETB)*1.0D-5
      IFLAG =0
      II = 1
      DO 10 I=1,3
      DO 10 J=1,3
      E(I,J) = 0.0D0
      IF (I .EQ. J) E(I,J) = 1.0D0
   10 CONTINUE
      IF (DETB .EQ. 0.0D0) GO TO 100
   15 BMAX = DMAX1(DABS(B(1,2)),DABS(B(1,3)),DABS(B(2,3)))
      IF (DABS(BMAX)  .LT. EPSIL) GO TO 100
      IF (BMAX .NE. DABS(B(1,2))) GO TO 20
      I = 1
      J = 2
      K = 3
      GO TO 40
   20 IF (BMAX .NE. DABS(B(1,3))) GO TO 30
      I = 1
      J = 3
      K = 2
      GO TO 40
   30 I = 2
      J = 3
      K = 1
   40 R = (B(J,J)-B(I,I))/B(I,J)
      IF (DABS(R) .LT. 1.0D-6) GO TO 50
      IF (DABS(R) .GT. 1.0D+6) GO TO 60
      T = DSQRT((R*R)/4.0D0+1.0D0)-0.5D0*R
      C = DSQRT(1.0D0+T*T)
      S = T/C
      C = 1.0D0/C
      GO TO 70
   50 S = DSQRT(.5D0)
      C = S
      GO TO 70
   60 S = 0.0D0
      C = 1.0D0
   70 BP(I,I) = B(I,I)*C*C+B(J,J)*S*S-2.0D0*B(I,J)*S*C
      BP(J,J) = B(I,I)*S*S+B(J,J)*C*C+2.0D0*B(I,J)*S*C
      BP(K,K) = B(K,K)
      BP(J,I) = 0.0D0
      BP(I,J) = 0.0D0
      BP(K,I) = B(I,K)*C-B(J,K)*S
      BP(I,K) = BP(K,I)
      BP(K,J) = B(J,K)*C+B(I,K)*S
      BP(J,K) = BP(K,J)
      EP(I,1) = E(I,1)*C-E(J,1)*S
      EP(J,1) = E(I,1)*S+E(J,1)*C
      EP(K,1) = E(K,1)
      EP(I,2) = E(I,2)*C-E(J,2)*S
      EP(J,2) = E(I,2)*S+E(J,2)*C
      EP(K,2) = E(K,2)
      EP(I,3) = E(I,3)*C-E(J,3)*S
      EP(J,3) = E(I,3)*S+E(J,3)*C
      EP(K,3) = E(K,3)
      DO 80  I=1,3
      DO 80  J=1,3
      B(I,J) = BP(I,J)
      E(I,J) = EP(I,J)
   80 CONTINUE
      IF (II .GE. 21) GO TO 90
      II = II+1
      GO TO 15
   90 IFLAG=1
      GO TO 120
  100 DO 110  I=1,3
  110 EIG(I) = B(I,I)
  120 RETURN
      END


!program:
!this program is based on elimination of unkowns by Gauss.
!it's goal is to get some matrix's inverse matrix
!history:
!2011/-/-	don	first release
!2012/3/12	don	second release(changes:rectify some logical fault)
program main
use      sub
write(*,*)"input degree"
	read(*,*)n
	call subm(n)
!	 write(*,*)((B(i,j),j=1,N),i=1,N)
print *,"finished"
end program


C
C
*+ synch_fit.f

       subroutine synch_fit(ndata,freq_data,flux_data,err_data,
     *                      iopt,res_data,s                   )
C      --------------------------------------------------------
C
C Fit a theoretical synchrotron spectrum with one of a number of models
C
C Input:
C   Number of data points
       integer     ndata
C   frequency data points
       real*4      freq_data(ndata)
C   flux data points
       real*4      flux_data(ndata)
C   error data points
       real*4      err_data(ndata)
C   option code
       integer     iopt
C Returned:
C   results array
       real*4      res_data(*)
C   status
       integer     s
C
C
C The supplied data are fitted with a theoretical synchrotron spectrum
C which can take one of a number of forms depending on the value of
C iopt.
C
C iopt      spectral form and minimized function
C --------------------------------------------------------------------
C
C 11        power-law of the form:  S * x**(-alpha)    minimizing SoS
C 110                   "                "             minimizing Chi2
C 12        power-law with thermal component
C                      S x**(-alpha) + T x**(-0.1)     minimizing SoS
C 120                   "                              minimizing Chi2
C 13        power-law with thermal component; alpha0 given
C                      S x**(-alpha0) + T x**(-0.1)    minimizing SoS
C 130                   "                              minimizing Chi2
C 14        power-law with thermal component; alpha constrained
C                      S x**(-alpha0+a) + T x**(-0.1)  minimizing SoS
C 140                   "                              minimizing Chi2
C
C 20        current synchrotron spectrum               minimizing SoS
C 200                   "                              minimizing Chi2
C 21        current synchrotron spectrum + T x**(-0.1) minimizing SoS
C 210                   "                              minimizing Chi2
C 22        current synchrotron spectrum + T x**(-0.1)
C                      with fixed break frequency      minimizing SoS
C 220                   "                              minimizing Chi2
C
C 31        as 21 except break >= max_frequency for
C                      flat spectra                    minimizing SoS
C 310                   "                              minimizing Chi2
C 32        as 21 except use power-laws for flat spectra
C                                                      minimizing SoS
C 320                   "                              minimizing Chi2
C 33        as 21 except use power-laws for flat spectra
C                      and break >= max_frequency for
C                      flat, but steepening spectrum   minimizing SoS
C 330                   "                              minimizing Chi2
*-

C define local data variables passed in common to the internal routine
       real*8                    x_data(20), y_data(20), e_data(20)
       common /local_synch_fit/  x_data,     y_data,     e_data
       real*8                    con(20)
       common /local_synch_con/  con

C variables used by NAG -- X holds results
       integer       lrwork, liwork
       parameter    (lrwork=300, liwork=100)
       real*8        x(4), r_work(lrwork), fsumsq
       integer       ifail, i_work(liwork)
       real*8        synch_bfun8, aa, xs

C parameters describing spectral type
       integer       spectral_type
       real*4        injection_index_E, alpha

C loop counter, output unit number and number of model parameters
       integer       n, nn, iout, nx, nm

C flags to indiacte a local change of mode
       integer       ioptl

C flag used in ordering of the data
       integer       io(20)
       real*4        fmin

C logical variable used to test for input data which could be fitted by
C the spectrum as defined
       logical       test_OK, test_steep

C local variable used as a flag when fitwas not perfect or data do not
C obey tests before fitting -- this is set only when an error state
C does NOT occur
       integer                    local_warn
       common  /local_synch_warn/ local_warn

       include '/mrao/anmap/include/synch_errors.inc'

C check status on entry and initialise local warning flag
       if (s.ne.0) return
       if (ndata.le.1) then
         local_warn = -1
         return
       else
         local_warn = 0
       endif
       ioptl = iopt

C prepare data; scale so that values are within a sensible range
       test_OK = .true.
       do n=1,ndata
         if (freq_data(n).le.0.0 .or. flux_data(n).le.0.0) then
           test_OK = .false.
         endif
         if (iopt.gt.100) then
           if (err_data(n).le.0.0) then
             test_OK = .false.
           endif
         endif
         io(n) = n
       enddo
       if (.not.test_OK) then
         local_warn = -1
         return
       end if

C order and scale data
       do n=1,ndata
         fmin = 1.0E+30
         do nn=1,ndata
           if (io(nn).ne.0) then
             if (freq_data(nn).lt.fmin) then
               fmin = freq_data(nn)
               nx = nn
             endif
           endif
         enddo
         io(nx) = 0
         x_data(n) = freq_data(nx)
         y_data(n) = flux_data(nx)
         e_data(n) = err_data(nx)
         if (n.eq.1) then
           nm = nx
         endif
       enddo
       if (iopt.gt.100) then
         do n=1,ndata
           e_data(n) = e_data(n)/y_data(1)
         enddo
       endif
       do n=ndata,1,-1
         x_data(n) = x_data(n)/x_data(1)
         y_data(n) = y_data(n)/y_data(1)
       end do
       if (.not.test_ok) then
         local_warn = -1
         return
       end if

C find spectral range
       call synch_enqsp(injection_index_E,spectral_type)

C look for standard steep spectrum -- useful for all modes
       test_OK = .false.
       do n=1,ndata-1
         do nn=n+1,ndata
           alpha = - log(y_data(nn)/y_data(n))/
     *               log(x_data(nn)/x_data(n))
           test_OK = test_OK .or. (2.0*alpha+1.0).gt.injection_index_E
         end do
       end do
C look for steepening spectrum
       test_steep = .true.
       aa = 0.0
       do n=1,ndata-1
         nn = n + 1
         alpha = - log(y_data(nn)/y_data(n))/
     *             log(x_data(nn)/x_data(n))
         test_steep = test_steep .and. alpha.gt.aa
         aa = alpha
       enddo

C setup trial spectral index
       aa = -log(flux_data(2))/log(freq_data(2))

C initialise for call to NAG fitting routine
       if (iopt.eq.11 .or. iopt.eq.110) then
         nx = 2
         x(1) = y_data(1)
         x(2) = aa
       elseif (iopt.eq.12 .or. iopt.eq.120) then
         nx = 3
         if (ndata.lt.3) then
           local_warn = -1
           return
         endif
         if (test_OK) then
           x(1) = y_data(1)
           x(3) = aa
           x(2) = 0.0
         else
           x(1) = y_data(1)
           x(3) = aa
           x(2) = y_data(ndata)
         endif
       elseif (iopt.eq.13 .or. iopt.eq.130) then
         nx = 2
         if (test_OK) then
           x(1) = y_data(1)
           x(2) = 0.0
         else
           x(1) = y_data(1)
           x(2) = y_data(ndata)
         endif
         con(1) = res_data(3)
       elseif (iopt.eq.14 .or. iopt.eq.140) then
         nx = 3
         if (ndata.lt.3) then
           local_warn = -1
           return
         endif
         if (test_OK) then
           x(1) = y_data(1)
           x(3) = aa
           x(2) = 0.0
         else
           x(1) = y_data(1)
           x(3) = aa
           x(2) = y_data(ndata)
         endif
         con(1) = res_data(3)
       elseif (iopt.eq.20 .or. iopt.eq.200) then
         call synch_enqlim( con(1) )
         con(1) = con(1)*0.8D+0
         nx = 2
         if (test_OK) then
           x(2) = x_data(ndata)
           xs = x_data(1)/x(2)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s)/
     *                      synch_bfun8(xs,s)
         else
           local_warn = 100
           return
         endif
       elseif (iopt.eq.21 .or. iopt.eq.210) then
         nx = 3
         call synch_enqlim( con(1) )
         con(1) = con(1) * 0.8D+0
         if (test_OK) then
           x(3) = x_data(ndata)
           xs = x_data(1)/x(3)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                      synch_bfun8(xs,s)
           x(2) = 0.0D+0
         else
           x(3) = 2.0D+0*x_data(ndata)
           xs = x_data(1)/x(3)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                          synch_bfun8(xs,s)
           x(2) = y_data(ndata)
         endif
       elseif (iopt.eq.22 .or. iopt.eq.220) then
         nx = 2
         call synch_enqlim( con(1) )
         con(1) = res_data(3)/freq_data(nm)
         if (test_OK) then
           xs = x_data(1)/con(1)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                      synch_bfun8(xs,s)
           x(2) = 0.0D+0
         else
           xs = x_data(1)/con(1)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                          synch_bfun8(xs,s)
           x(2) = y_data(ndata)
         endif

       elseif (iopt.eq.31 .or. iopt.eq.310) then
         nx = 3
         ioptl = 21
         call synch_enqlim( con(1) )
         con(1) = con(1) * 0.8D+0
         if (test_OK) then
           x(3) = x_data(ndata)
           xs = x_data(1)/x(3)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                      synch_bfun8(xs,s)
           x(2) = 0.0D+0
         else
           con(1) = 1.0D+0
           x(3) = 2.0D+0*x_data(ndata)
           xs = x_data(1)/x(3)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                          synch_bfun8(xs,s)
           x(2) = y_data(ndata)
         endif

       elseif (iopt.eq.32 .or. iopt.eq.320) then
         nx = 3
         call synch_enqlim( con(1) )
         con(1) = con(1) * 0.8D+0
         if (test_OK) then
           ioptl = 21
           x(3) = x_data(ndata)
           xs = x_data(1)/x(3)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                      synch_bfun8(xs,s)
           x(2) = 0.0D+0
         else
           ioptl = 22
           con(1) = 100.0*x_data(ndata)
           xs = x_data(1)/con(1)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                          synch_bfun8(xs,s)
           x(2) = y_data(ndata)
         endif

       elseif (iopt.eq.33 .or. iopt.eq.330) then
         nx = 3
         call synch_enqlim( con(1) )
         con(1) = con(1) * 0.8D+0
         if (test_OK) then
           ioptl = 21
           x(3) = x_data(ndata)
           xs = x_data(1)/x(3)
           x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                      synch_bfun8(xs,s)
           x(2) = 0.0D+0
         else
           if (test_steep) then
             ioptl = 21
             con(1) = 1.0D+0
             x(3) = 2.0D+0*x_data(ndata)
             xs = x_data(1)/x(3)
             x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                            synch_bfun8(xs,s)
             x(2) = y_data(ndata)
           else
             ioptl = 22
             con(1) = 100.0*x_data(ndata)
             xs = x_data(1)/con(1)
             x(1) = y_data(1)*synch_bfun8(1.0D+0,s) /
     *                            synch_bfun8(xs,s)
             x(2) = y_data(ndata)
           endif
         endif

       end if

C initialise fitting mode and do the fit
       call synch_fitmode( ioptl )
       ifail = 1
       call e04fdf(ndata,nx,x,fsumsq,i_work,
     *             liwork,r_work,lrwork,ifail)

C check IFAIL on exit
       local_warn = 0
       if (ifail.eq.1) then
         call io_enqout(iout)
         call io_wrout('***(SYNCH_FIT) Error calling e04fdf')
         write(iout,*) '***(SYNCH_FIT) non-zero IFAIL = ',ifail
         s = ill_synNAG
         return
       else if (ifail.eq.2) then
         local_warn = 3000
       else if (ifail.eq.3) then
         local_warn = 2000
       else if (ifail.ge.4) then
         local_warn = 1000
       end if
       do n=1,3
         res_data(n) = abs(x(n))
       enddo
       res_data(4) = sqrt(fsumsq)
       res_data(1) = res_data(1) * flux_data(nm)

       if (ioptl.eq.11 .or. ioptl.eq.110) then
         res_data(1) = res_data(1)*(freq_data(nm)**res_data(2))
         res_data(2) = x(2)
         res_data(3) = 0.0
       endif
       if (ioptl.eq.13 .or. ioptl.eq.130 ) then
         res_data(3) = con(1)
       endif
       if (ioptl.eq.14 .or. ioptl.eq.140 ) then
         res_data(3) = con(1) + res_data(3)
       endif
       if (ioptl.eq.12 .or. ioptl.eq.120 .or.
     *     ioptl.eq.13 .or. ioptl.eq.130  .or.
     *     ioptl.eq.14 .or. ioptl.eq.140 ) then
         res_data(1) = res_data(1)*(freq_data(nm)**res_data(3))
         res_data(2) = res_data(2)*flux_data(nm)*(freq_data(nm)**0.1)
       endif
       if (ioptl.eq.22 .or. ioptl.eq.220 ) then
         res_data(3) = con(1)
       endif
       if (ioptl.eq.21 .or. ioptl.eq.210 .or.
     *     ioptl.eq.22 .or. ioptl.eq.220 ) then
         res_data(2) = res_data(2)*flux_data(nm)*(freq_data(nm)**0.1)
         res_data(3) = res_data(3)*freq_data(nm)
       endif

       if (ioptl.eq.20 .or. ioptl.eq.200) then
         res_data(2) = res_data(2)*freq_data(nm)
       endif
C check error on exit
       call iocmd_err(s,'synch_fit','Failed')
       end
C
C
*+ lsfun1
C
       subroutine lsfun1(ndata,nres,x,fvecc)
C      -------------------------------------
C
C Local routine used by NAG for fitting purposes
C
       integer     ndata, nres, n, status
       real*8      fvecc(ndata), x(nres)
       real*8      x_data(20), y_data(20), e_data(20)
       real*8      x_point, y_point
       real*8      synch_bfun8
       integer     mode, icount
       common /local_synch_fit/   x_data, y_data, e_data
       common /local_lsfun1_mode/ mode, icount
       real*8                     con(20)
       common /local_synch_con/   con

       status = 0
       if (mode.eq.11 .or. mode.eq.110) then
         do n=1,ndata
           fvecc(n) =
     *        abs(x(1)) * (x_data(n)**(-x(2))) -
     *        y_data(n)
           if (mode.eq.110) then
             fvecc(n) = fvecc(n) / e_data(n)
           endif
         end do
         icount = icount + 1

       else if (mode.eq.12 .or. mode.eq.120) then
         do n=1,ndata
           fvecc(n) =
     *        abs(x(1)) * (x_data(n)**(-abs(x(3)))) +
     *        abs(x(2))*(x_data(n)**(-0.1D+0)) -
     *        y_data(n)
           if (mode.eq.120) then
             fvecc(n) = fvecc(n) / e_data(n)
           endif
         end do
         icount = icount + 1

       else if (mode.eq.13 .or. mode.eq.130) then
         do n=1,ndata
           fvecc(n) =
     *        abs(x(1)) * (x_data(n)**(-con(1))) +
     *        abs(x(2))*(x_data(n)**(-0.1D+0)) -
     *        y_data(n)
           if (mode.eq.130) then
             fvecc(n) = fvecc(n) / e_data(n)
           endif
         end do
         icount = icount + 1

       else if (mode.eq.14 .or. mode.eq.140) then
         do n=1,ndata
           fvecc(n) =
     *        abs(x(1)) * (x_data(n)**(-(con(1)+abs(x(3))))) +
     *        abs(x(2))*(x_data(n)**(-0.1D+0)) -
     *        y_data(n)
           if (mode.eq.140) then
             fvecc(n) = fvecc(n) / e_data(n)
           endif
         end do
         icount = icount + 1

       else if (mode.eq.20 .or. mode.eq.200) then
         do n=1,ndata
           x_point = x_data(n) / max(abs(x(2)),x_data(ndata)/con(1))
           y_point = abs(x(1)) * synch_bfun8(x_point,status) /
     *                           synch_bfun8(1.0D+0,status)
           fvecc(n)= log(y_point) - log(y_data(n))
           if (mode.eq.200) then
             fvecc(n) = fvecc(n) * y_data(n) / e_data(n)
           endif
         end do
         icount = icount + 1

       else if (mode.eq.21 .or. mode.eq.210) then
         do n=1,ndata
           x_point = x_data(n) / max(abs(x(3)),x_data(ndata)/con(1))
           y_point = abs(x(1)) * synch_bfun8(x_point,status) /
     *                           synch_bfun8(1.0D+0,status) +
     *               abs(x(2))*(x_data(n)**(-0.1D+0))
           fvecc(n)= log(y_point) - log(y_data(n))
           if (mode.eq.210) then
             fvecc(n) = fvecc(n) * y_data(n) / e_data(n)
           endif
         end do
         icount = icount + 1

       else if (mode.eq.22 .or. mode.eq.220) then
         do n=1,ndata
           x_point = x_data(n) / con(1)
           y_point = abs(x(1)) * synch_bfun8(x_point,status) /
     *                           synch_bfun8(1.0D+0,status) +
     *               abs(x(2))*(x_data(n)**(-0.1D+0))
           fvecc(n)= log(y_point) - log(y_data(n))
           if (mode.eq.220) then
             fvecc(n) = fvecc(n) * y_data(n) / e_data(n)
           endif
         end do
         icount = icount + 1
       end if
       call iocmd_err(status,'LSFUN1 -- synch_fit',' ')
       end
C
C
*+
       real function synch_fitfun( x, iopt, res, s )
C      ---------------------------------------------
C
C Return the value of the fitted synchrotron spectrum at x
C
C Given:
C   frequency
       real*4        x
C   spectral type
       integer       iopt
C   results data
       real*4        res(*)
C Updated:
C   error status
       integer       s
C
C-
       real*4      synch_bfun

       if (s.ne.0) return

       if (iopt.eq.11 .or. iopt.eq.110) then
         synch_fitfun = res(1)*(x**(-res(2)))

       elseif (iopt.eq.12 .or. iopt.eq.120 .or.
     *         iopt.eq.13 .or. iopt.eq.130 .or.
     *         iopt.eq.14 .or. iopt.eq.140 ) then
         synch_fitfun = res(1)*(x**(-res(3))) +
     *                  res(2)*(x**(-0.1))

       elseif (iopt.eq.20 .or. iopt.eq.200) then
         s = 1
         synch_fitfun = res(1)*synch_bfun(x/res(2),s)/
     *                         synch_bfun(1.0,s)

       elseif (iopt.eq.21 .or. iopt.eq.210 .or.
     *         iopt.eq.22 .or. iopt.eq.220 .or.
     *         iopt.eq.31 .or. iopt.eq.310 .or.
     *         iopt.eq.32 .or. iopt.eq.320 .or.
     *         iopt.eq.33 .or. iopt.eq.330 .or.
     *         iopt.eq.34 .or. iopt.eq.340 ) then
         s = 1
         synch_fitfun = res(1)*synch_bfun(x/res(3),s)/
     *                         synch_bfun(1.0,s) +
     *                  res(2)*(x**(-0.1))

       endif
       end


subroutine SHSlepianVar(l, galpha, galpha_order, lmax, kmax, Sff, variance, &
                        exitstatus)
!------------------------------------------------------------------------------
!
!   Given the first KMAX Slepian functions in the matrix GALPHA, and an input
!   global power spectrum Sff, this subroutine will compute the theoretical
!   variance of the power of a function expanded in the first KMAX Slepian
!   functions at spherical harmonic degree l. This routine works using only the
!   Slepian functions of the spherical-cap concentration problem obtained from
!   SHReturnTapers.
!
!   Calling Parameters
!
!       IN
!           l               The single spherical harmonic degree to compute.
!           galpha          An array of (lmax+1, kmax) Slepian functions
!                           (arranged in columns) obtained from
!                           SHReturnTapers.
!           galpha_order    An array of dimension kmax containing the real
!                           angular order of the functions in galpha, as
!                           obtained from SHReturnTapers.
!           lmax            Maximum spherical harmonic degree of the
!                           bandlimited Slepian functions.
!           kmax            Maximum number of Slepian functions to be used in
!                           making the spectral estimate.
!           Sff             Known global power spectrum of the function.
!
!       OUT
!           variance        The variance of the function expanded in Slepian
!                           functions at spherical harmonic degree l.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: galpha(:,:), Sff(:)
    real(dp), intent(out) :: variance
    integer, intent(in) :: l, lmax, kmax, galpha_order(:)
    integer, intent(out), optional :: exitstatus
    integer :: m, lp, alpha, beta
    real(dp) :: fmm

    if (present(exitstatus)) exitstatus = 0

    variance = 0.0_dp

    if (size(Sff) < lmax + 1) then
        print*, "Error --- SHSlepianVar"
        print*, "Sff must be dimensioned (LMAX+1) where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(Sff)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(galpha(:,1)) < lmax+1 .or. size(galpha(1,:)) < kmax) then
        print*, "Error ---  SHSlepianVar"
        print*, "GALPHA must be dimensioned as (LMAX+1, KMAX) where " // &
                "LMAX and KMAX are ", lmax, kmax
        print*, "Input array is dimensioned ", size(galpha(:,1)), &
                size(galpha(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(galpha_order) < kmax) then
        print*, "Error ---  SHSlepianVar"
        print*, "GALPHA_ORDER must be dimensioned as (KMAX) where KMAX is ", &
                kmax
        print*, "Input array is dimensioned ", size(galpha_order)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate the variance,
    !
    !     var S_{\tilde{f}}(l) =
    !         \sum_{m=-l}^l 2 < \tilde{f}_{lm} \tilde{f}_{lm} >^2
    !
    !     < \tilde{f}_{lm} \tilde{f}_{lm} > =
    !         \sum_{l'=0}^L \frac{S_{f}(l')}{(2l'+1)} \sum_{\alpha=1}^N
    !         \sum_{\beta=1}^N g^{(\alpha)}_{l'm} g^{(\alpha)}_{lm}
    !         g^{(\beta)}_{l'm} g^{(\beta)}_{lm}.
    !
    !--------------------------------------------------------------------------
    do m = -l, l, 1

        fmm = 0.0_dp

        do lp = 0, lmax

            do alpha = 1, kmax
                if (galpha_order(alpha) /= m) cycle

                do beta = 1, kmax
                    if (galpha_order(beta) /= m) cycle

                    fmm = fmm + Sff(lp+1) / dble(2*lp+1) * &
                        galpha(lp+1, alpha) * galpha(l+1, alpha) * &
                        galpha(lp+1, beta) * galpha(l+1, beta)

                end do

            end do

        end do

        variance = variance + 2.0_dp * fmm**2

    end do

end subroutine SHSlepianVar


function h_lim(fi,tet)

common/topo/hsurf,nfi,fmin,fmax,ntet,tmin,tmax,htopo(1500,1500)

!write(*,*)hsurf,nfi,fmin,fmax,ntet,tmin,tmax

hhh=0.

if (nfi.eq.0) then
	h_lim=0
	return
end if

!write(*,*)' fi=',fi,' fmin=',fmin,' fmax=',fmax
if ((fi-fmin)*(fi-fmax).gt.0) then
	h_lim=0
	return
end if

!write(*,*)' tet=',tet,' tmin=',tmin,' tmax=',tmax
if ((tet-tmin)*(tet-tmax).gt.0) then
	h_lim=0
	return
end if

df=(fmax-fmin)/(nfi-1)
dt=(tmax-tmin)/(ntet-1)

do ifi=1,nfi-1
	f1=fmin+df*(ifi-1)
	f2=fmin+df*ifi
	if ((fi-f1)*(fi-f2).gt.0.) cycle
	exit
end do

do itet=1,ntet-1
	t1=tmin+dt*(itet-1)
	t2=tmin+dt*itet
	if ((tet-t1)*(tet-t2).gt.0.) cycle
	exit
end do

h11=htopo(ifi,itet)
h12=htopo(ifi,itet+1)
h21=htopo(ifi+1,itet)
h22=htopo(ifi+1,itet+1)

!write(*,*)h11,h12,h21,h22
!write(*,*)' fi=',fi,' tet=',tet
!write(*,*)' ifi=',ifi,' f1=',f1,' f2=',f2
!write(*,*)' itet=',itet,' t1=',t1,' t2=',t2

h1=h11+(h11-h12)*(tet-t1)/(t1-t2)
h2=h21+(h21-h22)*(tet-t1)/(t1-t2)

hhh=h1+(h1-h2)*(fi-f1)/(f1-f2)

h_lim=-hhh

return
end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine pintgr

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none

      include 'applu.incl'

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k
      integer ibeg, ifin, ifin1
      integer jbeg, jfin, jfin1
      double precision  phi1(0:isiz2+1,0:isiz3+1),
     >                  phi2(0:isiz2+1,0:isiz3+1)
      double precision  frc1, frc2, frc3

c---------------------------------------------------------------------
c   set up the sub-domains for integeration in each processor
c---------------------------------------------------------------------
      ibeg = ii1
      ifin = ii2
      jbeg = ji1
      jfin = ji2
      ifin1 = ifin - 1
      jfin1 = jfin - 1

c---------------------------------------------------------------------
c   initialize
c---------------------------------------------------------------------
!$omp parallel default(shared) private(i,j,k)
!$omp do
      do j = jbeg,jfin
        do i = ibeg,ifin
          phi1(i,j) = 0.
          phi2(i,j) = 0.
        end do
      end do
!$omp end do nowait

!$omp do
      do j = jbeg,jfin
         do i = ibeg,ifin

            k = ki1

            phi1(i,j) = c2*(  u(5,i,j,k)
     >           - 0.50d+00 * (  u(2,i,j,k) ** 2
     >                         + u(3,i,j,k) ** 2
     >                         + u(4,i,j,k) ** 2 )
     >                        / u(1,i,j,k) )

            k = ki2

            phi2(i,j) = c2*(  u(5,i,j,k)
     >           - 0.50d+00 * (  u(2,i,j,k) ** 2
     >                         + u(3,i,j,k) ** 2
     >                         + u(4,i,j,k) ** 2 )
     >                        / u(1,i,j,k) )
         end do
      end do
!$omp end do nowait
!$omp end parallel

      frc1 = 0.0d+00

!$omp parallel do default(shared) private(i,j) reduction(+:frc1)
      do j = jbeg,jfin1
         do i = ibeg, ifin1
            frc1 = frc1 + (  phi1(i,j)
     >                     + phi1(i+1,j)
     >                     + phi1(i,j+1)
     >                     + phi1(i+1,j+1)
     >                     + phi2(i,j)
     >                     + phi2(i+1,j)
     >                     + phi2(i,j+1)
     >                     + phi2(i+1,j+1) )
         end do
      end do
!$omp end parallel do

      frc1 = dxi * deta * frc1

c---------------------------------------------------------------------
c   initialize
c---------------------------------------------------------------------
!$omp parallel default(shared) private(i,k)
!$omp do
      do k = ki1,ki2
        do i = ibeg,ifin
          phi1(i,k) = 0.
          phi2(i,k) = 0.
        end do
      end do
!$omp end do nowait

!$omp do
      do k = ki1, ki2
         do i = ibeg, ifin
            phi1(i,k) = c2*(  u(5,i,jbeg,k)
     >           - 0.50d+00 * (  u(2,i,jbeg,k) ** 2
     >                         + u(3,i,jbeg,k) ** 2
     >                         + u(4,i,jbeg,k) ** 2 )
     >                        / u(1,i,jbeg,k) )
         end do
      end do
!$omp end do nowait

!$omp do
      do k = ki1, ki2
         do i = ibeg, ifin
            phi2(i,k) = c2*(  u(5,i,jfin,k)
     >           - 0.50d+00 * (  u(2,i,jfin,k) ** 2
     >                         + u(3,i,jfin,k) ** 2
     >                         + u(4,i,jfin,k) ** 2 )
     >                        / u(1,i,jfin,k) )
         end do
      end do
!$omp end do nowait
!$omp end parallel

      frc2 = 0.0d+00
!$omp parallel do default(shared) private(i,k) reduction(+:frc2)
      do k = ki1, ki2-1
         do i = ibeg, ifin1
            frc2 = frc2 + (  phi1(i,k)
     >                     + phi1(i+1,k)
     >                     + phi1(i,k+1)
     >                     + phi1(i+1,k+1)
     >                     + phi2(i,k)
     >                     + phi2(i+1,k)
     >                     + phi2(i,k+1)
     >                     + phi2(i+1,k+1) )
         end do
      end do
!$omp end parallel do

      frc2 = dxi * dzeta * frc2

c---------------------------------------------------------------------
c   initialize
c---------------------------------------------------------------------
!$omp parallel default(shared) private(j,k)
!$omp do
      do k = ki1,ki2
        do j = jbeg,jfin
          phi1(j,k) = 0.
          phi2(j,k) = 0.
        end do
      end do
!$omp end do nowait

!$omp do
      do k = ki1, ki2
         do j = jbeg, jfin
            phi1(j,k) = c2*(  u(5,ibeg,j,k)
     >           - 0.50d+00 * (  u(2,ibeg,j,k) ** 2
     >                         + u(3,ibeg,j,k) ** 2
     >                         + u(4,ibeg,j,k) ** 2 )
     >                        / u(1,ibeg,j,k) )
         end do
      end do
!$omp end do nowait

!$omp do
      do k = ki1, ki2
         do j = jbeg, jfin
            phi2(j,k) = c2*(  u(5,ifin,j,k)
     >           - 0.50d+00 * (  u(2,ifin,j,k) ** 2
     >                         + u(3,ifin,j,k) ** 2
     >                         + u(4,ifin,j,k) ** 2 )
     >                        / u(1,ifin,j,k) )
         end do
      end do
!$omp end do nowait
!$omp end parallel

      frc3 = 0.0d+00

!$omp parallel do default(shared) private(j,k) reduction(+:frc3)
      do k = ki1, ki2-1
         do j = jbeg, jfin1
            frc3 = frc3 + (  phi1(j,k)
     >                     + phi1(j+1,k)
     >                     + phi1(j,k+1)
     >                     + phi1(j+1,k+1)
     >                     + phi2(j,k)
     >                     + phi2(j+1,k)
     >                     + phi2(j,k+1)
     >                     + phi2(j+1,k+1) )
         end do
      end do
!$omp end parallel do

      frc3 = deta * dzeta * frc3
      frc = 0.25d+00 * ( frc1 + frc2 + frc3 )
c      write (*,1001) frc

      return

c 1001 format (//5x,'surface integral = ',1pe12.5//)

      end